diff --git a/CMakeLists.txt b/CMakeLists.txt index f16014cb7..17ccabebc 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -42,6 +42,7 @@ else(TYPEDEFS) include(${CMAKE_CURRENT_BINARY_DIR}/CCPP_TYPEDEFS.cmake) message(STATUS "Got CCPP TYPEDEFS from cmakefile include file") endif(TYPEDEFS) +list(REMOVE_DUPLICATES TYPEDEFS) # Generate list of Fortran modules from the CCPP type # definitions that need need to be installed @@ -58,6 +59,7 @@ else(SCHEMES) include(${CMAKE_CURRENT_BINARY_DIR}/CCPP_SCHEMES.cmake) message(STATUS "Got CCPP SCHEMES from cmakefile include file") endif(SCHEMES) +list(REMOVE_DUPLICATES SCHEMES) # Set the sources: physics scheme caps set(CAPS $ENV{CCPP_CAPS}) @@ -67,6 +69,7 @@ else(CAPS) include(${CMAKE_CURRENT_BINARY_DIR}/CCPP_CAPS.cmake) message(STATUS "Got CCPP CAPS from cmakefile include file") endif(CAPS) +list(REMOVE_DUPLICATES CAPS) # Schemes and caps from the CCPP code generator use full paths with symlinks # resolved, we need to do the same here for the below logic to work @@ -141,12 +144,32 @@ endif() SET_PROPERTY(SOURCE ${SCHEMES} ${CAPS} APPEND_STRING PROPERTY COMPILE_FLAGS " ${CMAKE_Fortran_FLAGS_PHYSICS} ${OpenMP_Fortran_FLAGS}") -# Reduce optimization for module_sf_mynn.F90 (to avoid an apparent compiler bug with Intel 18 on Hera) -if(${LOCAL_CURRENT_SOURCE_DIR}/physics/module_sf_mynn.F90 IN_LIST SCHEMES AND - (CMAKE_BUILD_TYPE STREQUAL "Release" OR CMAKE_BUILD_TYPE STREQUAL "Bitforbit") AND +# Lower optimization for certain schemes when compiling with Intel in Release mode +if((CMAKE_BUILD_TYPE STREQUAL "Release" OR CMAKE_BUILD_TYPE STREQUAL "Bitforbit") AND + ${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") + # Define a list of schemes that need lower optimization with Intel in Release mode + set(SCHEME_NAMES_LOWER_OPTIMIZATION module_sf_mynn.F90) + foreach(SCHEME_NAME IN LISTS SCHEME_NAMES_LOWER_OPTIMIZATION) + set(SCHEMES_TMP ${SCHEMES}) + # Need to determine the name of the scheme with its path + list(FILTER SCHEMES_TMP INCLUDE REGEX ".*${SCHEME_NAME}$") + SET_SOURCE_FILES_PROPERTIES(${SCHEMES_TMP} + APPEND_STRING PROPERTY COMPILE_FLAGS " ${CMAKE_Fortran_FLAGS_PHYSICS} ${OpenMP_Fortran_FLAGS} -O1") + endforeach() +endif() + +# No optimization for certain schemes when compiling with Intel in Release mode +if((CMAKE_BUILD_TYPE STREQUAL "Release" OR CMAKE_BUILD_TYPE STREQUAL "Bitforbit") AND ${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") - SET_SOURCE_FILES_PROPERTIES(${LOCAL_CURRENT_SOURCE_DIR}/physics/module_sf_mynn.F90 - APPEND_STRING PROPERTY COMPILE_FLAGS " ${CMAKE_Fortran_FLAGS_PHYSICS} ${OpenMP_Fortran_FLAGS} -O1") + # Define a list of schemes that can't be optimized with Intel in Release mode + set(SCHEME_NAMES_NO_OPTIMIZATION GFS_typedefs.F90) + foreach(SCHEME_NAME IN LISTS SCHEME_NAMES_NO_OPTIMIZATION) + set(SCHEMES_TMP ${SCHEMES}) + # Need to determine the name of the scheme with its path + list(FILTER SCHEMES_TMP INCLUDE REGEX ".*${SCHEME_NAME}$") + SET_SOURCE_FILES_PROPERTIES(${SCHEMES_TMP} + APPEND_STRING PROPERTY COMPILE_FLAGS " ${CMAKE_Fortran_FLAGS_PHYSICS} ${OpenMP_Fortran_FLAGS} -O0") + endforeach() endif() # Reduce optimization for mo_gas_optics_kernels.F90 (to avoid an apparent compiler bug with Intel 19+) diff --git a/physics/GFS_DCNV_generic.F90 b/physics/GFS_DCNV_generic.F90 index e7dec5ca1..a9e0ba7e0 100644 --- a/physics/GFS_DCNV_generic.F90 +++ b/physics/GFS_DCNV_generic.F90 @@ -19,7 +19,8 @@ subroutine GFS_DCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, do_cnvgwd, cplc gu0, gv0, gt0, gq0, nsamftrac, ntqv, & save_u, save_v, save_t, save_q, clw, & ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl, & - ntgnc, cscnv, satmedmf, trans_trac, ras, ntrac, & + ntgnc, nthl, nthnc, nthv, ntgv, & + cscnv, satmedmf, trans_trac, ras, ntrac, & dtidx, index_of_process_dcnv, errmsg, errflg) use machine, only: kind_phys @@ -27,7 +28,7 @@ subroutine GFS_DCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, do_cnvgwd, cplc implicit none integer, intent(in) :: im, levs, nsamftrac, ntqv, index_of_process_dcnv, dtidx(:,:), & - ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntrac,ntgnc + ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntrac,ntgnc,nthl,nthnc,nthv,ntgv logical, intent(in) :: ldiag3d, qdiag3d, do_cnvgwd, cplchm real(kind=kind_phys), dimension(:,:), intent(in) :: gu0 real(kind=kind_phys), dimension(:,:), intent(in) :: gv0 @@ -71,7 +72,9 @@ subroutine GFS_DCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, do_cnvgwd, cplc do n=2,ntrac if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt .and. & n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & - n /= ntsnc .and. n /= ntgl .and. n /= ntgnc) then + n /= ntsnc .and. n /= ntgl .and. n /= ntgnc .and. & + n /= nthl .and. n /= nthnc .and. n /= nthv .and. & + n /= ntgv ) then tracers = tracers + 1 if(dtidx(100+n,index_of_process_dcnv)>0) then save_q(:,:,n) = clw(:,:,tracers) @@ -111,7 +114,8 @@ subroutine GFS_DCNV_generic_post_run (im, levs, lssav, ldiag3d, qdiag3d, ras, & rainc, cldwrk, upd_mf, dwn_mf, det_mf, dtend, dtidx, index_of_process_dcnv, & index_of_temperature, index_of_x_wind, index_of_y_wind, ntqv, gq0, save_q, & cnvw, cnvc, cnvw_phy_f3d, cnvc_phy_f3d, flag_for_dcnv_generic_tend, & - ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntgnc, ntrac,clw, & + ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl, & + ntgnc, nthl, nthnc, nthv, ntgv, ntrac,clw, & satmedmf, trans_trac, errmsg, errflg) @@ -140,7 +144,8 @@ subroutine GFS_DCNV_generic_post_run (im, levs, lssav, ldiag3d, qdiag3d, ras, & real(kind=kind_phys), dimension(:,:,:), intent(inout) :: dtend integer, intent(in) :: dtidx(:,:), index_of_process_dcnv, index_of_temperature, & index_of_x_wind, index_of_y_wind, ntqv - integer, intent(in) :: ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntrac,ntgnc + integer, intent(in) :: ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl, & + ntgnc, nthl, nthnc, nthv, ntgv, ntrac real(kind=kind_phys), dimension(:,:,:), intent(in) :: clw @@ -205,7 +210,9 @@ subroutine GFS_DCNV_generic_post_run (im, levs, lssav, ldiag3d, qdiag3d, ras, & do n=2,ntrac if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt .and. & n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & - n /= ntsnc .and. n /= ntgl .and. n /= ntgnc) then + n /= ntsnc .and. n /= ntgl .and. n /= ntgnc .and. & + n /= nthl .and. n /= nthnc .and. n /= nthv .and. & + n /= ntgv ) then tracers = tracers + 1 idtend = dtidx(100+n,index_of_process_dcnv) if(idtend>0) then diff --git a/physics/GFS_DCNV_generic.meta b/physics/GFS_DCNV_generic.meta index 47fb65d9a..e15acaf1c 100644 --- a/physics/GFS_DCNV_generic.meta +++ b/physics/GFS_DCNV_generic.meta @@ -232,6 +232,34 @@ dimensions = () type = integer intent = in +[nthl] + standard_name = index_of_hail_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for hail + units = index + dimensions = () + type = integer + intent = in +[nthnc] + standard_name = index_of_mass_number_concentration_of_hail_in_tracer_concentration_array + long_name = tracer index for hail number concentration + units = index + dimensions = () + type = integer + intent = in +[ntgv] + standard_name = index_of_graupel_volume_in_tracer_concentration_array + long_name = tracer index for graupel particle volume + units = index + dimensions = () + type = integer + intent = in +[nthv] + standard_name = index_of_hail_volume_in_tracer_concentration_array + long_name = tracer index for hail particle volume + units = index + dimensions = () + type = integer + intent = in [clw] standard_name = convective_transportable_tracers long_name = array to contain cloud water and other convective trans. tracers @@ -684,6 +712,34 @@ dimensions = () type = integer intent = in +[nthl] + standard_name = index_of_hail_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for hail + units = index + dimensions = () + type = integer + intent = in +[nthnc] + standard_name = index_of_mass_number_concentration_of_hail_in_tracer_concentration_array + long_name = tracer index for hail number concentration + units = index + dimensions = () + type = integer + intent = in +[ntgv] + standard_name = index_of_graupel_volume_in_tracer_concentration_array + long_name = tracer index for graupel particle volume + units = index + dimensions = () + type = integer + intent = in +[nthv] + standard_name = index_of_hail_volume_in_tracer_concentration_array + long_name = tracer index for hail particle volume + units = index + dimensions = () + type = integer + intent = in [clw] standard_name = convective_transportable_tracers long_name = array to contain cloud water and other convective trans. tracers diff --git a/physics/GFS_MP_generic.F90 b/physics/GFS_MP_generic.F90 index cb072068e..e106cb908 100644 --- a/physics/GFS_MP_generic.F90 +++ b/physics/GFS_MP_generic.F90 @@ -87,7 +87,7 @@ end subroutine GFS_MP_generic_post_init !> \section gfs_mp_gen GFS MP Generic Post General Algorithm !> @{ subroutine GFS_MP_generic_post_run( & - im, levs, kdt, nrcm, nncl, ntcw, ntrac, imp_physics, imp_physics_gfdl, imp_physics_thompson, & + im, levs, kdt, nrcm, nncl, ntcw, ntrac, imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_nssl, & imp_physics_mg, imp_physics_fer_hires, cal_pre, cplflx, cplchm, con_g, rainmin, dtf, frain, rainc, & rain1, rann, xlat, xlon, gt0, gq0, prsl, prsi, phii, tsfc, ice, snow, graupel, save_t, save_q, rain0, ice0, snow0,& graupel0, del, rain, domr_diag, domzr_diag, domip_diag, doms_diag, tprcp, srflag, sr, cnvprcp, totprcp, totice, & @@ -103,6 +103,7 @@ subroutine GFS_MP_generic_post_run( integer, intent(in) :: im, levs, kdt, nrcm, nncl, ntcw, ntrac, num_dfi_radar, index_of_process_dfi_radar integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_mg, imp_physics_fer_hires + integer, intent(in) :: imp_physics_nssl logical, intent(in) :: cal_pre, lssav, ldiag3d, qdiag3d, cplflx, cplchm integer, intent(in) :: index_of_temperature,index_of_process_mp @@ -193,12 +194,11 @@ subroutine GFS_MP_generic_post_run( ice = ice0 snow = snow0 ! Do it right from the beginning for Thompson - else if (imp_physics == imp_physics_thompson) then + else if (imp_physics == imp_physics_thompson .or. imp_physics == imp_physics_nssl ) then tprcp = max (zero, rainc + frain * rain1) ! time-step convective and explicit precip graupel = frain*graupel0 ! time-step graupel ice = frain*ice0 ! time-step ice snow = frain*snow0 ! time-step snow - else if (imp_physics == imp_physics_fer_hires) then tprcp = max (zero, rain) ! time-step convective and explicit precip ice = frain*rain1*sr ! time-step ice @@ -233,7 +233,7 @@ subroutine GFS_MP_generic_post_run( ! ! HCHUANG: use new precipitation type to decide snow flag for LSM snow accumulation - if (imp_physics /= imp_physics_gfdl .and. imp_physics /= imp_physics_thompson) then + if (imp_physics /= imp_physics_gfdl .and. imp_physics /= imp_physics_thompson .and. imp_physics /= imp_physics_nssl) then do i=1,im tprcp(i) = max(zero, rain(i) ) if(doms(i) > zero .or. domip(i) > zero) then @@ -320,7 +320,8 @@ subroutine GFS_MP_generic_post_run( !! and convective rainfall from the cumulus scheme if the surface temperature is below !! \f$0^oC\f$. - if (imp_physics == imp_physics_gfdl .or. imp_physics == imp_physics_thompson) then + if (imp_physics == imp_physics_gfdl .or. imp_physics == imp_physics_thompson .or. & + imp_physics == imp_physics_nssl ) then ! determine convective rain/snow by surface temperature ! determine large-scale rain/snow by rain/snow coming out directly from MP diff --git a/physics/GFS_MP_generic.meta b/physics/GFS_MP_generic.meta index 1526948e4..6177b1344 100644 --- a/physics/GFS_MP_generic.meta +++ b/physics/GFS_MP_generic.meta @@ -220,6 +220,13 @@ dimensions = () type = integer intent = in +[imp_physics_nssl] + standard_name = identifier_for_nssl_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme + units = flag + dimensions = () + type = integer + intent = in [cal_pre] standard_name = flag_for_dominant_precipitation_type_partition long_name = flag controls precip type algorithm diff --git a/physics/GFS_PBL_generic.F90 b/physics/GFS_PBL_generic.F90 index 5bbbefe52..aae7d72ec 100644 --- a/physics/GFS_PBL_generic.F90 +++ b/physics/GFS_PBL_generic.F90 @@ -14,15 +14,16 @@ module GFS_PBL_generic_common subroutine set_aerosol_tracer_index(imp_physics, imp_physics_wsm6, & imp_physics_thompson, ltaerosol, & imp_physics_mg, ntgl, imp_physics_gfdl, & - imp_physics_zhao_carr, kk, & + imp_physics_zhao_carr, imp_physics_nssl,& + nssl_hail_on, nssl_ccn_on, kk, & errmsg, errflg) implicit none ! integer, intent(in ) :: imp_physics, imp_physics_wsm6, & imp_physics_thompson, & imp_physics_mg, ntgl, imp_physics_gfdl, & - imp_physics_zhao_carr - logical, intent(in ) :: ltaerosol + imp_physics_zhao_carr,imp_physics_nssl + logical, intent(in ) :: ltaerosol, nssl_hail_on, nssl_ccn_on integer, intent(out) :: kk character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -53,6 +54,13 @@ subroutine set_aerosol_tracer_index(imp_physics, imp_physics_wsm6, & elseif (imp_physics == imp_physics_zhao_carr) then ! Zhao/Carr/Sundqvist kk = 3 + elseif (imp_physics == imp_physics_nssl) then + IF ( nssl_hail_on ) THEN + kk = 16 + ELSE + kk = 13 + ENDIF + IF ( nssl_ccn_on ) kk = kk + 1 else write(errmsg,'(*(a))') 'Logic error: unknown microphysics option in set_aerosol_tracer_index' kk = -999 @@ -82,8 +90,10 @@ end subroutine GFS_PBL_generic_pre_finalize subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, rtg_ozone_index, & ntqv, ntcw, ntiw, ntrw, ntsw, ntlnc, ntinc, ntrnc, ntsnc, ntgnc, & ntwa, ntia, ntgl, ntoz, ntke, ntkev, nqrimef, trans_aero, ntchs, ntchm, & + ntccn, nthl, nthnc, ntgv, nthv, & imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, & - imp_physics_zhao_carr, imp_physics_mg, imp_physics_fer_hires, ltaerosol, & + imp_physics_zhao_carr, imp_physics_mg, imp_physics_fer_hires, imp_physics_nssl, & + ltaerosol, nssl_ccn_on, nssl_hail_on, & hybedmf, do_shoc, satmedmf, qgrs, vdftra, save_u, save_v, save_t, save_q, & flag_for_pbl_generic_tend, ldiag3d, qdiag3d, lssav, ugrs, vgrs, tgrs, errmsg, errflg) @@ -97,10 +107,13 @@ subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, rtg_ozone_index, integer, intent(in) :: im, levs, nvdiff, ntrac integer, intent(in) :: ntqv, ntcw, ntiw, ntrw, ntsw, ntlnc, ntinc, ntrnc, ntsnc, ntgnc integer, intent(in) :: ntwa, ntia, ntgl, ntoz, ntke, ntkev, nqrimef,ntchs, ntchm + integer, intent(in) :: ntccn, nthl, nthnc, ntgv, nthv logical, intent(in) :: trans_aero, ldiag3d, qdiag3d, lssav integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6 integer, intent(in) :: imp_physics_zhao_carr, imp_physics_mg, imp_physics_fer_hires logical, intent(in) :: ltaerosol, hybedmf, do_shoc, satmedmf, flag_for_pbl_generic_tend + integer, intent(in) :: imp_physics_nssl + logical, intent(in) :: nssl_hail_on, nssl_ccn_on real(kind=kind_phys), dimension(:,:,:), intent(in) :: qgrs real(kind=kind_phys), dimension(:,:), intent(in) :: ugrs, vgrs, tgrs @@ -250,13 +263,67 @@ subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, rtg_ozone_index, enddo enddo rtg_ozone_index = 3 + elseif (imp_physics == imp_physics_nssl ) then + ! nssl + IF ( nssl_hail_on ) THEN + do k=1,levs + do i=1,im + vdftra(i,k,1) = qgrs(i,k,ntqv) + vdftra(i,k,2) = qgrs(i,k,ntcw) + vdftra(i,k,3) = qgrs(i,k,ntiw) + vdftra(i,k,4) = qgrs(i,k,ntrw) + vdftra(i,k,5) = qgrs(i,k,ntsw) + vdftra(i,k,6) = qgrs(i,k,ntgl) + vdftra(i,k,7) = qgrs(i,k,nthl) + vdftra(i,k,8) = qgrs(i,k,ntlnc) + vdftra(i,k,9) = qgrs(i,k,ntinc) + vdftra(i,k,10) = qgrs(i,k,ntrnc) + vdftra(i,k,11) = qgrs(i,k,ntsnc) + vdftra(i,k,12) = qgrs(i,k,ntgnc) + vdftra(i,k,13) = qgrs(i,k,nthnc) + vdftra(i,k,14) = qgrs(i,k,ntgv) + vdftra(i,k,15) = qgrs(i,k,nthv) + vdftra(i,k,16) = qgrs(i,k,ntoz) + IF ( nssl_ccn_on ) THEN + vdftra(i,k,17) = qgrs(i,k,ntccn) + ENDIF + enddo + enddo + + ELSE + ! no hail + do k=1,levs + do i=1,im + vdftra(i,k,1) = qgrs(i,k,ntqv) + vdftra(i,k,2) = qgrs(i,k,ntcw) + vdftra(i,k,3) = qgrs(i,k,ntiw) + vdftra(i,k,4) = qgrs(i,k,ntrw) + vdftra(i,k,5) = qgrs(i,k,ntsw) + vdftra(i,k,6) = qgrs(i,k,ntgl) + vdftra(i,k,7) = qgrs(i,k,ntlnc) + vdftra(i,k,8) = qgrs(i,k,ntinc) + vdftra(i,k,9) = qgrs(i,k,ntrnc) + vdftra(i,k,10) = qgrs(i,k,ntsnc) + vdftra(i,k,11) = qgrs(i,k,ntgnc) + vdftra(i,k,12) = qgrs(i,k,ntgv) + vdftra(i,k,13) = qgrs(i,k,ntoz) + IF ( nssl_ccn_on ) THEN + vdftra(i,k,14) = qgrs(i,k,ntccn) + ENDIF + enddo + enddo + + ENDIF + + endif ! if (trans_aero) then call set_aerosol_tracer_index(imp_physics, imp_physics_wsm6, & imp_physics_thompson, ltaerosol, & imp_physics_mg, ntgl, imp_physics_gfdl, & - imp_physics_zhao_carr, kk, & + imp_physics_zhao_carr, imp_physics_nssl,& + nssl_hail_on, nssl_ccn_on, kk, & errmsg, errflg) if (errflg /= 0) return ! @@ -326,10 +393,10 @@ end subroutine GFS_PBL_generic_post_finalize !! subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, & ntqv, ntcw, ntiw, ntrw, ntsw, ntlnc, ntinc, ntrnc, ntsnc, ntgnc, ntwa, ntia, ntgl, ntoz, ntke, ntkev,nqrimef, & - trans_aero, ntchs, ntchm, & + trans_aero, ntchs, ntchm, ntccn, nthl, nthnc, ntgv, nthv, & imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, imp_physics_zhao_carr, imp_physics_mg, & - imp_physics_fer_hires, & - ltaerosol, cplflx, cplchm, lssav, flag_for_pbl_generic_tend, ldiag3d, lsidea, hybedmf, do_shoc, satmedmf, & + imp_physics_fer_hires, imp_physics_nssl, nssl_ccn_on, & + ltaerosol, nssl_hail_on, cplflx, cplchm, lssav, flag_for_pbl_generic_tend, ldiag3d, lsidea, hybedmf, do_shoc, satmedmf,& shinhong, do_ysu, dvdftra, dusfc1, dvsfc1, dtsfc1, dqsfc1, dtf, dudt, dvdt, dtdt, htrsw, htrlw, xmu, & dqdt, dusfc_cpl, dvsfc_cpl, dtsfc_cpl, dtend, dtidx, index_of_temperature, index_of_x_wind, index_of_y_wind, & index_of_process_pbl, dqsfc_cpl, dusfci_cpl, dvsfci_cpl, dtsfci_cpl, dqsfci_cpl, dusfc_diag, dvsfc_diag, dtsfc_diag, & @@ -346,9 +413,12 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, integer, parameter :: kp = kind_phys integer, intent(in) :: im, levs, nvdiff, ntrac, ntchs, ntchm, kdt integer, intent(in) :: ntqv, ntcw, ntiw, ntrw, ntsw, ntlnc, ntinc, ntrnc, ntsnc, ntgnc, ntwa, ntia, ntgl, ntoz, ntke, ntkev, nqrimef + integer, intent(in) :: ntccn, nthl, nthnc, ntgv, nthv logical, intent(in) :: trans_aero integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6 integer, intent(in) :: imp_physics_zhao_carr, imp_physics_mg, imp_physics_fer_hires + integer, intent(in) :: imp_physics_nssl + logical, intent(in) :: nssl_ccn_on, nssl_hail_on logical, intent(in) :: ltaerosol, cplflx, cplchm, lssav, ldiag3d, lsidea logical, intent(in) :: hybedmf, do_shoc, satmedmf, shinhong, do_ysu @@ -419,7 +489,8 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, call set_aerosol_tracer_index(imp_physics, imp_physics_wsm6, & imp_physics_thompson, ltaerosol, & imp_physics_mg, ntgl, imp_physics_gfdl, & - imp_physics_zhao_carr, kk, & + imp_physics_zhao_carr, imp_physics_nssl,& + nssl_hail_on, nssl_ccn_on, kk, & errmsg, errflg) if (errflg /= 0) return ! @@ -546,6 +617,57 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, dqdt(i,k,ntoz) = dvdftra(i,k,3) enddo enddo + elseif (imp_physics == imp_physics_nssl ) then + ! nssl + IF ( nssl_hail_on ) THEN + do k=1,levs + do i=1,im + dqdt(i,k,ntqv) = dvdftra(i,k,1) + dqdt(i,k,ntcw) = dvdftra(i,k,2) + dqdt(i,k,ntiw) = dvdftra(i,k,3) + dqdt(i,k,ntrw) = dvdftra(i,k,4) + dqdt(i,k,ntsw) = dvdftra(i,k,5) + dqdt(i,k,ntgl) = dvdftra(i,k,6) + dqdt(i,k,nthl) = dvdftra(i,k,7) + dqdt(i,k,ntlnc) = dvdftra(i,k,8) + dqdt(i,k,ntinc) = dvdftra(i,k,9) + dqdt(i,k,ntrnc) = dvdftra(i,k,10) + dqdt(i,k,ntsnc) = dvdftra(i,k,11) + dqdt(i,k,ntgnc) = dvdftra(i,k,12) + dqdt(i,k,nthnc) = dvdftra(i,k,13) + dqdt(i,k,ntgv) = dvdftra(i,k,14) + dqdt(i,k,nthv) = dvdftra(i,k,15) + dqdt(i,k,ntoz) = dvdftra(i,k,16) + IF ( nssl_ccn_on ) THEN + dqdt(i,k,ntccn) = dvdftra(i,k,17) + ENDIF + enddo + enddo + + ELSE + + do k=1,levs + do i=1,im + dqdt(i,k,ntqv) = dvdftra(i,k,1) + dqdt(i,k,ntcw) = dvdftra(i,k,2) + dqdt(i,k,ntiw) = dvdftra(i,k,3) + dqdt(i,k,ntrw) = dvdftra(i,k,4) + dqdt(i,k,ntsw) = dvdftra(i,k,5) + dqdt(i,k,ntgl) = dvdftra(i,k,6) + dqdt(i,k,ntlnc) = dvdftra(i,k,7) + dqdt(i,k,ntinc) = dvdftra(i,k,8) + dqdt(i,k,ntrnc) = dvdftra(i,k,9) + dqdt(i,k,ntsnc) = dvdftra(i,k,10) + dqdt(i,k,ntgnc) = dvdftra(i,k,11) + dqdt(i,k,ntgv) = dvdftra(i,k,12) + dqdt(i,k,ntoz) = dvdftra(i,k,13) + IF ( nssl_ccn_on ) THEN + dqdt(i,k,ntccn) = dvdftra(i,k,14) + ENDIF + enddo + enddo + + ENDIF endif endif ! nvdiff == ntrac diff --git a/physics/GFS_PBL_generic.meta b/physics/GFS_PBL_generic.meta index 27c659c2c..9e0d68a7d 100644 --- a/physics/GFS_PBL_generic.meta +++ b/physics/GFS_PBL_generic.meta @@ -182,6 +182,41 @@ dimensions = () type = integer intent = in +[ntccn] + standard_name = index_of_cloud_condensation_nuclei_number_concentration_in_tracer_concentration_array + long_name = tracer index for cloud condensation nuclei number concentration + units = index + dimensions = () + type = integer + intent = in +[nthl] + standard_name = index_of_hail_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for hail + units = index + dimensions = () + type = integer + intent = in +[nthnc] + standard_name = index_of_mass_number_concentration_of_hail_in_tracer_concentration_array + long_name = tracer index for hail number concentration + units = index + dimensions = () + type = integer + intent = in +[ntgv] + standard_name = index_of_graupel_volume_in_tracer_concentration_array + long_name = tracer index for graupel particle volume + units = index + dimensions = () + type = integer + intent = in +[nthv] + standard_name = index_of_hail_volume_in_tracer_concentration_array + long_name = tracer index for hail particle volume + units = index + dimensions = () + type = integer + intent = in [imp_physics] standard_name = control_for_microphysics_scheme long_name = choice of microphysics scheme @@ -231,6 +266,13 @@ dimensions = () type = integer intent = in +[imp_physics_nssl] + standard_name = identifier_for_nssl_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme + units = flag + dimensions = () + type = integer + intent = in [ltaerosol] standard_name = flag_for_aerosol_physics long_name = flag for aerosol physics @@ -238,6 +280,20 @@ dimensions = () type = logical intent = in +[nssl_ccn_on] + standard_name = nssl_ccn_on + long_name = CCN activation flag in NSSL micro + units = flag + dimensions = () + type = logical + intent = in +[nssl_hail_on] + standard_name = nssl_hail_on + long_name = hail activation flag in NSSL micro + units = flag + dimensions = () + type = logical + intent = in [hybedmf] standard_name = flag_for_hybrid_edmf_pbl_scheme long_name = flag for hybrid edmf pbl scheme (moninedmf) @@ -553,6 +609,41 @@ dimensions = () type = integer intent = in +[ntccn] + standard_name = index_of_cloud_condensation_nuclei_number_concentration_in_tracer_concentration_array + long_name = tracer index for cloud condensation nuclei number concentration + units = index + dimensions = () + type = integer + intent = in +[nthl] + standard_name = index_of_hail_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for hail + units = index + dimensions = () + type = integer + intent = in +[nthnc] + standard_name = index_of_mass_number_concentration_of_hail_in_tracer_concentration_array + long_name = tracer index for hail number concentration + units = index + dimensions = () + type = integer + intent = in +[ntgv] + standard_name = index_of_graupel_volume_in_tracer_concentration_array + long_name = tracer index for graupel particle volume + units = index + dimensions = () + type = integer + intent = in +[nthv] + standard_name = index_of_hail_volume_in_tracer_concentration_array + long_name = tracer index for hail particle volume + units = index + dimensions = () + type = integer + intent = in [imp_physics] standard_name = control_for_microphysics_scheme long_name = choice of microphysics scheme @@ -602,6 +693,13 @@ dimensions = () type = integer intent = in +[imp_physics_nssl] + standard_name = identifier_for_nssl_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme + units = flag + dimensions = () + type = integer + intent = in [ltaerosol] standard_name = flag_for_aerosol_physics long_name = flag for aerosol physics @@ -609,6 +707,20 @@ dimensions = () type = logical intent = in +[nssl_ccn_on] + standard_name = nssl_ccn_on + long_name = CCN activation flag in NSSL micro + units = flag + dimensions = () + type = logical + intent = in +[nssl_hail_on] + standard_name = nssl_hail_on + long_name = hail activation flag in NSSL micro + units = flag + dimensions = () + type = logical + intent = in [cplflx] standard_name = flag_for_surface_flux_coupling long_name = flag controlling cplflx collection (default off) diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index 9d5d24aa8..f01f25cbc 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -1378,7 +1378,7 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%clxss ', Interstitial%clxss ) end if ! GFDL and Thompson MP - if (Model%imp_physics == Model%imp_physics_gfdl .or. Model%imp_physics == Model%imp_physics_thompson) then + if (Model%imp_physics == Model%imp_physics_gfdl .or. Model%imp_physics == Model%imp_physics_thompson .or. Model%imp_physics == Model%imp_physics_nssl) then call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%graupelmp ', Interstitial%graupelmp ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%icemp ', Interstitial%icemp ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%rainmp ', Interstitial%rainmp ) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 15845d4b3..89c9cec7f 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -18,8 +18,10 @@ end subroutine GFS_rrtmg_pre_init ! in the CCPP version - they are defined in the interstitial_create routine subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & imfdeepcnv, imfdeepcnv_gf, me, ncnd, ntrac, num_p3d, npdf3d, ncnvcld3d,& - ntqv, ntcw,ntiw, ntlnc, ntinc, ntrw, ntsw, ntgl, ntwa, ntoz, & - ntclamt, nleffr, nieffr, nseffr, lndp_type, kdt, imp_physics, & + ntqv, ntcw,ntiw, ntlnc, ntinc, ntrnc, ntsnc, ntccn, & + ntrw, ntsw, ntgl, nthl, ntwa, ntoz, & + ntclamt, nleffr, nieffr, nseffr, lndp_type, kdt, & + imp_physics,imp_physics_nssl, nssl_ccn_on, nssl_invertccn, & imp_physics_thompson, imp_physics_gfdl, imp_physics_zhao_carr, & imp_physics_zhao_carr_pdf, imp_physics_mg, imp_physics_wsm6, & imp_physics_fer_hires, julian, yearlen, lndp_var_list, lsswr, lslwr, & @@ -86,7 +88,8 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & imfdeepcnv_gf, me, ncnd, ntrac, & num_p3d, npdf3d, ncnvcld3d, ntqv, & ntcw, ntiw, ntlnc, ntinc, & - ntrw, ntsw, ntgl, ntwa, ntoz, & + ntrnc, ntsnc,ntccn, & + ntrw, ntsw, ntgl, nthl, ntwa, ntoz, & ntclamt, nleffr, nieffr, nseffr, & lndp_type, & kdt, imp_physics, & @@ -95,6 +98,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & imp_physics_zhao_carr, & imp_physics_zhao_carr_pdf, & imp_physics_mg, imp_physics_wsm6, & + imp_physics_nssl, & imp_physics_fer_hires, & yearlen, icloud @@ -104,6 +108,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & uni_cld, effr_in, do_mynnedmf, & lmfshal, lmfdeep2, pert_clds + logical, intent(in) :: nssl_ccn_on, nssl_invertccn integer, intent(in) :: spp_rad real(kind_phys), intent(in) :: spp_wts_rad(:,:) @@ -647,7 +652,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & ccnd(i,k,4) = tracer1(i,k,ntsw) ! snow water enddo enddo - elseif (ncnd == 5) then ! GFDL MP, Thompson, MG3, FA + elseif ( ncnd == 5 .or. ncnd == 6) then ! GFDL MP, Thompson, MG3, NSSL do k=1,LMK do i=1,IM ccnd(i,k,1) = tracer1(i,k,ntcw) ! liquid water @@ -656,7 +661,11 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & if (imp_physics == imp_physics_fer_hires ) then ccnd(i,k,4) = 0.0 else + IF ( ncnd == 5 ) THEN ccnd(i,k,4) = tracer1(i,k,ntsw) + tracer1(i,k,ntgl) ! snow + graupel + ELSEIF ( ncnd == 6 ) THEN + ccnd(i,k,4) = tracer1(i,k,ntsw) + tracer1(i,k,ntgl) + tracer1(i,k,nthl) ! snow + graupel + hail + ENDIF endif enddo enddo @@ -796,7 +805,25 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & enddo enddo endif - elseif (imp_physics == imp_physics_thompson) then ! Thompson MP + + elseif (imp_physics == imp_physics_nssl ) then ! NSSL MP + cldcov = 0.0 + if(effr_in) then + do k=1,lm + k1 = k + kd + do i=1,im + effrl(i,k1) = effrl_inout(i,k)! re_cloud (i,k) + effri(i,k1) = effri_inout(i,k)! re_ice (i,k) + effrr(i,k1) = effrr_in(i,k) + effrs(i,k1) = effrs_inout(i,k) ! re_snow(i,k) + enddo + enddo + else + ! not used yet -- effr_in should always be true for now + endif + + elseif (imp_physics == imp_physics_thompson) then ! Thompson MP + ! ! Compute effective radii for QC, QI, QS with (GF, MYNN) or without (all others) sub-grid clouds ! @@ -951,6 +978,41 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & effri_inout(:,:), effrs_inout(:,:), & dzb, xlat_d, julian, yearlen, & clouds,cldsa,mtopa,mbota, de_lgth, alpha) ! --- outputs + + elseif ( imp_physics == imp_physics_nssl ) then ! NSSL MP + + if(do_mynnedmf .or. imfdeepcnv == imfdeepcnv_gf ) then ! MYNN PBL or GF conv + !-- MYNN PBL or convective GF + !-- use cloud fractions with SGS clouds + do k=1,lmk + do i=1,im + clouds(i,k,1) = clouds1(i,k) + enddo + enddo + + ! --- use clduni with the NSSL microphysics. + ! --- make sure that effr_in=.true. in the input.nml! + call progclduni (plyr, plvl, tlyr, tvly, ccnd, ncndl, & ! --- inputs + xlat, xlon, slmsk, dz, delp, IM, LMK, LMP, & + clouds(:,1:LMK,1), & + effrl, effri, effrr, effrs, effr_in , & + dzb, xlat_d, julian, yearlen, & + clouds, cldsa, mtopa, mbota, de_lgth, alpha) ! --- outputs + + else + ! MYNN PBL or GF convective are not used + call progcld6 (plyr,plvl,tlyr,qlyr,qstl,rhly,tracer1, & ! --- inputs + xlat,xlon,slmsk,dz,delp, & + ntrac-1, ntcw-1,ntiw-1,ntrw-1, & + ntsw-1,ntgl-1, & + im, lmk, lmp, uni_cld, lmfshal, lmfdeep2, & + cldcov(:,1:LMK), cnvw, effrl_inout, & + effri_inout, effrs_inout, & + lwp_ex, iwp_ex, lwp_fc, iwp_fc, & + dzb, xlat_d, julian, yearlen, & + clouds, cldsa, mtopa ,mbota, de_lgth, alpha) ! --- outputs + endif ! MYNN PBL or GF + elseif(imp_physics == imp_physics_thompson) then ! Thompson MP diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index 1eac8a571..df2553790 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -142,6 +142,20 @@ dimensions = () type = integer intent = in +[ntrnc] + standard_name = index_of_mass_number_concentration_of_rain_in_tracer_concentration_array + long_name = tracer index for rain number concentration + units = index + dimensions = () + type = integer + intent = in +[ntsnc] + standard_name = index_of_mass_number_concentration_of_snow_in_tracer_concentration_array + long_name = tracer index for snow number concentration + units = index + dimensions = () + type = integer + intent = in [ntrw] standard_name = index_of_rain_mixing_ratio_in_tracer_concentration_array long_name = tracer index for rain water @@ -163,6 +177,20 @@ dimensions = () type = integer intent = in +[nthl] + standard_name = index_of_hail_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for hail + units = index + dimensions = () + type = integer + intent = in +[ntccn] + standard_name = index_of_cloud_condensation_nuclei_number_concentration_in_tracer_concentration_array + long_name = tracer index for cloud condensation nuclei number concentration + units = index + dimensions = () + type = integer + intent = in [ntwa] standard_name = index_of_mass_number_concentration_of_hygroscopic_aerosols_in_tracer_concentration_array long_name = tracer index for water friendly aerosol @@ -177,6 +205,20 @@ dimensions = () type = integer intent = in +[nssl_ccn_on] + standard_name = nssl_ccn_on + long_name = CCN activation flag in NSSL micro + units = flag + dimensions = () + type = logical + intent = in +[nssl_invertccn] + standard_name = nssl_invertccn + long_name = flag to invert CCN in NSSL micro + units = flag + dimensions = () + type = logical + intent = in [ntclamt] standard_name = index_of_cloud_area_fraction_in_atmosphere_layer_in_tracer_concentration_array long_name = tracer index for cloud amount integer @@ -226,6 +268,13 @@ dimensions = () type = integer intent = in +[imp_physics_nssl] + standard_name = identifier_for_nssl_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme + units = flag + dimensions = () + type = integer + intent = in [imp_physics_thompson] standard_name = identifier_for_thompson_microphysics_scheme long_name = choice of Thompson microphysics scheme diff --git a/physics/GFS_rrtmgp_gfdlmp_pre.F90 b/physics/GFS_rrtmgp_gfdlmp_pre.F90 index c6afd6ac0..92429fc28 100644 --- a/physics/GFS_rrtmgp_gfdlmp_pre.F90 +++ b/physics/GFS_rrtmgp_gfdlmp_pre.F90 @@ -106,7 +106,7 @@ subroutine GFS_rrtmgp_gfdlmp_pre_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cld errflg = 0 ! Test inputs - if (ncnd .ne. 5) then + if (ncnd .ne. 5 .and. ncnd .ne. 6 ) then errmsg = 'Incorrect number of cloud condensates provided' errflg = 1 call check_error_msg('GFS_rrtmgp_gfdlmp_pre_run',errmsg) diff --git a/physics/GFS_suite_interstitial.F90 b/physics/GFS_suite_interstitial.F90 index 6963e94c3..044912e07 100644 --- a/physics/GFS_suite_interstitial.F90 +++ b/physics/GFS_suite_interstitial.F90 @@ -512,13 +512,15 @@ end subroutine GFS_suite_interstitial_3_finalize !> \section arg_table_GFS_suite_interstitial_3_run Argument Table !! \htmlinclude GFS_suite_interstitial_3_run.html !! - subroutine GFS_suite_interstitial_3_run (im, levs, nn, cscnv, & + subroutine GFS_suite_interstitial_3_run (otsptflag, & + im, levs, nn, cscnv, & satmedmf, trans_trac, do_shoc, ltaerosol, ntrac, ntcw, & ntiw, ntclamt, ntrw, ntsw, ntrnc, ntsnc, ntgl, ntgnc, & xlon, xlat, gt0, gq0, imp_physics, imp_physics_mg, & imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, & imp_physics_gfdl, imp_physics_thompson, dtidx, ntlnc, & imp_physics_wsm6, imp_physics_fer_hires, prsi, ntinc, & + imp_physics_nssl, & prsl, prslk, rhcbot,rhcpbl, rhctop, rhcmax, islmsk, & work1, work2, kpbl, kinver, ras, me, save_lnc, save_inc, & ldiag3d, qdiag3d, index_of_process_conv_trans, & @@ -529,9 +531,11 @@ subroutine GFS_suite_interstitial_3_run (im, levs, nn, cscnv, & implicit none ! interface variables + logical, intent(in) :: otsptflag(:)! on/off switch for tracer transport (size ntrac) integer, intent(in ) :: im, levs, nn, ntrac, ntcw, ntiw, ntclamt, ntrw, ntsw,& ntrnc, ntsnc, ntgl, ntgnc, imp_physics, imp_physics_mg, imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, & - imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6,imp_physics_fer_hires, me, index_of_process_conv_trans + imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6,imp_physics_fer_hires, & + imp_physics_nssl, me, index_of_process_conv_trans integer, intent(in ), dimension(:) :: islmsk, kpbl, kinver logical, intent(in ) :: cscnv, satmedmf, trans_trac, do_shoc, ltaerosol, ras @@ -576,9 +580,10 @@ subroutine GFS_suite_interstitial_3_run (im, levs, nn, cscnv, & if (cscnv .or. satmedmf .or. trans_trac .or. ras) then tracers = 2 do n=2,ntrac - if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt .and. & - n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & - n /= ntsnc .and. n /= ntgl .and. n /= ntgnc) then +! if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt .and. & +! n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & +! n /= ntsnc .and. n /= ntgl .and. n /= ntgnc) then + IF ( otsptflag(n) ) THEN tracers = tracers + 1 do k=1,levs do i=1,im @@ -662,6 +667,15 @@ subroutine GFS_suite_interstitial_3_run (im, levs, nn, cscnv, & else save_qi(:,:) = clw(:,:,1) endif + else if (imp_physics == imp_physics_nssl ) then + do k=1,levs + do i=1,im + clw(i,k,1) = gq0(i,k,ntiw) ! cloud ice + clw(i,k,2) = gq0(i,k,ntcw) ! cloud droplets + enddo + enddo + save_qi(:,:) = clw(:,:,1) + save_qc(:,:) = clw(:,:,2) elseif (imp_physics == imp_physics_wsm6 .or. imp_physics == imp_physics_mg .or. imp_physics == imp_physics_fer_hires) then do k=1,levs do i=1,im @@ -698,10 +712,11 @@ end subroutine GFS_suite_interstitial_4_finalize !! \htmlinclude GFS_suite_interstitial_4_run.html !! subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntrac, ntcw, ntiw, ntclamt, & - ntrw, ntsw, ntrnc, ntsnc, ntgl, ntgnc, ntlnc, ntinc, nn, imp_physics, imp_physics_gfdl, imp_physics_thompson, & + ntrw, ntsw, ntrnc, ntsnc, ntgl, ntgnc, ntlnc, ntinc, ntccn, nn, imp_physics, imp_physics_gfdl, imp_physics_thompson, & + imp_physics_nssl, nssl_invertccn, nssl_ccn_on, & imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, convert_dry_rho, dtf, save_qc, save_qi, con_pi, dtidx, dtend,& - index_of_process_conv_trans, gq0, clw, prsl, save_tcp, con_rd, con_eps, nwfa, spechum, ldiag3d, & - qdiag3d, save_lnc, save_inc, ntk, ntke, errmsg, errflg) + index_of_process_conv_trans, gq0, clw, prsl, save_tcp, con_rd, con_eps, nssl_cccn, nwfa, spechum, ldiag3d, & + qdiag3d, save_lnc, save_inc, ntk, ntke, otsptflag, errmsg, errflg) use machine, only: kind_phys use module_mp_thompson_make_number_concentrations, only: make_IceNumber, make_DropletNumber @@ -710,11 +725,13 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr ! interface variables + logical, intent(in) :: otsptflag(:)! on/off switch for tracer transport by updraft and integer, intent(in ) :: im, levs, tracers_total, ntrac, ntcw, ntiw, ntclamt, ntrw, & - ntsw, ntrnc, ntsnc, ntgl, ntgnc, ntlnc, ntinc, nn, imp_physics, imp_physics_gfdl, imp_physics_thompson, & - imp_physics_zhao_carr, imp_physics_zhao_carr_pdf + ntsw, ntrnc, ntsnc, ntgl, ntgnc, ntlnc, ntinc, ntccn, nn, imp_physics, imp_physics_gfdl, imp_physics_thompson, & + imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, imp_physics_nssl logical, intent(in) :: ltaerosol, convert_dry_rho + logical, intent(in) :: nssl_ccn_on, nssl_invertccn real(kind=kind_phys), intent(in ) :: con_pi, dtf real(kind=kind_phys), intent(in ), dimension(:,:) :: save_qc @@ -730,7 +747,7 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr real(kind=kind_phys), dimension(:,:,:), intent(inout) :: gq0 real(kind=kind_phys), dimension(:,:,:), intent(inout) :: clw real(kind=kind_phys), dimension(:,:), intent(in) :: prsl - real(kind=kind_phys), intent(in) :: con_rd, con_eps + real(kind=kind_phys), intent(in) :: con_rd, con_eps, nssl_cccn real(kind=kind_phys), dimension(:,:), intent(in) :: nwfa, save_tcp real(kind=kind_phys), dimension(:,:), intent(in) :: spechum @@ -740,6 +757,7 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr ! local variables real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys integer :: i,k,n,tracers,idtend + real(kind=kind_phys) :: liqm, icem, xccn, xcwmas, xccw, xcimas, qccn real(kind=kind_phys) :: rho, orho real(kind=kind_phys), dimension(im,levs) :: qv_mp !< kg kg-1 (dry mixing ratio) @@ -806,9 +824,14 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr tracers = 2 do n=2,ntrac ! if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt) then - if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt .and. & - n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & - n /= ntsnc .and. n /= ntgl .and. n /= ntgnc ) then +! if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt .and. & +! n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & +! n /= ntsnc .and. n /= ntgl .and. n /= ntgnc & +! .and. & +! n /= nthl .and. n /= nthnc .and. n /= ntgv .and. & +! n /= nthv .and. n /= ntccn & +! ) then + IF ( otsptflag(n) ) THEN tracers = tracers + 1 if(n/=ntk .and. n/=ntlnc .and. n/=ntinc .and. n /= ntcw .and. n /= ntiw) then idtend=dtidx(100+n,index_of_process_conv_trans) @@ -841,6 +864,55 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr enddo enddo + if ( imp_physics == imp_physics_nssl ) then + liqm = con_pi/6.*1.e3*(18.e-6)**3 ! 4./3.*con_pi*1.e-12 + icem = con_pi/6.*1.e3*(120.e-6)**3 ! 4./3.*con_pi*3.2768*1.e-14*890. + qccn = nssl_cccn/1.225 !1.225 is a reference air density and should match what is used in module_mp_nssl_2mom.F90 (rho00) + do k=1,levs + do i=1,im + ! check number of available ccn + IF ( nssl_ccn_on ) THEN + IF ( nssl_invertccn ) THEN + xccn = qccn - gq0(i,k,ntccn) + ELSE + xccn = gq0(i,k,ntccn) + ENDIF + ELSE + xccn = Max(0.0, qccn - gq0(i,k,ntlnc)) + ENDIF + + IF ( gq0(i,k,ntlnc) > 0.0 .and. save_qc(i,k) > 0.0 ) THEN + xcwmas = Max( liqm, clw(i,k,2)/gq0(i,k,ntlnc) ) + ELSE + xcwmas = liqm + ENDIF + + IF ( gq0(i,k,ntinc) > 0.0 .and. save_qi(i,k) > 0.0 ) THEN + xcimas = Max( liqm, clw(i,k,1)/gq0(i,k,ntinc) ) + ELSE + xcimas = icem + ENDIF + + IF ( xccn > 0.0 ) THEN + xccw = Min( xccn, max(0.0, (clw(i,k,2)-save_qc(i,k))) / xcwmas ) + gq0(i,k,ntlnc) = gq0(i,k,ntlnc) + xccw + IF ( nssl_ccn_on ) THEN + IF ( nssl_invertccn ) THEN + ! ccn are activated CCN, so add + gq0(i,k,ntccn) = gq0(i,k,ntccn) + xccw + ELSE + ! ccn are unactivated CCN, so subtract + gq0(i,k,ntccn) = gq0(i,k,ntccn) - xccw + ENDIF + ENDIF + ENDIF + + gq0(i,k,ntinc) = gq0(i,k,ntinc) & + + max(0.0, (clw(i,k,1)-save_qi(i,k))) / xcimas + enddo + enddo + endif + if (imp_physics == imp_physics_thompson .and. (ntlnc>0 .or. ntinc>0)) then if_convert_dry_rho: if (convert_dry_rho) then do k=1,levs @@ -969,4 +1041,3 @@ subroutine GFS_suite_interstitial_5_run (im, levs, ntrac, ntcw, ntiw, nn, gq0, c end subroutine GFS_suite_interstitial_5_run end module GFS_suite_interstitial_5 - diff --git a/physics/GFS_suite_interstitial.meta b/physics/GFS_suite_interstitial.meta index 43b3d5efa..1c0bbed47 100644 --- a/physics/GFS_suite_interstitial.meta +++ b/physics/GFS_suite_interstitial.meta @@ -1040,6 +1040,13 @@ [ccpp-arg-table] name = GFS_suite_interstitial_3_run type = scheme +[otsptflag] + standard_name = flag_convective_tracer_transport_interstitial + long_name = flag for interstitial tracer transport + units = flag + dimensions = (number_of_tracers) + type = logical + intent = in [im] standard_name = horizontal_loop_extent long_name = horizontal loop extent @@ -1254,6 +1261,13 @@ dimensions = () type = integer intent = in +[imp_physics_nssl] + standard_name = identifier_for_nssl_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme + units = flag + dimensions = () + type = integer + intent = in [prsi] standard_name = air_pressure_at_interface long_name = air pressure at model layer interfaces @@ -1604,6 +1618,13 @@ dimensions = () type = integer intent = in +[ntccn] + standard_name = index_of_cloud_condensation_nuclei_number_concentration_in_tracer_concentration_array + long_name = tracer index for cloud condensation nuclei number concentration + units = index + dimensions = () + type = integer + intent = in [imp_physics] standard_name = control_for_microphysics_scheme long_name = choice of microphysics scheme @@ -1646,6 +1667,27 @@ dimensions = () type = logical intent = in +[imp_physics_nssl] + standard_name = identifier_for_nssl_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[nssl_ccn_on] + standard_name = nssl_ccn_on + long_name = CCN activation flag in NSSL micro + units = flag + dimensions = () + type = logical + intent = in +[nssl_invertccn] + standard_name = nssl_invertccn + long_name = flag to invert CCN in NSSL micro + units = flag + dimensions = () + type = logical + intent = in [dtf] standard_name = timestep_for_dynamics long_name = dynamics timestep @@ -1742,6 +1784,14 @@ type = real kind = kind_phys intent = in +[nssl_cccn] + standard_name = nssl_ccn_concentration + long_name = CCN concentration + units = m-3 + dimensions = () + type = real + kind = kind_phys + intent = in [nwfa] standard_name = mass_number_concentration_of_hygroscopic_aerosols long_name = number concentration of water-friendly aerosols @@ -1808,6 +1858,13 @@ dimensions = () type = integer intent = in +[otsptflag] + standard_name = flag_convective_tracer_transport_interstitial + long_name = flag for interstitial tracer transport + units = flag + dimensions = (number_of_tracers) + type = logical + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/docs/library.bib b/physics/docs/library.bib index 48ef43910..2ee46aac9 100644 --- a/physics/docs/library.bib +++ b/physics/docs/library.bib @@ -3310,6 +3310,44 @@ @inproceedings{yudin_et_al_2019 Title = {Longitudinal Variability of Wave Dynamics in Weather Models Extended into the Mesosphere and Thermosphere}, Year = {2019}} +@article{mansell_2013, + Author = {Edward R. Mansell and Conrad L. Ziegler}, + Date-Added = {2015-02-26 22:32:59 +0000}, + Date-Modified = {2020-02-10 23:06:41 +0000}, + Doi = {10.1175/JAS-D-12-0264.1}, + Journal = {Journal of the Atmospheric Sciences}, + Keywords = {storm electrification, microphysics 2-moment}, + Number = {7}, + Pages = {2032-2050}, + Title = {Aerosol Effects on Simulated Storm Electrification and Precipitation in a Two-moment Bulk Microphysics Model}, + Volume = {70}, + Year = {2013}} + +@article{mansell_2010, + Author = {Edward R. Mansell}, + Date-Added = {2011-02-22 10:34:11 -0600}, + Date-Modified = {2011-02-22 10:35:34 -0600}, + Doi = {10.1175/2010JAS3341.1}, + Journal = {Journal of the Atmospheric Sciences}, + Keywords = {advection, microphysics 2-moment}, + Pages = {3084-3094}, + Title = {On Sedimentation and Advection in Multimoment Bulk Microphysics}, + Volume = {67}, + Year = {2010}} + +@article{mansell_etal_2010, + Author = {E. R. Mansell and C. L. Ziegler and E. C. Bruning}, + Date-Added = {2007-08-20 15:44:13 -0500}, + Date-Modified = {2010-04-13 16:55:16 -0500}, + Doi = {10.1175/2009JAS2965.1}, + Journal = {Journal of the Atmospheric Sciences}, + Keywords = {storm electrification, microphysics 2-moment}, + Pages = {171-194}, + Title = {Simulated Electrification of a Small Thunderstorm with Two-Moment Bulk Microphysics}, + Volume = {67}, + Year = {2010}} + + @comment{BibDesk Static Groups{ diff --git a/physics/docs/pdftxt/NSSLMICRO.txt b/physics/docs/pdftxt/NSSLMICRO.txt new file mode 100644 index 000000000..5d94f6600 --- /dev/null +++ b/physics/docs/pdftxt/NSSLMICRO.txt @@ -0,0 +1,35 @@ +/** +\page NSSLMICRO NSSL 2-moment Microphysics Scheme +\section nssl2m_descrp Description + +The NSSL two-moment bulk microphysical parameterization scheme that describes form and phase changes among a range of liquid and ice hydrometeors, as described in Mansell et al. (2010) \cite Mansell_etal_2010 and Mansell and Ziegler (2013) \cite Mansell_2013. The microphysical parameterization predicts the mass mixing ratio and number concentration of cloud droplets, raindrops, cloud ice crystals (columns), snow particles (including large crystals and aggregates), graupel, and (optionally) hail. + +The graupel and hail particle densities are also calculated by predicting the total particle volume. The graupel category therefore emulates a range of characteristics from high-density frozen drops (includes small hail) to low-density graupel (from rimed ice crystals/snow) in its size and density spectrum. The hail category is designed to simulate larger hail sizes. Hail is only produced from higher-density large graupel. + +Hydrometeor size distributions are assumed to follow a gamma functional form. Microphysical processes include cloud droplet and cloud ice nucleation, condensation, deposition, evaporation, sublimation, collection–coalescence, variable-density riming, shedding, ice multiplication, cloud ice aggregation, freezing and melting, and conversions between hydrometeor categories. + +CCN concentration is predicted as in Mansell et al. (2010) with a bulk activation spectrum approximating small aerosols. The model tracks the number of unactivated CCN, and the local CCN concentration is depleted as droplets are activated, either at cloud base or in cloud. The CCN are subjected to advection and subgrid turbulent mixing but have no other interactions with hydrometeors; for example, scavenging by raindrops is omitted. CCN are restored by droplet evaporation and by a gradual regeneration when no hydrometeors are present. Aerosol sensitivity is enhanced by explicitly treating droplet condensation instead of using a saturation adjustment. Supersaturation (within reason) is allowed to persist in updraft with low droplet concentration. + +Excessive size sorting (common in 2-moment schemes) is effectively controlled by an adaptive breakup method that prevents reflectivity growth by sedimentation (Mansell 2010 \cite Mansell_2010). + +The NSSL scheme is designed with deep (severe) convection in mind at grid spacings of 4km or smaller, but can also be run at larger grid spacing as needed for nesting etc. It is also able to capture non-severe and winter weather. + +Namelist parameters: +- \b nssl_hail_on: (logical: .true./.false.) Turns the hail category (3 variables: mass, number, and volume) Default value is .false. Field table variables: hailwat, hail_nc, hail_vol + +- \b nssl_ccn_on: (logical: .true./.false.) Turns prediction on/off for simple CCN number concentration. Default value is .true. Field table variable: ccn_nc + +- \b nssl_cccn: (real) Background CCN concentration at STP. CCN are initialized as a constant number mixing ratio (nssl_cccn/1.225). The default value is 0.6e9 m-3 + +- \b nssl_alphah, nssl_alphahl: (real) Shape parameters for graupel (h) and hail (hl). Default values are 0.0 and 1.0. + + + +\section intra_nssl2m Intraphysics Communication +\ref arg_table_mp_nssl_run + +\section gen_nssl2m General Algorithm +- \ref gen_nssl2m_init +- \ref gen_nssl2m_driver + +*/ diff --git a/physics/h2ointerp.f90 b/physics/h2ointerp.f90 index fe7acaed3..f26ae6c0c 100644 --- a/physics/h2ointerp.f90 +++ b/physics/h2ointerp.f90 @@ -123,7 +123,7 @@ subroutine setindxh2o(npts,dlat,jindx1,jindx2,ddy) enddo return - end + end subroutine setindxh2o ! !********************************************************************** ! @@ -201,6 +201,6 @@ subroutine h2ointerpol(me,npts,idate,fhour,jindx1,jindx2,h2oplout,ddy) enddo ! return - end + end subroutine h2ointerpol end module h2ointerp diff --git a/physics/maximum_hourly_diagnostics.F90 b/physics/maximum_hourly_diagnostics.F90 index 1486ac027..6beae0da2 100644 --- a/physics/maximum_hourly_diagnostics.F90 +++ b/physics/maximum_hourly_diagnostics.F90 @@ -27,7 +27,8 @@ end subroutine maximum_hourly_diagnostics_finalize #endif subroutine maximum_hourly_diagnostics_run(im, levs, reset, lradar, imp_physics, & imp_physics_gfdl, imp_physics_thompson, & - imp_physics_fer_hires,con_g, phil, & + imp_physics_fer_hires, imp_physics_nssl, & + con_g, phil, & gt0, refl_10cm, refdmax, refdmax263k, u10m, v10m, & u10max, v10max, spd10max, pgr, t2m, q2m, t02max, & t02min, rh02max, rh02min, dtp, rain, pratemax, & @@ -36,7 +37,8 @@ subroutine maximum_hourly_diagnostics_run(im, levs, reset, lradar, imp_physics, ! Interface variables integer, intent(in) :: im, levs logical, intent(in) :: reset, lradar - integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_fer_hires + integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_fer_hires, & + imp_physics_nssl real(kind_phys), intent(in ) :: con_g real(kind_phys), intent(in ) :: phil(:,:) real(kind_phys), intent(in ) :: gt0(:,:) @@ -73,15 +75,23 @@ subroutine maximum_hourly_diagnostics_run(im, levs, reset, lradar, imp_physics, !Calculate hourly max 1-km agl and -10C reflectivity if (lradar .and. (imp_physics == imp_physics_gfdl .or. & imp_physics == imp_physics_thompson .or. & - imp_physics == imp_physics_fer_hires)) then + imp_physics == imp_physics_fer_hires .or. & + imp_physics == imp_physics_nssl )) then allocate(refd(im)) allocate(refd263k(im)) call max_fields(phil,refl_10cm,con_g,im,levs,refd,gt0,refd263k) if (reset) then - do i=1,im - refdmax(i) = -35. - refdmax263k(i) = -35. - enddo + IF ( imp_physics == imp_physics_nssl ) THEN ! ERM: might not need this as a separate assignment + do i=1,im + refdmax(i) = 0. + refdmax263k(i) = 0. + enddo + ELSE + do i=1,im + refdmax(i) = -35. + refdmax263k(i) = -35. + enddo + ENDIF endif do i=1,im refdmax(i) = max(refdmax(i),refd(i)) diff --git a/physics/maximum_hourly_diagnostics.meta b/physics/maximum_hourly_diagnostics.meta index 6f7a055b8..391dbde52 100644 --- a/physics/maximum_hourly_diagnostics.meta +++ b/physics/maximum_hourly_diagnostics.meta @@ -63,6 +63,13 @@ dimensions = () type = integer intent = in +[imp_physics_nssl] + standard_name = identifier_for_nssl_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme + units = flag + dimensions = () + type = integer + intent = in [con_g] standard_name = gravitational_acceleration long_name = gravitational acceleration diff --git a/physics/module_MYNNPBL_wrapper.F90 b/physics/module_MYNNPBL_wrapper.F90 index 7c0ba1ba4..64892e542 100644 --- a/physics/module_MYNNPBL_wrapper.F90 +++ b/physics/module_MYNNPBL_wrapper.F90 @@ -64,6 +64,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & qgrs_ozone, & & qgrs_water_aer_num_conc, & & qgrs_ice_aer_num_conc, & + & qgrs_cccn, & & prsl,exner, & & slmsk,tsurf,qsfc,ps, & & ust,ch,hflx,qflx,wspd,rb, & @@ -95,6 +96,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & dqdt_ice_cloud, dqdt_ozone, & ! <=== ntiw, ntoz & dqdt_cloud_droplet_num_conc, dqdt_ice_num_conc, & ! <=== ntlnc, ntinc & dqdt_water_aer_num_conc, dqdt_ice_aer_num_conc, & ! <=== ntwa, ntia + & dqdt_cccn, & ! <=== ntccn & flag_for_pbl_generic_tend, & & dtend, dtidx, index_of_temperature, & & index_of_x_wind, index_of_y_wind, ntke, & @@ -108,6 +110,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & icloud_bl, do_mynnsfclay, & & imp_physics, imp_physics_gfdl, & & imp_physics_thompson, imp_physics_wsm6, & + & imp_physics_nssl, nssl_ccn_on, & & ltaerosol, spp_wts_pbl, spp_pbl, lprnt, huge, errmsg, errflg ) ! should be moved to inside the mynn: @@ -195,7 +198,7 @@ SUBROUTINE mynnedmf_wrapper_run( & ! NAMELIST OPTIONS (INPUT): LOGICAL, INTENT(IN) :: bl_mynn_tkeadvect, ltaerosol, & lprnt, do_mynnsfclay, & - flag_for_pbl_generic_tend + flag_for_pbl_generic_tend, nssl_ccn_on INTEGER, INTENT(IN) :: & & bl_mynn_cloudpdf, & & bl_mynn_mixlength, & @@ -210,6 +213,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & grav_settling, & & imp_physics, imp_physics_wsm6, & & imp_physics_thompson, imp_physics_gfdl, & + & imp_physics_nssl, & & spp_pbl !TENDENCY DIAGNOSTICS @@ -253,6 +257,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & dqdt_water_vapor, dqdt_liquid_cloud, dqdt_ice_cloud, & & dqdt_cloud_droplet_num_conc, dqdt_ice_num_conc, & & dqdt_ozone, dqdt_water_aer_num_conc, dqdt_ice_aer_num_conc + real(kind=kind_phys), dimension(:,:), intent(inout) ::dqdt_cccn real(kind=kind_phys), dimension(:,:), intent(inout) :: & & qke, qke_adv, EL_PBL, Sh3D, & & qc_bl, qi_bl, cldfra_bl @@ -272,6 +277,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & qgrs_ozone, & & qgrs_water_aer_num_conc, & & qgrs_ice_aer_num_conc + real(kind=kind_phys), dimension(:,:), intent(in) ::qgrs_cccn real(kind=kind_phys), dimension(:,:), intent(out) :: & & Tsq, Qsq, Cov, exch_h, exch_m real(kind=kind_phys), dimension(:), intent(in) :: xmu @@ -401,6 +407,37 @@ SUBROUTINE mynnedmf_wrapper_run( & qnifa(i,k) = 0. enddo enddo + elseif (imp_physics == imp_physics_nssl ) then + ! NSSL + FLAG_QI = .true. + FLAG_QNI= .true. + FLAG_QC = .true. + FLAG_QNC= .true. + FLAG_QNWFA= nssl_ccn_on ! ERM: Perhaps could use this field for CCN field? + FLAG_QNIFA= .false. + ! p_q vars not used? + p_qc = 2 + p_qr = 0 + p_qi = 2 + p_qs = 0 + p_qg = 0 + p_qnc= 0 + p_qni= 0 + do k=1,levs + do i=1,im + sqv(i,k) = qgrs_water_vapor(i,k) + sqc(i,k) = qgrs_liquid_cloud(i,k) + sqi(i,k) = qgrs_ice_cloud(i,k) + ozone(i,k) = qgrs_ozone(i,k) + qnc(i,k) = qgrs_cloud_droplet_num_conc(i,k) + qni(i,k) = qgrs_cloud_ice_num_conc(i,k) + qnwfa(i,k) = 0. + IF ( nssl_ccn_on ) THEN + qnwfa(i,k) = qgrs_cccn(i,k) + ENDIF + qnifa(i,k) = 0. + enddo + enddo elseif (imp_physics == imp_physics_thompson) then ! Thompson if(ltaerosol) then @@ -841,6 +878,21 @@ SUBROUTINE mynnedmf_wrapper_run( & ! enddo !enddo endif !end thompson choice + elseif (imp_physics == imp_physics_nssl) then + ! NSSL + do k=1,levs + do i=1,im + dqdt_water_vapor(i,k) = RQVBLTEN(i,k) !/(1.0 + qv(i,k)) + dqdt_liquid_cloud(i,k) = RQCBLTEN(i,k) !/(1.0 + qv(i,k)) + dqdt_cloud_droplet_num_conc(i,k) = RQNCBLTEN(i,k) + dqdt_ice_cloud(i,k) = RQIBLTEN(i,k) !/(1.0 + qv(i,k)) + dqdt_ice_num_conc(i,k) = RQNIBLTEN(i,k) + IF ( nssl_ccn_on ) THEN ! + dqdt_cccn(i,k) = RQNWFABLTEN(i,k) + ENDIF + enddo + enddo + elseif (imp_physics == imp_physics_gfdl) then ! GFDL MP do k=1,levs diff --git a/physics/module_MYNNPBL_wrapper.meta b/physics/module_MYNNPBL_wrapper.meta index 3e3267668..19532207c 100644 --- a/physics/module_MYNNPBL_wrapper.meta +++ b/physics/module_MYNNPBL_wrapper.meta @@ -336,6 +336,14 @@ type = real kind = kind_phys intent = in +[qgrs_cccn] + standard_name = cloud_condensation_nuclei_number_concentration + long_name = number concentration of cloud condensation nuclei + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout [prsl] standard_name = air_pressure long_name = mean layer pressure @@ -994,6 +1002,14 @@ type = real kind = kind_phys intent = inout +[dqdt_cccn] + standard_name = tendency_of_cloud_condensation_nuclei_number_concentration_due_to_model_physics + long_name = number concentration of cloud condensation nuclei tendency due to model physics + units = kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout [flag_for_pbl_generic_tend] standard_name = flag_for_generic_tendency_due_to_planetary_boundary_layer long_name = true if GFS_PBL_generic should calculate tendencies @@ -1250,6 +1266,20 @@ dimensions = () type = integer intent = in +[imp_physics_nssl] + standard_name = identifier_for_nssl_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[nssl_ccn_on] + standard_name = nssl_ccn_on + long_name = CCN activation flag in NSSL micro + units = flag + dimensions = () + type = logical + intent = in [ltaerosol] standard_name = flag_for_aerosol_physics long_name = flag for aerosol physics diff --git a/physics/module_mp_nssl_2mom.F90 b/physics/module_mp_nssl_2mom.F90 new file mode 100644 index 000000000..e6f2ae162 --- /dev/null +++ b/physics/module_mp_nssl_2mom.F90 @@ -0,0 +1,19964 @@ +! !> \file module_mp_nssl_2mom.F90 + + + + + + + + +!--------------------------------------------------------------------- +! code snapshot: "Feb 24 2022" at "14:27:57" +!--------------------------------------------------------------------- +!--------------------------------------------------------------------- +! IMPORTANT: Best results are attained using the 5th-order WENO (Weighted Essentially Non-Oscillatory) advection option (4) for scalars: +! moist_adv_opt = 4, +! scalar_adv_opt = 4, (can also use option 3, which is WENO without the positive definite filter) +! The WENO-5 scheme provides a 5th-order (horizontal and vertical) adaptive weighting of components that +! better preserve monotinicity in strong gradients. The standard 5th-order formulation is prone to undershoots +! (negative values) of mass and number concentrations at cloud edges. The WENO scheme helps +! to prevent undershoots and results in less noise at cloud and reflectivity boundaries. This is particularly +! useful for multi-moment schemes to preserve relationships between mass and number concentration. An option is also available +! for WENO-5 advection of momentum, but this can result in excessive damping of poorly-resolved features. For both scalar and momentum +! the steps 1 and 2 of the Runge-Kutta time integration use standare 5th-order advection, and the WENO-5 is applied on the 3rd (final) +! RK step. Option 3 applies the WENO-5, and option 4 adds the positive definite filter (as also used in option 1). +! +! WENO references: Jiang and Shu, 1996, J. Comp. Phys. v. 126, 202-223; Shu 2003, Int. J. Comp. Fluid Dyn. v. 17 107-118; +! +!>\ingroup mod_mp_nssl2m +!! This module provides a 2-moment bulk microphysics scheme described by +!! Mansell, Zeigler, and Bruning (2010, JAS) +!! +!! This module provides a 2-moment bulk microphysics scheme based on a combination of +!! Straka and Mansell (2005, JAM) and Zeigler (1985, JAS) and modified/upgraded in +!! in Mansell, Zeigler, and Bruning (2010, JAS). Two-moment adaptive sedimentation +!! follows Mansell (2010, JAS), using parameter infall = 4. +!! +!! Added info on graupel density and soaking is in Mansell and Ziegler (2013, JAS) +!! +!! Average graupel particle density is predicted, which affects fall speed as well. +!! Hail density prediction is by default disabled in this version, but may be enabled +!! at some point if there is interest. +!! +!! Maintainer: Ted Mansell, National Severe Storms Laboratory +!! +!! Microphysics References: +!! +!! Mansell, E. R., C. L. Ziegler, and E. C. Bruning, 2010: Simulated electrification of a small +!! thunderstorm with two-moment bulk microphysics. J. Atmos. Sci., 67, 171-194, doi:10. 1175/2009JAS2965.1. +!! +!! Mansell, E. R. and C. L. Ziegler, 2013: Aerosol effects on simulated storm electrification and +!! precipitation in a two-moment bulk microphysics model. J. Atmos. Sci., 70 (7), 2032-2050, +!! doi:10.1175/JAS-D-12-0264.1. +!! +!! Ziegler, C. L., 1985: Retrieval of thermal and microphysical variables in observed convective storms. +!! Part I: Model development and preliminary testing. J. Atmos. Sci., 42, 1487-1509. +!! +!! Sedimentation reference: +!! +!! Mansell, E. R., 2010: On sedimentation and advection in multimoment bulk microphysics. +!! J. Atmos. Sci., 67, 3084-3094, doi:10.1175/2010JAS3341.1. +! +! Possible parameters to adjust: +! +! ccn : base cloud condensation nuclei concentration (use namelist.input value "nssl_cccn") +! alphah, alphahl : Size distribution shape parameters for graupel (h) and hail (hl) +! infall : changes sedimentation options to see effects (see below) +! +! lightning model references: +! +! Fierro, A. O., E.R. Mansell, C. Ziegler and D. R. MacGorman 2013: The +! implementation of an explicit charging and discharge lightning scheme +! within the WRF-ARW model: Benchmark simulations of a continental squall line, a +! tropical cyclone and a winter storm. Monthly Weather Review, Volume 141, 2390-2415 +! +! Mansell et al. 2005: Charge structure and lightning sensitivity in a simulated +! multicell thunderstorm. J. Geophys. Res., 110, D12101, doi:10.1029/2004JD005287 +! +! Note: Some parameters below apply to unreleased features. +! +! +!--------------------------------------------------------------------- +! Sept. 2021: +! Fixes: +! Restored previous formulation of snow reflectivity, as it was realized that the last change incorrectly assumed a fixed +! density independent of size. Generally lower snow reflectivity values as a result (no effect on microphysics) +! Other: +! Generic fall speed coeffecients (axx,bxx) to accomodate future frozen drops category (no effect) +! Reordered collection coefficients (dab1lh) to be consistent (no effect) +! Switched to full calculation of rain number loss via collection by graupel (chacr; to be consisted with collection by hail) (minor effects) +!--------------------------------------------------------------------- +! April 2021: +! Fixes: +! Fall speed air density factor limited to air density of 0.05 (for very high model top) to mitigate excessive fall speeds +! Fixed issue of spurious creation of large concentrations of very small droplets and transient large condensation (also increased minimum droplet size) +! Fixed issue of negligible "seed" values of graupel from Bigg freezing at relatively high temperatures (thanks to S. Lasher-Trapp) +! Minor bug fix in effective radius calculation of snow. (thanks to T. Iguchi) +! Updates: +! Enabled regeneration of CCN by droplet evaporation and background restore (default time constant of 3600s) +! Updated the routine that handles single-moment variables on the first time step. This sets a higher threshold for meaningful mixing ratios and sets a more realistic droplet concentration (also activating CCN as needed). +! Enabled radar reflectivity from cloud ice (new formulation) ( idbzci = 1 ) +! Added internal option for ice crystal nucleation by DeMott et al. (2010, PNAS) (inucopt=4) +! Allow greater fraction of hail to melt in one time step +! Reduced minimum number concentration from 1e-4 to 1e-8 (based on CAPS input) +! Added internal namelist for easier access to internal variables for development/testing and easier setup for ensemble microphysics diversity +! (namelist read is disabled by default) +! Increased resolution of lookup table for incomplete gamma functions +! +!--------------------------------------------------------------------- +! Sept. 2019: +! Bug fixes: +! - Effective radius calculation was only done at history times. Now every time step (though should be just before radiation is called) +! - Snow reflectivity: Previous "fix" was incorrect and yields snow dBZ that is too low. Reverted to old version which was correct +! - Incorrectly updated a state value in the reflectivity code. (Could cause small differences if reflectivity is not calculated) +! Updates: +! - Added code hints to use the "axtra2d" array to communicate rates from the microphysics routine into any 3d arrays that are passed in to the driver. +! - Graupel and hail drag coefficients are returned from fall speed subroutine to use in ventilation coeffs. for consistency (minor change) +! - Added (compile) option flag to turn on diagnosis of cloud droplet shape parameter based on number concentration +! - Added (compile) option flag icracr to turn off rain self-collection +! - Added compile options 'depfac' and 'meltfac' to adjust deposition/sublimation and melting (not freezing) rates of graupel/hail by a constant factor (for experimentation). Default value is 1.0 +! - Put limit on snow volume (2 cm) in aggregation rate +!--------------------------------------------------------------------- +! WRF 4.0 update: +! Major: +! Fixed excessive sublimation that could occur in very strong downdrafts (3.9.1.1 update) +! +! Minor: +! icefallopt=3 : New ice crystal fall speed that has faster speeds for small ice particles. Main effect +! is on anvil clouds to help them decay a bit faster. Old behavior can be recovered with icefallopt=1 +! Cosmetic: removed stray single quotes because some preprocessors complain about unclosed quotes even in comments +! +!--------------------------------------------------------------------- +! WRF 3.9.1.1 update: +! +! Added a check on overdepletion of ice by sublimation, which could sometimes result in water supersaturation +! Bug fix: setting of t7 used 'dn' instead of 'dn1' (Thanks to Chunxi Zhang) +! +!--------------------------------------------------------------------- +! WRF 3.9 updates: +! +! 2-moment scheme now creates number concentration tendencies from cumulus scheme mass mixing ratio rates +! Renamed internal gamma function routine from 'gamma' to 'gamma_sp' to avoid name conflicts +! Restored older settings that allow snow aggregation starting at T > -25C +! Adjusted Meyers number of activated nuclei by the local air density to compensate for using data at surface +! Minor updates to rain-ice crystal and hail-rain collection efficiencies +! +! +! Reduced minimum mean snow diameter from 100 microns to 10 microns +! +!--------------------------------------------------------------------- +! WRF 3.8 updates: +! Fixed issue with reflectivity conservation for graupel melting into rain. Rain number concentrations were too low, +! resulting in excessive reflectivity of a couple dBZ +! Changed default value of iusewetgraupel to 1 (turns off diagnostic meltwater on graupel for reflectivity) +! Apply a 70 m/s fall speed limit for sedimentation +! Changed vapor ice nucleation to Meyers-Ferrier method (original scheme) +! New method for Bigg freezing (ibiggopt=2) +! Reduced snow aggregration efficiency and restricted aggregation to higher temperatures (assuming dendrites and mechanical aggregation) +! Increased maximum graupel-droplet collection efficiency when hail is turned off (nssl_2momg) +! Updates for compatibility with WRF-NMM +! Added calculation of hail number concentration in calcnfromq (creates number concentration from mixing ratio +! when starting from an analysis). And fixed error in graupel intercept +! Bug fix in snow fall speeds +! Further fix in snow reflectivity +! Use diameter of maximum mass rather than mean diamter when checking maximum size +! Helped performance in sedimentation with flag "do_accurate_sedimentation" to control recalculation of fall speeds when +! more than one sub-time step is needed (often happens with large time steps and small dz near the ground): +! = .true. : recalculates fall speed after each substep (more accurate) +! = .false. : (default) reuses fall speeds calculated on the first substep (typical for most schemes), theoretically could cause an occasional glitch, but none seen in practice +! Increased maximum mean droplet radius from 40 to 60 microns, which alleviates spurious number concentration increases at low CCN concentration. +! Removed a duplicate factor from hail reflectivity that was causing a loss of about 6 dBZ (since WRF 3.5). +! +!--------------------------------------------------------------------- + + + +!>\defgroup mod_nsslmp NSSL 2-moment microphysics modules +!!\ingroup nsslmp testphrase one +!! Module for NSSL cloud physics +MODULE module_mp_nssl_2mom + IMPLICIT NONE + + public nssl_2mom_driver + public nssl_2mom_init + public nssl_2mom_init_const + public calc_eff_radius + public calcnfromq + private gamma_sp,gamxinf,GAML02, GAML02d300, GAML02d500, fqvs, fqis + private gamma_dp, gamxinfdp, gamma_dpr + private delbk, delabk + private gammadp + + logical, private :: cleardiag = .false. + PRIVATE + +#if ( WRF_CHEM == 1 ) + integer, parameter :: wrfchem_flag = 1 +#else + integer, parameter :: wrfchem_flag = 0 +#endif + + LOGICAL, PRIVATE:: is_aerosol_aware = .false. + + logical, private :: turn_on_cin = .false. + + integer, private :: eqtset = 1 ! Flag for use with cm1 to use alternate equation set (changes latent heating rates) + ! value of > 2 invokes the equivalent version of eqtset=2 that applies updates to both theta and Pi. + double precision, parameter, public :: zscale = 1.0d0 ! 1.000e-10 + double precision, parameter, public :: zscaleinv = 1.0d0/zscale ! 1.000e-10 + + + real, parameter :: warmonly = 0.0 ! testing parameter, set to 1.0 to reduce to warm-rain physics (ice variables stay zero) + + logical, parameter :: lwsm6 = .false. ! act like wsm6 for some single moment interactions + +! some constants from WSM6 + real, parameter :: dimax = 500.e-6 ! limited maximum value for the cloud-ice diamter + real, parameter :: roqimax = 2.08e22*dimax**8 + +! Params for dbz: + integer :: iuseferrier = 1 ! =1: use dry graupel only from Ferrier 1994; = 0: Use Smith (wet graupel) + integer :: idbzci = 1 + integer :: iusewetgraupel = 1 ! =1 to turn on use of QHW for graupel reflectivity (only for ZVDM -- mixedphase) + ! =2 turn on for graupel density less than 300. only + integer :: iusewethail = 0 ! =1 to turn on use of QHW for graupel reflectivity (only for ZVDM -- mixedphase) + integer :: iusewetsnow = 0 ! =1 to turn on diagnosed bright band; =2 'old' snow reflectivity (dry), =3 'old' snow dbz + brightband +! microphysics + + real, private :: rho_qr = 1000., cnor = 8.0e5 ! cnor is set in namelist!! rain params + real, private :: rho_qs = 100., cnos = 3.0e6 ! set in namelist!! snow params + real, private :: rho_qh = 500., cnoh = 4.0e5 ! set in namelist!! graupel params + real, private :: rho_qhl= 900., cnohl = 4.0e4 ! set in namelist!! hail params + + real, private :: hdnmn = 170.0 ! minimum graupel density (for variable density graupel) + real, private :: hldnmn = 500.0 ! minimum hail density (for variable density hail) + + real :: cnohmn = 1.e-2 ! minimum intercept for 2-moment graupel (alphah < 0.5) + real :: cnohlmn = 1.e-2 ! minimum intercept for 2-moment hail (alphahl < 0.5) + +! Autoconversion parameters + + real , private :: qcmincwrn = 2.0e-3 ! qc threshold for autonconversion (LFO; for 10ICE use qminrncw for ircnw != 5) + real , private :: cwdiap = 20.0e-6 ! threshold diameter of cloud drops (Ferrier 1994 autoconversion) + real , private :: cwdisp = 0.15 ! assume droplet dispersion parameter (can be 0.3 for maritime) + real , private :: ccn = 0.6e+09 ! set in namelist!! Central plains CCN value + real , public :: qccn ! ccn "mixing ratio" + real , private :: old_qccn = -1.0 + integer, private :: iauttim = 1 ! 10-ice rain delay flag + real , private :: auttim = 300. ! 10-ice rain delay time + real , private :: qcwmntim = 1.0e-5 ! 10-ice rain delay min qc for time accrual + +#if (NMM_CORE == 1) +! NMM WRF core does not have special boundary conditions for CCN, therefore set invertccn to true + logical, parameter :: invertccn = .true. ! =true for base state of ccn=0, =false for ccn initialized in the base state +#else + logical, parameter :: invertccn = .false. ! =true for base state of ccn=0, =false for ccn initialized in the base state +#endif + logical :: switchccn = .false. + real :: old_cccn = -1.0 + logical :: restoreccn = .true. ! whether or not to nudge CCN back to base state (qccn) (only applies if CCNA is NOT predicted) + real :: ccntimeconst = 3600. ! time constant for CCN restore (either for CCNA or when restoreccn = true) + +! sedimentation flags +! itfall -> 0 = 1st order fallout (other options removed) +! iscfall, infall -> fallout options for charge and number concentration, respectively +! 1 = mass-weighted fall speed; 2 = number-weighted fallspeed. + integer, private :: itfall = 0 + integer, private :: iscfall = 1 + integer, private :: irfall = -1 + logical, private :: do_accurate_sedimentation = .true. ! if true, recalculate fall speeds on sub time steps; (more expensive) + ! if false, reuse fall speeds on multiple steps (can have a noticeable speedup) + ! Mainly is an issue for small dz near the surface. + integer, private :: interval_sedi_vt = 2 ! interval for recalculating Vt in sedimentation subloop (only when do_accurate_sedimentation = .true.) + integer, private :: infall = 4 ! 0 -> uses number-wgt for N; NO correction applied (results in excessive size sorting) + ! 1 -> uses mass-weighted fallspeed for N ALWAYS + ! 2 -> uses number-wgt for N and mass-weighted correction for N (Method II in Mansell, 2010 JAS) + ! 3 -> uses number-wgt for N and Z-weighted correction for N (Method I in Mansell, 2010 JAS) + ! 4 -> Hybrid of 2 and 3: Uses minimum N from each method (z-wgt and m-wgt corrections) (Method I+II in Mansell, 2010 JAS) + ! 5 -> uses number-wgt for N and uses average of N-wgt and q-wgt instead of Max. + real, private :: rainfallfac = 1.0 ! factor to adjust rain fall speed (single moment only) + real, private :: icefallfac = 1.5 ! factor to adjust ice fall speed + real, private :: snowfallfac = 1.25 ! factor to adjust snow fall speed + real, private :: graupelfallfac = 1.0 ! factor to adjust graupel fall speed + real, private :: hailfallfac = 1.0 ! factor to adjust hail fall speed + integer, private :: icefallopt = 3 ! 1= default, 2 = Ferrier ice fall speed; 3 = adjusted Ferrier (slightly high Vt) + integer, private :: icdx = 3 ! (graupel) 0=Ferrier; 1=leave drag coef. cd fixed; 2=vary by density, 4=set by user with cdxmin,cdxmax,etc. + integer, private :: icdxhl = 3 ! (hail) 0=Ferrier; 1=leave drag coef. cd fixed; 2=vary by density, 4=set by user with cdxmin,cdxmax,etc. + real , private :: cdhmin = 0.45, cdhmax = 0.8 ! defaults for graupel (icdx=4) + real , private :: cdhdnmin = 500., cdhdnmax = 800.0 ! defaults for graupel (icdx=4) + real , private :: cdhlmin = 0.45, cdhlmax = 0.6 ! defaults for hail (icdx=4) + real , private :: cdhldnmin = 500., cdhldnmax = 800.0 ! defaults for hail (icdx=4) + real , private :: vtmaxsed = 70. ! Limit on fall speed (m/s, all moments) for sedimentation calculations. Not applied to fall speeds for microphysical rates + + integer :: rssflg = 1 ! Rain size-sorting allowed (1, default), or disallowed (0). If 0, sets N and Z-weighted fall speeds to q-weighted value + integer :: sssflg = 1 ! As above but for snow + integer :: hssflg = 1 ! As above but for graupel + integer :: hlssflg = 1 ! As above but for hail + +! input flags + + integer, private :: ndebug = -1, ncdebug = 0 + integer, private :: ipconc = 5 + integer, private :: inucopt = 0 + integer, private :: ichaff = 0 + integer, parameter :: ilimit = 0 + + real, private :: constccw = -1. + + real, private :: cimn = 1.0e3, cimx = 1.0e6 + + real , private :: rhofrz = 900 ! density of freezing drops + real , private :: ifrzg = 1.0 ! fraction of frozen drops (Bigg freezing) going to graupel. 1=freeze all rain to graupel, 0=freeze all to hail + real , private :: ifiacrg = 1.0 ! fraction of frozen drops (3-component freezing qiacr) going to graupel. 1=freeze all rain to graupel, 0=freeze all to hail + real , private :: ifrzs = 1.0 ! fraction of small frozen drops going to snow. 1=freeze rain to snow, 0=freeze to cloud ice + real , private :: ffrzs = 0.0 ! fraction of other initiated cloud ice going to snow. 1=freeze rain to snow, 0=freeze to cloud ice + real , private :: f2h = 1.0 ! fraction of cloud ice conversion going to graupel (vs. frozen drops). For testing + integer, private :: irwfrz = 1 ! compute total rain that can freeze (checks heat budget) + integer, private :: irimtim = 0 ! future use +! integer, private :: infdo = 1 ! 1 = calculate number-weighted fall speeds + + integer, private :: irimdenopt = 1 ! = 1 for default Macklin; = 2 for experimental Cober and List (1993) + real , private :: rimc1 = 300.0, rimc2 = 0.44 ! rime density coeff. and power (Default Heymsfield and Pflaum, 1985) + real , private :: rimc3 = 170.0 ! minimum rime density + real :: rimc4 = 900.0 ! maximum rime density + real , private :: rimtim = 120.0 ! cut-off rime time (10ICE) + real , private :: eqtot = 1.0e-9 ! threshold for mass budget reporting + real, private :: rimdenvwgt = 0.0 ! weight (0-1) given to number-weighted fall speed when calculating rime density + + integer, private :: ireadmic = 0 + + integer, private :: idiagnosecnu = 0 ! =1 to diagnose cnu based on Chandrakar et al. 2016 data; =2 for Geoffroy et al. (2010, ACP) + integer, private :: iccwflg = 1 ! sets max size of first droplets in parcel to 4 micron radius (in two-moment liquid) + ! (first nucleation is done with a KW sat. adj. step) + integer, private :: issfilt = 0 ! flag to turn on filtering of supersaturation field + integer, private :: icnuclimit = 0 ! limit droplet nucleation based on Konwar et al. (2012) and Chandrakar et al. (2016) + integer, private :: irenuc = 2 ! =1 to always allow renucleation of droplets within the cloud + ! =2 renucleation following Twomey/Cohard&Pinty + ! =7 New renucleation that requires prediction of the number of activated nuclei + ! i.e., not only at cloud base + integer, private :: irenuc3d = 0 ! =1 to include horizontal gradient in renucleation of droplets within the cloud + real :: renucfrac = 0.0 ! = 0 : cnuc = cwccn + ! = 1 : cnuc = actual available CCN + ! otherwise cnuc = cwccn*(1. - renufrac) + ccnc(1:ngscnt)*renucfrac + real :: ssf2kmax = 10. ! max value for ssf**cck in irenuc=4 or 5 + real , private :: cck = 0.6 ! exponent in Twomey expression + real , private :: ciintmx = 1.0e6 ! limit on ice concentration from primary nucleation + + real , private :: cwccn ! , cwmasn,cwmasx + real , private :: ccwmx + + integer, private :: idocw = 1, idorw = 1, idoci = 1, idoir = 1, idoip = 1, idosw = 1 + integer, private :: idogl = 1, idogm = 1, idogh = 1, idofw = 1, idohw = 1, idohl = 1 +! integer, private :: ido(3:14) = / 12*1 / + + +! 0,2, 5.00e-10, 1, 0, 0, 0 : itype1,itype2,cimas0,icfn,ihrn,ibfc,iacr + integer, private :: itype1 = 0, itype2 = 2 ! controls Hallett-Mossop process + integer, private :: icenucopt = 1 ! =1 Meyers/Ferrier primary ice nucleation; =2 Thompson/Cooper, =3 Phillips (Meyers/Demott), =4 DeMott (2010) + real, private :: naer = 1.0e6 ! background large aerosol conc. for DeMott + integer, private :: icfn = 2 ! contact freezing: 0 = off; 1 = hack (ok for single moment); 2 = full Cotton/Meyers version + integer, private :: ihrn = 0 ! Hobbs-Rangno ice multiplication (Ferrier, 1994; use in 10-ice only) + integer, private :: ibfc = 1 ! Flag to use Bigg freezing on droplets (0 = off (uses alternate freezing), 1 = on) + real, private :: cwfrz2snowfrac = 0.0 ! fraction of freezing droplet mass to send to snow + real, private :: cwfrz2snowratio = 5. ! Assumed number of frozen droplets in a cluster + integer, private :: iremoveqwfrz = 1 ! Whether to remove (=1) or not (=0) the newly-frozen cloud droplets (ibfc=1) from the CWC used for charge separation + integer, private :: iacr = 2 ! Flag for drop contact freezing with crytals + ! (0=off; 1=drops > 500micron diameter; 2 = > 300micron) + integer, private :: icracr = 1 ! Flag to turn rain self-collection on/off (=0 to turn off) + integer, private :: ibfr = 2 ! Flag for Bigg freezing conversion of freezing drops to graupel + ! (1=min graupel size is vr1mm; 2=use min size of dfrz, 5= as for 2 and apply dbz conservation) + integer, private :: ibiggopt = 2 ! 1 = old Bigg; 2 = experimental Bigg (only for imurain = 1, however) + integer :: ibiggsmallrain = 0 ! 1 = When rain is too small, freeze none to graupel and send all to snow (experimental) + integer, private :: iacrsize = 5 ! assumed min size of drops freezing by capture + ! 1: > 500 micron diam + ! 2: > 300 micron + ! 3: > 40 micron + ! 4: all sizes + ! 5: > 150 micron (only for imurain = 1) + real , private :: cimas0 = 6.62e-11 ! default mass of Hallett-Mossop crystals + ! 6.62e-11kg results in half the diam. (60 microns) of old default value of 5.0e-10 + real , private :: cimas1 = 6.88e-13 ! default mass of new ice crystals + real , private :: splintermass = 6.88e-13 + real , private :: cfnfac = 0.1 ! Hack factor that goes with icfn=1 + integer, private :: iscni = 4 ! default option for ice crystal aggregation/conversion to snow + real , private :: fscni = 1.0 ! factor for calculating cscni + logical, private :: imeyers5 = .false. ! .false.=off, true=on for Meyers ice nucleation for temp > -5 C + real , private :: dmincw = 15.0e-6 ! minimum droplet diameter for collection for iehw=3 + integer, private :: iehw = 1 ! 0 -> ehw=ehw0; 1 -> old ehw; 2 -> test ehw with Mason table data + integer, private :: iefw = 1 ! 0 -> ehw=ehw0; 1 -> old ehw; 2 -> test ehw with Mason table data + integer, private :: iehlw = 1 ! 0 -> ehlw=ehlw0; 1 -> old ehlw; 2 -> test ehlw with Mason table data + ! For ehw/ehlw = 1, ehw0/ehlw0 act as maximum limit on collection efficiency (defaults are 1.0) + integer, private :: ierw = 1 ! for single-moment rain (LFO/Z) + integer, private :: iehr0c = 0 ! 0 -> no collection for T > 0C; 1 -> turn on collection/shedding for T > 0C + integer, private :: iehlr0c = 0 ! 0 -> no collection for T > 0C; 1 -> turn on collection/shedding for T > 0C + real , private :: ehw0 = 0.9 ! constant or max assumed graupel-droplet collection efficiency + real , private :: erw0 = 1.0 ! constant assumed rain-droplet collection efficiency + real , private :: ehlw0 = 0.9 ! constant or max assumed hail-droplet collection efficiency + real , private :: efw0 = 0.5 ! constant or max assumed graupel-droplet collection efficiency + real :: ehr0 = 1.0 ! constant or max assumed graupel-rain collection efficiency + real :: efr0 = 1.0 ! constant or max assumed graupel-rain collection efficiency + real :: ehlr0 = 1.0 ! constant or max assumed hail-rain collection efficiency + real , private :: exwmindiam = 0.0 ! minimum diameter of droplets for riming. If set > 0, will exclude that fraction of mass/number from accretion (idea from Furtado and Field 2017 JAS but also Fierro and Mansell 2017) + + + real , private :: esilfo0 = 1.0 ! factor for LFO collection efficiency of snow for cloud ice. + real , private :: ehslfo0 = 1.0 ! factor for LFO collection efficiency of hail/graupel for snow. + + integer, private :: ircnw = 5 ! single-moment warm-rain autoconversion option. 5= Ferrier 1994. + real , private :: qminrncw = 2.0e-3 ! qc threshold for rain autoconversion (NA for ircnw=5) + + integer, private :: iqcinit = 2 ! For ZVDxx schemes, flag to choose which way to initialize droplets + ! 1 = Soong-Ogura adjustment + ! 2 = Saturation adjustment to value of ssmxinit + ! 3 = KW adjustment + + real , private :: ssmxinit = 0.4 ! saturation percentage to adjust down to for initial cloud + ! formation (ZVDxx scheme only) + + real , private :: ewfac = 1.0 ! hack factor applied to graupel and hail collection eff. for droplets + real , private :: eii0 = 0.1 ,eii1 = 0.1 ! graupel-crystal coll. eff. parameters: eii0*exp(eii1*min(temcg(mgs),0.0)) + ! set eii1 = 0 to get a constant value of eii0 + real , private :: eii0hl = 0.2 ,eii1hl = 0.0 ! hail-crystal coll. eff. parameters: eii0hl*exp(eii1hl*min(temcg(mgs),0.0)) + ! set eii1hl = 0 to get a constant value of eii0hl + real , private :: eri0 = 0.1 ! rain efficiency to collect ice crystals + real , private :: eri_cimin = 10.e-6 ! minimum ice crystal diameter for collection by rain + real , private :: esi0 = 0.1 ! linear factor in snow-ice collection efficiency + real , private :: ehs0 = 0.1, ehs1 = 0.1 ! graupel-snow coll. eff. parameters: ehs0*exp(ehs1*min(temcg(mgs),0.0)) + ! set ehs1 = 0 to get a constant value of ehs0 + real , private :: ess0 = 0.5, ess1 = 0.05 ! snow aggregation coefficients: ess0*exp(ess1*min(temcg(mgs),0.0)) + ! set ess1 = 0 to get a constant value of ess0 + real , private :: esstem1 = -15. ! lower temperature where snow aggregation turns on + real , private :: esstem2 = -10. ! higher temperature for linear ramp of ess from zero at esstem1 to formula value at esstem2 + real , private :: essrmax = 0.02 ! maximum snow radius (meters) for csacs + real , private :: essfrac1 = 0.5 ! snow mass fraction 1 for aggregation roll-off + real , private :: essfrac2 = 0.75 ! snow mass fraction 2 for aggregation roll-off + integer, private :: iessec0flag = 0 ! flag to activate aggregation roll-off + real , private :: ehsfrac = 1.0 ! multiplier for graupel collection efficiency in wet growth + real , private :: ehimin = 0.0 ! Minimum collection efficiency (graupel - ice crystal) + real , private :: ehimax = 1.0 ! Maximum collection efficiency (graupel - ice crystal) + real , private :: ehsmax = 0.5 ! Maximum collection efficiency (graupel - snow) + real , private :: ecollmx = 0.5 ! Maximum collision efficiency for graup/hail with ice; used only for charging rates + integer, private :: iglcnvi = 1 ! flag for riming conversion from cloud ice to rimed ice/graupel + integer, private :: iglcnvs = 2 ! flag for conversion from snow to rimed ice/graupel + + real , private :: rz ! reflectivity conservation factor for graupel/rain + ! now calculated in icezvd_dr.F from alphah and rnu + ! currently only used for graupel melting to rain + real , private :: rzhl ! reflectivity conservation factor for hail/rain + ! now calculated in icezvd_dr.F from alphahl and rnu + + real , private :: rzs ! reflectivity conservation factor for snow(imusnow=3) with rain (imurain=1) + + real , private :: alphahacx = 0.0 ! assumed minimum shape parameter for zhacw and zhacr + + real , private :: fconv = 1.0 ! factor to boost max graupel depletion by riming conversions in 10ICE + + real , private :: rg0 = 400.0 ! reference graupel density for graupel fall speed + + integer, private :: rcond = 2 ! (Z only) rcond = 2 includes rain condensation in loop with droplet condensation + ! 0 = no condensation on rain; 1 = bulk condensation on rain + integer, parameter, private :: icond = 1 ! (Z only) icond = 1 calculates ice deposition (crystals and snow) BEFORE droplet condensation + ! icond = 2 does not work (intended to calc. dep in loop with droplet cond.) + + real , private :: dfrz = 0.15e-3 ! 0.25e-3 ! minimum diameter of frozen drops from Bigg freezing (used for vfrz) for iacr > 1 + ! and for ciacrf for iacr=4 + real , private :: dmlt = 3.0e-3 ! maximum diameter for rain melting from graupel and hail + real , private :: dshd = 1.0e-3 ! nominal diameter for rain drops shed from graupel/hail + integer, private :: ished2cld = 0 ! 1: Send shed liquid (from wet growth) to cloud droplets + + integer, private :: ihmlt = 2 ! 1=old melting with vmlt; 2=new melting using mean volume diam of graupel/hail + integer, private :: imltshddmr = 2 ! 0 (default)=mean diameter of drops produced during melting+shedding as before (using mean diameter of graupel/hail + ! and max mean diameter of rain) + ! 1=new method where mean diameter of rain during melting is adjusted linearly downward + ! toward 3 mm for large (> sheddiam) graupel and hail, to take into account shedding of + ! smaller drops. sheddiam0 controls the size of graupel/hail above which the assumed + ! mean diameter of rain is set to 3 mm + ! Only valid for ihmlt = 2 for ZVD(H) but also applies to ZVD(H)M + ! 2 = method that sets the resulting rain size ( vshdgs ) according to the mass-weighted diameter of the ice + + real :: mltdiam1 = 9.0e-3, mltdiam2 = 16.0e-3, mltdiam3 = 19.0e-3, mltdiam4 = 200.0e-3, mltdiam05 = 4.5e-3 + + integer, private :: nsplinter = 0 ! number of ice splinters per freezing drop, if negative, then per resulting graupel particle + real, private :: lawson_splinter_fac = 2.5e-11 ! constant in Lawson et al. (2015, JAS) for ice particle production from freezing drops + integer, private :: isnwfrac = 0 ! 0= no snow fragmentation; 1 = turn on snow fragmentation (Schuur, 2000) + +! integer, private :: denscale = 1 ! 1=scale num. conc. and charge by air density for advection, 0=turn off for comparison + + real, private :: qhdpvdn = -1. + real, private :: qhacidn = -1. + + logical, private :: mixedphase = .false. ! .false.=off, true=on to include mixed phase graupel + integer, private :: imixedphase = 0 + logical, private :: qsdenmod = .false. ! true = modify snow density by linear interpolation of snow and rain density + logical, private :: qhdenmod = .false. ! true = modify graupel density by linear interpolation of graupel and rain density + logical, private :: qsvtmod = .false. ! true = modify snow fall speed by linear interpolation of snow and rain vt + real , private :: sheddiam = 8.0e-03 ! minimum diameter of graupel before shedding occurs + real :: sheddiamlg = 10.0e-03 ! diameter of hail to use fwmlarge + real :: sheddiam0 = 20.0e-03 ! diameter of hail at which all water is shed + + integer :: ifwmhopt = 2 ! option for calculating maximum liquid fraction when fwmh and/or fwmhl is set to -1 + ! 1 = maximum based on size of maximum mass diameter + ! 2 = integrate over spectrum for maximum liquid (experimental) + + integer :: ihxw2rain = 0 ! = 0 no transfer + ! = 1 transfer completely melted (99.5%) graupel/hail to rain when fwmh/fwmhl is set to -1. + + real , private :: fwms = 0.5 ! maximum liquid water fraction on snow + real , private :: fwmh = 0.5 ! maximum liquid water fraction on graupel + real , private :: fwmhl = 0.5 ! maximum liquid water fraction on hail + real :: fwmlarge = 0.2 ! maximum liquid water fraction on hail larger than sheddiam + integer :: ifwmfall = 0 ! whether to interpolate toward rain fall speed for graupel and hail + ! when diam < sheddiam and liquid fraction is predicted (0=no, 1=yes) + + logical :: rescale_high_alpha = .false. ! whether to rescale number. conc. when alpha = alphamax (3-moment only) + logical :: rescale_low_alpha = .true. ! whether to rescale Z (graupel/hail) when alpha = alphamin (3-moment only) + logical :: rescale_low_alphar = .true. ! whether to rescale Z for rain when alpha = alphamin (3-moment only) + logical :: rescale_low_alphah = .true. ! whether to rescale Z for rain when alpha = alphamin (3-moment only) + logical :: rescale_low_alphahl = .true. ! whether to rescale Z for rain when alpha = alphamin (3-moment only) + + real, parameter :: alpharmax = 8. ! limited for rwvent calculation + + integer, private :: ihlcnh = 1 ! which graupel -> hail conversion to use + ! 1 = Milbrandt and Yau (2005) using Ziegler 1985 wet growth diameter + ! 2 = Straka and Mansell (2005) conversion using size threshold + real, private :: hlcnhdia = 1.e-3 ! threshold diameter for graupel -> hail conversion for ihlcnh = 1 option. + real, private :: hlcnhqmin = 0.1e-3 ! minimum graupel mass content for graupel -> hail conversion (ihlcnh = 1) + real , private :: hldia1 = 20.0e-3 ! threshold diameter for graupel -> hail conversion for ihlcnh = 2 option. + integer, private :: iusedw = 0 ! flag to use experimental wet growth ice diameter for gr -> hl conversion (=1 turns on) + real , private :: dwmin = 0.0 ! Minimum diameter with iusedw (can stay at 0 or be set to something larger) + real , private :: dwtempmin = 242. ! lowest temperature to allow wet growth conversion to hail + real , private :: dwehwmin = 0. ! Minimum ehw to use to find wet growth diameter (if > ehw0, then wet growth diam becomes smaller) + real , private :: dg0thresh = 0.15 ! graupel wet growth diameter above which we say do not bother + integer :: icvhl2h = 0 ! allow conversion of hail back to graupel when hail density gets close to minimum allowed + + integer, private :: imurain = 1 ! 3 for gamma-volume, 1 for gamma-diameter DSD for rain. + integer, private :: imusnow = 3 ! 3 for gamma-volume, 1 for gamma-diameter DSD for snow (=1 NOT IMPLEMENTED!!). + integer, private :: iturbenhance = 0 ! warm-rain collision enhancement + ! 1 = enhance autoconversion only + ! 2 = add rain collection of cloud + ! 3 = add rain self-collection + integer, private :: isedonly = 0 ! 1= only do sedimentation and skip other microphysics + integer, private :: iferwisventr = 2 ! =1 for Ferrier rwvent, =2 for Wisner rwvent (imurain=1) + integer, private :: izwisventr = 2 ! =1 for old Ziegler rwvent, =2 for Wisner-style rwvent (imurain=3) + integer :: iresetmoments = 0 ! if >0, then set all moments to zero when one of them is zero (3-moment only) + integer, private :: imaxdiaopt = 3 + ! = 1 use mean diameter for breakup + ! = 2 use maximum mass diameter for breakup + ! = 3 use mass-weighted diameter for breakup + integer, private :: dmrauto = 0 + ! = -1 no limiter on crcnw + ! = 0 limit crcnw when qr > 1.2*L (Cohard-Pinty 2002) + ! = 1 DTD version based on MY code + ! = 2 DTD mass-weighted version based on MY code + ! = 3 Milbrandt version (from Cohard and Pinty code + integer :: dmropt = 0 ! extra option for crcnw + integer :: dmhlopt = 1 ! options for graupel -> conversion + integer :: irescalerainopt = 3 ! 0 = default option + ! 1 = qx(mgs,lc) > qxmin(lc) + ! 2 = qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < 3.0 + ! 3 = temcg(mgs) > 0.0.and. qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < 3.0 + real :: rescale_wthresh = 3.0 + real :: rescale_tempthresh = 0.0 + real, parameter :: alpharaut = 0.0 ! MY2005 for autoconversion + real :: cxmin = 1.e-8 ! threshold cutoff for number concentration + real :: zxmin = 1.e-28 ! threshold cutoff for reflectivity moment + + integer :: ithompsoncnoh = 0 ! For single moment graupel only + ! 0 = fixed intercept + ! 1 = intercept based on graupel mass + + integer :: ivhmltsoak = 1 ! 0=off, 1=on : flag to simulate soaking (graupel/hail) during melting + ! when liquid fraction is not predicted + logical :: iwetsoak = .true. ! soak and freeze during wet growth or not + integer, private :: ioldlimiter = 0 ! test switch for new(=0) or old(=1) size limiter at the end of GS for 3-moment categories + integer, private :: isnowfall = 2 ! Option for choosing between snow fall speed parameters + ! 1 = original Zrnic et al. (Mansell et al. 2010) + ! 2 = Ferrier 1994 (results in slower fall speeds) + + integer, private :: isnowdens = 1 ! Option for choosing between snow density options + ! 1 = constant of 100 kg m^-3 + ! 2 = Option based on Cox + + integer, private :: ibiggsnow = 3 ! 1 = switch conversion over to snow for small frozen drops from Bigg freezing + ! 2 = switch conversion over to snow for small frozen drops from rain-ice interaction + ! 3 = switch conversion over to snow for small frozen drops from both + real :: biggsnowdiam = -1.0 ! If >0, use for ibiggsnow threshold + + integer, private :: ixtaltype = 1 ! =1 column, =2 disk (similar to Takahashi) + + real, private :: takshedsize1 = 0.15 ! diameter (cm) of drop shed from ice with D > 1.9 cm + real, private :: takshedsize2 = 0.3 ! diameter (cm) of drop shed from ice with D < 1.9 cm and D > 0.8 cm + real, private :: takshedsize3 = 0.45 ! diameter (cm) of drop shed from ice with D < 1.6 cm and D > 0.8 cm + integer, private :: numshedregimes = 3 + + real, private :: evapfac = 1.0 ! Multiplier on rain evaporation rate + real, private :: depfac = 1.0 ! Multiplier on graupel/hail deposition/sublimation rate + real,private,parameter :: meltfac = 1.0 ! Multiplier on graupel/hail melting rate + + integer, private :: ibinhmlr = 0 ! =1 use incomplete gammas to determine melting from larger and smaller sizes of graupel, and appropriate shed drop sizes + ! =2 to test melting by temporary bins + integer, private :: ibinhlmlr = 0 ! =1 use incomplete gammas to determine melting from larger and smaller sizes of hail, and appropriate shed drop sizes + ! =2 to test melting by temporary bins + integer, private :: ibinnum = 2 ! number of bins for melting of smaller ice (for ibinhmlr = 1) + integer, private :: iqhacrmlr = 1 ! turn on/off qhacrmlr + integer, private :: iqhlacrmlr = 1 ! turn on/off qhlacrmlr + real, private :: binmlrmxdia = 40.e-3 ! threshold diameter (graupel/hail) to switch bin-bulk melting to use standard chmlr + real, private :: binmlrzrrfac = 1.0 ! factor for reflectivity change ice that sheds while melting + real, private :: snowmeltdia = 0 ! If nonzero, sets the size of rain drops from melting snow. + real, private :: delta_alphamlr = 0.5 ! offset from alphamax at which melting does not further collapse the shape parameter + + integer :: iqvsopt = 0 ! =0 use old default for tabqvs; =1 use Bolton formulation (Rogers and Yau) + + integer :: imaxsupopt = 4 ! how to treat saturation adjustment in two-moment droplets + ! 1 = add droplets with same mean mass as current droplets + ! 2 = add droplets with minimum radius of 30 microns + ! 3 = only add 1.5*cxmin to number concentration (allow max size to apply) + ! 4 = add droplets with minimum radius of 20 microns + real :: maxsupersat = 1.9 ! maximum supersaturation ratio, above which a saturation adustment is done + real :: maxlowtempss = 1.08 ! Sat. ratio threshold for allowing droplet nucleation at T < tfrh + real :: ssmxuf = 4.0 ! supersaturation at which to start using "ultrafine" CCN (if ccnuf > 0.) + + + integer, parameter :: icespheres = 0 ! turn ice spheres (frozen droplets) on (1) or off (0). NOT COMPLETE IN WRF/ARPS/CM1 CODE! + integer, parameter :: lqmx = 30 + integer, parameter :: lt = 1 + integer, parameter :: lv = 2 + integer, parameter :: lc = 3 + integer, parameter :: lr = 4 + integer, parameter :: li = 5 + integer, private :: lis = 0 + integer, private :: ls = 6 + integer, private :: lh = 7 + integer, private :: lf = 0 + integer, private :: lhl = 0 + + integer, private :: lccn = 9 ! 0 or 9, other indices adjusted accordingly + integer, private :: lccnuf = 0 + integer, private :: lccna = 0 + integer, private :: lcina = 0 + integer, private :: lcin = 0 + integer, private :: lnc = 9 + integer, private :: lnr = 10 + integer, private :: lni = 11 + integer, private :: lnis = 0 + integer, private :: lns = 12 + integer, private :: lnh = 13 + integer, private :: lnf = 0 + integer, private :: lnhl = 0 + integer, private :: lnhf = 0 + integer, private :: lnhlf = 0 + integer, private :: lss = 0 + integer :: lvh = 15 + + integer, private :: lhab = 8 + integer, private :: lg = 7 + +! Particle volume + + integer :: lvi = 0 + integer :: lvs = 0 + integer :: lvgl = 0 + integer :: lvgm = 0 + integer :: lvgh = 0 + integer :: lvf = 0 +! integer :: lvh = 16 + integer :: lvhl = 0 + +! liquid water fraction (not predicted here but tested for) + integer :: lhw = 0 + integer :: lfw = 0 + integer :: lsw = 0 + integer :: lhlw = 0 + integer :: lhwlg = 0 + integer :: lhlwlg = 0 + +! reflectivity (6th moment) ! not predicted here but may be tested against + + integer :: lzr = 0 + integer :: lzi = 0 + integer :: lzs = 0 + integer :: lzgl = 0 + integer :: lzgm = 0 + integer :: lzgh = 0 + integer :: lzf = 0 + integer :: lzh = 0 + integer :: lzhl = 0 + +! Space charge + + integer :: lscw = 0 + integer :: lscr = 0 + integer :: lsci = 0 + integer :: lscis = 0 + integer :: lscs = 0 + integer :: lsch = 0 + integer :: lscf = 0 + integer :: lschl = 0 + integer :: lscwi = 0 + integer :: lscpi = 0 + integer :: lscni = 0 + integer :: lscpli = 0 + integer :: lscnli = 0 + integer :: lschab = 0 + + integer :: lscb = 0 + integer :: lsce = 0 + integer :: lsceq = 0 + +! integer, parameter :: lscmx = 100 + + integer :: lne = 0 ! last varible for transforming + + real :: cnoh0 = 4.0e+5 + real :: hwdn1 = 700.0 + + real :: alphai = 0.0 ! shape parameter for ZIEG ice crystals ! not currently used + real :: alphas = 0.0 ! shape parameter for ZIEG snow ! used only for single moment + real :: alphar = 0.0 ! shape parameter for rain (imurain=1 only) + real, private :: alphah = 0.0 ! set in namelist!! shape parameter for ZIEG graupel + real, private :: alphahl = 1.0 ! set in namelist!! shape parameter for ZIEG hail + + real :: dmuh = 1.0 ! power in exponential part (graupel) + real :: dmuhl = 1.0 ! power in exponential part (hail) + + real, private :: alphamax = 15. + real, private :: alphamin = 0. + real, parameter :: rnumin = -0.8 + real, parameter :: rnumax = 15.0 + + + real :: cnu = 0.0 ! default value of droplet shape parameter. Can be diagnosed by setting idiagnosecnu=1 + real, parameter :: rnu = -0.8, snu = -0.8, cinu = 0.0 +! parameter ( cnu = 0.0, rnu = -0.8, snu = -0.8, cinu = 0.0 ) + + real xnu(lc:lqmx) ! 1st shape parameter (mass) + real xmu(lc:lqmx) ! 2nd shape parameter (mass) + real dnu(lc:lqmx) ! 1st shape parameter (diameter) + real dmu(lc:lqmx) ! 2nd shape parameter (diameter) + + real ax(lc:lqmx) + real bx(lc:lqmx) + real fx(lc:lqmx) + + real da0 (lc:lqmx) ! collection coefficients from Seifert 2005 + real dab0(lc:lqmx,lc:lqmx) ! collection coefficients from Seifert 2005 + real dab1(lc:lqmx,lc:lqmx) ! collection coefficients from Seifert 2005 + real da1 (lc:lqmx) ! collection coefficients from Seifert 2005 + real bb (lc:lqmx) + +! put ipelec here for now.... + integer :: ipelec = 0 + integer :: isaund = 0 + logical :: idoniconly = .false. + integer, private :: elec_on_time = -1 ! time (seconds) to turn on charge separation. + integer, private :: elec_ramp_time = 0 ! time (interval) for linear ramp after elec_on_time + ! (i.e., linear factor on chg sep to smoothly turn on elec) + ! full charging rate is achieved at time = elec_on_time + elec_ramp_time + integer :: jchgs = 3 ! number of points near boundary where charging is turned off (to keep lightning from getting wonky) + integer :: jchgn = 2 + integer :: ichge = 3 + integer :: ichgw = 2 + real :: charging_border = 4000. ! width of no-charging zone from boundary + real, private :: delqnw = -1.0e-10!-1.0e-12 ! + real, private :: delqxw = 1.0e-10! 1.0e-12 ! + real :: tindmn = 233, tindmx = 298.0 ! min and max temperatures where inductive charging is allowed + +! +! gamma function lookup table +! + integer ngm0,ngm1,ngm2 + parameter (ngm0=3001,ngm1=500,ngm2=500) + double precision, parameter :: dgam = 0.01, dgami = 100. + double precision gmoi(0:ngm0) ! ,gmod(0:ngm1,0:ngm2),gmdi(0:ngm1,0:ngm2) + + integer, parameter :: nqiacralpha = 240 !480 ! 240 ! 120 ! 15 + integer, parameter :: nqiacrratio = 100 ! 500 !50 ! 25 +! real, parameter :: maxratiolu = 25. + real, parameter :: maxratiolu = 100. ! 25. + real, parameter :: maxalphalu = 15. + real, parameter :: minalphalu = -0.95 + real, parameter :: dqiacralpha = maxalphalu/Float(nqiacralpha), dqiacrratio = maxratiolu/Float(nqiacrratio) + real, parameter :: dqiacrratioinv = 1./dqiacrratio, dqiacralphainv = 1./dqiacralpha + integer, parameter :: ialpstart = minalphalu*dqiacralphainv + real :: ciacrratio(0:nqiacrratio,ialpstart:nqiacralpha) + real :: qiacrratio(0:nqiacrratio,ialpstart:nqiacralpha) + real :: ziacrratio(0:nqiacrratio,ialpstart:nqiacralpha) + double precision :: gamxinflu(0:nqiacrratio,ialpstart:nqiacralpha,12,2) ! last index for graupel (1) or hail (2) +! real :: ciacrratio(0:nqiacrratio,0:nqiacralpha) +! real :: qiacrratio(0:nqiacrratio,0:nqiacralpha) +! real :: ziacrratio(0:nqiacrratio,0:nqiacralpha) +! double precision :: gamxinflu(0:nqiacrratio,0:nqiacralpha,12,2) ! last index for graupel (1) or hail (2) + + integer, parameter :: ngdnmm = 9 + real :: mmgraupvt(ngdnmm,3) ! Milbrandt and Morrison (2013) fall speed coefficients for graupel/hail + + DATA mmgraupvt(:,1) / 50., 150., 250., 350., 450., 550., 650., 750., 850./ + DATA mmgraupvt(:,2) / 62.923, 94.122, 114.74, 131.21, 145.26, 157.71, 168.98, 179.36, 189.02 / + DATA mmgraupvt(:,3) / 0.67819, 0.63789, 0.62197, 0.61240, 0.60572, 0.60066, 0.59663, 0.59330, 0.59048 / + + integer lsc(lc:lqmx) + integer ln(lc:lqmx) + integer ipc(lc:lqmx) + integer lvol(lc:lqmx) + integer lz(lc:lqmx) + integer lliq(li:lqmx) + integer denscale(lc:lqmx) ! flag for density scaling (mixing ratio conversion) + + integer ido(lc:lqmx) + logical ldovol + + real xdn0(lc:lqmx) + real xdnmx(lc:lqmx), xdnmn(lc:lqmx) + real cdx(lc:lqmx) + real cno(lc:lqmx) + real xvmn(lc:lqmx), xvmx(lc:lqmx) + real qxmin(lc:lqmx) + real qxmin_init(lc:lqmx) + + integer nqsat + parameter (nqsat=1000001) ! (nqsat=20001) + real fqsat,fqsati + parameter (fqsat=0.002,fqsati=1./fqsat) + real tabqvs(nqsat),tabqis(nqsat),dtabqvs(nqsat),dtabqis(nqsat) + +! +! constants +! + real, parameter :: ar = 841.99666 ! rain terminal velocity power law coefficient (LFO) + real, parameter :: br = 0.8 ! rain terminal velocity power law coefficient (LFO) + real, parameter :: aradcw = -0.27544 ! + real, parameter :: bradcw = 0.26249e+06 ! + real, parameter :: cradcw = -1.8896e+10 ! + real, parameter :: dradcw = 4.4626e+14 ! + real, parameter :: bta1 = 0.6 ! beta-1 constant used for ice nucleation by deposition (Ferrier 94, among others) + real, parameter :: cnit = 1.0e-02 ! No for ice nucleation by deposition (Cotton et al. 86) + real, parameter :: dragh = 0.60 ! coefficient used to adjust fall speed for hail versus graupel (Pruppacher and Klett 78) + real, parameter :: dnz00 = 1.225 ! reference/MSL air density + real, parameter :: rho00 = 1.225 ! reference/MSL air density +! cs = 4.83607122 ! snow terminal velocity power law coefficient (LFO) +! ds = 0.25 ! snow terminal velocity power law coefficient (LFO) +! new values for cs and ds + real, parameter :: cs = 12.42 ! snow terminal velocity power law coefficient + real, parameter :: ds = 0.42 ! snow terminal velocity power law coefficient + real :: cp608 = 0.608 ! constant used in conversion of T to Tv + real :: gr = 9.8 + + real, parameter :: pi = 3.141592653589793 + real, parameter :: piinv = 1./pi + real, parameter :: pid4 = pi/4.0 + +! +! max and min mean volumes +! + real xvrmn, xvrmx0 ! min, max rain volumes + real xvsmn, xvsmx ! min, max snow volumes + real xvfmn, xvfmx ! min, max frozen drop volumes + real xvgmn, xvgmx ! min, max graupel volumes + real xvhmn, xvhmn0, xvhmx, xvhmx0 ! min, max hail volumes + real xvhlmn, xvhlmx ! min, max lg hail volumes + + real, parameter :: dhlmn = 0.3e-3, dhlmx = 40.e-3 + real, parameter :: dhmn0 = 0.3e-3 + real, private :: dhmn = dhmn0, dhmx = -1. + + real, parameter :: cwradn = 2.0e-6, xcradmn = cwradn ! minimum radius + real, parameter :: cwradx = 60.e-6, xcradmx = cwradx ! maximum radius + real, parameter :: cwc1 = 6.0/(pi*1000.) + +! parameter( xvcmn=4.188e-18 ) ! mks min volume = 3 micron radius + real, parameter :: xvcmn=0.523599*(2.*cwradn)**3 ! mks min volume = 2.5 micron radius + real, parameter :: xvcmx=0.523599*(2.*xcradmx)**3 ! mks min volume = 2.5 micron radius + real, parameter :: cwmasn = 1000.*xvcmn ! minimum mass, defined by radius of 5.0e-6 + real, parameter :: cwmasx = 1000.*xvcmx ! maximum mass, defined by radius of 50.0e-6 + real, parameter :: cwmasn5 = 1000.*0.523599*(2.*5.0e-6)**3 ! 5.23e-13 + + real, parameter :: xvimn=0.523599*(2.*5.e-6)**3 ! mks min volume = 5 micron radius + real, parameter :: xvimx=0.523599*(2.*1.e-3)**3 ! mks max volume = 1 mm radius (solid sphere approx) + + real, private :: xvdmx = -1.0 ! 3.0e-3 + real :: xvrmx + parameter( xvrmn=0.523599*(80.e-6)**3, xvrmx0=0.523599*(6.e-3)**3 ) !( was 4.1887e-9 ) ! mks + parameter( xvsmn=0.523599*(0.01e-3)**3, xvsmx=0.523599*(10.e-3)**3 ) !( was 4.1887e-9 ) ! mks + parameter( xvfmn=0.523599*(0.1e-3)**3, xvfmx=0.523599*(10.e-3)**3 ) ! mks xvfmx = (pi/6)*(10mm)**3 + parameter( xvgmn=0.523599*(0.1e-3)**3, xvgmx=0.523599*(10.e-3)**3 ) ! mks xvfmx = (pi/6)*(10mm)**3 + parameter( xvhmn0=0.523599*(0.3e-3)**3, xvhmx0=0.523599*(20.e-3)**3 ) ! mks xvfmx = (pi/6)*(20mm)**3 + parameter( xvhlmn=0.523599*(dhlmn)**3, xvhlmx=0.523599*(dhlmx)**3 ) ! mks xvfmx = (pi/6)*(40mm)**3 + +! +! electrical permitivity of air C / (N m**2) - check the units +! + real eperao + parameter (eperao = 8.8592e-12 ) + + real ec,eci ! fundamental unit of charge + parameter (ec = 1.602e-19) + parameter (eci = 1.0/ec) + + real :: scwppmx = 20.0e-12 + real :: scippmx = 20.0e-12 +! +! constants +! + real, parameter :: c1f3 = 1.0/3.0 + + real, parameter :: cai = 21.87455 + real, parameter :: caw = 17.2693882 + real, parameter :: cbi = 7.66 + real, parameter :: cbw = 35.86 + + real, parameter :: cbwbolton = 29.65 ! constants for Bolton formulation + real, parameter :: cawbolton = 17.67 + + real, parameter :: tfrh = 233.15 + real :: tfr = 273.15 + + real :: cp = 1004.0, rd = 287.04 + real :: rw = 461.5 ! gas const. for water vapor + REAL, PRIVATE :: cpl = 4190.0 + REAL, PRIVATE :: cpigb = 2106.0 + real :: cpi + real :: cap + real :: tfrcbw + real :: tfrcbi + real :: rovcp + + real, parameter :: poo = 1.0e+05 + real, parameter :: advisc0 = 1.832e-05 ! reference dynamic viscosity (SMT; see Beard & Pruppacher 71) + real, parameter :: advisc1 = 1.718e-05 ! dynamic viscosity constant used in thermal conductivity calc + real, parameter :: tka0 = 2.43e-02 ! reference thermal conductivity + + ! GHB: Needed for eqtset=2 in cm1 +! REAL, PRIVATE :: cv = cp - rd + real, private, parameter :: cv = 717.0 ! specific heat at constant volume - air + REAL, PRIVATE, parameter :: cvv = 1408.5 + ! GHB + + real, parameter :: bfnu0 = (rnu + 2.0)/(rnu + 1.0) + real :: ventr, ventrn, ventc, c1sw + + + real :: cckm,ccne,ccnefac,cnexp,CCNE0 + + integer, public :: na = 9 + integer :: nxtra = 1 + real gf4p5, gf4ds, gf4br + real gsnow1, gsnow53, gsnow73 + real gfcinu1, gfcinu1p47, gfcinu2p47 + real gfcinu1p22,gfcinu2p22 + real gfcinu1p18,gfcinu2p18 + + real :: cwchtmp0 = 1.0 + real :: cwchltmp0 = 1.0 + + real :: esctot = 1.0e-13 + + integer iexy(lc:lqmx,lc:lqmx) + integer :: ieswi = 1, ieswc = 1, ieswr = 0 + integer :: iehlsw = 1, iehli = 1, iehlc = 1, iehlr = 0 + integer :: iehwsw = 1, iehwi = 1, iehwc = 1, iehwr = 0 + + logical, parameter :: do_satadj_for_wrfchem = .true. + + +! Note to users: Many of these options are for development and not guaranteed to perform well. +! Some may not be functional depending on the version of the code. +! Some may be useful for ensemble physics diversity. Feel free to contact me if you have questions +! in that regard. + NAMELIST /nssl_mp_params/ & + ndebug, ncdebug,& + iusewetgraupel, & + iusewethail, & + iusewetsnow, & + idbzci, & + vtmaxsed, & + itfall,iscfall, & + infall, & + rssflg, & + sssflg, & + hssflg, & + hlssflg, & + irimdenopt,rimdenvwgt, & + rimc1, rimc2, rimc3, rimc4, & + idiagnosecnu, & + icnuclimit, & + irenuc, & + restoreccn, ccntimeconst, cck, & + switchccn, old_cccn, & + ciintmx, & + itype1, itype2, & + icenucopt, & + naer, & + icfn, & + ibfc, iacr, icracr, & + cwfrz2snowfrac, cwfrz2snowratio, & + ibfr, & + ibiggopt, & + ibiggsmallrain, & + ifrzg,ifiacrg, & + ifrzs,ffrzs, & + iacrsize, & + cimas0, cimas1, cfnfac, & + splintermass, & + ewfac, & + eii0, eii1, & + eri0, esi0, & + eri_cimin, & + eii0hl, eii1hl, & + ehs0, ehs1, & + ess0, ess1, & + esstem1,esstem2, & + ircnw, qminrncw,& ! single-moment only + iglcnvi, & + iglcnvs, & + alphahacx, & + fconv, & + eqtot, & + imeyers5, & + iehw, & + ierw, & + iehr0c,iehlr0c, & + alphai, & + alphar, & + alphas, & ! note that alphah and alphahl come through physics namelist + cnu, & + iscni,fscni, & + dfrz, & + dmlt, & + rainfallfac, & + icefallfac, & + snowfallfac, & + graupelfallfac, & + hailfallfac, & + icefallopt, & + icdx,icdxhl, & + cdhmin, cdhmax, & + cdhdnmin, cdhdnmax, & + cdhlmin, cdhlmax, & + cdhldnmin, cdhldnmax, & + ihmlt, & + ehimin, & + ehimax, & + ehsmax, & + ecollmx, & + ehw0, ehlw0, & + ehr0, ehlr0, & + erw0, & + exwmindiam, & + nsplinter, & + lawson_splinter_fac, & + iqcinit, & + ssmxinit, & + xvdmx, & + dhmn, dhmx, & + fwms,fwmh,fwmhl, & + ifwmhopt, & + ihxw2rain, & + fwmlarge, & + ifwmfall, & + iturbenhance, & + qsdenmod,qhdenmod, & + qsvtmod, & + alphamin,alphamax, & + isnwfrac, & + rescale_low_alpha, & + rescale_low_alphar, & + rescale_low_alphah, & + rescale_low_alphahl, & + rescale_high_alpha, & + ihlcnh, hldia1,iusedw, dwehwmin, dwmin, dwtempmin, & + icvhl2h, hldnmn,hdnmn, & + hlcnhdia, hlcnhqmin, & + isedonly, & + iresetmoments, & + cxmin, zxmin, & + imurain, & + iferwisventr, & + izwisventr, & + qhdpvdn, & + qhacidn, & + sheddiam,sheddiamlg, & + sheddiam0, & + mltdiam1,mltdiam2,mltdiam3,mltdiam4,mltdiam05, & + imaxdiaopt, & + ithompsoncnoh, & + cnohmn, & + ivhmltsoak, & + ioldlimiter, & + isnowfall, & + isnowdens, & + ibiggsnow, & + ixtaltype, & + evapfac, & + depfac, & + dmrauto,irescalerainopt, dmropt,dmhlopt, & + rescale_tempthresh, rescale_wthresh, & + ibinhmlr,ibinhlmlr,imltshddmr, binmlrmxdia, binmlrzrrfac,ibinnum, & + iqhacrmlr, iqhlacrmlr, & + snowmeltdia, & + delta_alphamlr, & + iqvsopt, & + maxsupersat, & + do_accurate_sedimentation, interval_sedi_vt +! ##################################################################### +! ##################################################################### + + CONTAINS + +! ##################################################################### +! ##################################################################### + + +!>\ingroup mod_nsslmp +!! This function is for saturation vapor pressure with respect to liquid water + REAL FUNCTION fqvs(t) + implicit none + real :: t + fqvs = exp(caw*(t-273.15)/(t-cbw)) + END FUNCTION fqvs + +!>\ingroup mod_nsslmp +!! This function is for saturation vapor pressure with respect to ice + REAL FUNCTION fqis(t) + implicit none + real :: t + fqis = exp(cai*(t-273.15)/(t-cbi)) + END FUNCTION fqis + + + + +! ##################################################################### +! ##################################################################### + + +!>\ingroup mod_nsslmp +!! NSSL MP subroutine to initialize physical constants provided by host model + SUBROUTINE nssl_2mom_init_const( & + con_g, con_rd, con_cp, con_rv, con_t0c, con_cliq, con_csol, con_eps ) + + implicit none + real, intent(in) :: con_g, con_rd, con_cp, con_rv, & + con_t0c, con_cliq, con_csol, con_eps + + cp608 = con_eps ! 0.608 ! constant used in conversion of T to Tv + gr = con_g + tfr = con_t0c + cp = con_cp + rd = con_rd + rw = con_rv + cpl = con_cliq ! 4190.0 + cpigb = con_csol ! 2106.0 + cpi = 1./cp + cap = rd/cp + tfrcbw = tfr - cbw + tfrcbi = tfr - cbi + rovcp = rd/cp + + + + RETURN + END SUBROUTINE nssl_2mom_init_const +! ##################################################################### +! ##################################################################### +!>\ingroup mod_nsslmp +!! NSSL MP setup routine (sets local options and array indices) + SUBROUTINE nssl_2mom_init( & + & ims,ime, jms,jme, kms,kme, nssl_params, ipctmp, mixphase,ihvol,idoniconlytmp, & + & nssl_graupelfallfac, & + & nssl_hailfallfac, & + & nssl_ehw0, & + & nssl_ehlw0, & + & nssl_icdx, & + & nssl_icdxhl, & + & nssl_icefallfac, & + & nssl_snowfallfac, & + & errmsg, errflg, & + & myrank, mpiroot & + ) + + implicit none + + real, intent(in), optional :: & + & nssl_graupelfallfac, & + & nssl_hailfallfac, & + & nssl_ehw0, & + & nssl_ehlw0, & + & nssl_icefallfac, & + & nssl_snowfallfac + integer, intent(in), optional :: & + & nssl_icdx, & + & nssl_icdxhl, myrank, mpiroot + + ! CCPP error handling + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg + integer, intent(in) :: ims,ime, jms,jme, kms,kme + real, intent(in), dimension(20) :: nssl_params + + + + integer, intent(in) :: ipctmp,mixphase,ihvol + logical, optional, intent(in) :: idoniconlytmp + + logical :: wrote_namelist = .false. + logical :: wrf_dm_on_monitor + + double precision :: arg + real :: temq + integer :: igam + integer :: i,il,j,l + integer :: ltmp + integer :: isub + real :: bxh,bxhl + + real :: alp,ratio + double precision :: x,y,y2,y7 + logical :: turn_on_ccna, turn_on_cina + integer :: istat + + + errmsg = '' + errflg = 0 + turn_on_ccna = .false. + turn_on_cina = .false. +! +! set some global values from namelist input +! + + ccn = Abs( nssl_params(1) ) + alphah = nssl_params(2) + alphahl = nssl_params(3) + cnoh = nssl_params(4) + cnohl = nssl_params(5) + cnor = nssl_params(6) + cnos = nssl_params(7) + rho_qh = nssl_params(8) + rho_qhl = nssl_params(9) + rho_qs = nssl_params(10) + +! ipelec = Nint(nssl_params(11)) +! isaund = Nint(nssl_params(12)) + IF ( present(nssl_graupelfallfac) ) graupelfallfac = nssl_graupelfallfac + IF ( present(nssl_hailfallfac) ) hailfallfac = nssl_hailfallfac + IF ( present(nssl_ehw0) ) ehw0 = nssl_ehw0 + IF ( present(nssl_ehlw0) ) ehlw0 = nssl_ehlw0 + IF ( present(nssl_icdx) ) icdx = nssl_icdx + IF ( present(nssl_icdxhl) ) icdxhl = nssl_icdxhl + IF ( present(nssl_icefallfac) ) icefallfac = nssl_icefallfac + IF ( present(nssl_snowfallfac) ) snowfallfac = nssl_snowfallfac + + + IF ( Nint(nssl_params(13)) == 1 ) THEN + ! hack to switch CCN field to CCNA (activated ccn) +! invertccn = .true. + turn_on_ccna = .true. + irenuc = 7 + ENDIF + + + + + + IF ( .false. ) THEN ! set to true to enable internal namelist read + open(15,file='input.nml',status='old',form='formatted',action='read') + rewind(15) + read(15,NML=nssl_mp_params,iostat=istat) + close(15) + IF ( present ( myrank ) .and. present ( mpiroot ) ) THEN + IF ( myrank == mpiroot ) THEN + IF ( istat /= 0 ) THEN + write(0,*) 'NSSL_2MOM_INIT: PROBLEM WITH NSSL_MP_PARAMS namelist: not found or bad token' + ENDIF + +! write(0,*) 'iusewetsnow = ',iusewetsnow + + open(15,file='nssl_mp_params.out',status='unknown',form='formatted') + write(15,NML=nssl_mp_params) + close(15) + ENDIF + ENDIF + ENDIF + + + + IF ( irenuc >= 5 ) THEN + turn_on_ccna = .true. + ENDIF + + cwccn = ccn + + lhab = 8 + lhl = 8 + IF ( icespheres >= 1 ) THEN + lhab = lhab + 1 + lis = li + 1 + ls = ls + 1 + lh = lh + 1 + lhl = lhl + 1 + ENDIF + IF ( ihvol <= -1 .or. ihvol == 2 ) THEN + IF ( ihvol == -1 .or. ihvol == -2 ) THEN + lhab = lhab - 1 ! turns off hail + lhl = 0 + ! past me thought it would be a good idea to change graupel factors when hail is off.... + ! ehw0 = 0.75 + ! iehw = 2 + ! dfrz = Max( dfrz, 0.5e-3 ) + ENDIF + IF ( ihvol == -2 .or. ihvol == 2 ) THEN ! ice crystals are turned off + ! a value of -3 means to turn off ice crystals but turn on hail + renucfrac = 1.0 + ffrzs = 1.0 + ! idoci = 0 ! try this later + ENDIF + ENDIF + + IF ( iresetmoments == 0 ) iresetmoments = 1 ! lhl +! write(0,*) 'wrf_init: lhab,lhl = ',lhab,lhl + +! IF ( ipelec > 0 ) idonic = .true. + +! +! Build lookup table for saturation mixing ratio (Soong and Ogura 73) +! + + do l = 1,nqsat + temq = 163.15 + (l-1)*fqsat + IF ( iqvsopt == 0 ) THEN + tabqvs(l) = exp(caw*(temq-273.15)/(temq-cbw)) + dtabqvs(l) = ((-caw*(-273.15 + temq))/(temq - cbw)**2 + & + & caw/(temq - cbw))*tabqvs(l) + ELSE + tabqvs(l) = exp(caw*(temq-273.15)/(temq-cbw)) + dtabqvs(l) = ((-cawbolton*(-273.15 + temq))/(temq - cbwbolton)**2 + & + & cawbolton/(temq - cbwbolton))*tabqvs(l) + ENDIF + tabqis(l) = exp(cai*(temq-273.15)/(temq-cbi)) + dtabqis(l) = ((-cai*(-273.15 + temq))/(temq - cbi)**2 + & + & cai/(temq - cbi))*tabqis(l) + end do + + bx(lr) = 0.85 + ax(lr) = 1647.81 + fx(lr) = 135.477 + + IF ( icdx == 6 ) THEN + bx(lh) = 0.6 ! Milbrandt and Morrison (2013) for density of 550. + ax(lh) = 157.71 + ELSEIF ( icdx > 0 ) THEN + bx(lh) = 0.5 + ax(lh) = 75.7149 + ELSE + bx(lh) = 0.37 ! 0.6 ! Ferrier 1994 + ax(lh) = 19.3 + ENDIF +! bx(lh) = 0.6 + + IF ( lhl .gt. 1 ) THEN + IF ( icdxhl == 6 ) THEN + bx(lhl) = 0.593 ! Milbrandt and Morrison (2013) for density of 750. + ax(lhl) = 179.36 + ELSEIF (icdxhl > 0 ) THEN + bx(lhl) = 0.5 + ax(lhl) = 75.7149 + ELSE + ax(lhl) = 206.984 ! Ferrier 1994 + bx(lhl) = 0.6384 + ENDIF + ENDIF + +! fill in the complete gamma function lookup table + gmoi(0) = 1.d32 + do igam = 1,ngm0 + arg = dgam*igam + gmoi(igam) = gamma_dp(arg) + end do + + ! build lookup table to compute the number and mass fractions of rain drops + ! (imurain=1) greater than a given diameter. Used for qiacr and ciacr + ! Uses incomplete gamma functions + ! The terms with bxh or bxhl will be off if the actual bxh or bxhl is different from the base value (icdx=6 option) + + bxh = bx(lh) + bxhl = bx(Max(lh,lhl)) + +! DO j = 0,nqiacralpha + DO j = ialpstart,nqiacralpha + alp = float(j)*dqiacralpha + y = gamma_dpr(1.+alp) + y2 = gamma_dpr(2.+alp) + DO i = 0,nqiacrratio + ratio = float(i)*dqiacrratio + x = gamxinfdp( 1.+alp, ratio ) +! write(0,*) 'i, x/y = ',i, x/y + ciacrratio(i,j) = x/y + + ! graupel (.,.,.,1) + gamxinflu(i,j,1,1) = x/y + gamxinflu(i,j,2,1) = gamxinfdp( 2.0+alp, ratio )/y + gamxinflu(i,j,3,1) = gamxinfdp( 2.5+alp+0.5*bxh, ratio )/y + gamxinflu(i,j,5,1) = (gamma_dpr(5.0+alp) - gamxinfdp( 5.0+alp, ratio ))/y + gamxinflu(i,j,6,1) = (gamma_dpr(5.5+alp+0.5*bxh) - gamxinfdp( 5.5+alp+0.5*bxh, ratio ))/y + gamxinflu(i,j,9,1) = gamxinfdp( 1.0+alp, ratio )/y + gamxinflu(i,j,10,1)= gamxinfdp( 4.0+alp, ratio )/y + + gamxinflu(i,j,12,1) = gamxinfdp( 2.0+alp, ratio )/y2 + + ! hail (.,.,.,2) + gamxinflu(i,j,1,2) = gamxinflu(i,j,1,1) + gamxinflu(i,j,2,2) = gamxinflu(i,j,2,1) + gamxinflu(i,j,3,2) = gamxinfdp( 2.5+alp+0.5*bxhl, ratio )/y + gamxinflu(i,j,5,2) = gamxinflu(i,j,5,1) + gamxinflu(i,j,6,2) = (gamma_dpr(5.5+alp+0.5*bxhl) - gamxinfdp( 5.5+alp+0.5*bxhl, ratio ))/y + gamxinflu(i,j,9,2) = gamxinflu(i,j,9,1) + gamxinflu(i,j,10,2)= gamxinflu(i,j,10,1) + + IF ( alp > 1.1 ) THEN +! gamxinflu(i,j,7,1) = gamxinfdp( alp - 1., ratio )/y + gamxinflu(i,j,7,1) = (gamma_dpr(alp - 1.) - gamxinfdp( alp - 1., ratio ))/y +! gamxinflu(i,j,8,1) = gamxinfdp( alp - 0.5 + 0.5*bxh, ratio )/y + gamxinflu(i,j,8,1) = (gamma_dpr(alp - 0.5 + 0.5*bxh) - gamxinfdp( alp - 0.5 + 0.5*bxh, ratio ))/y +! gamxinflu(i,j,8,2) = gamxinfdp( alp - 0.5 + 0.5*bxhl, ratio )/y + gamxinflu(i,j,8,2) = (gamma_dpr(alp - 0.5 + 0.5*bxhl) - gamxinfdp( alp - 0.5 + 0.5*bxhl, ratio ))/y + ELSE +! gamxinflu(i,j,7,1) = gamxinfdp( .1, ratio )/y + gamxinflu(i,j,7,1) = (gamma_dpr(0.1) - gamxinfdp( 0.1, ratio ) )/y +! gamxinflu(i,j,8,1) = gamxinfdp( 1.1 - 0.5 + 0.5*bxh, ratio )/y +! gamxinflu(i,j,8,2) = gamxinfdp( 1.1 - 0.5 + 0.5*bxhl, ratio )/y + gamxinflu(i,j,8,1) = (gamma_dpr(1.1 - 0.5 + 0.5*bxh) - gamxinfdp( 1.1 - 0.5 + 0.5*bxh, ratio ) )/y + gamxinflu(i,j,8,2) = (gamma_dpr(1.1 - 0.5 + 0.5*bxhl) - gamxinfdp( 1.1 - 0.5 + 0.5*bxhl, ratio ) )/y + ENDIF + + gamxinflu(i,j,7,2) = gamxinflu(i,j,7,1) + + ENDDO + ENDDO + ciacrratio(0,:) = 1.0 + + DO j = ialpstart,nqiacralpha + alp = float(j)*dqiacralpha + y = gamma_sp(4.+alp) + y7 = gamma_sp(7.+alp) + DO i = 0,nqiacrratio + ratio = float(i)*dqiacrratio + + ! mass fraction + x = gamxinfdp( 4.+alp, ratio ) +! write(0,*) 'i, x/y = ',i, x/y + qiacrratio(i,j) = x/y + gamxinflu(i,j,4,1) = x/y + gamxinflu(i,j,4,2) = x/y + + ! reflectivity fraction + x = gamxinfdp( 7.+alp, ratio ) + ziacrratio(i,j) = x/y7 + gamxinflu(i,j,11,1) = x/y7 + gamxinflu(i,j,11,2) = x/y7 + + ENDDO + ENDDO + qiacrratio(0,:) = 1.0 + + + isub = Min( 0, Max(-1,ihvol) ) ! is -1 or 0 + + lccn = 0 + lccna = 0 + lnc = 0 + lnr = 0 + lni = 0 + lnis = 0 + lns = 0 + lnh = 0 + lnhl = 0 + lvh = 0 + lvhl = 0 + lzr = 0 + lzh = 0 + lzhl = 0 + lsw = 0 + lhw = 0 + lhlw = 0 + + denscale(:) = 0 + +! lccn = 9 + + ipconc = ipctmp + + IF ( ipconc == 0 ) THEN + IF ( ihvol >= 0 ) THEN + lvh = 9 + ltmp = 9 + denscale(lvh) = 1 + ELSE ! no hail + ltmp = lhab + lhl = 0 + ENDIF + ELSEIF ( ipconc == 5 ) THEN + lccn = lhab+1 ! 9 + lnc = lhab+2 ! 10 + lnr = lhab+3 ! 11 + lni = lhab+4 !12 + lns = lhab+5 !13 + lnh = lhab+6 !14 + ltmp = lnh + IF ( ihvol >= 0 ) THEN + ltmp = ltmp + 1 + lnhl = ltmp ! lhab+7 ! 15 + ENDIF + ltmp = ltmp + 1 + lvh = ltmp ! lhab+8 + isub ! 16 + isub ! isub adjusts to 15 if hail is off +! ltmp = lvh + denscale(lccn:lvh) = 1 + IF ( ihvol >= 1 ) THEN + ltmp = ltmp + 1 + lvhl = ltmp +! ltmp = lvhl + denscale(lvhl) = 1 + ENDIF + IF ( mixedphase ) THEN + ltmp = ltmp + 1 + lsw = ltmp + ltmp = ltmp + 1 + lhw = ltmp + IF ( lhl > 1 ) THEN + ltmp = ltmp + 1 + lhlw = ltmp + ENDIF +! ltmp = lhlw + ENDIF + ELSEIF ( ipconc >= 6 ) THEN + errmsg = 'NSSL microphysics has not been compiled for 3-moment. Sorry.' + errflg = 1 + return + lccn = lhab+1 ! 9 + lnc = lhab+2 ! 10 + lnr = lhab+3 ! 11 + lni = lhab+4 !12 + lns = lhab+5 !13 + lnh = lhab+6 !14 + ltmp = lnh + IF ( lhl > 0 ) THEN + ltmp = ltmp + 1 + lnhl = ltmp ! lhab+7 ! 15 + ENDIF + ltmp = ltmp + 1 + lvh = ltmp ! lhab+8 + isub ! 16 + isub ! isub adjusts to 15 if hail is off +! ltmp = lvh + denscale(lccn:lvh) = 1 + IF ( ihvol >= 1 ) THEN + ltmp = ltmp + 1 + lvhl = ltmp +! ltmp = lvhl + denscale(lvhl) = 1 + ENDIF + + IF ( ipconc == 6 ) THEN + ltmp = ltmp + 1 + lzh = ltmp + ELSEIF ( ipconc == 7 ) THEN + ltmp = ltmp + 1 + lzh = ltmp + ltmp = ltmp + 1 + lzr = ltmp + ELSEIF ( ipconc == 8 ) THEN + ltmp = ltmp + 1 + lzh = ltmp + ltmp = ltmp + 1 + lzr = ltmp + ltmp = ltmp + 1 + IF ( lhl > 1 ) THEN + ltmp = ltmp + 1 + lzhl = ltmp + ENDIF + ENDIF +! ltmp = lvh + ! denscale(lccn:lvh) = 1 + IF ( ihvol >= 1 ) THEN + lvhl = ltmp+1 + ltmp = lvhl + denscale(lvhl) = 1 + ENDIF + IF ( mixedphase ) THEN + ltmp = ltmp + 1 + lsw = ltmp + ltmp = ltmp + 1 + lhw = ltmp + IF ( lhl > 1 ) THEN + ltmp = ltmp + 1 + lhlw = ltmp + ENDIF +! ltmp = lhlw + ENDIF + ELSE + errmsg = 'nssl_2mom_init: Invalid value of ipctmp' + errflg = 1 + RETURN + ENDIF + + + + + ! write(0,*) 'wrf_init: irenuc, turn_on_ccna = ',irenuc, turn_on_ccna + IF ( turn_on_ccna ) THEN + ltmp = ltmp + 1 + lccna = ltmp + denscale(ltmp) = 1 + ENDIF + + IF ( turn_on_cina ) THEN + ltmp = ltmp + 1 + lcina = ltmp + denscale(ltmp) = 1 + ENDIF + + IF ( turn_on_cin .or. is_aerosol_aware ) THEN + ltmp = ltmp + 1 + lcin = ltmp + denscale(ltmp) = 1 +!debug write(0,*) 'Setting lcin to ',lcin + ENDIF + na = ltmp + + ln(lc) = lnc + ln(lr) = lnr + ln(li) = lni + ln(ls) = lns + ln(lh) = lnh + IF ( lhl .gt. 1 ) ln(lhl) = lnhl + + ipc(lc) = 2 + ipc(lr) = 3 + ipc(li) = 1 + ipc(ls) = 4 + ipc(lh) = 5 + IF ( lhl .gt. 1 ) ipc(lhl) = 5 + + ldovol = .false. + lvol(:) = 0 + lvol(li) = lvi + lvol(ls) = lvs + lvol(lh) = lvh + IF ( lhl .gt. 1 .and. lvhl .gt. 1 ) lvol(lhl) = lvhl + + lne = Max(lnh,lnhl) + lne = Max(lne,lvh) + lne = Max(lne,lvhl) + lne = Max(lne,na) + + lsc(:) = 0 + lsc(lc) = lscw + lsc(lr) = lscr + lsc(li) = lsci + lsc(ls) = lscs + lsc(lh) = lsch + IF ( lhl .gt. 1 ) lsc(lhl) = lschl + + + DO il = lc,lhab + ldovol = ldovol .or. ( lvol(il) .gt. 1 ) + ENDDO + +! write(0,*) 'nssl_2mom_init: ldovol = ',ldovol + + lz(:) = 0 + lz(lr) = lzr + lz(li) = lzi + lz(ls) = lzs + lz(lh) = lzh + IF ( lhl .gt. 1 .and. lzhl > 1 ) lz(lhl) = lzhl + + lliq(:) = 0 + lliq(ls) = lsw + lliq(lh) = lhw + IF ( lhl .gt. 1 ) lliq(lhl) = lhlw + IF ( mixedphase ) THEN +! write(0,*) 'lsw,lhw,lhlw = ',lsw,lhw,lhlw + ENDIF + + + + xnu(lc) = cnu + xmu(lc) = 1. + + IF ( imurain == 3 ) THEN + xnu(lr) = rnu + xmu(lr) = 1. + ELSEIF ( imurain == 1 ) THEN + xnu(lr) = (alphar - 2.0)/3.0 + xmu(lr) = 1./3. + ENDIF + + xnu(li) = cinu + xmu(li) = 1. + + IF ( lis >= 1 ) THEN + xnu(lis) = 0.0 + xmu(lis) = 1. + ENDIF + + dnu(lc) = 3.*xnu(lc) + 2. ! alphac + dmu(lc) = 3.*xmu(lc) + + dnu(lr) = 3.*xnu(lr) + 2. ! alphar + dmu(lr) = 3.*xmu(lr) + + xnu(ls) = snu + xmu(ls) = 1. + + dnu(ls) = 3.*xnu(ls) + 2. ! -0.4 ! alphas + dmu(ls) = 3.*xmu(ls) + + + dnu(lh) = alphah + dmu(lh) = dmuh + + xnu(lh) = (dnu(lh) - 2.)/3. + xmu(lh) = dmuh/3. + + + IF ( imurain == 3 ) THEN ! rain is gamma of volume + rz = ((4. + alphah)*(5. + alphah)*(6. + alphah)*(1. + xnu(lr)))/ & + & ((1 + alphah)*(2 + alphah)*(3 + alphah)*(2. + xnu(lr))) + +! IF ( ipconc .lt. 5 ) alphahl = alphah + + rzhl = ((4. + alphahl)*(5. + alphahl)*(6. + alphahl)*(1. + xnu(lr)))/ & + & ((1. + alphahl)*(2. + alphahl)*(3. + alphahl)*(2. + xnu(lr))) + + rzs = 1. ! assume rain and snow are both gamma volume + + ELSE ! rain is gamma of diameter + + rz = ((4. + alphah)*(5. + alphah)*(6. + alphah)*(1. + alphar)*(2. + alphar)*(3. + alphar))/ & + & ((1 + alphah)*(2 + alphah)*(3 + alphah)*(4. + alphar)*(5. + alphar)*(6. + alphar)) + + rzhl = ((4. + alphahl)*(5. + alphahl)*(6. + alphahl)*(1. + alphar)*(2. + alphar)*(3. + alphar))/ & + & ((1 + alphahl)*(2 + alphahl)*(3 + alphahl)*(4. + alphar)*(5. + alphar)*(6. + alphar)) + + + rzs = & + & ((1. + alphar)*(2. + alphar)*(3. + alphar)*(2. + xnu(ls)))/ & + & ((4. + alphar)*(5. + alphar)*(6. + alphar)*(1. + xnu(ls))) + + + ENDIF + + IF ( ipconc <= 5 ) THEN + imltshddmr = Min(1, imltshddmr) + ibinhmlr = 0 + ibinhlmlr = 0 + ENDIF + + IF ( ipconc > 5 .and. (ibinhmlr == 0 .and. ibinhlmlr == 0 ) ) THEN + imltshddmr = Min(1, imltshddmr) + ENDIF + +! write(0,*) 'rz,rzhl = ', rz,rzhl + + IF ( ipconc .lt. 4 ) THEN + + dnu(ls) = alphas + dmu(ls) = 1. + + xnu(ls) = (dnu(ls) - 2.)/3. + xmu(ls) = 1./3. + + + ENDIF + + IF ( lhl .gt. 1 ) THEN + + dnu(lhl) = alphahl + dmu(lhl) = dmuhl + + xnu(lhl) = (dnu(lhl) - 2.)/3. + xmu(lhl) = dmuhl/3. + + ENDIF + + cno(lc) = 1.0e+08 + IF ( li .gt. 1 ) cno(li) = 1.0e+08 + cno(lr) = cnor + IF ( ls .gt. 1 ) cno(ls) = cnos ! 8.0e+06 + IF ( lh .gt. 1 ) cno(lh) = cnoh ! 4.0e+05 + IF ( lhl .gt. 1 ) cno(lhl) = cnohl ! 4.0e+05 +! +! density maximums and minimums +! + xdnmx(:) = 900.0 + + xdnmx(lr) = 1000.0 + xdnmx(lc) = 1000.0 + xdnmx(li) = 917.0 + xdnmx(ls) = 300.0 + xdnmx(lh) = 900.0 + IF ( lhl .gt. 1 ) xdnmx(lhl) = 900.0 +! + xdnmn(:) = 900.0 + + xdnmn(lr) = 1000.0 + xdnmn(lc) = 1000.0 + xdnmn(li) = 100.0 + xdnmn(ls) = 100.0 + xdnmn(lh) = hdnmn + IF ( lhl .gt. 1 ) xdnmn(lhl) = hldnmn + + xdn0(:) = 900.0 + + xdn0(lc) = 1000.0 + xdn0(li) = 900.0 + xdn0(lr) = 1000.0 + xdn0(ls) = rho_qs ! 100.0 + xdn0(lh) = rho_qh ! (0.5)*(xdnmn(lh)+xdnmx(lh)) + IF ( lhl .gt. 1 ) xdn0(lhl) = rho_qhl ! 800.0 + +! +! Set terminal velocities... +! also set drag coefficients +! + cdx(lr) = 0.60 + cdx(lh) = 0.8 ! 1.0 ! 0.45 + cdx(ls) = 2.00 + IF ( lhl .gt. 1 ) cdx(lhl) = 0.45 + + ido(lc) = idocw + ido(lr) = idorw + ido(li) = idoci + ido(ls) = idosw + ido(lh) = idohw + IF ( lhl .gt. 1 ) ido(lhl) = idohl + + IF ( irfall .lt. 0 ) irfall = infall + IF ( lzr > 0 ) irfall = 0 + + qccn = ccn/rho00 + IF ( old_cccn > 0.0 ) THEN + old_qccn = old_cccn/rho00 + ELSE + old_qccn = qccn + ENDIF +! xvcmx = (4./3.)*pi*xcradmx**3 + +! set max rain diameter + IF ( xvdmx .gt. 0.0 ) THEN + xvrmx = 0.523599*(xvdmx)**3 + ELSE + xvrmx = xvrmx0 + ENDIF + + IF ( dhmn <= 0.0 ) THEN + xvhmn = xvhmn0 +! xvhmn = Min(xvhmn0, 0.523599*(dfrz)**3 ) + ELSE + xvhmn = 0.523599*(dhmn)**3 +! xvhmn = 0.523599*(Min(dhmn,dfrz))**3 + ENDIF + + IF ( dhmx <= 0.0 ) THEN + xvhmx = xvhmx0 + ELSE + xvhmx = 0.523599*(dhmx)**3 + ENDIF + + IF ( qhdpvdn < 0. ) qhdpvdn = xdnmn(lh) + IF ( qhacidn < 0. ) qhacidn = xdnmn(lh) + +! load max/min diameters + xvmn(lc) = xvcmn + xvmn(li) = xvimn + xvmn(lr) = xvrmn + xvmn(ls) = xvsmn + xvmn(lh) = xvhmn + + xvmx(lc) = xvcmx + xvmx(li) = xvimx + xvmx(lr) = xvrmx + xvmx(ls) = xvsmx + xvmx(lh) = xvhmx + + IF ( lhl .gt. 1 ) THEN + xvmn(lhl) = xvhlmn + xvmx(lhl) = xvhlmx + ENDIF + +! +! cloud water constants in mks units +! +! cwmasn = 4.25e-15 ! radius of 1.0e-6 +! cwmasn = 5.23e-13 ! minimum mass, defined by radius of 5.0e-6 +! cwmasn5 = 5.23e-13 +! cwradn = 5.0e-6 ! minimum radius +! cwmasx = 5.25e-10 ! maximum mass, defined by radius of 50.0e-6 +! mwfac = 6.0**(1./3.) + IF ( ipconc .ge. 2 ) THEN +! cwmasn = xvmn(lc)*1000. ! minimum mass, defined by minimum droplet volume +! cwradn = 1.0e-6 ! minimum radius +! cwmasx = xvmx(lc)*1000. ! maximum mass, defined by maximum droplet volume + + ENDIF +! rwmasn = xvmn(lr)*1000. ! minimum mass, defined by minimum rain volume +! rwmasx = xvmx(lr)*1000. ! maximum mass, defined by maximum rain volume + + IF ( lhl < 1 ) ifrzg = 1 + + ventr = 1. + IF ( imurain == 3 ) THEN +! IF ( izwisventr == 1 ) THEN + ventr = Gamma_sp(rnu + 4./3.)/((rnu + 1.)**(1./3.)*Gamma_sp(rnu + 1.)) ! Ziegler 1985 +! ELSE + ventrn = Gamma_sp(rnu + 1.5 + br/6.)/(Gamma_sp(rnu + 1.)*(rnu + 1.)**((1.+br)/6. + 1./3.) ) ! adapted from Wisner et al. 1972; for second term in rwvent +! ventr = Gamma_sp(rnu + 4./3.)/((rnu + 1.)**(1./3.)*Gamma_sp(rnu + 1.)) ! Ziegler 1985, still use for first term in rwvent +! ventr = Gamma_sp(rnu + 4./3.)/Gamma_sp(rnu + 1.) +! ENDIF + ELSE ! imurain == 1 +! IF ( iferwisventr == 1 ) THEN + ventr = Gamma_sp(2. + alphar) ! Ferrier 1994 +! ELSEIF ( iferwisventr == 2 ) THEN + ventrn = Gamma_sp(alphar + 2.5 + br/2.)/Gamma_sp(alphar + 1.) ! adapted from Wisner et al. 1972 +! ENDIF + ENDIF + ventc = Gamma_sp(cnu + 4./3.)/(cnu + 1.)**(1./3.)/Gamma_sp(cnu + 1.) + c1sw = Gamma_sp(snu + 4./3.)*(snu + 1.0)**(-1./3.)/gamma_sp(snu + 1.0) + + ! set threshold mixing ratios + + qxmin(:) = 1.0e-12 + + qxmin(lc) = 1.e-9 + qxmin(lr) = 1.e-7 + IF ( li > 1 ) qxmin(li) = 1.e-12 + IF ( ls > 1 ) qxmin(ls) = 1.e-7 + IF ( lh > 1 ) qxmin(lh) = 1.e-7 + IF ( lhl .gt. 1 ) qxmin(lhl) = 1.e-7 + + IF ( lc .gt. 1 .and. lnc .gt. 1 ) qxmin(lc) = 1.0e-13 + IF ( lr .gt. 1 .and. lnr .gt. 1 ) qxmin(lr) = 1.0e-12 + + IF ( li .gt. 1 .and. lni .gt. 1 ) qxmin(li ) = 1.0e-13 + IF ( ls .gt. 1 .and. lns .gt. 1 ) qxmin(ls ) = 1.0e-13 + IF ( lh .gt. 1 .and. lnh .gt. 1 ) qxmin(lh ) = 1.0e-12 + IF ( lhl.gt. 1 .and. lnhl.gt. 1 ) qxmin(lhl) = 1.0e-12 + + qxmin_init(:) = 1.0e-8 ! threshold for considering single-moment initial condition mixing ratios + ! constants for droplet nucleation + + cckm = cck-1. + ccnefac = (1.63/(cck * beta(3./2., cck/2.)))**(cck/(cck + 2.0)) + cnexp = (3./2.)*cck/(cck+2.0) +! ccne is all the factors with w in eq. A7 in Mansell et al. 2010 (JAS). The constant changes +! if k (cck) is changed! + ccne = ccnefac*1.e6*(1.e-6*Abs(cwccn))**(2./(2.+cck)) + ccne0 = ccnefac*1.e6*(1.e-6)**(2./(2.+cck)) +! write(0,*) 'cwccn, cck, ccne = ',cwccn,cck,ccne,ccnefac,cnexp + IF ( cwccn .lt. 0.0 ) THEN + cwccn = Abs(cwccn) + ccwmx = 50.e9 ! cwccn + ELSE + ccwmx = 50.e9 ! cwccn ! *1.4 + ENDIF + +! +! +! Set collection coefficients (Seifert and Beheng 05) +! + bb(:) = 1.0/3.0 + bb(li) = 0.3429 + DO il = lc,lhab + da0(il) = delbk(bb(il), xnu(il), xmu(il), 0) + da1(il) = delbk(bb(il), xnu(il), xmu(il), 1) + +! write(0,*) 'il, da0, da1, xnu, xmu = ', il, da0(il), da1(il), xnu(il), xmu(il) + ENDDO + + dab0(:,:) = 0.0 + dab1(:,:) = 0.0 + + DO il = lc,lhab + DO j = lc,lhab + IF ( il .ne. j ) THEN + + dab0(il,j) = delabk(bb(il), bb(j), xnu(il), xnu(j), xmu(il), xmu(j), 0) + dab1(il,j) = delabk(bb(il), bb(j), xnu(il), xnu(j), xmu(il), xmu(j), 1) + +! write(0,*) 'il, j, dab0, dab1 = ',il, j, dab0(il,j), dab1(il,j) + ENDIF + ENDDO + ENDDO + + gf4br = gamma_sp(4.0+br) + gf4ds = gamma_sp(4.0+ds) + gf4p5 = gamma_sp(4.0+0.5) + gfcinu1 = gamma_sp(cinu + 1.0) + gfcinu1p47 = gamma_sp(cinu + 1.47167) + gfcinu2p47 = gamma_sp(cinu + 2.47167) + gfcinu1p22 = gamma_sp(cinu + 1.22117) + gfcinu2p22 = gamma_sp(cinu + 2.22117) + gfcinu1p18 = gamma_sp(cinu + 1.18333) + gfcinu2p18 = gamma_sp(cinu + 2.18333) + + gsnow1 = gamma_sp(snu + 1.0) + gsnow53 = gamma_sp(snu + 5./3.) + gsnow73 = gamma_sp(snu + 7./3.) + + IF ( lh .gt. 1 ) cwchtmp0 = 6.0/pi*gamma_sp( (xnu(lh) + 1.)/xmu(lh) )/gamma_sp( (xnu(lh) + 2.)/xmu(lh) ) + IF ( lhl .gt. 1 ) cwchltmp0 = 6.0/pi*gamma_sp( (xnu(lhl) + 1)/xmu(lhl) )/gamma_sp( (xnu(lhl) + 2)/xmu(lhl) ) + + + iexy(:,:)=0; ! sets to zero the ones Imight have forgotten + +! snow + iexy(ls,li) = ieswi + iexy(ls,lc) = ieswc ; iexy(ls,lr) = ieswr ; + +! graupel + iexy(lh,ls) = iehwsw ; iexy(lh,li) = iehwi ; + iexy(lh,lc) = iehwc ; iexy(lh,lr) = iehwr ; + +! hail + IF (lhl .gt. 1 ) THEN + iexy(lhl,ls) = iehlsw ; iexy(lhl,li) = iehli ; + iexy(lhl,lc) = iehlc ; iexy(lhl,lr) = iehlr ; + ENDIF + +! IF ( icefallfac /= 1.0 ) write(0,*) 'icefallfac = ',icefallfac +! IF ( snowfallfac /= 1.0 ) write(0,*) 'snowfallfac = ',snowfallfac + + + RETURN +END SUBROUTINE nssl_2mom_init + +! ##################################################################### +! ##################################################################### + +!>\ingroup mod_nsslmp +!! Driver subroutine that copies state data to local 2D arrays for microphysics calls +SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw, chl, & + cn, vhw, vhl, cna, cni, f_cn, f_cna, f_cina, & + zrw, zhw, zhl, & + qsw, qhw, qhlw, & + tt, th, pii, p, w, dn, dz, dtp, itimestep, & + RAINNC,RAINNCV, & + dx, dy, & + axtra, & + SNOWNC, SNOWNCV, GRPLNC, GRPLNCV, & + SR,HAILNC, HAILNCV, & + tkediss, & + re_cloud, re_ice, re_snow, re_rain, & + has_reqc, has_reqi, has_reqs, has_reqr, & + rainncw2, rainnci2, & + dbz, vzf,compdbz, & + rscghis_2d,rscghis_2dp,rscghis_2dn, & + scr,scw,sci,scs,sch,schl,sctot, & + elec_physics, & + induc,elecz,scion,sciona, & + noninduc,noninducp,noninducn, & + pcc2, pre2, depsubr, & + mnucf2, melr2, ctr2, & + rim1_2, rim2_2,rim3_2, & + nctr2, nnuccd2, nnucf2, & + effc2,effr2,effi2, & + effs2, effg2, & + fc2, fr2,fi2,fs2,fg2, & + fnc2, fnr2,fni2,fns2,fng2, & +! qcond,qdep,qfrz,qrauto,qhcnvi,qhcollw,qscollw, & +! ncauto, niinit,nifrz, & +! re_liquid, re_graupel, re_hail, re_icesnow, & +! vtcloud, vtrain, vtsnow, vtgraupel, vthail, & + ipelectmp, & + diagflag,ke_diag, & + errmsg, errflg, & + nssl_progn, & ! wrf-chem +! 20130903 acd_mb_washout start + wetscav_on, rainprod, evapprod, & ! wrf-chem +! 20130903 acd_mb_washout end + cu_used, qrcuten, qscuten, qicuten, qccuten, & ! hm added + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + its,ite, jts,jte, kts,kte) ! tile dims + + + + implicit none + + + !Subroutine arguments: + + integer, intent(in):: & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + real, dimension(ims:ime, kms:kme, jms:jme), intent(inout):: & + qv,qc,qr,qs,qh + ! tt is air temperature -- used by CCPP instead of th (theta) + real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: & + th, tt, & + zrw, zhw, zhl, & + qsw, qhw, qhlw, & + qi,qhl,ccw,crw,cci,csw,chw,chl,vhw,vhl + real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: dbz, vzf, cn, cna, cni + real, dimension(ims:ime, jms:jme), optional, intent(inout):: compdbz + real, dimension(ims:ime, jms:jme), optional, intent(inout):: rscghis_2d, & ! 2D accumulation arrays for vertically-integrated charging rate + rscghis_2dp, & ! 2D accumulation arrays for vertically-integrated charging rate (positive only) + rscghis_2dn ! 2D accumulation arrays for vertically-integrated charging rate (negative only) +! real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout)::rscghis_3d + integer, optional, intent(in) :: elec_physics + real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: & + scr,scw,sci,scs,sch,schl,sciona,sctot ! space charge + real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: & + induc,noninduc,noninducp,noninducn ! charging rates: inductive, noninductive (all, positive, negative to graupel) + real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(in) :: elecz ! elecsave = Ez + real, dimension(ims:ime, kms:kme, jms:jme,2),optional, intent(inout) :: scion + real, dimension(ims:ime, kms:kme, jms:jme), intent(in):: p,w,dz,dn + + real, dimension(ims:ime, kms:kme, jms:jme), intent(in):: pii + real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: & + pcc2, pre2, depsubr, & + mnucf2, melr2, ctr2, & + rim1_2, rim2_2,rim3_2, & + nctr2, nnuccd2, nnucf2, & + effc2,effr2,effi2, & + effs2, effg2, & + fc2, fr2,fi2,fs2,fg2, & + fnc2, fnr2,fni2,fns2,fng2 +! qcond,qdep,qfrz,qrauto,qhcnvi,qhcollw,qscollw, & +! ncauto, niinit,nifrz, & +! re_liquid, re_graupel, re_hail, re_icesnow, & +! vtcloud, vtrain, vtsnow, vtgraupel, vthail + + real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout) :: axtra + +! WRF variables + real, dimension(ims:ime, jms:jme), intent(inout):: & + RAINNC,RAINNCV ! accumulated precip (NC) and rate (NCV) + real, dimension(ims:ime, jms:jme), optional, intent(inout):: & + SNOWNC,SNOWNCV,GRPLNC,GRPLNCV,SR ! accumulated precip (NC) and rate (NCV) + real, dimension(ims:ime, jms:jme), optional, intent(inout):: & + HAILNC,HAILNCV ! accumulated precip (NC) and rate (NCV) + integer, parameter :: nproc = 1 + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, INTENT(INOUT):: re_cloud, re_ice, re_snow, re_rain + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, INTENT(IN):: tkediss + INTEGER, INTENT(IN), optional :: has_reqc, has_reqi, has_reqs, has_reqr + real, dimension(ims:ime, jms:jme), intent(out), optional :: & + rainncw2, rainnci2 ! liquid rain, ice, accumulation rates + real, optional, intent(in) :: dx,dy + real, intent(in):: dtp + integer, intent(in):: itimestep !, ccntype + logical, optional, intent(in) :: diagflag, f_cna, f_cn, f_cina + integer, optional, intent(in) :: ipelectmp, ke_diag + + ! CCPP error handling + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg + + LOGICAL, INTENT(IN), OPTIONAL :: nssl_progn ! flags for wrf-chem + +! REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional,INTENT(INOUT):: qndrop + LOGICAL :: flag_qndrop ! wrf-chem + LOGICAL :: flag_qnifa , flag_qnwfa + logical :: flag + real :: cinchange, t7max,testmax,wmax + +! 20130903 acd_ck_washout start +! rainprod - total tendency of conversion of cloud water/ice and graupel to rain (kg kg-1 s-1) +! evapprod - tendency of evaporation of rain (kg kg-1 s-1) +! 20130903 acd_ck_washout end + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional,INTENT(INOUT):: rainprod, evapprod + +! qrcuten, rain tendency from parameterized cumulus convection +! qscuten, snow tendency from parameterized cumulus convection +! qicuten, cloud ice tendency from parameterized cumulus convection +! mu : air mass in column + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, INTENT(IN):: qrcuten, qscuten, qicuten, qccuten + INTEGER, optional, intent(in) :: cu_used + LOGICAL, optional, intent(in) :: wetscav_on + +! +! local variables +! + real, dimension(its:ite, 1, kts:kte) :: elec2 ! ez = elecsave slab +! real, dimension(its:ite, 1, kts:kte,2) :: scion2 ! 1=- , 2=+ + real, dimension(its:ite, kts:kte) :: rainprod2d, evapprod2d,tke2d + real, dimension(its:ite, 1, kts:kte, na) :: an, ancuten + real, dimension(its:ite, 1, kts:kte, nxtra) :: axtra2d + real, dimension(its:ite, 1, kts:kte) :: t0,t1,t2,t3,t4,t5,t6,t7,t8,t9 + real, dimension(its:ite, 1, kts:kte) :: dn1,t00,t77,ssat,pn,wn,dz2d,dz2dinv,dbz2d,vzf2d + real, dimension(its:ite, 1, na) :: xfall + real, dimension(kts:kte, nproc) :: thproclocal + integer, parameter :: nor = 0, ng = 0 + integer :: nx,ny,nz + integer ix,jy,kz,i,j,k,il,n + integer :: infdo + real :: ssival, ssifac, t8s, t9s, qvapor + integer :: ltemq + double precision :: dp1 + integer :: jye, lnb + integer :: imx,kmx + real :: dbzmx,refl + integer :: vzflag0 = 0 + logical :: makediag + real :: dx1,dy1 + real, parameter :: cnin20 = 1.0e3 + real, parameter :: cnin10 = 5.0e1 + real, parameter :: cnin1a = 4.5 + real, parameter :: cnin2a = 12.96 + real, parameter :: cnin2b = 0.639 + + double precision :: cwmass1,cwmass2 + double precision :: rwmass1,rwmass2 + double precision :: icemass1,icemass2 + double precision :: swmass1,swmass2 + double precision :: grmass1,grmass2 + double precision :: hlmass1,hlmass2 + double precision :: wvol5,wvol10 + real :: tmp,dv,dv1,tmpchg + real :: rdt + + double precision :: dt1,dt2 + double precision :: timesed,timesed1,timesed2,timesed3, timegs, timenucond, timedbz,zmaxsed + double precision :: timevtcalc,timesetvt + + logical :: f_cnatmp, f_cinatmp + logical :: has_wetscav + + integer :: kediagloc + integer :: iunit + + real :: ycent, y, emissrate, emissrate0, emissrate1, z, fac, factot + real :: fach(kts:kte) + + logical, parameter :: debugdriver = .false. + +#ifdef MPI + +#if defined(MPI) + integer, parameter :: ntot = 50 + double precision mpitotindp(ntot), mpitotoutdp(ntot) + INTEGER :: mpi_error_code = 1 +#endif +#endif + + +! ------------------------------------------------------------------- + + errmsg = '' + errflg = 0 + + rdt = 1.0/dtp + + IF ( debugdriver ) write(0,*) 'N2M: entering routine' + + flag_qndrop = .false. + flag_qnifa = .false. + flag_qnwfa = .false. + + IF ( PRESENT ( nssl_progn ) ) flag_qndrop = nssl_progn + + + + + ! --- + + IF ( present( f_cna ) ) THEN + f_cnatmp = f_cna + ELSE + f_cnatmp = .false. + ENDIF + + IF ( present( f_cina ) ) THEN + f_cinatmp = f_cina + ELSE + f_cinatmp = .false. + ENDIF + + IF ( present( vzf ) ) vzflag0 = 1 + + IF ( present( ipelectmp ) ) THEN + ipelec = ipelectmp + ELSE + ipelec = 0 + ENDIF +! IF ( present( dbz ) ) THEN +! DO jy = jts,jte +! DO kz = kts,kte +! DO ix = its,ite +! dbz(ix,kz,jy) = 0.0 +! ENDDO +! ENDDO +! ENDDO +! ENDIF + + IF ( present( dx ) .and. present( dy ) ) THEN + dx1 = dx + dy1 = dy + ELSE + dx1 = 1.0 + dy1 = 1.0 + ENDIF + + + makediag = .true. + IF ( present( diagflag ) ) THEN + makediag = diagflag .or. itimestep == 1 + ENDIF + + IF ( debugdriver ) write(0,*) 'N2M: makediag = ',makediag + + + nx = ite-its+1 + ny = 1 ! set up as 2D slabs + nz = kte-kts+1 + + IF ( .not. present( cn ) ) THEN + renucfrac = 1.0 + ENDIF + + + + +! ENDIF ! itimestep == 1 + + +! sedimentation settings + + infdo = 2 + + IF ( infall .ne. 1 .or. iscfall .ge. 2 ) THEN + infdo = 1 + ELSE + infdo = 0 + ENDIF + + IF ( infall .ge. 3 .or. ipconc .ge. 6 ) THEN + infdo = 2 + ENDIF + + + IF ( present( HAILNCV ) .and. lhl < 1 ) THEN ! for WRF 3.1 compatibility + HAILNCV(its:ite,jts:jte) = 0. + ENDIF + + tke2d(:,:) = 0.0 ! initialize if not used + + lnb = Max(lh,lhl)+1 ! lnc +! IF ( lccn > 1 ) lnb = lccn + + jye = jte + + IF ( present( compdbz ) .and. makediag ) THEN + DO jy = jts,jye + DO ix = its,ite + compdbz(ix,jy) = -3.0 + ENDDO + ENDDO + ENDIF + + zmaxsed = 0.0d0 + timevtcalc = 0.0d0 + timesetvt = 0.0d0 + timesed = 0.0d0 + timesed1 = 0.0d0 + timesed2 = 0.0d0 + timesed3 = 0.0d0 + timegs = 0.0d0 + timenucond = 0.0d0 + + + + IF ( debugdriver ) write(0,*) 'N2M: jy loop 1, lhl,na = ',lhl,na,present(qhl) + + ancuten(its:ite,1,kts:kte,:) = 0.0 + thproclocal(:,:) = 0.0 + + DO jy = jts,jye + + xfall(:,:,:) = 0.0 + +! write(0,*) 'N2M: load an, jy,lccn = ',jy,lccn,qccn + + IF ( present( pcc2 ) .and. makediag ) THEN + axtra2d(its:ite,1,kts:kte,:) = 0.0 + ENDIF + + ! copy from 3D array to 2D slab + + DO kz = kts,kte + DO ix = its,ite + + IF ( present( tt ) ) THEN + an(ix,1,kz,lt) = tt(ix,kz,jy)/pii(ix,kz,jy) + ELSE + an(ix,1,kz,lt) = th(ix,kz,jy) + ENDIF + + + an(ix,1,kz,lv) = qv(ix,kz,jy) + an(ix,1,kz,lc) = qc(ix,kz,jy) + an(ix,1,kz,lr) = qr(ix,kz,jy) + IF ( present( qi ) ) THEN + an(ix,1,kz,li) = qi(ix,kz,jy) + ELSE + an(ix,1,kz,li) = 0.0 + ENDIF + an(ix,1,kz,ls) = qs(ix,kz,jy) + an(ix,1,kz,lh) = qh(ix,kz,jy) + IF ( lhl > 1 ) an(ix,1,kz,lhl) = qhl(ix,kz,jy) + IF ( lccn > 1 ) THEN + IF ( is_aerosol_aware .and. flag_qnwfa ) THEN + ! + ELSEIF ( present( cn ) ) THEN + IF ( lccna > 1 .and. .not. ( present( cna ) .and. f_cnatmp ) ) THEN + an(ix,1,kz,lccna) = cn(ix,kz,jy) + an(ix,1,kz,lccn) = qccn ! cn(ix,kz,jy) + ELSE + an(ix,1,kz,lccn) = cn(ix,kz,jy) + ENDIF + ELSE + IF ( lccna == 0 .and. ( .not. f_cnatmp ) ) THEN + an(ix,1,kz,lccn) = qccn - ccw(ix,kz,jy) + ELSE + an(ix,1,kz,lccn) = qccn + ENDIF + + ENDIF + ENDIF + + IF ( lccna > 1 ) THEN + IF ( present( cna ) .and. f_cnatmp ) THEN + an(ix,1,kz,lccna) = cna(ix,kz,jy) + ENDIF + ENDIF + + IF ( lcina > 1 ) THEN + IF ( present( cni ) .and. f_cinatmp ) THEN + an(ix,1,kz,lcina) = cni(ix,kz,jy) + ENDIF + ENDIF + + IF ( ipconc >= 5 ) THEN + an(ix,1,kz,lnc) = ccw(ix,kz,jy) + IF ( constccw > 0.0 ) THEN + an(ix,1,kz,lnc) = constccw + ENDIF + an(ix,1,kz,lnr) = crw(ix,kz,jy) + IF ( present( cci ) ) THEN + an(ix,1,kz,lni) = cci(ix,kz,jy) + ELSE + an(ix,1,kz,lni) = 0.0 + ENDIF + an(ix,1,kz,lns) = csw(ix,kz,jy) + an(ix,1,kz,lnh) = chw(ix,kz,jy) + IF ( lhl > 1 ) an(ix,1,kz,lnhl) = chl(ix,kz,jy) + ENDIF + IF ( lvh > 0 ) an(ix,1,kz,lvh) = vhw(ix,kz,jy) + IF ( lvhl > 0 .and. present( vhl ) ) an(ix,1,kz,lvhl) = vhl(ix,kz,jy) + + + + + + + IF ( present( tt ) ) THEN + t0(ix,1,kz) = tt(ix,kz,jy) ! temperature (Kelvin) + ELSE + t0(ix,1,kz) = th(ix,kz,jy)*pii(ix,kz,jy) ! temperature (Kelvin) + ENDIF + t1(ix,1,kz) = 0.0 + t2(ix,1,kz) = 0.0 + t3(ix,1,kz) = 0.0 + t4(ix,1,kz) = 0.0 + t5(ix,1,kz) = 0.0 + t6(ix,1,kz) = 0.0 + t7(ix,1,kz) = 0.0 + t8(ix,1,kz) = 0.0 + t9(ix,1,kz) = 0.0 + t00(ix,1,kz) = 380.0/p(ix,kz,jy) + t77(ix,1,kz) = pii(ix,kz,jy) + dbz2d(ix,1,kz) = 0.0 + vzf2d(ix,1,kz) = 0.0 + + dn1(ix,1,kz) = dn(ix,kz,jy) + pn(ix,1,kz) = p(ix,kz,jy) + wn(ix,1,kz) = w(ix,kz,jy) +! wmax = Max(wmax,wn(ix,1,kz)) + dz2d(ix,1,kz) = dz(ix,kz,jy) + dz2dinv(ix,1,kz) = 1./dz(ix,kz,jy) + + ltemq = Int( (t0(ix,1,kz)-163.15)/fqsat+1.5 ) + ltemq = Min( nqsat, Max(1,ltemq) ) +! +! saturation mixing ratio +! + t8s = t00(ix,1,kz)*tabqvs(ltemq) !saturation mixing ratio wrt water + t9s = t00(ix,1,kz)*tabqis(ltemq) !saturation mixing ratio wrt ice + +! +! calculate rate of nucleation +! + ssival = Min(t8s,max(an(ix,1,kz,lv),0.0))/t9s ! qv/qvi + + if ( ssival .gt. 1.0 ) then +! + IF ( icenucopt == 1 ) THEN + + if ( t0(ix,1,kz).le.268.15 ) then + + dp1 = dn1(ix,1,kz)/rho00*cnin20*exp( Min( 57.0 ,(cnin2a*(ssival-1.0)-cnin2b) ) ) + t7(ix,1,kz) = Min(dp1, 1.0d30) + end if + +! +! Default value of imeyers5 turns off nucleation by Meyer at higher temperatures +! This is really from Ferrier (1994), eq. 4.31 - 4.34 + IF ( imeyers5 ) THEN + if ( t0(ix,1,kz).lt.tfr .and. t0(ix,1,kz).gt.268.15 ) then + qvapor = max(an(ix,1,kz,lv),0.0) + ssifac = 0.0 + if ( (qvapor-t9s) .gt. 1.0e-5 ) then + if ( (t8s-t9s) .gt. 1.0e-5 ) then + ssifac = (qvapor-t9s) /(t8s-t9s) + ssifac = ssifac**cnin1a + end if + end if + t7(ix,1,kz) = dn1(ix,1,kz)/rho00*cnin10*ssifac*exp(-(t0(ix,1,kz)-tfr)*bta1) + end if + ENDIF + +! t7max = Max(t7max, t7(ix,1,kz) ) + + ELSEIF ( icenucopt == 2 ) THEN ! Thompson/Cooper; Note Thompson 2004 has constants of + ! 0.005 and 0.304 because the line function was estimated from Cooper plot + ! Here, the fit line values from Cooper 1986 are converted. Very little difference + ! in practice + + t7(ix,1,kz) = 1000.*0.00446684*exp(0.3108*(273.16 - Max(233.0, t0(ix,1,kz) ) ) ) ! factor of 1000 to convert L**-1 to m**-3 + +! write(0,*) 'Cooper t7,ssival = ',ix,kz,t7(ix,1,kz),ssival + + ELSEIF ( icenucopt == 3 ) THEN ! Phillips (Meyers/DeMott) + + if ( t0(ix,1,kz).le.268.15 .and. t0(ix,1,kz) > 243.15 ) then ! Meyers with factor of Psi=0.06 + + dp1 = 0.06*cnin20*exp( Min( 57.0 ,(cnin2a*(ssival-1.0)-cnin2b) ) ) + t7(ix,1,kz) = Min(dp1, 1.0d30) + elseif ( t0(ix,1,kz) <= 243.15 ) then ! Phillips estimate of DeMott et al (2003) data + dp1 = 1000.*( exp( Min( 57.0 ,cnin2a*(ssival-1.1) ) ) )**0.3 + t7(ix,1,kz) = Min(dp1, 1.0d30) + + end if + + ELSEIF ( icenucopt == 4 ) THEN ! DeMott 2010 + + IF ( t0(ix,jy,kz) < 268.16 .and. t0(ix,jy,kz) > 223.15 .and. ssival > 1.001 ) THEN ! + + ! a = 0.0000594, b = 3.33, c = 0.0264, d = 0.0033, + ! nint = a*(-Tc)**b * naer**(c*(-Tc) + d) + ! nint has units of per (standard) liter, so mult by 1.e3 and scale by dn/rho00 + ! naer needs units of cm**-3, so mult by 1.e-6 + + ! dp1 = 1.e3*0.0000594*(273.16 - t0(ix,jy,kz))**3.33 * (1.e-6*cin*dn(ix,jy,kz))**(0.0264*(273.16 - t0(ix,jy,kz)) + 0.0033) + dp1 = 1.e3*dn(ix,jy,kz)/rho00*0.0000594*(273.16 - t0(ix,jy,kz))**3.33 * (1.e-6*naer)**(0.0264*(273.16 - t0(ix,jy,kz)) + 0.0033) + t7(ix,jy,kz) = Min(dp1, 1.0d30) + + ELSE + t7(ix,jy,kz) = 0.0 + ENDIF + + ENDIF ! icenucopt + + +! + end if ! ( ssival .gt. 1.0 ) +! + + ENDDO ! ix + ENDDO ! kz + + has_wetscav = .false. + IF ( wrfchem_flag > 0 ) THEN + IF ( PRESENT( wetscav_on ) ) THEN + has_wetscav = wetscav_on + IF ( has_wetscav ) THEN + IF ( PRESENT( rainprod ) ) rainprod2d(its:ite,kts:kte) = 0 + IF ( PRESENT( evapprod ) ) evapprod2d(its:ite,kts:kte) = 0 + ENDIF + ENDIF + ENDIF + + + ! transform from number mixing ratios to number conc. + + DO il = lnb,na + IF ( denscale(il) == 1 ) THEN + DO kz = kts,kte + DO ix = its,ite + an(ix,1,kz,il) = an(ix,1,kz,il)*dn(ix,kz,jy) + ENDDO + ENDDO + ENDIF + ENDDO ! il + +! sedimentation + xfall(:,:,:) = 0.0 + + IF ( .true. ) THEN + + +! #ifndef CM1 +! for real cases when hydrometeor mixing ratios have been initialized without concentrations + IF ( itimestep == 1 .and. ipconc > 0 ) THEN + call calcnfromq(nx,ny,nz,an,na,nor,nor,dn1) + ENDIF +! IF ( itimestep == 3 .and. ipconc > 0 ) THEN +! call calcnfromq(nx,ny,nz,an,na,nor,nor,dn1) +! ENDIF +! #endif + + IF ( present(cu_used) .and. & + ( present( qrcuten ) .or. present( qscuten ) .or. & + present( qicuten ) .or. present( qccuten ) ) ) THEN + + IF ( cu_used == 1 ) THEN + DO kz = kts,kte + DO ix = its,ite + + IF ( present( qrcuten ) ) ancuten(ix,1,kz,lr) = dtp*qrcuten(ix,kz,jy) + IF ( present( qscuten ) ) ancuten(ix,1,kz,ls) = dtp*qscuten(ix,kz,jy) + IF ( present( qicuten ) ) ancuten(ix,1,kz,li) = dtp*qicuten(ix,kz,jy) + IF ( present( qccuten ) ) ancuten(ix,1,kz,lc) = dtp*qccuten(ix,kz,jy) + + ENDDO + ENDDO + + call calcnfromcuten(nx,ny,nz,ancuten,an,na,nor,nor,dn1) + + + ENDIF + + ENDIF + + + call sediment1d(dtp,nx,ny,nz,an,na,nor,nor,xfall,dn1,dz2d,dz2dinv, & + & t0,t7,infdo,jy,its,jts & + & ,timesed1,timesed2,timesed3,zmaxsed,timesetvt) + + +! copy xfall to appropriate places... + + IF ( debugdriver ) write(0,*) 'N2M: end sediment, jy = ',jy + + DO ix = its,ite + IF ( lhl > 1 ) THEN + RAINNCV(ix,jy) = dtp*dn1(ix,1,1)*(xfall(ix,1,lr) + xfall(ix,1,ls)*1000./xdn0(lr) + & + & xfall(ix,1,lh)*1000./xdn0(lr) + xfall(ix,1,lhl)*1000./xdn0(lr) ) + ELSE + RAINNCV(ix,jy) = dtp*dn1(ix,1,1)*(xfall(ix,1,lr) + xfall(ix,1,ls)*1000./xdn0(lr) + & + & xfall(ix,1,lh)*1000./xdn0(lr) ) + ENDIF + IF ( present ( rainncw2 ) ) THEN ! rain only + rainncw2(ix,jy) = rainncw2(ix,jy) + dtp*dn1(ix,1,1)*xfall(ix,1,lr) + ENDIF + IF ( present ( rainnci2 ) ) THEN ! ice only + IF ( lhl > 1 ) THEN + rainnci2(ix,jy) =rainnci2(ix,jy) + dtp*dn1(ix,1,1)*(xfall(ix,1,ls)*1000./xdn0(lr) + & + & xfall(ix,1,lh)*1000./xdn0(lr) + xfall(ix,1,lhl)*1000./xdn0(lr) ) + ELSE + rainnci2(ix,jy) = rainnci2(ix,jy) + dtp*dn1(ix,1,1)*(xfall(ix,1,ls)*1000./xdn0(lr) + & + & xfall(ix,1,lh)*1000./xdn0(lr) ) + ENDIF + ENDIF + IF ( present( SNOWNCV ) ) SNOWNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,ls)*1000./xdn0(lr) + IF ( present( GRPLNCV ) ) THEN + IF ( lhl > 1 .and. .not. present( HAILNC) ) THEN ! if no separate hail accum, then add to graupel + GRPLNCV(ix,jy) = dtp*dn1(ix,1,1)*(xfall(ix,1,lh) + xfall(ix,1,lhl)) *1000./xdn0(lr) + ELSE + GRPLNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,lh)*1000./xdn0(lr) + ENDIF + ENDIF + RAINNC(ix,jy) = RAINNC(ix,jy) + RAINNCV(ix,jy) + + IF ( present (SNOWNC) .and. present (SNOWNCV) ) SNOWNC(ix,jy) = SNOWNC(ix,jy) + SNOWNCV(ix,jy) + IF ( lhl > 1 ) THEN +!#ifdef CM1 +! IF ( .true. ) THEN +!#else + IF ( present( HAILNC ) ) THEN +!#endif + HAILNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,lhl)*1000./xdn0(lr) + HAILNC(ix,jy) = HAILNC(ix,jy) + HAILNCV(ix,jy) +! ELSEIF ( present( GRPLNCV ) ) THEN ! if no separate hail accum, then add to graupel +! GRPLNCV(ix,jy) = GRPLNCV(ix,jy) + dtp*dn1(ix,1,1)*xfall(ix,1,lhl)*1000./xdn0(lr) + ENDIF + ENDIF + IF ( present( GRPLNCV ) ) GRPLNC(ix,jy) = GRPLNC(ix,jy) + GRPLNCV(ix,jy) + IF ( present( SR ) .and. present (SNOWNCV) .and. present(GRPLNCV) ) THEN + IF ( present( HAILNC ) ) THEN + SR(ix,jy) = (SNOWNCV(ix,jy)+HAILNCV(ix,jy)+GRPLNCV(ix,jy))/(RAINNCV(ix,jy)+1.e-12) + ELSE + SR(ix,jy) = (SNOWNCV(ix,jy)+GRPLNCV(ix,jy))/(RAINNCV(ix,jy)+1.e-12) + ENDIF + ENDIF + ENDDO + + ENDIF ! .false. + + IF ( isedonly /= 1 ) THEN + ! call nssl_2mom_gs: main gather-scatter routine to calculate microphysics + + IF ( debugdriver ) write(0,*) 'N2M: gs, jy = ',jy +! IF ( isedonly /= 2 ) THEN + + + call nssl_2mom_gs & + & (nx,ny,nz,na,jy & + & ,nor,nor & + & ,dtp,dz2d & + & ,t0,t1,t2,t3,t4,t5,t6,t7,t8,t9 & + & ,an,dn1,t77 & + & ,pn,wn,0 & + & ,t00,t77, & + & ventr,ventc,c1sw,1,ido, & + & xdnmx,xdnmn, & +! & ln,ipc,lvol,lz,lliq, & + & cdx, & + & xdn0,dbz2d,tke2d, & + & thproclocal,nproc,dx1,dy1, & + & timevtcalc,axtra2d, makediag & + & ,has_wetscav, rainprod2d, evapprod2d & + & ,errmsg,errflg & + & ,elec2,its,ids,ide,jds,jde & + & ) + + + + + ENDIF ! isedonly /= 1 + + ! droplet nucleation/condensation/evaporation + IF ( .true. ) THEN + CALL NUCOND & + & (nx,ny,nz,na,jy & + & ,nor,nor,dtp,nx & + & ,dz2d & + & ,t0,t9 & + & ,an,dn1,t77 & + & ,pn,wn & + & ,axtra2d, makediag & + & ,ssat,t00,t77,flag_qndrop) + + + ENDIF + + + + IF ( present( pcc2 ) .and. makediag ) THEN + DO kz = kts,kte + DO ix = its,ite +! example of using the 'axtra2d' array to get rates out of the microphysics routine for output. +! Search for 'axtra' to find example code below +! pcc2(ix,kz,jy) = axtra2d(ix,1,kz,1) + + ENDDO + ENDDO + ENDIF + + +! compute diagnostic S-band reflectivity if needed + IF ( present( dbz ) .and. makediag ) THEN + ! calc dbz + + IF ( .true. ) THEN + IF ( present(ke_diag) ) THEN + kediagloc = ke_diag + ELSE + kediagloc = nz + ENDIF + call radardd02(nx,ny,nz,nor,na,an,t0, & + & dbz2d,dn1,nz,cnoh,rho_qh,ipconc,kediagloc, 0) + ENDIF ! .false. + + + DO kz = kts,kediagloc ! kte + DO ix = its,ite + dbz(ix,kz,jy) = dbz2d(ix,1,kz) + IF ( present( vzf ) ) THEN + vzf(ix,kz,jy) = vzf2d(ix,1,kz) + IF ( dbz2d(ix,1,kz) <= 0.0 ) THEN + vzf(ix,kz,jy) = 0.0 + ELSEIF ( dbz2d(ix,1,kz) <= 15.0 ) THEN + refl = 10**(0.1*dbz2d(ix,1,kz)) + vzf(ix,kz,jy) = Min( vzf2d(ix,1,kz), 2.6 * Max(0.0,refl)**0.107 * (1.2/dn1(ix,1,kz))**0.4 ) + ENDIF + ENDIF + IF ( present( compdbz ) ) THEN + compdbz(ix,jy) = Max( compdbz(ix,jy), dbz2d(ix,1,kz) ) + ENDIF + ENDDO + ENDDO + + ENDIF + + + +! Following Greg Thompson, calculation for effective radii. Used by RRTMG LW/SW schemes if enabled in module_physics_init.F + IF ( present( has_reqc ).and. present( has_reqi ) .and. present( has_reqs ) .and. & + present( re_cloud ).and. present( re_ice ) .and. present( re_snow ) ) THEN + IF ( has_reqc.ne.0 .or. has_reqi.ne.0 .or. has_reqs.ne.0) THEN + DO kz = kts,kte + DO ix = its,ite + re_cloud(ix,kz,jy) = 2.51E-6 + re_ice(ix,kz,jy) = 10.01E-6 + re_snow(ix,kz,jy) = 25.E-6 + t1(ix,1,kz) = 2.51E-6 + t2(ix,1,kz) = 10.01E-6 + t3(ix,1,kz) = 25.E-6 + t4(ix,1,kz) = 50.e-6 + ENDDO + ENDDO + + + call calc_eff_radius & + & (nx,ny,nz,na,jy & + & ,nor,nor & + & ,t1=t1,t2=t2,t3=t3,t4=t4 & + & ,an=an,dn=dn1 ) + + DO kz = kts,kte + DO ix = its,ite + re_cloud(ix,kz,jy) = MAX(2.51E-6, MIN(t1(ix,1,kz), 50.E-6)) + re_ice(ix,kz,jy) = MAX(10.01E-6, MIN(t2(ix,1,kz), 200.E-6)) + re_snow(ix,kz,jy) = MAX(25.E-6, MIN(t3(ix,1,kz), 999.E-6)) + ! check for case where snow needs to be treated as cloud ice (for rrtmg radiation) + IF ( .not. present(qi) ) re_ice(ix,kz,jy) = MAX(10.E-6, MIN(t3(ix,1,kz), 200.E-6)) + ENDDO + ENDDO + + IF ( present(has_reqr) .and. present( re_rain ) ) THEN + IF ( has_reqr /= 0 ) THEN + DO kz = kts,kte + DO ix = its,ite + re_rain(ix,kz,jy) = MAX(50.E-6, MIN(t4(ix,1,kz), 2999.E-6)) + ENDDO + ENDDO + ENDIF + ENDIF + + ENDIF + ENDIF + + + + +! transform concentrations back to mixing ratios + DO il = lnb,na + IF ( denscale(il) == 1 ) THEN + DO kz = kts,kte + DO ix = its,ite + an(ix,1,kz,il) = an(ix,1,kz,il)/dn(ix,kz,jy) + ENDDO + ENDDO + ENDIF + ENDDO ! il + + ! copy 2D slabs back to 3D + + + DO kz = kts,kte + DO ix = its,ite + + IF ( present( tt ) ) THEN + tt(ix,kz,jy) = t0(ix,1,kz) + ELSE + th(ix,kz,jy) = an(ix,1,kz,lt) + ENDIF + + qv(ix,kz,jy) = an(ix,1,kz,lv) + qc(ix,kz,jy) = an(ix,1,kz,lc) + qr(ix,kz,jy) = an(ix,1,kz,lr) + IF ( present(qi) ) qi(ix,kz,jy) = an(ix,1,kz,li) + qs(ix,kz,jy) = an(ix,1,kz,ls) + qh(ix,kz,jy) = an(ix,1,kz,lh) + IF ( lhl > 1 ) qhl(ix,kz,jy) = an(ix,1,kz,lhl) + + IF ( lccn > 1 .and. is_aerosol_aware .and. flag_qnwfa ) THEN + ! not used here + ELSEIF ( present( cn ) .and. lccn > 1 .and. .not. flag_qndrop) THEN + IF ( lccna > 1 .and. .not. present( cna ) ) THEN + cn(ix,kz,jy) = Max(0.0, an(ix,1,kz,lccna) ) + ELSE + cn(ix,kz,jy) = an(ix,1,kz,lccn) + ENDIF + ENDIF + IF ( lccna > 1 ) THEN + IF ( present( cna ) .and. f_cnatmp ) THEN + cna(ix,kz,jy) = Max(0.0, an(ix,1,kz,lccna) ) + ENDIF + ENDIF + + IF ( lcina > 1 ) THEN + IF ( present( cni ) .and. f_cinatmp ) THEN + cni(ix,kz,jy) = Max(0.0, an(ix,1,kz,lcina) ) + ENDIF + ENDIF + + IF ( ipconc >= 5 ) THEN + + ccw(ix,kz,jy) = an(ix,1,kz,lnc) + crw(ix,kz,jy) = an(ix,1,kz,lnr) + IF ( present( cci ) ) cci(ix,kz,jy) = an(ix,1,kz,lni) + csw(ix,kz,jy) = an(ix,1,kz,lns) + chw(ix,kz,jy) = an(ix,1,kz,lnh) + IF ( lhl > 1 ) chl(ix,kz,jy) = an(ix,1,kz,lnhl) + ENDIF + + + + + IF ( lvh > 0 ) vhw(ix,kz,jy) = an(ix,1,kz,lvh) + IF ( lvhl > 0 .and. present( vhl ) ) vhl(ix,kz,jy) = an(ix,1,kz,lvhl) + +#if ( WRF_CHEM == 1 ) + IF ( has_wetscav ) THEN + IF ( PRESENT( rainprod ) ) rainprod(ix,kz,jy) = rainprod2d(ix,kz) + IF ( PRESENT( evapprod ) ) evapprod(ix,kz,jy) = evapprod2d(ix,kz) + ENDIF +#endif + + ENDDO + ENDDO + + ENDDO ! jy + + + + + + + + RETURN +END SUBROUTINE nssl_2mom_driver + +! ##################################################################### +! ##################################################################### + +!>\ingroup mod_nsslmp +!! Single-precision complete gamma function + REAL FUNCTION GAMMA_SP(xx) + + implicit none + real xx + integer j + +! Double precision ser,stp,tmp,x,y,cof(6) + + real*8 ser,stp,tmp,x,y,cof(6) + SAVE cof,stp + DATA cof,stp/76.18009172947146d+0, & + & -86.50532032941677d0, & + & 24.01409824083091d0, & + & -1.231739572450155d0, & + & 0.1208650973866179d-2,& + & -0.5395239384953d-5, & + & 2.5066282746310005d0/ + + IF ( xx <= 0.0 ) THEN + write(0,*) 'Argument to gamma must be > 0!! xx = ',xx + ENDIF + + x = xx + y = x + tmp = x + 5.5d0 + tmp = (x + 0.5d0)*Log(tmp) - tmp + ser = 1.000000000190015d0 + DO j=1,6 + y = y + 1.0d0 + ser = ser + cof(j)/y + END DO + gamma_sp = Exp(tmp + log(stp*ser/x)) + + RETURN + END FUNCTION GAMMA_SP + +! ##################################################################### + +!>\ingroup mod_nsslmp +!! Douple-precision complete gamma function (single precision input) + DOUBLE PRECISION FUNCTION GAMMA_DPR(x) + ! dp gamma with real input + implicit none + real :: x + double precision :: xx + + xx = x + + gamma_dpr = gamma_dp(xx) + + return + end FUNCTION GAMMA_DPR + + + + +! ##################################################################### + +!>\ingroup mod_nsslmp +!! single-precision incomplete gamma function (single precision args) + real function GAMXINF(A1,X1) + +! =================================================== +! Purpose: Compute the incomplete gamma function +! from x to infinity +! Input : a --- Parameter ( a 170 ) +! x --- Argument +! Output: GIM --- gamma(a,x) t=x,Infinity +! Routine called: GAMMA for computing gamma(x) +! =================================================== + +! IMPLICIT DOUBLE PRECISION (A-H,O-Z) + implicit none + real :: a1,x1 + double precision :: xam,dlog,s,r,ga,t0,a,x + integer :: k + double precision :: gin, gim + + a = a1 + x = x1 + IF ( x1 <= 0.0 ) THEN + gamxinf = GAMMA_SP(A1) + return + ENDIF + XAM=-X+A*DLOG(X) + IF (XAM.GT.700.0.OR.A.GT.170.0) THEN + WRITE(*,*)'a and/or x too large' + ENDIF + IF (X.EQ.0.0) THEN + GIN=0.0 + GIM = GAMMA_SP(A1) + ELSE IF (X.LE.1.0+A) THEN + S=1.0D0/A + R=S + DO 10 K=1,60 + R=R*X/(A+K) + S=S+R + IF (DABS(R/S).LT.1.0D-15) GO TO 15 +10 CONTINUE +15 GIN=DEXP(XAM)*S + ga = GAMMA_SP(A1) + GIM=GA-GIN + ELSE IF (X.GT.1.0+A) THEN + T0=0.0D0 + DO 20 K=60,1,-1 + T0=(K-A)/(1.0D0+K/(X+T0)) +20 CONTINUE + GIM=DEXP(XAM)/(X+T0) +! GA = GAMMA_SP(A1) +! GIN=GA-GIM + ENDIF + + gamxinf = GIM + return + END function GAMXINF + +! ##################################################################### + +!>\ingroup mod_nsslmp +!! Double-precision incomplete gamma function (single precision args) + double precision function GAMXINFDP(A1,X1) + +! =================================================== +! Purpose: Compute the incomplete gamma function +! from x to infinity +! Input : a --- Parameter ( a < 170 ) +! x --- Argument +! Output: GIM --- Gamma(a,x) t=x,Infinity +! Routine called: GAMMA for computing gamma_dp(x) +! =================================================== + +! IMPLICIT DOUBLE PRECISION (A-H,O-Z) + implicit none + real :: a1,x1 +! dont declare gamma_dp because it is within the module +! double precision :: gamma_dp + double precision :: xam,dlog,s,r,ga,t0,a,x + integer :: k + double precision :: gin, gim + + a = a1 + x = x1 + IF ( x1 <= 0.0 ) THEN + gamxinfdp = GAMMA_DP(A) + return + ENDIF + XAM=-X+A*DLOG(X) + IF (XAM.GT.700.0.OR.A.GT.170.0) THEN + WRITE(*,*)'a and/or x too large' + ENDIF + IF (X.EQ.0.0) THEN + GIN=0.0 + GIM = GAMMA_dp(A) + ELSE IF (X.LE.1.0+A) THEN + S=1.0D0/A + R=S + DO 10 K=1,60 + R=R*X/(A+K) + S=S+R + IF (DABS(R/S).LT.1.0D-15) GO TO 15 +10 CONTINUE +15 GIN=DEXP(XAM)*S + ga = GAMMA_DP(A) + GIM=GA-GIN + ELSE IF (X.GT.1.0+A) THEN + T0=0.0D0 + DO 20 K=60,1,-1 + T0=(K-A)/(1.0D0+K/(X+T0)) +20 CONTINUE + GIM=DEXP(XAM)/(X+T0) +! GA = GAMMA_dp(A) +! GIN=GA-GIM + ENDIF + + gamxinfdp = GIM + return + END function GAMXINFDP + + +! ##################################################################### + +!>\ingroup mod_nsslmp +!! Function to interpolate from a table of incomplete gamma function values + real function gaminterp(ratio, alp, luindex, ilh) + + implicit none + + real, intent(in) :: ratio, alp + integer, intent(in) :: ilh ! 1 = graupel, 2 = hail + integer, intent(in) :: luindex ! which argument: + ! gamxinflu(i,j,1,1) = x/y + ! gamxinflu(i,j,2,1) = gamxinf( 2.0+alp, ratio )/y + ! gamxinflu(i,j,3,1) = gamxinf( 2.5+alp+0.5*bxh, ratio )/y + ! gamxinflu(i,j,5,1) = gamxinf( 5.0+alp, ratio )/y + ! gamxinflu(i,j,6,1) = gamxinf( 5.5+alp+0.5*bxh, ratio )/y + + + real :: delx, dely, tmp1, tmp2, temp3 + integer :: i,j,ip1,jp1 !,ilh + +! ilh = Abs(ilh0) + + + i = Min(nqiacrratio,Int(ratio*dqiacrratioinv)) + j = Int(Max(0.0,Min(maxalphalu,alp))*dqiacralphainv) + delx = Min(maxratiolu,ratio) - float(i)*dqiacrratio + dely = alp - float(j)*dqiacralpha + ip1 = Min( i+1, nqiacrratio ) + jp1 = Min( j+1, nqiacralpha ) + + ! interpolate along x, i.e., ratio; + tmp1 = gamxinflu(i,j,luindex,ilh) + delx*dqiacrratioinv* & + & (gamxinflu(ip1,j,luindex,ilh) - gamxinflu(i,j,luindex,ilh)) + tmp2 = gamxinflu(i,jp1,luindex,ilh) + delx*dqiacrratioinv* & + & (gamxinflu(ip1,jp1,luindex,ilh) - gamxinflu(i,jp1,luindex,ilh)) + + ! interpolate along alpha; + + gaminterp = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1)) + + ! debug +! IF ( ilh0 < 0 ) THEN +! write(0,*) 'gaminterp: ',i,j,ilh,ratio,delx,dely,gamxinflu(i,j,luindex,ilh),tmp1,tmp2 +! ENDIF + + END FUNCTION gaminterp +! ##################################################################### + +!**************************** GAML02 *********************** +! This calculates Gamma(0.2,x)/Gamma[0.2], where is a ratio +! It is used for qiacr with the gamma of volume to calculate what +! fraction of drops exceed a certain size (this version is for 40 micron drops) +! ********************************************************** +!>\ingroup mod_nsslmp +!! Function calculates Gamma(0.2,x)/Gamma[0.2] for 40 micro drops ( imurain == 3 ) + real FUNCTION GAML02(x) + implicit none + integer ig, i, ii, n, np + real x + integer ng + parameter(ng=12) + real gamxg(ng), xg(ng) + DATA xg/0.01,0.02,0.025,0.04,0.075,0.1,0.25,0.5,0.75,1.,2.,10./ + DATA gamxg/ & + & 7.391019203578037e-8,0.02212726874591478,0.06959352407989682, & + & 0.2355654024970809,0.46135930387500346,0.545435791452399, & + & 0.7371571313308203, & + & 0.8265676632204345,0.8640182781845841,0.8855756211304151, & + & 0.9245079225301251, & + & 0.9712578342732681/ + IF ( x .ge. xg(ng) ) THEN + gaml02 = xg(ng) + RETURN + ENDIF + IF ( x .lt. xg(1) ) THEN + gaml02 = 0.0 + RETURN + ENDIF + DO ii = 1,ng-1 + i = ng - ii + n = i + np = n + 1 + IF ( x .ge. xg(i) ) THEN +! GOTO 2 + gaml02 = gamxg(N)+((X-XG(N))/(XG(NP)-XG(N)))* & + & ( gamxg(NP) - gamxg(N) ) + RETURN + ENDIF + ENDDO + RETURN + END FUNCTION GAML02 + +!**************************** GAML02d300 *********************** +! This calculates Gamma(0.2,x)/Gamma[0.2], where is a ratio +! It is used for qiacr with the gamma of volume to calculate what +! fraction of drops exceed a certain size (this version is for 300 micron drops) (see zieglerstuff.nb) +! ********************************************************** +!>\ingroup mod_nsslmp +!! Function calculates fraction of drops larger than 300 microns ( imurain == 3 ) + real FUNCTION GAML02d300(x) + implicit none + integer ig, i, ii, n, np + real x + integer ng + parameter(ng=9) + real gamxg(ng), xg(ng) + DATA xg/0.04,0.075,0.1,0.25,0.5,0.75,1.,2.,10./ + DATA gamxg/ & + & 0.0, & + & 7.391019203578011e-8,0.0002260640810600053, & + & 0.16567071824457152, & + & 0.4231369044918005,0.5454357914523988, & + & 0.6170290936864555, & + & 0.7471346054110058,0.9037156157718299 / + IF ( x .ge. xg(ng) ) THEN + GAML02d300 = xg(ng) + RETURN + ENDIF + IF ( x .lt. xg(1) ) THEN + GAML02d300 = 0.0 + RETURN + ENDIF + DO ii = 1,ng-1 + i = ng - ii + n = i + np = n + 1 + IF ( x .ge. xg(i) ) THEN +! GOTO 2 + GAML02d300 = gamxg(N)+((X-XG(N))/(XG(NP)-XG(N)))* & + & ( gamxg(NP) - gamxg(N) ) + RETURN + ENDIF + ENDDO + RETURN + END FUNCTION GAML02d300 +!c + +! ##################################################################### +! ##################################################################### + +!**************************** GAML02 *********************** +! This calculates Gamma(0.2,x)/Gamma[0.2], where is a ratio +! It is used for qiacr with the gamma of volume to calculate what +! fraction of drops exceed a certain size (this version is for 500 micron drops) (see zieglerstuff.nb) +! ********************************************************** +!>\ingroup mod_nsslmp +!! Function calculates Gamma(0.2,x)/Gamma[0.2] for 500 micro drops ( imurain == 3 ) + real FUNCTION GAML02d500(x) + implicit none + integer ig, i, ii, n, np + real x + integer ng + parameter(ng=9) + real gamxg(ng), xg(ng) + DATA xg/0.04,0.075,0.1,0.25,0.5,0.75,1.,2.,10./ + DATA gamxg/ & + & 0.0,0.0, & + & 2.2346039e-13, 0.0221272687459, & + & 0.23556540, 0.38710348, & + & 0.48136183,0.6565833, & + & 0.86918315 / + IF ( x .ge. xg(ng) ) THEN + GAML02d500 = xg(ng) + RETURN + ENDIF + IF ( x .lt. xg(1) ) THEN + GAML02d500 = 0.0 + RETURN + ENDIF + DO ii = 1,ng-1 + i = ng - ii + n = i + np = n + 1 + IF ( x .ge. xg(i) ) THEN +! GOTO 2 + GAML02d500 = gamxg(N)+((X-XG(N))/(XG(NP)-XG(N)))* & + & ( gamxg(NP) - gamxg(N) ) + RETURN + ENDIF + ENDDO + RETURN + END FUNCTION GAML02d500 +!c + +! ##################################################################### + +! ##################################################################### + + + real function BETA(P,Q) +! +! ========================================== +! Purpose: Compute the beta function B(p,q) +! Input : p --- Parameter ( p > 0 ) +! q --- Parameter ( q > 0 ) +! Output: BT --- B(p,q) +! Routine called: GAMMA for computing gamma(x) +! ========================================== +! +! IMPLICIT real (A-H,O-Z) + implicit none + double precision p1,gp,q1,gq, ppq,gpq + real p,q + + p1 = p + q1 = q + CALL GAMMADP(P1,GP) + CALL GAMMADP(Q1,GQ) + PPQ=P1+Q1 + CALL GAMMADP(PPQ,GPQ) + beta=GP*GQ/GPQ + RETURN + END function BETA + +! ##################################################################### +! ##################################################################### + +!>\ingroup mod_nsslmp +!! Douple-precision complete gamma function (double precision argument) + DOUBLE PRECISION FUNCTION GAMMA_DP(xx) + + implicit none + double precision xx + integer j + +! Double precision ser,stp,tmp,x,y,cof(6) + + real*8 ser,stp,tmp,x,y,cof(6) + SAVE cof,stp + DATA cof,stp/76.18009172947146d+0, & + & -86.50532032941677d0, & + & 24.01409824083091d0, & + & -1.231739572450155d0, & + & 0.1208650973866179d-2,& + & -0.5395239384953d-5, & + & 2.5066282746310005d0/ + + x = xx + y = x + tmp = x + 5.5d0 + tmp = (x + 0.5d0)*Log(tmp) - tmp + ser = 1.000000000190015d0 + DO j=1,6 + y = y + 1.0d0 + ser = ser + cof(j)/y + END DO + gamma_dp = Exp(tmp + log(stp*ser/x)) + + RETURN + END function gamma_dp +! ##################################################################### + +!>\ingroup mod_nsslmp +!! Double-precision complete gamma function subroutine (used by beta function routine) + SUBROUTINE GAMMADP(X,GA) +! +! ================================================== +! Purpose: Compute gamma function Gamma(x) +! Input : x --- Argument of Gamma(x) +! ( x is not equal to 0,-1,-2,...) +! Output: GA --- gamma(x) +! ================================================== +! +! IMPLICIT DOUBLE PRECISION (A-H,O-Z) + implicit none + + double precision, parameter :: PI=3.141592653589793D0 + double precision :: x,ga,z,r,gr + integer :: k,m1,m + + double precision :: G(26) + + IF (X.EQ.INT(X)) THEN + IF (X.GT.0.0D0) THEN + GA=1.0D0 + M1=X-1 + DO K=2,M1 + GA=GA*K + ENDDO + ELSE + GA=1.0D+300 + ENDIF + ELSE + IF (DABS(X).GT.1.0D0) THEN + Z=DABS(X) + M=INT(Z) + R=1.0D0 + DO K=1,M + R=R*(Z-K) + ENDDO + Z=Z-M + ELSE + Z=X + ENDIF + DATA G/1.0D0,0.5772156649015329D0, & + & -0.6558780715202538D0, -0.420026350340952D-1, & + & 0.1665386113822915D0,-.421977345555443D-1, & + & -.96219715278770D-2, .72189432466630D-2, & + & -.11651675918591D-2, -.2152416741149D-3, & + & .1280502823882D-3, -.201348547807D-4, & + & -.12504934821D-5, .11330272320D-5, & + & -.2056338417D-6, .61160950D-8, & + & .50020075D-8, -.11812746D-8, & + & .1043427D-9, .77823D-11, & + & -.36968D-11, .51D-12, & + & -.206D-13, -.54D-14, .14D-14, .1D-15/ + GR=G(26) + DO K=25,1,-1 + GR=GR*Z+G(K) + ENDDO + GA=1.0D0/(GR*Z) + IF (DABS(X).GT.1.0D0) THEN + GA=GA*R + IF (X.LT.0.0D0) GA=-PI/(X*GA*DSIN(PI*X)) + ENDIF + ENDIF + RETURN + END SUBROUTINE GAMMADP + + +! ##################################################################### +! ##################################################################### +! +! +! ##################################################################### +!>\ingroup mod_nsslmp +!! Function calculates collection coefficients following Siefert (2006) + Function delbk(bb,nu,mu,k) +! +! Purpose: Caluculates collection coefficients following Siefert (2006) +! +! delbk is equation (90) (b collecting b -- self-collection) +! mass-diameter relationship: D = a*x**(b), where x = particle mass +! general distribution: n(x) = A*x**(nu)*Exp(-lam*x**(mu)) +! where +! A = mu*N/(Gamma((nu+1)/mu)) *lam**((nu+1)/mu) +! +! lam = ( Gamma((nu+1)/mu)/Gamma((nu+2)/mu) * xbar )**(-mu) +! +! where xbar = L/N (mass content)/(number concentration) = q*rhoa/N +! + + implicit none + real delbk + real nu, mu, bb + integer k + + real tmp, del + real x1, x2, x3, x4 + integer i + + tmp = ((1.0 + nu)/mu) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x1 = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = ((2.0 + nu)/mu) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x2 = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = ((1.0 + 2.0*bb + k + nu)/mu) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x3 = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + +! delbk = & +! & ((Gamma_sp((1.0 + nu)/mu)/Gamma_sp((2.0 + nu)/mu))**(2.0*bb + k)* & +! & Gamma_sp((1.0 + 2.0*bb + k + nu)/mu))/Gamma_sp((1.0 + nu)/mu) + + delbk = & + & ((x1/x2)**(2.0*bb + k)* & + & x3)/x1 + + RETURN + END Function delbk + +! ##################################################################### +! +! +! ##################################################################### +! Equation (91) in Seifert and Beheng (2006) ("a" collecting "b") +!>\ingroup mod_nsslmp +!! Function calculates collection coefficients following Siefert (2006) + Function delabk(ba,bb,nua,nub,mua,mub,k) + + implicit none + real delabk + real nua, mua, ba + integer k + real nub, mub, bb + + integer i + real tmp,del + + real g1pnua, g2pnua, g1pbapnua, g1pbbpk, g1pnub, g2pnub + + tmp = (1. + nua)/mua + i = Int(dgami*(tmp)) + del = tmp - dgam*i + IF ( i+1 > ngm0 ) THEN + write(0,*) 'delabk: i+1 > ngm0!!!!',i,ngm0,nua,mua,tmp + ENDIF + g1pnua = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami +! write(91,*) 'delabk: g1pnua,gamma = ',g1pnua,Gamma_sp((1. + nua)/mua) + + tmp = ((2. + nua)/mua) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g2pnua = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = ((1. + ba + nua)/mua) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1pbapnua = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = ((1. + nub)/mub) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1pnub = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = ((2 + nub)/mub) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g2pnub = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = ((1. + bb + k + nub)/mub) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1pbbpk = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + delabk = & + & (2.*(g1pnua/g2pnua)**ba* & + & g1pbapnua* & + & (g1pnub/g2pnub)**(bb + k)* & + & g1pbbpk)/ & + & (g1pnua*g1pnub) + + RETURN + END Function delabk + + +!>\ingroup mod_nsslmp +!! Sedimentation driver subroutine. Calls fallout column by column + subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & + & t0,t7,infdo,jslab,its,jts, & + & timesed1,timesed2,timesed3,zmaxsed,timesetvt) ! used for timing +! +! Sedimentation driver -- column by column +! +! Written by ERM 10/2011 +! +! +! + implicit none + + integer nx,ny,nz,nor,norz,ngt,jgs,na,ia + integer id ! =1 use density, =0 no density + integer :: its,jts ! SW point of local tile + + integer ng1 + parameter(ng1 = 1) + + real an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) + real dn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real dz3d(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real dz3dinv(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real t0(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real t7(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + +! real gz(-nor+ng1:nz+nor),z1d(-nor+ng1:nz+nor,4) + real dtp + real xfall(nx,ny,na) ! array for stuff landing on the ground + real xfall0(nx,ny) ! dummy array + integer infdo + integer jslab ! which line of xfall to use + + integer ix,jy,kz,ndfall,n,k,il,in + real tmp, vtmax, dtptmp, dtfrac + real, parameter :: dz = 200. + + real :: xvt(nz+1,nx,3,lc:lhab) ! (nx,nz,2,lc:lhab) ! 1=mass-weighted, 2=number-weighted + real :: tmpn(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real :: tmpn2(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real :: z(-nor+ng1:nx+nor,-norz+ng1:nz+norz,lr:lhab) + real :: db1(nx,nz+1),dtz1(nz+1,nx,0:1),dz2dinv(nz+1,nx),db1inv(nx,nz+1) + + real :: rhovtzx(nz,nx) + + double precision :: timesed1,timesed2,timesed3, zmaxsed,timesetvt,dummy + double precision :: dt1,dt2,dt3,dt4 + + integer,parameter :: ngs = 128 + integer :: ngscnt,mgs,ipconc0 + + real :: qx(ngs,lv:lhab) + real :: qxw(ngs,ls:lhab) + real :: cx(ngs,lc:lhab) + real :: xv(ngs,lc:lhab) + real :: vtxbar(ngs,lc:lhab,3) + real :: xmas(ngs,lc:lhab) + real :: xdn(ngs,lc:lhab) + real :: xdia(ngs,lc:lhab,3) + real :: vx(ngs,li:lhab) + real :: alpha(ngs,lc:lhab) + real :: zx(ngs,lr:lhab) + logical :: hasmass(nx,lc+1:lhab) + + integer igs(ngs),kgs(ngs) + + real rho0(ngs),temcg(ngs) + + real temg(ngs) + + real rhovt(ngs) + + real cwnc(ngs),cinc(ngs) + real fadvisc(ngs),cwdia(ngs),cipmas(ngs) + + real cimasn,cimasx,cnina(ngs),cimas(ngs) + + real cnostmp(ngs) + + +!----------------------------------------------------------------------------- + + integer :: ixb, jyb, kzb + integer :: ixe, jye, kze + integer :: plo, phi + + logical :: debug_mpi = .TRUE. + +! ################################################################### + + + + + kzb = 1 + kze = nz + + ixb = 1 + ixe = nx + + + jy = 1 + jgs = jy + + +! +! zero the precip flux arrays (2d) +! + + xvt(:,:,:,:) = 0.0 + + if ( ndebug .gt. 0 ) write(0,*) 'dbg = 3a' + + + DO kz = kzb,kze + DO ix = ixb,ixe + db1(ix,kz) = dn(ix,jy,kz) + db1inv(ix,kz) = 1./dn(ix,jy,kz) + rhovtzx(kz,ix) = Sqrt(rho00*Min(1.0/0.05, db1inv(ix,kz))) ! prevent excessive rhovt + ENDDO + ENDDO + + DO kz = kzb,kze + DO ix = ixb,ixe + dtz1(kz,ix,0) = dz3dinv(ix,jy,kz) + dtz1(kz,ix,1) = dz3dinv(ix,jy,kz)*db1inv(ix,kz) + dz2dinv(kz,ix) = dz3dinv(ix,jy,kz) + ENDDO + ENDDO + + IF ( lzh .gt. 1 ) THEN + DO kz = kzb,kze + DO ix = ixb,ixe + an(ix,jy,kz,lzh) = Max( 0., an(ix,jy,kz,lzh) ) + ENDDO + ENDDO + ENDIF + + + DO il = lc+1,lhab + DO ix = ixb,ixe +! hasmass(ix,il) = Any( an(ix,jy,:,il) > qxmin(il) ) + ENDDO + ENDDO + + + + + if (ndebug .gt. 0 ) write(0,*) 'dbg = 3a2' + +! loop over columns + DO ix = ixb,ixe + + dummy = 0.d0 + + + call ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ix, & + & xvt, rhovtzx, & + & an,dn,ipconc,t0,t7,cwmasn,cwmasx, & + & cwradn, & + & qxmin,xdnmx,xdnmn,cdx,cno,xdn0,xvmn,xvmx, & + & ngs,qx,qxw,cx,xv,vtxbar,xmas,xdn,xdia,vx,alpha,zx,igs,kgs, & + & rho0,temcg,temg,rhovt,cwnc,cinc,fadvisc,cwdia,cipmas,cnina,cimas, & + & cnostmp, & + & infdo,0 & + & ) + + +! loop over each species and do sedimentation for all moments + DO il = lc,lhab + IF ( ido(il) == 0 ) CYCLE + +! IF ( .not. hasmass(ix,il) ) CYCLE + +! plo = nz +! phi = 0 + + + vtmax = 0.0 + + do kz = kzb,kze + + ! apply limit vtmaxsed (08/20/2015) + xvt(kz,ix,1,il) = Min( vtmaxsed, xvt(kz,ix,1,il) ) + xvt(kz,ix,2,il) = Min( vtmaxsed, xvt(kz,ix,2,il) ) + xvt(kz,ix,3,il) = Min( vtmaxsed, xvt(kz,ix,3,il) ) + + vtmax = Max(vtmax,xvt(kz,ix,1,il)*dz2dinv(kz,ix)) + vtmax = Max(vtmax,xvt(kz,ix,2,il)*dz2dinv(kz,ix)) + vtmax = Max(vtmax,xvt(kz,ix,3,il)*dz2dinv(kz,ix)) + +! IF ( dtp*xvt(kz,ix,1,il)*dz2dinv(kz,ix) >= 0.7 .or. & +! & dtp*xvt(kz,ix,2,il)*dz2dinv(kz,ix) >= 0.7 .or. & +! & dtp*xvt(kz,ix,3,il)*dz2dinv(kz,ix) >= 0.7 ) THEN +! +! zmaxsed = Max(zmaxsed, float(kz) ) +!! plo = Min(plo,kz) +!! phi = Max(phi,kz) +! +! ENDIF + + ENDDO + + IF ( vtmax == 0.0 ) CYCLE + + + + IF ( dtp*vtmax .lt. 0.7 ) THEN ! check whether multiple steps are needed. + ndfall = 1 + ELSE + IF ( dtp > 20.0 ) THEN ! more stringent subdivision for large time steps + ndfall = Max(2, Int(dtp*vtmax/0.7) + 1) + ELSE ! more relaxed for small time steps, but might still be a problem for very thin vertical layers near the ground + ndfall = 1+Int(dtp*vtmax + 0.301) + ENDIF + ENDIF + + IF ( ndfall .gt. 1 ) THEN + dtptmp = dtp/Real(ndfall) +! write(0,*) 'subdivide fallout on its,jts,ix,plo,phi = ',its,jts,ix,plo,phi +! write(0,*) 'for il,jsblab,c,ndfall = ',il,jslab,dtp*vtmax,ndfall + ELSE + dtptmp = dtp + ENDIF + + dtfrac = dtptmp/dtp + + + DO n = 1,ndfall + + IF ( do_accurate_sedimentation .and. n .ge. 2 .and. ( n == interval_sedi_vt*(n/interval_sedi_vt) ) ) THEN +! +! zero the precip flux arrays (2d) +! + + dummy = 0.d0 + + xvt(kzb:kze,ix,1:3,il) = 0.0 ! reset to zero because routine will only compute points with q > qmin + + call ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ix, & + & xvt, rhovtzx, & + & an,dn,ipconc,t0,t7,cwmasn,cwmasx, & + & cwradn, & + & qxmin,xdnmx,xdnmn,cdx,cno,xdn0,xvmn,xvmx, & + & ngs,qx,qxw,cx,xv,vtxbar,xmas,xdn,xdia,vx,alpha,zx,igs,kgs, & + & rho0,temcg,temg,rhovt,cwnc,cinc,fadvisc,cwdia,cipmas,cnina,cimas, & + & cnostmp, & + & infdo,il) + + + DO kz = kzb,kze + ! apply limit vtmaxsed (08/20/2015) + xvt(kz,ix,1,il) = Min( vtmaxsed, xvt(kz,ix,1,il) ) + xvt(kz,ix,2,il) = Min( vtmaxsed, xvt(kz,ix,2,il) ) + xvt(kz,ix,3,il) = Min( vtmaxsed, xvt(kz,ix,3,il) ) + ENDDO + + + + + ENDIF ! (n .ge. 2) + + + IF ( il >= lr .and. ( infall .eq. 3 .or. infall .eq. 4 ) .and. ln(il) > 0 ) THEN + IF ( (il .eq. lr .and. irfall .eq. infall .and. lzr < 1) .or. (il .ge. lh .and. lz(il) .lt. 1 ) ) THEN + call calczgr1d(nx,ny,nz,nor,na,an,ixe,kze, & + & z,db1,jgs,ipconc, dnu(il), il, ln(il), qxmin(il), xvmn(il), xvmx(il), lvol(il), xdn0(il), ix ) + ENDIF + ENDIF + + if (ndebug .gt. 0 ) write(0,*) 'dbg = 1b' + +! mixing ratio + + call fallout1d(nx,ny,nz,nor,na,dtptmp,dtfrac,jgs,xvt(1,1,1,il), & + & an,db1,il,1,xfall,dtz1,ix) + + + if (ndebug .gt. 0 ) write(0,*) 'dbg = 3c' + +! volume + + IF ( ldovol .and. il >= li ) THEN + IF ( lvol(il) .gt. 1 ) THEN + call fallout1d(nx,ny,nz,nor,na,dtptmp,dtfrac,jgs,xvt(1,1,1,il), & + & an,db1,lvol(il),0,xfall,dtz1,ix) + ENDIF + ENDIF + + + if (ndebug .gt. 0 ) write(0,*) 'dbg = 3d' + + + IF ( ipconc .gt. 0 ) THEN !{ + IF ( ipconc .ge. ipc(il) ) THEN + + IF ( ( infall .ge. 2 .or. (infall .eq. 0 .and. il .lt. lh) ) .and. lz(il) .lt. 1) THEN !{ +! +! load number conc. into tmpn to do fallout by mass-weighted mean fall speed +! to put a lower bound on number conc. +! + + IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. ( il .eq. lh .or. il .eq. lhl .or. & + & ( il .eq. lr .and. irfall .eq. infall) ) ) THEN + + DO kz = kzb,kze +! DO ix = ixb,ixe + tmpn2(ix,jy,kz) = z(ix,kz,il) +! ENDDO + ENDDO + DO kz = kzb,kze +! DO ix = ixb,ixe + tmpn(ix,jy,kz) = an(ix,jy,kz,ln(il)) +! ENDDO + ENDDO + + ELSE + + DO kz = kzb,kze +! DO ix = ixb,ixe + tmpn(ix,jy,kz) = an(ix,jy,kz,ln(il)) +! ENDDO + ENDDO + + ENDIF + + ENDIF !} + + + if (ndebug .gt. 0 ) write(0,*) 'dbg = 3f' + + in = 2 + IF ( infall .eq. 1 ) in = 1 + + call fallout1d(nx,ny,nz,nor,na,dtptmp,dtfrac,jgs,xvt(1,1,in,il), & + & an,db1,ln(il),0,xfall,dtz1,ix) + + + IF ( lz(il) .lt. 1 ) THEN ! if not 3-moment, run one of the correction schemes + IF ( (infall .ge. 2 .or. infall .eq. 3) .and. .not. (infall .eq. 0 .and. il .ge. lh) & + & .and. ( il .eq. lr .or. (il .ge. li .and. il .le. lhab) )) THEN +! : .or. il .eq. lhl )) THEN + + xfall0(:,jgs) = 0.0 + + IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. & + & ( il .ge. lh .or. (il .eq. lr .and. irfall .eq. infall) ) ) THEN + call fallout1d(nx,ny,nz,nor,1,dtptmp,dtfrac,jgs,xvt(1,1,3,il), & + & tmpn2,db1,1,0,xfall0,dtz1,ix) + call fallout1d(nx,ny,nz,nor,1,dtptmp,dtfrac,jgs,xvt(1,1,1,il), & + & tmpn,db1,1,0,xfall0,dtz1,ix) + ELSE + call fallout1d(nx,ny,nz,nor,1,dtptmp,dtfrac,jgs,xvt(1,1,1,il), & + & tmpn,db1,1,0,xfall0,dtz1,ix) + ENDIF + + IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. ( (il .eq. lr .and. irfall .eq. infall) & + & .or. il .ge. lh ) ) THEN +! "Method I" - dbz correction + + call calcnfromz1d(nx,ny,nz,nor,na,an,tmpn2,ixe,kze, & + & z,db1,jgs,ipconc, dnu(il), il, ln(il), qxmin(il), xvmn(il), xvmx(il),tmpn, & + & lvol(il), rho_qh, infall, ix) + + ELSEIF ( infall .eq. 5 .and. il .ge. lh .or. ( il == lr .and. irfall == 5 ) ) THEN + + DO kz = kzb,kze +! DO ix = ixb,ixe + an(ix,jgs,kz,ln(il)) = Max( an(ix,jgs,kz,ln(il)), 0.5* ( an(ix,jgs,kz,ln(il)) + tmpn(ix,jy,kz) )) + +! ENDDO + ENDDO + + ELSEIF ( .not. (il .eq. lr .and. irfall .eq. 0) ) THEN +! "Method II" M-wgt N-fallout correction + + DO kz = kzb,kze +! DO ix = ixb,ixe + + an(ix,jgs,kz,ln(il)) = Max( an(ix,jgs,kz,ln(il)), tmpn(ix,jy,kz) ) + +! ENDDO + ENDDO + ENDIF + ENDIF ! lz(il) .lt. 1 + + + ENDIF + ENDIF + + + ENDIF !} + + + ENDDO ! n=1,ndfall + ENDDO ! il + + ENDDO ! ix + + + + + RETURN + END SUBROUTINE SEDIMENT1D + + +! ##################################################################### + +! +! ##################################################################### + + +! +!-------------------------------------------------------------------------- +! +!-------------------------------------------------------------------------- +! +!>\ingroup mod_nsslmp +!! Column sedimentation fallout subroutine + subroutine fallout1d(nx,ny,nz,nor,na,dtp,dtfrac,jgs,vt, & + & a,db1,ia,id,xfall,dtz1,ixcol) +! +! First-order, upwind fallout scheme +! +! Written by ERM 6/10/2011 +! +! +! + implicit none + + integer nx,ny,nz,nor,ngt,jgs,na,ia + integer id ! =1 use density, =0 no density + integer ng1 + parameter(ng1 = 1) + integer :: ixcol + +! real dz3dinv(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) +! real a(nx,ny,nz,na) + real a(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor,na) ! quantity to be 'advected' + real vt(nz+1,nx) ! terminal speed for a + real dtp,dtfrac + real cmax + real xfall(nx,ny,na) ! array for stuff landing on the ground + real db1(nx,nz+1),dtz1(nz+1,nx,0:1) + +! Local + + integer ix,jy,kz,n,k + integer iv1,iv2 + real tmp + integer imn,imx,kmn,kmx + real qtmp1(nz+1) + +!----------------------------------------------------------------------------- + + integer :: ixb, jyb, kzb + integer :: ixe, jye, kze + + logical :: debug_mpi = .TRUE. + +! ################################################################### + + jy = 1 + + iv1 = 0 + iv2 = 0 + + imn = nx + imx = 1 + kmn = nz + kmx = 1 + + cmax = 0.0 + + kzb = 1 + kze = nz + + ixb = ixcol + ixe = ixcol + ix = ixcol + + qtmp1(nz+1) = 0.0 + + DO kz = kzb,kze +! DO ix = ixb,ixe +! cmax = Max(cmax, vt(ix,kz)*dz3dinv(ix,jy,kz)) + + IF ( id == 1 ) THEN + qtmp1(kz) = a(ix,jgs,kz,ia)*vt(kz,ix)*db1(ix,kz) + ELSE + qtmp1(kz) = a(ix,jgs,kz,ia)*vt(kz,ix) + ENDIF + + IF ( a(ix,jgs,kz,ia) .ne. 0.0 ) THEN +! imn = Min(ix,imn) +! imx = Max(ix,imx) + kmn = Min(kz,kmn) + kmx = Max(kz,kmx) + ENDIF +! ENDDO + ENDDO + + kmn = Max(1,kmn-1) + +! first check if fallout is worth doing +! IF ( cmax .eq. 0.0 .or. imn .gt. imx ) THEN +! RETURN +! ENDIF + + IF ( kmn == 1 ) THEN + + kz = 1 +! do ix = imn,imx ! 1,nx-1 + xfall(ix,jy,ia) = xfall(ix,jy,ia) + a(ix,jgs,kz,ia)*vt(kz,ix)*dtfrac +! enddo + + ENDIF + + do kz = 1,nz +! do ix = 1,nx + a(ix,jgs,kz,ia) = a(ix,jgs,kz,ia) + dtp*dtz1(kz,ix,id)*(qtmp1(kz+1) - qtmp1(kz) ) +! enddo + enddo + + + RETURN + END SUBROUTINE FALLOUT1D + +! ############################################################################## +! ############################################################################## + +!>\ingroup mod_nsslmp +!! Calculates temporary reflectivity moment for adaptive size-sorting limiter + subroutine calczgr1d(nx,ny,nz,nor,na,a,ixe,kze, & + & z,db,jgs,ipconc, alpha, l,ln, qmin, xvmn,xvmx, lvol, rho_qx, ixcol) + + + implicit none + + integer nx,ny,nz,nor,na,ngt,jgs + integer :: ixcol + integer, parameter :: norz = 3 + real a(-nor+1:nx+nor,-nor+1:ny+nor,-nor+1:nz+nor,na) + real z(-nor+1:nx+nor,-nor+1:nz+nor,lr:lhab) ! reflectivity + real db(nx,nz+1) ! air density +! real gt(-nor+1:nx+nor,-nor+1:ny+nor,-nor+1:nz+nor,ngt) + + integer ixe,kze + real alpha + real qmin + real xvmn,xvmx + integer ipconc + integer l ! index for q + integer ln ! index for N + integer lvol ! index for volume + real rho_qx + + + integer ix,jy,kz + real vr,qr,nrx,rd,xv,g1,zx,chw,xdn + + + jy = jgs + ix = ixcol + + IF ( l .eq. lh .or. l .eq. lhl .or. ( l .eq. lr .and. imurain == 1 ) ) THEN + + + DO kz = 1,kze + + + + IF ( a(ix,jy,kz,l) .gt. qmin .and. a(ix,jy,kz,ln) .gt. 1.e-15 ) THEN + + IF ( lvol .gt. 1 ) THEN + IF ( a(ix,jy,kz,lvol) .gt. 0.0 ) THEN + xdn = db(ix,kz)*a(ix,jy,kz,l)/a(ix,jy,kz,lvol) + xdn = Min( 900., Max( hdnmn, xdn ) ) + ELSE + xdn = rho_qx + ENDIF + ELSE + xdn = rho_qx + ENDIF + + IF ( l == lr ) xdn = 1000. + + qr = a(ix,jy,kz,l) + xv = db(ix,kz)*a(ix,jy,kz,l)/(xdn*a(ix,jy,kz,ln)) + chw = a(ix,jy,kz,ln) + + IF ( xv .lt. xvmn .or. xv .gt. xvmx ) THEN + xv = Min( xvmx, Max( xvmn,xv ) ) + chw = db(ix,kz)*a(ix,jy,kz,l)/(xv*xdn) + ENDIF + + g1 = (6.0 + alpha)*(5.0 + alpha)*(4.0 + alpha)/ & + & ((3.0 + alpha)*(2.0 + alpha)*(1.0 + alpha)) + zx = g1*db(ix,kz)**2*(a(ix,jy,kz,l))*a(ix,jy,kz,l)/chw +! z(ix,kz,l) = 1.e18*zx*(6./(pi*1000.))**2 + z(ix,kz,l) = zx*(6./(pi*1000.))**2 + + +! IF ( ny.eq.2 .and. kz .ge. 25 .and. kz .le. 29 .and. z(ix,kz,l) .gt. 0. ) THEN +! write(*,*) 'calczgr: z,dbz,xdn = ',ix,kz,z(ix,kz,l),10*log10(z(ix,kz,l)),xdn +! ENDIF + + ELSE + + z(ix,kz,l) = 0.0 + + ENDIF + + ENDDO + + ELSEIF ( l .eq. lr .and. imurain == 3) THEN + + xdn = 1000. + + DO kz = 1,kze + IF ( a(ix,jy,kz,l) .gt. qmin .and. a(ix,jy,kz,ln) .gt. 1.e-15 ) THEN + + vr = db(ix,kz)*a(ix,jy,kz,l)/(xdn*a(ix,jy,kz,ln)) +! z(ix,kz,l) = 3.6e18*(rnu+2.0)*a(ix,jy,kz,ln)*vr**2/(rnu+1.0) + z(ix,kz,l) = 3.6*(rnu+2.0)*a(ix,jy,kz,ln)*vr**2/(rnu+1.0) +! qr = a(ix,jy,kz,lr) +! nrx = a(ix,jy,kz,lnr) + + ELSE + + z(ix,kz,l) = 0.0 + + ENDIF + + + ENDDO + + ENDIF + + RETURN + + END subroutine calczgr1d + +! ############################################################################## +! ############################################################################## +! +! Subroutine to correct number concentration to prevent reflectivity growth by +! sedimentation in 2-moment ZXX scheme. +! Calculation is in a slab (constant jgs) +! + +!>\ingroup mod_nsslmp +!! Subroutine to correct number concentration to prevent reflectivity growth + subroutine calcnfromz1d(nx,ny,nz,nor,na,a,t0,ixe,kze, & + & z0,db,jgs,ipconc, alpha, l,ln, qmin, xvmn,xvmx,t1, & + & lvol, rho_qx, infall, ixcol) + + + implicit none + + integer nx,ny,nz,nor,na,ngt,jgs,ixcol + + real a(-nor+1:nx+nor,-nor+1:ny+nor,-nor+1:nz+nor,na) ! sedimented N and q + real t0(-nor+1:nx+nor,-nor+1:ny+nor,-nor+1:nz+nor) ! sedimented reflectivity + real t1(-nor+1:nx+nor,-nor+1:ny+nor,-nor+1:nz+nor) ! sedimented N (by Vm) +! real gt(-nor+1:nx+nor,-nor+1:ny+nor,-nor+1:nz+nor,ngt) + real z0(-nor+1:nx+nor,-nor+1:nz+nor,lr:lhab) ! initial reflectivity + + real db(nx,nz+1) ! air density + + integer ixe,kze + real alpha + real qmin + real xvmn,xvmx + integer ipconc + integer l ! index for q + integer ln ! index for N + integer lvol ! index for volume + real rho_qx + integer infall + + + integer ix,jy,kz + double precision vr,qr,nrx,rd,g1,zx,chw,z,znew,zt,zxt + real xv,xdn + integer :: ndbz, nmwgt, nnwgt, nwlessthanz + + ndbz = 0 + nmwgt = 0 + nnwgt = 0 + nwlessthanz = 0 + + + + jy = jgs + ix = ixcol + + IF ( l .eq. lh .or. l .eq. lhl .or. ( l == lr .and. imurain == 1 ) ) THEN + + g1 = (6.0 + alpha)*(5.0 + alpha)*(4.0 + alpha)/ & + & ((3.0 + alpha)*(2.0 + alpha)*(1.0 + alpha)) + + DO kz = 1,kze + + + IF ( t0(ix,jy,kz) .gt. 0. ) THEN ! { + + IF ( lvol .gt. 1 ) THEN + IF ( a(ix,jy,kz,lvol) .gt. 0.0 ) THEN + xdn = db(ix,kz)*a(ix,jy,kz,l)/a(ix,jy,kz,lvol) + xdn = Min( 900., Max( hdnmn, xdn ) ) + ELSE + xdn = rho_qx + ENDIF + ELSE + xdn = rho_qx + ENDIF + + IF ( l == lr ) xdn = 1000. + + qr = a(ix,jy,kz,l) + xv = db(ix,kz)*a(ix,jy,kz,l)/(xdn*a(ix,jy,kz,ln)) + chw = a(ix,jy,kz,ln) + + IF ( xv .lt. xvmn .or. xv .gt. xvmx ) THEN + xv = Min( xvmx, Max( xvmn,xv ) ) + chw = db(ix,kz)*a(ix,jy,kz,l)/(xv*xdn) + ENDIF + + zx = g1*db(ix,kz)**2*( a(ix,jy,kz,l))*a(ix,jy,kz,l)/chw + z = zx*(6./(pi*1000.))**2 + + + IF ( (z .gt. t0(ix,jy,kz) .and. z .gt. 0.0 .and. & + & t0(ix,jy,kz) .gt. z0(ix,kz,l) )) THEN !{ + + zx = t0(ix,jy,kz)/((6./(pi*1000.))**2) + + nrx = g1*db(ix,kz)**2*( a(ix,jy,kz,l))*a(ix,jy,kz,l)/zx + IF ( infall .eq. 3 ) THEN + IF ( nrx .gt. a(ix,jy,kz,ln) ) THEN + ndbz = ndbz + 1 + IF ( t1(ix,jy,kz) .lt. ndbz ) nwlessthanz = nwlessthanz + 1 + ELSE + nnwgt = nnwgt + 1 + ENDIF + a(ix,jy,kz,ln) = Max( real(nrx), a(ix,jy,kz,ln) ) + ELSE + IF ( nrx .gt. a(ix,jy,kz,ln) .and. t1(ix,jy,kz) .gt. a(ix,jy,kz,ln) ) THEN + IF ( nrx .lt. t1(ix,jy,kz) ) THEN + ndbz = ndbz + 1 + ELSE + nmwgt = nmwgt + 1 + IF ( t1(ix,jy,kz) .lt. ndbz ) nwlessthanz = nwlessthanz + 1 + ENDIF + ELSE + nnwgt = nnwgt + 1 + ENDIF + + a(ix,jy,kz,ln) = Max(Min( real(nrx), t1(ix,jy,kz) ), a(ix,jy,kz,ln) ) + ENDIF + + ELSE ! } { + IF ( t1(ix,jy,kz) .gt. 0 .and. a(ix,jy,kz,ln) .gt. 0 ) THEN + IF ( t1(ix,jy,kz) .gt. a(ix,jy,kz,ln) ) THEN + nmwgt = nmwgt + 1 + ELSE + nnwgt = nnwgt + 1 + ENDIF + ENDIF + a(ix,jy,kz,ln) = Max(t1(ix,jy,kz), a(ix,jy,kz,ln) ) + nrx = a(ix,jy,kz,ln) + + + + ENDIF ! } + + ! } + ELSE ! { + IF ( t1(ix,jy,kz) .gt. 0 .and. a(ix,jy,kz,ln) .gt. 0 ) THEN + IF ( t1(ix,jy,kz) .gt. a(ix,jy,kz,ln) ) THEN + nmwgt = nmwgt + 1 + ELSE + nnwgt = nnwgt + 1 + ENDIF + ENDIF + ENDIF! } + + ENDDO + + + ELSEIF ( l .eq. lr .and. imurain == 3) THEN + + xdn = 1000. + + DO kz = 1,kze + IF ( t0(ix,jy,kz) .gt. 0. ) THEN + + vr = db(ix,kz)*a(ix,jy,kz,l)/(xdn*a(ix,jy,kz,ln)) + z = 3.6*(rnu+2.0)*a(ix,jy,kz,ln)*vr**2/(rnu+1.0) + + IF ( z .gt. t0(ix,jy,kz) .and. z .gt. 0.0 .and. & + & t0(ix,jy,kz) .gt. 0.0 & + & .and. t0(ix,jy,kz) .gt. z0(ix,kz,l) ) THEN + + vr = db(ix,kz)*a(ix,jy,kz,l)/(xdn) + chw = a(ix,jy,kz,ln) + nrx = 3.6*(rnu+2.0)*vr**2/((rnu+1.0)*t0(ix,jy,kz)) + IF ( infall .eq. 3 ) THEN + a(ix,jy,kz,ln) = Max( real(nrx), a(ix,jy,kz,ln) ) + ELSEIF ( infall .eq. 4 ) THEN + a(ix,jy,kz,ln) = Max( Min( real(nrx), t1(ix,jy,kz)), a(ix,jy,kz,ln) ) + ENDIF + + ELSE + + a(ix,jy,kz,ln) = Max(t1(ix,jy,kz), a(ix,jy,kz,ln) ) + + ENDIF + + ELSE + + a(ix,jy,kz,ln) = Max(t1(ix,jy,kz), a(ix,jy,kz,ln) ) + + ENDIF + + + ENDDO + + ENDIF + + RETURN + + END subroutine calcnfromz1d + + +! ############################################################################## +! ############################################################################## +! +! Subroutine to calculate number concentrations from initial state that has only mixing ratio. +! Output N will be in #/m^3 in 'an' array, since sedimentation is done next. +! Output ccw,cci etc. will be in #/kg + +! +! 10.27.2015: Added hail calculation +! +!>\ingroup mod_nsslmp +!! Subroutine to calculate number concentrations from initial state that has only mixing ratio. + subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & + & qcw,qci,qsw,qrw,qhw,qhl, & + & ccw,cci,csw,crw,chw,chl, & + & cccn,cccna, vhw,vhl,qv,spechum, invertccn_flag, cwmasin ) + + + + implicit none + + integer nx,ny,nz,nor,norz,na,ngt,jgs,ixcol + + real an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) ! scalars (q, N, Z) + + real dn(nx,nz+1) ! air density + + real, optional, dimension(nx,nz), intent(inout) :: qcw,qci,qsw,qrw,qhw,qhl, & + ccw,cci,csw,crw,chw,chl, & + cccn,cccna,vhw,vhl,qv, spechum + logical, optional, intent(in) :: invertccn_flag + real, optional :: cwmasin + + integer ixe,kze + real alpha + real qmin + real xvmn,xvmx + integer ipconc + integer lvol ! index for volume + integer infall + + + integer ix,jy,kz + double precision vr,q,nrx,nrx2,rd,g1h,g1hl,g1r,g1s,zx,z,znew,zt,zxt,n1,laminv1 + double precision :: zr, zs, zh, dninv + real, parameter :: xn0s = 3.0e6, xn0r = 8.0e6, xn0h = 2.0e5, xn0hl = 4.0e4 + real, parameter :: xdnr = 1000., xdns = 100. ,xdnh = 700.0, xdnhl = 900.0 + real, parameter :: zhlfac = 1./(pi*xdnhl*xn0hl) + real, parameter :: zhfac = 1./(pi*xdnh*xn0h) + real, parameter :: zrfac = 1./(pi*xdnr*xn0r) + real, parameter :: zsfac = 1./(pi*xdns*xn0s) + real, parameter :: g0 = (6.0)*(5.0)*(4.0)/((3.0)*(2.0)*(1.0)) + real, parameter :: xims=900.*0.523599*(2.*50.e-6)**3 ! mks (100 micron diam solid sphere approx) + real, parameter :: xgms=xdnh*0.523599*(300.e-6)**3 ! mks (300 micron diam sphere approx) + real, parameter :: cwmas09 = 1000.*0.523599*(2.*9.e-6)**3 ! mass of 9-micron radius droplet + + real xv,xdn,cwmasinv + integer :: ndbz, nmwgt, nnwgt, nwlessthanz + double precision :: mixconv, mixconvqv, qsmax,qsmax2,qsmax3,qsmax4 + logical :: invertccn_local + +! ------------------------------------------------------------------ + + IF ( present( invertccn_flag ) ) THEN + invertccn_local = invertccn_flag + ELSE + invertccn_local = .false. + ENDIF + + IF ( present( cwmasin ) ) THEN + cwmasinv = 1.0/cwmasin + ELSE + cwmasinv = 1.0/cwmas09 + ENDIF + + jy = 1 + + + g1h = (6.0 + alphah)*(5.0 + alphah)*(4.0 + alphah)/ & + & ((3.0 + alphah)*(2.0 + alphah)*(1.0 + alphah)) + + g1hl = (6.0 + alphahl)*(5.0 + alphahl)*(4.0 + alphahl)/ & + & ((3.0 + alphahl)*(2.0 + alphahl)*(1.0 + alphahl)) + + IF ( imurain == 3 ) THEN + g1r = (rnu+2.0)/(rnu+1.0) + ELSE ! imurain == 1 + g1r = (6.0 + alphar)*(5.0 + alphar)*(4.0 + alphar)/ & + & ((3.0 + alphar)*(2.0 + alphar)*(1.0 + alphar)) + ENDIF + + g1s = (snu+2.0)/(snu+1.0) + qsmax = 0 + qsmax2 = 0 + qsmax3 = 0 + qsmax4 = 0 +! IF ( .not. present( qcw ) ) THEN + DO kz = 1,nz + DO ix = 1,nx ! ixcol + +! qv_mp = spechum/(1.0_kind_phys-spechum) +! IF ( convertdry ) THEN +! qc_mp = qc/(1.0_kind_phys-spechum) + mixconv = 1 + IF ( present( spechum ) ) THEN ! convert to "dry" mixing ratios + an(ix,jy,kz,lv) = spechum(ix,kz)/(1.0d0 - spechum(ix,kz)) + mixconv = 1.0d0/(1.0d0 - spechum(ix,kz)) + ELSE + mixconv = 1.0d0 + ENDIF + IF ( present( qv ) ) an(ix,jy,kz,lv) = qv(ix,kz) ! assume qv is "dry" mixing ratio if passed in + IF ( present( qcw ) ) an(ix,jy,kz,lc) = qcw(ix,kz)*mixconv + IF ( present( qrw ) ) an(ix,jy,kz,lr) = qrw(ix,kz)*mixconv + IF ( present( qci ) ) an(ix,jy,kz,li) = qci(ix,kz)*mixconv + IF ( present( qsw ) ) THEN + an(ix,jy,kz,ls) = qsw(ix,kz)*mixconv +! qsmax = Max( qsmax, qsw(ix,kz) ) +! qsmax2 = Max( qsmax2, an(ix,jy,kz,ls) ) + ENDIF + IF ( present( qhw ) ) an(ix,jy,kz,lh) = qhw(ix,kz)*mixconv + IF ( lhl > 1 .and. present( qhl ) ) an(ix,jy,kz,lhl) = qhl(ix,kz)*mixconv + IF ( present( ccw ) ) an(ix,jy,kz,lnc) = ccw(ix,kz)*mixconv*dn(ix,kz) + IF ( present( crw ) ) an(ix,jy,kz,lnr) = crw(ix,kz)*mixconv*dn(ix,kz) + IF ( present( cci ) ) an(ix,jy,kz,lni) = cci(ix,kz)*mixconv*dn(ix,kz) + IF ( present( csw ) ) an(ix,jy,kz,lns) = csw(ix,kz)*mixconv*dn(ix,kz) + IF ( present( chw ) ) an(ix,jy,kz,lnh) = chw(ix,kz)*mixconv*dn(ix,kz) + IF ( lhl > 1 .and. present( chl ) ) an(ix,jy,kz,lnhl) = chl(ix,kz)*mixconv*dn(ix,kz) + IF ( lvh > 1 .and. present( vhw ) ) an(ix,jy,kz,lvh) = vhw(ix,kz)*mixconv + IF ( lvhl > 1 .and. present( vhl ) ) an(ix,jy,kz,lvhl) = vhl(ix,kz)*mixconv + IF ( lccn > 1 .and. present( cccn ) ) an(ix,jy,kz,lccn) = cccn(ix,kz)*mixconv*dn(ix,kz) + IF ( lccna > 1 .and. present( cccna ) ) an(ix,jy,kz,lccna) = cccna(ix,kz)*mixconv + + dninv = 1./dn(ix,kz) + +! IF ( .not. present( qcw ) ) THEN + ! Cloud droplets + + IF ( lnc > 1 ) THEN + IF ( an(ix,jy,kz,lnc) <= cxmin .and. an(ix,jy,kz,lc) > qxmin_init(lc) ) THEN + + an(ix,jy,kz,lnc) = Min(qccn, an(ix,jy,kz,lc)*cwmasinv )*dn(ix,kz) + + IF ( invertccn_local ) THEN + an(ix,jy,kz,lccn) = an(ix,jy,kz,lccn) + an(ix,jy,kz,lnc) + ELSE + + IF ( lccn > 1 .and. lccna < 1 ) THEN + an(ix,jy,kz,lccn) = an(ix,jy,kz,lccn) - an(ix,jy,kz,lnc) + ENDIF + IF ( lccna > 1 ) THEN + an(ix,jy,kz,lccna) = an(ix,jy,kz,lccna) + an(ix,jy,kz,lnc) + ENDIF + ENDIF + + ELSEIF ( an(ix,jy,kz,lc) <= qxmin(lc) .or. & + ( an(ix,jy,kz,lnc) <= cxmin .and. an(ix,jy,kz,lc) <= qxmin_init(lc)) ) THEN + + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lc) + an(ix,jy,kz,lnc) = 0.0 + an(ix,jy,kz,lc) = 0.0 + + ENDIF + ENDIF + + ! Cloud ice + + IF ( lni > 1 ) THEN + IF ( an(ix,jy,kz,lni) <= cxmin .and. an(ix,jy,kz,li) > qxmin_init(li) ) THEN + an(ix,jy,kz,lni) = dn(ix,kz)*an(ix,jy,kz,li)/xims + + ELSEIF ( an(ix,jy,kz,li) <= qxmin(li) .or. & + ( an(ix,jy,kz,lni) <= cxmin .and. an(ix,jy,kz,li) <= qxmin_init(li)) ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,li) + an(ix,jy,kz,lni) = 0.0 + an(ix,jy,kz,li) = 0.0 + ENDIF + ENDIF + + ! rain + + IF ( lnr > 1 ) THEN + IF ( an(ix,jy,kz,lnr) <= 0.1*cxmin .and. an(ix,jy,kz,lr) > qxmin_init(lr) ) THEN + + q = an(ix,jy,kz,lr) + + laminv1 = (dn(ix,kz) * q * zrfac)**(0.25) ! inverse of slope + + n1 = laminv1*xn0r ! number concentration for inv. exponential single moment input + + nrx = n1*g1r/g0 ! number concentration for different shape parameter + + an(ix,jy,kz,lnr) = nrx ! *dninv ! convert to number mixing ratio + + ELSEIF ( an(ix,jy,kz,lr) <= qxmin(lr) .or. & + ( an(ix,jy,kz,lnr) <= cxmin .and. an(ix,jy,kz,lr) <= qxmin_init(lr)) ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lr) + an(ix,jy,kz,lnr) = 0.0 + an(ix,jy,kz,lr) = 0.0 + ENDIF + ENDIF + + ! snow + IF ( lns > 1 ) THEN + IF ( an(ix,jy,kz,lns) <= 0.1*cxmin .and. an(ix,jy,kz,ls) > qxmin_init(ls) ) THEN + + q = an(ix,jy,kz,ls) + + laminv1 = (dn(ix,kz) * q * zsfac)**(0.25) ! inverse of slope + + n1 = laminv1*xn0s ! number concentration for inv. exponential single moment input + + nrx = n1*g1s/g0 ! number concentration for different shape parameter + + an(ix,jy,kz,lns) = nrx ! *dninv ! convert to number mixing ratio + + ELSEIF ( an(ix,jy,kz,ls) <= qxmin(ls) .or. & + ( an(ix,jy,kz,lns) <= cxmin .and. an(ix,jy,kz,ls) <= qxmin_init(ls)) ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,ls) + an(ix,jy,kz,lns) = 0.0 + an(ix,jy,kz,ls) = 0.0 + + ENDIF + ENDIF + + ! graupel + + IF ( lnh > 1 ) THEN + IF ( an(ix,jy,kz,lnh) <= 0.1*cxmin .and. an(ix,jy,kz,lh) > qxmin_init(lh) ) THEN + IF ( lvh > 1 ) THEN + IF ( an(ix,jy,kz,lvh) <= 0.0 ) THEN + an(ix,jy,kz,lvh) = an(ix,jy,kz,lh)/xdnh + ENDIF + ENDIF + + q = an(ix,jy,kz,lh) + + laminv1 = (dn(ix,kz) * q * zhfac)**(0.25) ! inverse of slope + + n1 = laminv1*xn0h ! number concentration for inv. exponential single moment input + + nrx = n1*g1h/g0 ! number concentration for different shape parameter + + nrx2 = dn(ix,kz) * q / xgms + + nrx = Min( nrx, nrx2 ) + + IF ( nrx > cxmin ) THEN + an(ix,jy,kz,lnh) = nrx ! *dninv ! convert to number mixing ratio + ELSE + an(ix,jy,kz,lh) = 0.0 + an(ix,jy,kz,lnh) = 0.0 + an(ix,jy,kz,lvh) = 0.0 + ENDIF + + ELSEIF ( an(ix,jy,kz,lh) <= qxmin(lh) .or. & + ( an(ix,jy,kz,lnh) <= cxmin .and. an(ix,jy,kz,lh) <= qxmin_init(lh)) ) THEN + + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lh) + an(ix,jy,kz,lh) = 0.0 + + ENDIF + ENDIF + + ! hail + + IF ( lnhl > 1 .and. lhl > 1 ) THEN + IF ( an(ix,jy,kz,lnhl) <= 0.1*cxmin .and. an(ix,jy,kz,lhl) > qxmin_init(lhl) ) THEN + IF ( lvhl > 1 ) THEN + IF ( an(ix,jy,kz,lvhl) <= 0.0 ) THEN + an(ix,jy,kz,lvhl) = an(ix,jy,kz,lhl)/xdnhl + ENDIF + ENDIF + + q = an(ix,jy,kz,lhl) + + laminv1 = (dn(ix,kz) * q * zhlfac)**(0.25) ! inverse of slope + + n1 = laminv1*xn0hl ! number concentration for inv. exponential single moment input + + nrx = n1*g1hl/g0 ! number concentration for different shape parameter + + an(ix,jy,kz,lnhl) = nrx ! *dninv ! convert to number mixing ratio + + + ELSEIF ( an(ix,jy,kz,lhl) <= qxmin(lhl) .or. & + ( an(ix,jy,kz,lnhl) <= cxmin .and. an(ix,jy,kz,lhl) <= qxmin_init(lhl)) ) THEN + + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lhl) + an(ix,jy,kz,lhl) = 0.0 + + ENDIF + ENDIF + + +! ENDIF + +! spechum = qv_mp/(1.0_kind_phys+qv_mp) +! IF ( convertdry ) THEN +! qc = qc_mp/(1.0_kind_phys+qv_mp) + mixconvqv = 1 + IF ( present( spechum ) ) THEN ! convert back to "dry+vapor" mixing ratios + !an(ix,jy,kz,lv) = spechum(ix,kz)/(1.0d0 - spechum(ix,kz)) + mixconvqv = 1.0d0/(1.0d0 + an(ix,jy,kz,lv)) + spechum(ix,kz) = an(ix,jy,kz,lv)*mixconvqv + ELSE + mixconvqv = 1.0d0 + ENDIF + + IF ( present( qv ) ) qv(ix,kz) = an(ix,jy,kz,lv) + IF ( present( qcw ) ) qcw(ix,kz) = an(ix,jy,kz,lc)*mixconvqv + IF ( present( qrw ) ) qrw(ix,kz) = an(ix,jy,kz,lr)*mixconvqv + IF ( present( qci ) ) qci(ix,kz) = an(ix,jy,kz,li)*mixconvqv + IF ( present( qsw ) ) THEN + qsw(ix,kz) = an(ix,jy,kz,ls)*mixconvqv +! qsmax3 = Max( qsmax3, qsw(ix,kz) ) +! qsmax4 = Max( qsmax4, an(ix,jy,kz,ls) ) + ENDIF + IF ( present( qhw ) ) qhw(ix,kz) = an(ix,jy,kz,lh)*mixconvqv + IF ( lhl > 1 .and. present( qhl ) ) qhl(ix,kz) = an(ix,jy,kz,lhl)*mixconvqv + IF ( present( ccw ) ) ccw(ix,kz) = an(ix,jy,kz,lnc)*mixconvqv*dninv + IF ( present( crw ) ) crw(ix,kz) = an(ix,jy,kz,lnr)*mixconvqv*dninv + IF ( present( cci ) ) cci(ix,kz) = an(ix,jy,kz,lni)*mixconvqv*dninv + IF ( present( csw ) ) csw(ix,kz) = an(ix,jy,kz,lns)*mixconvqv*dninv + IF ( present( chw ) ) chw(ix,kz) = an(ix,jy,kz,lnh)*mixconvqv*dninv + IF ( lhl > 1 .and. present( chl ) ) chl(ix,kz) = an(ix,jy,kz,lnhl)*mixconvqv*dninv + IF ( lvh > 1 .and. present( vhw ) ) vhw(ix,kz) = an(ix,jy,kz,lvh)*mixconvqv + IF ( lvhl > 1 .and. present( vhl ) ) vhl(ix,kz) = an(ix,jy,kz,lvhl)*mixconvqv + IF ( lccn > 1 .and. present( cccn ) ) cccn(ix,kz) = an(ix,jy,kz,lccn)*mixconvqv*dninv + IF ( lccna > 1 .and. present( cccna ) ) cccna(ix,kz) = an(ix,jy,kz,lccna)*mixconvqv + + + ENDDO ! ix + ENDDO ! kz +! ELSE +! write(0,*) 'calcnfromq: lv = ',lv,lc,lr,li,ls,lh,lvh,lhl,lccn,lccna +! write(0,*) 'calcnfromq: nx,ny,nz,na = ',nx,ny,nz,na +! +! ENDIF + +! IF ( present( qsw ) ) THEN +! write(0,*) 'calcnfromq: qsmax = ',qsmax,qsmax2,qsmax3,qsmax4 +! ENDIF + + RETURN + + END subroutine calcnfromq + +! ############################################################################## +! ############################################################################## +! +! Subroutine to calculate number concentrations from convection parameterization rates that have only mixing ratio. +! N will be in #/kg, NOT #/m^3, since sedimentation is done next. +! + +! +! 10.27.2015: Added hail calculation +! +!>\ingroup mod_nsslmp +!! Subroutine to calculate number concentrations from convection parameterization rates that have only mixing ratio. + subroutine calcnfromcuten(nx,ny,nz,an,anold,na,nor,norz,dn) + + + implicit none + + integer nx,ny,nz,nor,norz,na,ngt,jgs,ixcol + + real an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) ! scalars (q, N, Z) from CUTEN arrays + real anold(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) ! scalars (q, N, Z) + + real dn(nx,nz+1) ! air density + + integer ixe,kze + real alpha + real qmin + real xvmn,xvmx + integer ipconc + integer lvol ! index for volume + integer infall + + + integer ix,jy,kz + double precision vr,q,nrx,rd,g1h,g1hl,g1r,g1s,zx,chw,z,znew,zt,zxt,n1,laminv1 + double precision :: zr, zs, zh, dninv + real, parameter :: xn0s = 3.0e6, xn0r = 8.0e6, xn0h = 4.0e4, xn0hl = 4.0e4 + real, parameter :: xdnr = 1000., xdns = 100. ,xdnh = 700.0, xdnhl = 900.0 + real, parameter :: zhlfac = 1./(pi*xdnhl*xn0hl) + real, parameter :: zhfac = 1./(pi*xdnh*xn0h) + real, parameter :: zrfac = 1./(pi*xdnr*xn0r) + real, parameter :: zsfac = 1./(pi*xdns*xn0s) + real, parameter :: g0 = (6.0)*(5.0)*(4.0)/((3.0)*(2.0)*(1.0)) + real, parameter :: xims=900.*0.523599*(2.*50.e-6)**3 ! mks (100 micron diam solid sphere approx) + real, parameter :: xcms=1000.*0.523599*(2.*7.5e-6)**3 ! mks (100 micron diam solid sphere approx) + + real :: xmass,xv,xdn + integer :: ndbz, nmwgt, nnwgt, nwlessthanz + +! ------------------------------------------------------------------ + + + jy = 1 + + + g1h = (6.0 + alphah)*(5.0 + alphah)*(4.0 + alphah)/ & + & ((3.0 + alphah)*(2.0 + alphah)*(1.0 + alphah)) + + g1hl = (6.0 + alphahl)*(5.0 + alphahl)*(4.0 + alphahl)/ & + & ((3.0 + alphahl)*(2.0 + alphahl)*(1.0 + alphahl)) + + IF ( imurain == 3 ) THEN + g1r = (rnu+2.0)/(rnu+1.0) + ELSE ! imurain == 1 + g1r = (6.0 + alphar)*(5.0 + alphar)*(4.0 + alphar)/ & + & ((3.0 + alphar)*(2.0 + alphar)*(1.0 + alphar)) + ENDIF + + g1s = (snu+2.0)/(snu+1.0) + + DO kz = 1,nz + DO ix = 1,nx ! ixcol + + dninv = 1./dn(ix,kz) + + ! Cloud droplets + + IF ( lnc > 1 ) THEN +! IF ( an(ix,jy,kz,lnc) <= 0.1*cxmin .and. an(ix,jy,kz,lc) > qxmin(lc) ) THEN + IF ( an(ix,jy,kz,lnc) > qxmin(lc) ) THEN + anold(ix,jy,kz,lnc) = anold(ix,jy,kz,lnc) + an(ix,jy,kz,lc)/xcms + ENDIF + ENDIF + + ! Cloud ice + + IF ( lni > 1 ) THEN + IF ( an(ix,jy,kz,lni) > qxmin(li) ) THEN + anold(ix,jy,kz,lni) = anold(ix,jy,kz,lni) + an(ix,jy,kz,li)/xims + ENDIF + ENDIF + + ! rain + + IF ( lnr > 1 ) THEN + IF ( an(ix,jy,kz,lr) > qxmin(lr) ) THEN ! adding rain mass from CU scheme + + IF ( .true. .or. (anold(ix,jy,kz,lr) - an(ix,jy,kz,lr)) < qxmin(lr) .or. anold(ix,jy,kz,lnr) < cxmin ) THEN + + q = an(ix,jy,kz,lr) + + laminv1 = (dn(ix,kz) * q * zrfac)**(0.25) ! inverse of slope + + n1 = laminv1*xn0r ! number concentration for inv. exponential single moment input + + nrx = n1*g1r/g0 ! number concentration for different shape parameter + + anold(ix,jy,kz,lnr) = anold(ix,jy,kz,lnr) + nrx ! *dninv ! convert to number mixing ratio + + ELSE + ! assume mean particle mass of pre-existing snow + xmass = anold(ix,jy,kz,lr)/anold(ix,jy,kz,lnr) + anold(ix,jy,kz,lnr) = anold(ix,jy,kz,lnr) + an(ix,jy,kz,lr)/xmass + ENDIF + + ENDIF + ENDIF + + ! snow + IF ( lns > 1 ) THEN + IF ( an(ix,jy,kz,ls) > qxmin(ls) ) THEN ! adding snow mass from CU scheme + + IF ( .true. .or. (anold(ix,jy,kz,ls) - an(ix,jy,kz,ls)) < qxmin(ls) .or. anold(ix,jy,kz,lns) < cxmin ) THEN + + ! assume that there was no snow before this + + q = an(ix,jy,kz,ls) + + laminv1 = (dn(ix,kz) * q * zsfac)**(0.25) ! inverse of slope + + n1 = laminv1*xn0s ! number concentration for inv. exponential single moment input + + nrx = n1*g1s/g0 ! number concentration for different shape parameter + + anold(ix,jy,kz,lns) = anold(ix,jy,kz,lns) + nrx ! *dninv ! convert to number mixing ratio + + ELSE + ! assume mean particle mass of pre-existing snow + xmass = anold(ix,jy,kz,ls)/anold(ix,jy,kz,lns) + anold(ix,jy,kz,lns) = anold(ix,jy,kz,lns) + an(ix,jy,kz,ls)/xmass + ENDIF + + ENDIF + ENDIF + + ! graupel + +! IF ( lnh > 1 ) THEN +! IF ( an(ix,jy,kz,lnh) <= 0.1*cxmin .and. an(ix,jy,kz,lh) > qxmin(lh) ) THEN +! IF ( lvh > 1 ) THEN +! IF ( an(ix,jy,kz,lvh) <= 0.0 ) THEN +! an(ix,jy,kz,lvh) = an(ix,jy,kz,lh)/xdnh +! ENDIF +! ENDIF +! +! q = an(ix,jy,kz,lh) +! +! laminv1 = (dn(ix,kz) * q * zhfac)**(0.25) ! inverse of slope +! +! n1 = laminv1*xn0h ! number concentration for inv. exponential single moment input +! +! nrx = n1*g1h/g0 ! number concentration for different shape parameter +! +! an(ix,jy,kz,lnh) = nrx ! *dninv ! convert to number mixing ratio +! +! ENDIF +! ENDIF +! +! ! hail +! +! IF ( lnhl > 1 .and. lhl > 1 ) THEN +! IF ( an(ix,jy,kz,lnhl) <= 0.1*cxmin .and. an(ix,jy,kz,lhl) > qxmin(lhl) ) THEN +! IF ( lvhl > 1 ) THEN +! IF ( an(ix,jy,kz,lvhl) <= 0.0 ) THEN +! an(ix,jy,kz,lvhl) = an(ix,jy,kz,lhl)/xdnhl +! ENDIF +! ENDIF +! +! q = an(ix,jy,kz,lhl) +! +! laminv1 = (dn(ix,kz) * q * zhlfac)**(0.25) ! inverse of slope +! +! n1 = laminv1*xn0hl ! number concentration for inv. exponential single moment input +! +! nrx = n1*g1hl/g0 ! number concentration for different shape parameter +! +! an(ix,jy,kz,lnhl) = nrx ! *dninv ! convert to number mixing ratio +! +! ENDIF +! ENDIF + + ENDDO ! ix + ENDDO ! kz + + RETURN + + END subroutine calcnfromcuten + +! ##################################################################### +! ##################################################################### + +!>\ingroup mod_nsslmp +!! Subroutine to calculate effective radii for use by radiation routines + SUBROUTINE calc_eff_radius & + & (nx,ny,nz,na,jyslab & + & ,nor,norz & + & ,t1,t2,t3,t4 & + & ,qcw,qci,qsw,qrw & + & ,ccw,cci,csw,crw & + & ,an,dn ) + + implicit none + + integer, parameter :: ng1 = 1 + integer :: nx,ny,nz,na + integer :: ng + integer :: nor,norz, jyslab ! ,nht,ngt,igsr + real :: dtp ! time step + + +! +! external temporary arrays +! + + real,optional :: t1(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real,optional :: t2(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real,optional :: t3(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real,optional :: t4(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + + real, optional :: an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) + real dn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real, optional, dimension(nx,nz) :: qcw,qci,qsw,qrw,ccw,cci,csw,crw + + + + + + ! local + + real pb(-norz+ng1:nz+norz) + real pinit(-norz+ng1:nz+norz) + +! +! declarations microphysics and for gather/scatter +! + integer nxmpb,nzmpb,nxz + integer mgs,ngs,numgs,inumgs + parameter (ngs=1) + integer ngscnt,igs(ngs),kgs(ngs) + real rho0(ngs) + + integer ix,kz,i,n, kp1 + integer :: jy, jgs + integer ixb,ixe,jyb,jye,kzb,kze + + integer itile,jtile,ktile + integer ixend,jyend,kzend,kzbeg + integer nxend,nyend,nzend,nzbeg + + real :: qx(ngs,lv:lhab) + real :: cx(ngs,lc:lhab) + real :: xv(ngs,lc:lhab) + real :: xmas(ngs,lc:lhab) + real :: xdn(ngs,lc:lhab) + real :: xdia(ngs,lc:lhab,3) + real :: alpha(ngs,lc:lhab) + + real :: gamc1,gamc2,gami1,gami2,gams1,gams2,gamr1,gamr2 + real :: factor_c, factor_i, factor_s, factor_r + real :: lam_c, lam_i, lam_s, lam_r + integer :: il + + +! ------------------------------------------------------------------------------- + itile = nx + jtile = ny + ktile = nz + ixend = nx + jyend = ny + kzend = nz + nxend = nx + 1 + nyend = ny + 1 + nzend = nz + kzbeg = 1 + nzbeg = 1 + + jy = 1 + pb(:) = 0.0 + pinit(:) = 0.0 + + gamc1 = Gamma_sp(2. + cnu) + gamc2 = 1. ! Gamma[1 + alphac] + gami1 = Gamma_sp(2. + cinu) + gami2 = 1. ! Gamma[1 + alphac] + gams1 = Gamma_sp(2. + snu) + gams2 = Gamma_sp(1. + snu) + gamr1 = Gamma_sp(2. + rnu) + gamr2 = Gamma_sp(1. + rnu) + + factor_c = (1. + cnu)*Gamma_sp(1. + cnu)/Gamma_sp(5./3. + cnu) + factor_i = (1. + cinu)*Gamma_sp(1. + cinu)/Gamma_sp(5./3. + cinu) + factor_s = (1. + snu)*Gamma_sp(1. + snu)/Gamma_sp(5./3. + snu) + + IF ( present(t4) ) THEN + IF ( imurain == 3 ) THEN + factor_r = (1. + rnu)*Gamma_sp(1. + rnu)/Gamma_sp(5./3. + rnu) + ELSE + factor_r = ((Pi*(alphar+3.)*(alphar+1.)*(alphar+1.))/6.)**(1./3.) + ENDIF + ENDIF + +! +! jy = 1 ! working on a 2d slab +!! VERY IMPORTANT: SET jgs = jy + + jgs = jy + + mgs = 1 + DO kz = 1,nz + DO ix = 1,nx ! ixcol + + rho0(mgs) = dn(ix,jy,kz) + IF ( present( an ) ) THEN + DO il = lc,ls + qx(mgs,il) = max(an(ix,jy,kz,il), 0.0) + cx(mgs,il) = max(an(ix,jy,kz,ln(il)), 0.0) + ENDDO + ELSE + qx(mgs,:) = 0.0 + cx(mgs,:) = 0.0 + IF ( present(qcw) ) qx(mgs,lc) = qcw(ix,kz) + IF ( present(qci) ) qx(mgs,li) = qci(ix,kz) + IF ( present(qsw) ) qx(mgs,ls) = qsw(ix,kz) + IF ( present(qrw) ) qx(mgs,lr) = qrw(ix,kz) + IF ( present(ccw) ) cx(mgs,lc) = ccw(ix,kz)*rho0(mgs) + IF ( present(cci) ) cx(mgs,li) = cci(ix,kz)*rho0(mgs) + IF ( present(csw) ) cx(mgs,ls) = csw(ix,kz)*rho0(mgs) + IF ( present(crw) ) cx(mgs,lr) = crw(ix,kz)*rho0(mgs) + + ENDIF + + IF ( present( t1 ) .and. qx(mgs,lc) > qxmin(lc) .and. cx(mgs,lc) > cxmin ) THEN +! Lambda for cloud droplets + lam_c = ((cx(mgs,lc)*(Pi/6.)*xdn0(lc)*Gamc1)/(qx(mgs,lc)*rho0(mgs)*Gamc2))**(1./3.) + t1(ix,jy,kz) = 0.5*factor_c/lam_c + ENDIF + + IF ( present( t2 ) .and. qx(mgs,li) > qxmin(li) .and. cx(mgs,li) > cxmin ) THEN +! Lambda for cloud ice + lam_i = ((cx(mgs,li)*(Pi/6.)*xdn0(li)*Gami1)/(qx(mgs,li)*rho0(mgs)*Gami2))**(1./3.) + t2(ix,jy,kz) = 0.5*factor_i/lam_i + ENDIF + + IF ( present( t3 ) .and. qx(mgs,ls) > qxmin(ls) .and. cx(mgs,ls) > cxmin ) THEN +! Lambda for snow + lam_s = ((cx(mgs,ls)*(Pi/6.)*xdn0(ls)*Gams1)/(qx(mgs,ls)*rho0(mgs)*Gams2))**(1./3.) + t3(ix,jy,kz) = 0.5*factor_s/lam_s + ENDIF + + IF ( present( t4 ) .and. present(qrw) .and. present(crw) ) THEN + IF ( qx(mgs,lr) > Max(1.e-8,qxmin(lr)) .and. cx(mgs,lr) > cxmin ) THEN + IF ( imurain == 1 ) THEN ! gamma-diameter +! Lambda for rain + lam_r = factor_r *((xdn0(lr)*cx(mgs,lr))/(qx(mgs,lr)*rho0(mgs)))**(1./3.) + t4(ix,jy,kz) = 0.5*(alphar+3.)/lam_r + ELSE ! gamma-volume +! Lambda for rain + lam_r = ((cx(mgs,lr)*(Pi/6.)*xdn0(lr)*Gamr1)/(qx(mgs,lr)*rho0(mgs)*Gamr2))**(1./3.) + t4(ix,jy,kz) = 0.5*factor_r/lam_r + ENDIF + ENDIF + ENDIF + + + ENDDO ! ix + ENDDO ! kz + + RETURN + END SUBROUTINE calc_eff_radius + + +! ##################################################################### +! ##################################################################### + +!>\ingroup mod_nsslmp +!! Subroutine that returns the maximum possible condensation + SUBROUTINE QVEXCESS(ngs,mgs,qwvp0,qv0,qcw1,pres,thetap0,theta0, & + & qvex,pi0,tabqvs,nqsat,fqsat,cbw,fcqv1,felvcp,ss1,pk,ngscnt) + +!##################################################################### +! Purpose: find the amount of vapor that can be condensed to liquid +!##################################################################### + + implicit none + + integer ngs,mgs,ngscnt + + real theta2temp + + real qvex + + integer nqsat + real fqsat, cbw + + real ss1 ! 'target' supersaturation +! +! input arrays +! + real qv0(ngs), qcw1(ngscnt), pres(ngs), qwvp0(mgs) + real thetap0(ngs), theta0(ngs) + real fcqv1(ngs), felvcp(ngs), pi0(ngs) + real pk(ngs) + + real tabqvs(nqsat) +! +! Local stuff +! + + integer itertd + integer ltemq + real gamss + real theta(ngs), qvap(ngs), pqs(ngs), qcw(ngs), qwv(ngs) + real qcwtmp(ngs), qss(ngs), qvs(ngs), qwvp(ngs) + real dqcw(ngs), dqwv(ngs), dqvcnd(ngs) + real temg(ngs), temcg(ngs), thetap(ngs) + + real tfr + parameter ( tfr = 273.15 ) + +! real poo,cap +! parameter ( cap = rd/cp, poo = 1.0e+05 ) +! +! +! Modified Straka adjustment (nearly identical to Tao et al. 1989 MWR) +! +! +! +! set up temperature and vapor arrays +! + pqs(mgs) = (380.0)/(pres(mgs)) + thetap(mgs) = thetap0(mgs) + theta(mgs) = thetap(mgs) + theta0(mgs) + qwvp(mgs) = qwvp0(mgs) + qvap(mgs) = max( (qwvp0(mgs) + qv0(mgs)), 0.0 ) + temg(mgs) = theta(mgs)*pk(mgs) ! ( pres(mgs) / poo ) ** cap +! temg(mgs) = theta2temp( theta(mgs), pres(mgs) ) +! +! +! +! reset temporaries for cloud particles and vapor +! + + qwv(mgs) = max( 0.0, qvap(mgs) ) + qcw(mgs) = max( 0.0, qcw1(mgs) ) +! +! + qcwtmp(mgs) = qcw(mgs) + temcg(mgs) = temg(mgs) - tfr + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + qss(mgs) = (0.01*ss1 + 1.0)*qvs(mgs) +! +! iterate adjustment +! + do itertd = 1,2 +! +! +! calculate super-saturation +! + dqcw(mgs) = 0.0 + dqwv(mgs) = ( qwv(mgs) - qss(mgs) ) +! +! evaporation and sublimation adjustment +! + if( dqwv(mgs) .lt. 0. ) then ! subsaturated + if( qcw(mgs) .gt. -dqwv(mgs) ) then ! check if qc can make up all of the deficit + dqcw(mgs) = dqwv(mgs) + dqwv(mgs) = 0. + else ! otherwise make all qc available for evap + dqcw(mgs) = -qcw(mgs) + dqwv(mgs) = dqwv(mgs) + qcw(mgs) + end if +! + qwvp(mgs) = qwvp(mgs) - ( dqcw(mgs) ) ! add to perturbation vapor +! + qcw(mgs) = qcw(mgs) + dqcw(mgs) + + thetap(mgs) = thetap(mgs) + & + & 1./pi0(mgs)* & + & (felvcp(mgs)*dqcw(mgs) ) + + end if ! dqwv(mgs) .lt. 0. (end of evap/sublim) +! +! condensation/deposition +! + IF ( dqwv(mgs) .ge. 0. ) THEN +! + dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv1(mgs)*qss(mgs)/ & + & ((temg(mgs)-cbw)**2)) +! +! + dqcw(mgs) = dqvcnd(mgs) +! + thetap(mgs) = thetap(mgs) + & + & (felvcp(mgs)*dqcw(mgs) ) & + & / (pi0(mgs)) + qwvp(mgs) = qwvp(mgs) - ( dqvcnd(mgs) ) + qcw(mgs) = qcw(mgs) + dqcw(mgs) +! + END IF ! dqwv(mgs) .ge. 0. + + theta(mgs) = thetap(mgs) + theta0(mgs) + temg(mgs) = theta(mgs)*pk(mgs) ! ( pres(mgs) / poo ) ** cap +! temg(mgs) = theta2temp( theta(mgs), pres(mgs) ) + qvap(mgs) = Max((qwvp(mgs) + qv0(mgs)), 0.0) + temcg(mgs) = temg(mgs) - tfr +! tqvcon = temg(mgs)-cbw + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + qcw(mgs) = max( 0.0, qcw(mgs) ) + qwv(mgs) = max( 0.0, qvap(mgs)) + qss(mgs) = (0.01*ss1 + 1.0)*qvs(mgs) + end do +! +! end the saturation adjustment iteration loop +! +! + qvex = Max(0.0, qcw(mgs) - qcw1(mgs) ) + + RETURN + END SUBROUTINE QVEXCESS + +! ##################################################################### +! ##################################################################### + + + + + +! +! ############################################################################## +! +!>\ingroup mod_nsslmp +!! Mean hydrometeor size and fall speed calculations + SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & + & xmas,vtxbar,xdn,xvmn0,xvmx0,xv,cdx,cdxgs, & + & ipconc1,ndebug1,ngs,nz,kgs,fadvisc, & + & cwmasn,cwmasx,cwradn,cnina,cimna,cimxa, & + & itype1a,itype2a,temcg,infdo,alpha,ildo,axx,bxx) +! & itype1a,itype2a,temcg,infdo,alpha,ildo,axh,bxh,axhl,bxhl) + + + implicit none + + integer ngscnt,ngs0,ngs,nz +! integer infall ! whether to calculate number-weighted fall speeds + + real xv(ngs,lc:lhab) + real qx(ngs,lv:lhab) + real qxw(ngs,ls:lhab) + real cx(ngs,lc:lhab) + real vtxbar(ngs,lc:lhab,3) + real xmas(ngs,lc:lhab) + real xdn(ngs,lc:lhab) + real cdxgs(ngs,lc:lhab) + real xdia(ngs,lc:lhab,3) + real xvmn0(lc:lhab), xvmx0(lc:lhab) + real qxmin(lc:lhab) + real cdx(lc:lhab) + real alpha(ngs,lc:lhab) + + real rho0(ngs),rhovt(ngs),temcg(ngs) + real cno(lc:lhab) + real cnostmp(ngs) + + real cwc1, cimna, cimxa + real cnina(ngs) + integer kgs(ngs) + real fadvisc(ngs) + real fsw + + integer ipconc1 + integer ndebug1 + + integer, intent (in) :: itype1a,itype2a,infdo + integer, intent (in) :: ildo ! which species to do, or all if ildo=0 + + real :: axx(ngs,lh:lhab),bxx(ngs,lh:lhab) +!! real :: axh(ngs),bxh(ngs) +! real :: axhl(ngs),bxhl(ngs) + +! Local vars + + + + real swmasmx, dtmp + real cd + real cwc0 ! ,cwc1 + real :: cwch(ngscnt), cwchl(ngscnt) + real :: cwchtmp,cwchltmp,xnutmp + real pii + real cimasx,cimasn + real cwmasn,cwmasx,cwradn + real cwrad + real vr,rnux + real alp + + real ccimx + + integer mgs + + real arx,frx,vtrain,fw + real fwlo,fwhi,rfwdiff + real ar,br,cs,ds +! real gf4p5, gf4ds, gf4br, ifirst, gf1ds +! real gfcinu1, gfcinu1p47, gfcinu2p47 + real gr + real rwrad,rwdia + real mwfac + integer il + +! save gf4p5, gf4ds, gf4br, ifirst, gf1ds +! save gfcinu1, gfcinu1p47, gfcinu2p47 +! data ifirst /0/ + + real bta1,cnit + parameter ( bta1 = 0.6, cnit = 1.0e-02 ) + real x,y,tmp,del + real aax,bbx,delrho + integer :: indxr + real mwt, nwt, zwt + real, parameter :: rho00 = 1.225 + integer i + real xvbarmax + + integer l1, l2 + + +! +! set values +! +! cwmasn = 5.23e-13 ! radius of 5.0e-6 +! cwradn = 5.0e-6 +! cwmasx = 5.25e-10 ! radius of 50.0e-6 + + fwlo = 0.2 ! water fraction to start weighting toward rain fall speed + fwhi = 0.4 ! water fraction at which rain fall speed only is used + rfwdiff = 1./(fwhi - fwlo) + +! pi = 4.0*atan(1.0) + pii = piinv ! 1.0/pi + + arx = 10. + frx = 516.575 ! raind fit parameters for arx*(1 - Exp(-fx*d)), where d is rain diameter in meters. + + ar = 841.99666 + br = 0.8 + gr = 9.8 +! new values for cs and ds + cs = 12.42 + ds = 0.42 + + IF ( ildo == 0 ) THEN + l1 = lc + l2 = lhab + ELSE + l1 = ildo + l2 = ildo + ENDIF + +! IF ( ifirst .eq. 0 ) THEN +! ifirst = 1 +! gf4br = gamma(4.0+br) +! gf4ds = gamma(4.0+ds) +!! gf1ds = gamma(1.0+ds) +! gf4p5 = gamma(4.0+0.5) +! gfcinu1 = gamma(cinu + 1.0) +! gfcinu1p47 = gamma(cinu + 1.47167) +! gfcinu2p47 = gamma(cinu + 2.47167) + + IF ( lh .gt. 1 ) THEN + IF ( dmuh == 1.0 ) THEN + cwchtmp = ((3. + dnu(lh))*(2. + dnu(lh))*(1.0 + dnu(lh)))**(-1./3.) + ELSE + cwchtmp = 6.0*pii*gamma_sp( (xnu(lh) + 1.)/xmu(lh) )/gamma_sp( (xnu(lh) + 2.)/xmu(lh) ) + ENDIF + ENDIF + IF ( lhl .gt. 1 ) THEN + IF ( dmuhl == 1.0 ) THEN + cwchltmp = ((3. + dnu(lhl))*(2. + dnu(lhl))*(1.0 + dnu(lhl)))**(-1./3.) + ELSE + cwchltmp = 6.0*pii*gamma_sp( (xnu(lhl) + 1)/xmu(lhl) )/gamma_sp( (xnu(lhl) + 2)/xmu(lhl) ) + ENDIF + ENDIF + + IF ( ipconc .le. 5 ) THEN + IF ( lh .gt. 1 ) cwch(:) = cwchtmp + IF ( lhl .gt. 1 ) cwchl(:) = cwchltmp + ELSE + DO mgs = 1,ngscnt + + IF ( lh .gt. 1 .and. ( ildo == 0 .or. ildo == lh ) ) THEN + IF ( qx(mgs,lh) .gt. qxmin(lh) ) THEN + IF ( dmuh == 1.0 ) THEN + cwch(mgs) = ((3. + alpha(mgs,lh))*(2. + alpha(mgs,lh))*(1.0 + alpha(mgs,lh)))**(-1./3.) + ELSE + xnutmp = (alpha(mgs,lh) - 2.0)/3.0 + cwch(mgs) = 6.0*pii*gamma_sp( (xnutmp + 1.)/xmu(lh) )/gamma_sp( (xnutmp + 2.)/xmu(lh) ) + ENDIF + ELSE + cwch(mgs) = cwchtmp + ENDIF + ENDIF + IF ( lhl .gt. 1 .and. ( ildo == 0 .or. ildo == lhl ) ) THEN + IF ( qx(mgs,lhl) .gt. qxmin(lhl) ) THEN + IF ( dmuhl == 1.0 ) THEN + cwchl(mgs) = ((3. + alpha(mgs,lhl))*(2. + alpha(mgs,lhl))*(1.0 + alpha(mgs,lhl)))**(-1./3.) + ELSE + xnutmp = (alpha(mgs,lhl) - 2.0)/3.0 + cwchl(mgs) = 6.0*pii*gamma_sp( (xnutmp + 1)/xmu(lhl) )/gamma_sp( (xnutmp + 2)/xmu(lhl) ) + ENDIF + ELSE + cwchl(mgs) = cwchltmp + ENDIF + ENDIF + + ENDDO + + ENDIF + + + cimasn = Min( cimas0, 6.88e-13) + cimasx = 1.0e-8 + ccimx = 5000.0e3 ! max of 5000 per liter + + cwc1 = 6.0/(pi*1000.) + cwc0 = pii ! 6.0*pii + mwfac = 6.0**(1./3.) + + + if (ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set scale diameter' +! + + +! +! cloud water variables +! ################################################################ +! +! DROPLETS +! +! + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set cloud water variables' + + IF ( ildo == 0 .or. ildo == lc ) THEN + + do mgs = 1,ngscnt + xv(mgs,lc) = 0.0 + + IF ( qx(mgs,lc) .gt. qxmin(lc) ) THEN !{ + + IF ( ipconc .ge. 2 ) THEN + IF ( cx(mgs,lc) .gt. cxmin) THEN !{ + xmas(mgs,lc) = & + & min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),cwmasn),cwmasx ) + xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) + ELSE + cx(mgs,lc) = Max( cxmin, rho0(mgs)*qx(mgs,lc)/cwmasx ) + xmas(mgs,lc) = Min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),cwmasn),cwmasx ) + xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) + + ENDIF + ELSE + IF ( ipconc .lt. 2 ) THEN + cx(mgs,lc) = rho0(mgs)*ccn/rho00 ! scales to local density, relative to standard air density + ENDIF + IF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. 0.01 ) THEN !{ + xmas(mgs,lc) = & + & min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),xdn(mgs,lc)*xvmn(lc)), & + & xdn(mgs,lc)*xvmx(lc) ) + + xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) + cx(mgs,lc) = qx(mgs,lc)*rho0(mgs)/xmas(mgs,lc) + + ELSEIF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .le. 1.0e-9 ) THEN + cx(mgs,lc) = Max( cxmin, rho0(mgs)*qx(mgs,lc)/cwmasx ) + xmas(mgs,lc) = & + & min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),cwmasn),cwmasx ) + xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) + + ELSEIF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .le. 0.01 ) THEN + xmas(mgs,lc) = xdn(mgs,lc)*4.*pi/3.*(5.0e-6)**3 + cx(mgs,lc) = rho0(mgs)*qx(mgs,lc)/xmas(mgs,lc) + xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) + + ELSE + xmas(mgs,lc) = cwmasn + xv(mgs,lc) = xmas(mgs,lc)/1000. +! do not define ccw here! it can feed back to ccn!!! cx(mgs,lc) = 0.0 ! cwnc(mgs) + ENDIF !} + ENDIF !} +! IF ( ipconc .lt. 2 ) THEN +! xmas(mgs,lc) = & +! & min( max(qx(mgs,lc)*rho0(mgs)/cwnc(mgs),cwmasn),cwmasx ) +! cx(mgs,lc) = Max(1.0,qx(mgs,lc)*rho0(mgs)/xmas(mgs,lc)) +! ELSE +! cwnc(mgs) = an(igs(mgs),jgs,kgs(mgs),lnc) +! cx(mgs,lc) = cwnc(mgs) +! ENDIF + xdia(mgs,lc,1) = (xmas(mgs,lc)*cwc1)**(1./3.) + xdia(mgs,lc,2) = xdia(mgs,lc,1)**2 + xdia(mgs,lc,3) = xdia(mgs,lc,1) + cwrad = 0.5*xdia(mgs,lc,1) + IF ( fadvisc(mgs) > 0.0 ) THEN + vtxbar(mgs,lc,1) = & + & (2.0*gr*xdn(mgs,lc) *(cwrad**2)) & + & /(9.0*fadvisc(mgs)) + ELSE + vtxbar(mgs,lc,1) = 0.0 + ENDIF + + + ELSE + xmas(mgs,lc) = cwmasn + xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) + IF ( qx(mgs,lc) <= 0.0 ) cx(mgs,lc) = 0.0 + IF ( ipconc .le. 1 ) cx(mgs,lc) = 0.01 + xdia(mgs,lc,1) = 2.*cwradn + xdia(mgs,lc,2) = 4.*cwradn**2 + xdia(mgs,lc,3) = xdia(mgs,lc,1) + vtxbar(mgs,lc,1) = 0.0 + + ENDIF !} qcw .gt. qxmin(lc) + + end do + + ENDIF + + + +! +! cloud ice variables +! columns +! +! ################################################################ +! +! CLOUD ICE +! + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set cip' + + IF ( li .gt. 1 .and. ( ildo == 0 .or. ildo == li ) ) THEN + do mgs = 1,ngscnt + xdn(mgs,li) = 900.0 + IF ( ipconc .eq. 0 ) THEN +! cx(mgs,li) = min(cnit*exp(-temcg(mgs)*bta1),1.e+09) + cx(mgs,li) = cnina(mgs) + IF ( cimna .gt. 1.0 ) THEN + cx(mgs,li) = Max(cimna,cx(mgs,li)) + ENDIF + IF ( cimxa .gt. 1.0 ) THEN + cx(mgs,li) = Min(cimxa,cx(mgs,li)) + ENDIF +! erm 3/28/2002 + IF ( itype1a .ge. 1 .or. itype2a .ge. 1 ) THEN + cx(mgs,li) = Max(cx(mgs,li),qx(mgs,li)*rho0(mgs)/cimasx) + cx(mgs,li) = Min(cx(mgs,li),qx(mgs,li)*rho0(mgs)/cimasn) + ENDIF +! + cx(mgs,li) = max(1.0e-20,cx(mgs,li)) +! cx(mgs,li) = Min(ccimx, cx(mgs,li)) + + + ELSEIF ( ipconc .ge. 1 ) THEN + IF ( qx(mgs,li) .gt. qxmin(li) ) THEN + cx(mgs,li) = Max(cx(mgs,li),qx(mgs,li)*rho0(mgs)/cimasx) + cx(mgs,li) = Min(cx(mgs,li),qx(mgs,li)*rho0(mgs)/cimasn) +! cx(mgs,li) = Max(1.0,cx(mgs,li)) + ENDIF + ENDIF + + IF ( qx(mgs,li) .gt. qxmin(li) ) THEN + xmas(mgs,li) = & + & max( qx(mgs,li)*rho0(mgs)/cx(mgs,li), cimasn ) +! & min( max(qx(mgs,li)*rho0(mgs)/cx(mgs,li),cimasn),cimasx ) + +! if ( temcg(mgs) .gt. 0.0 ) then +! xdia(mgs,li,1) = 0.0 +! else + if ( xmas(mgs,li) .gt. 0.0 ) THEN ! cimasn ) then +!c xdia(mgs,li,1) = 0.4892*(xmas(mgs,li)**(0.4554)) +! xdia(mgs,li,1) = 0.1871*(xmas(mgs,li)**(0.3429)) + +! xdia(mgs,li,1) = (132.694*5.40662/xmas(mgs,li))**(-1./2.9163) ! for inverse exponential distribution + IF ( ixtaltype == 1 ) THEN ! column + xdia(mgs,li,1) = 0.1871*(xmas(mgs,li)**(0.3429)) + xdia(mgs,li,3) = 0.1871*(xmas(mgs,li)**(0.3429)) + ELSEIF ( ixtaltype == 2 ) THEN ! disk + xdia(mgs,li,1) = 0.277823*xmas(mgs,li)**0.359971 + xdia(mgs,li,3) = 0.277823*xmas(mgs,li)**0.359971 + ENDIF + end if +! end if +! xdia(mgs,li,1) = max(xdia(mgs,li,1), 5.e-6) +! xdia(mgs,li,1) = min(xdia(mgs,li,1), 1000.e-6) + + IF ( ipconc .ge. 0 ) THEN +! vtxbar(mgs,li,1) = rhovt(mgs)*49420.*40.0005/5.40662*xdia(mgs,li,1)**(1.415) ! mass-weighted +! vtxbar(mgs,li,1) = (4.942e4)*(xdia(mgs,li,1)**(1.4150)) + xv(mgs,li) = xmas(mgs,li)/xdn(mgs,li) + IF ( icefallopt == 1 ) THEN ! default ice fall + IF ( ixtaltype == 1 ) THEN ! column + tmp = (67056.6300748612*rhovt(mgs))/ & + & (((1.0 + cinu)/xv(mgs,li))**0.4716666666666667*gfcinu1) + vtxbar(mgs,li,2) = tmp*gfcinu1p47 + vtxbar(mgs,li,1) = tmp*gfcinu2p47/(1. + cinu) + vtxbar(mgs,li,3) = vtxbar(mgs,li,1) + ELSEIF ( ixtaltype == 2 ) THEN ! disk -- but just use Ferrier (1994) snow fall speeds for now + vtxbar(mgs,li,1) = 11.9495*rhovt(mgs)*(xv(mgs,li))**(0.14) + vtxbar(mgs,li,2) = 7.02909*rhovt(mgs)*(xv(mgs,li))**(0.14) + vtxbar(mgs,li,3) = vtxbar(mgs,li,1) + + ENDIF + + ELSEIF ( icefallopt == 2 ) THEN ! ! Ferrier ice fall speed + tmp = (82.3166*rhovt(mgs))/ & + & (((1.0 + cinu)/xv(mgs,li))**0.22117*gfcinu1) + vtxbar(mgs,li,2) = tmp*gfcinu1p22 + vtxbar(mgs,li,1) = tmp*gfcinu2p22/(1. + cinu) + vtxbar(mgs,li,3) = vtxbar(mgs,li,1) + + ELSEIF ( icefallopt == 3 ) THEN ! ! Adjusted Ferrier (smaller exponent of 0.55 instead of 0.6635) + + tmp = (47.6273*rhovt(mgs))/ & + & (((1.0 + cinu)/xv(mgs,li))**0.18333*gfcinu1) + vtxbar(mgs,li,2) = tmp*gfcinu1p18 + vtxbar(mgs,li,1) = tmp*gfcinu2p18/(1. + cinu) + vtxbar(mgs,li,3) = vtxbar(mgs,li,1) + + ENDIF +! vtxbar(mgs,li,1) = vtxbar(mgs,li,2)*(1.+cinu)/(1. + cinu) +! xdn(mgs,li) = min(max(769.8*xdia(mgs,li,1)**(-0.0140),300.0),900.0) +! xdn(mgs,li) = 900.0 + xdia(mgs,li,2) = xdia(mgs,li,1)**2 +! vtxbar(mgs,li,1) = vtxbar(mgs,li,1)*rhovt(mgs) + ELSE + xdia(mgs,li,1) = max(xdia(mgs,li,1), 10.e-6) + xdia(mgs,li,1) = min(xdia(mgs,li,1), 1000.e-6) + vtxbar(mgs,li,1) = (4.942e4)*(xdia(mgs,li,1)**(1.4150)) +! xdn(mgs,li) = min(max(769.8*xdia(mgs,li,1)**(-0.0140),300.0),900.0) + xdn(mgs,li) = 900.0 + xdia(mgs,li,2) = xdia(mgs,li,1)**2 + vtxbar(mgs,li,1) = vtxbar(mgs,li,1)*rhovt(mgs) + xv(mgs,li) = xmas(mgs,li)/xdn(mgs,li) + ENDIF ! ipconc gt 3 + ELSE + xmas(mgs,li) = 1.e-13 + IF ( qx(mgs,li) <= 0.0 ) cx(mgs,li) = 0.0 + xdn(mgs,li) = 900.0 + xdia(mgs,li,1) = 1.e-7 + xdia(mgs,li,2) = (1.e-14) + xdia(mgs,li,3) = 1.e-7 + vtxbar(mgs,li,1) = 0.0 +! cicap(mgs) = 0.0 +! ciat(mgs) = 0.0 + ENDIF + + IF ( icefallfac /= 1.0 ) THEN + vtxbar(mgs,li,1) = icefallfac*vtxbar(mgs,li,1) + vtxbar(mgs,li,2) = icefallfac*vtxbar(mgs,li,2) + vtxbar(mgs,li,3) = icefallfac*vtxbar(mgs,li,3) + ENDIF + + + + end do + + ENDIF ! li .gt. 1 + + +! ################################################################ +! +! RAIN +! + +! + IF ( ildo == 0 .or. ildo == lr ) THEN + do mgs = 1,ngscnt + if ( qx(mgs,lr) .gt. qxmin(lr) ) then + +! IF ( qx(mgs,lr) .gt. 10.0e-3 ) & +! & write(0,*) 'RAIN1: ',igs(mgs),kgs(mgs),qx(mgs,lr) + + if ( ipconc .ge. 3 ) then + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*Max(1.0e-11,cx(mgs,lr))) + xvbarmax = xvmx(lr) + IF ( imaxdiaopt == 1 ) THEN + xvbarmax = xvmx(lr) + ELSEIF ( imaxdiaopt == 2 ) THEN ! test against maximum mass diameter + IF ( imurain == 1 ) THEN + xvbarmax = xvmx(lr)/((3. + alpha(mgs,lr))**3/((3. + alpha(mgs,lr))*(2. + alpha(mgs,lr))*(1. + alpha(mgs,lr)))) + ELSEIF ( imurain == 3 ) THEN + + ENDIF + ELSEIF ( imaxdiaopt == 3 ) THEN ! test against mass-weighted diameter + IF ( imurain == 1 ) THEN + xvbarmax = xvmx(lr)/((4. + alpha(mgs,lr))**3/((3. + alpha(mgs,lr))*(2. + alpha(mgs,lr))*(1. + alpha(mgs,lr)))) + ELSEIF ( imurain == 3 ) THEN + + ENDIF + ENDIF + + IF ( xv(mgs,lr) .gt. xvbarmax ) THEN + xv(mgs,lr) = xvbarmax + cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvbarmax*xdn(mgs,lr)) + ELSEIF ( xv(mgs,lr) .lt. xvmn(lr) ) THEN + xv(mgs,lr) = xvmn(lr) + cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmn(lr)*xdn(mgs,lr)) + ENDIF + + + xmas(mgs,lr) = xv(mgs,lr)*xdn(mgs,lr) + xdia(mgs,lr,3) = (xmas(mgs,lr)*cwc1)**(1./3.) ! xdia(mgs,lr,1) + IF ( imurain == 3 ) THEN +! xdia(mgs,lr,1) = (6.*pii*xv(mgs,lr)/(alpha(mgs,lr)+1.))**(1./3.) + xdia(mgs,lr,1) = xdia(mgs,lr,3) ! formulae for Ziegler (1985) use mean volume diameter, not lambda**(-1) + ELSE ! imurain == 1, Characteristic diameter (1/lambda) + xdia(mgs,lr,1) = (6.*pii*xv(mgs,lr)/((alpha(mgs,lr)+3.)*(alpha(mgs,lr)+2.)*(alpha(mgs,lr)+1.)))**(1./3.) + ENDIF +! rwrad(mgs) = 0.5*xdia(mgs,lr,1) + +! Inverse exponential version: +! xdia(mgs,lr,1) = +! & (qx(mgs,lr)*rho0(mgs) +! & /(pi*xdn(mgs,lr)*cx(mgs,lr)))**(0.333333) + ELSE + xdia(mgs,lr,1) = & + & (qx(mgs,lr)*rho0(mgs)/(pi*xdn(mgs,lr)*cno(lr)))**(0.25) + xmas(mgs,lr) = xdn(mgs,lr)*(pi/6.)*xdia(mgs,lr,1)**3 + xdia(mgs,lr,3) = (xmas(mgs,lr)*cwc1)**(1./3.) + cx(mgs,lr) = cno(lr)*xdia(mgs,lr,1) + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*cx(mgs,lr)) + end if + else + xdia(mgs,lr,1) = 1.e-9 + xdia(mgs,lr,3) = 1.e-9 + xmas(mgs,lr) = xdn(mgs,lr)*(pi/6.)*xdia(mgs,lr,1)**3 +! rwrad(mgs) = 0.5*xdia(mgs,lr,1) + end if + xdia(mgs,lr,2) = xdia(mgs,lr,1)**2 +! xmas(mgs,lr) = xdn(mgs,lr)*(pi/6.)*xdia(mgs,lr,1)**3 + end do + + ENDIF +! ################################################################ +! +! SNOW +! + + IF ( ls .gt. 1 .and. ( ildo == 0 .or. ildo == ls ) ) THEN + + do mgs = 1,ngscnt + if ( qx(mgs,ls) .gt. qxmin(ls) ) then + if ( ipconc .ge. 4 ) then ! + + xmas(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(Max(1.0e-9,cx(mgs,ls))) + swmasmx = 13.7e-6 +! IF ( xmas(mgs,ls) > swmasmx ) THEN +! xmas(mgs,ls) = swmasmx +! cx(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xmas(mgs,ls)) +! ENDIF + + IF ( isnowdens == 2 ) THEN ! Set values according to Cox relationship + + xdn(mgs,ls) = 0.0346159*Sqrt(cx(mgs,ls)/(qx(mgs,ls)*rho0(mgs)) ) + xdn(mgs,ls) = Max( 100.0, xdn(mgs,ls) ) ! limit snow to 100. to keep other equations in line + + IF ( xdn(mgs,ls) <= 900. ) THEN + dtmp = Sqrt( xmas(mgs,ls)/0.069 ) ! diameter (meters) of mean mass particle using Cox 1998 relation (m = p d^2) + xv(mgs,ls) = 28.8887*xmas(mgs,ls)**(3./2.) + ELSE ! at small sizes, assume ice spheres + xdn(mgs,ls) = 900. + xv(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xdn(mgs,ls)*Max(1.0e-9,cx(mgs,ls))) + dtmp = (xv(mgs,ls)*cwc0*6.0)**(1./3.) + ENDIF + + ELSE ! leave xdn(ls) at default value + xv(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xdn(mgs,ls)*Max(1.0e-9,cx(mgs,ls))) + dtmp = (xv(mgs,ls)*cwc0*6.0)**(1./3.) + ENDIF + + xdia(mgs,ls,1) = dtmp ! (xv(mgs,ls)*cwc0*6.0)**(1./3.) + + IF ( xv(mgs,ls) .lt. xvmn(ls) .and. isnowdens == 1) THEN + xv(mgs,ls) = Max( xvmn(ls),xv(mgs,ls) ) + xmas(mgs,ls) = xv(mgs,ls)*xdn(mgs,ls) + cx(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xmas(mgs,ls)) + xdia(mgs,ls,1) = (xv(mgs,ls)*cwc0*6.0)**(1./3.) + ENDIF + + IF ( xv(mgs,ls) .gt. xvmx(ls)*Max(1.,100./Min(100.,xdn(mgs,ls))) ) THEN + xv(mgs,ls) = Min( xvmx(ls), Max( xvmn(ls),xv(mgs,ls) ) ) + xmas(mgs,ls) = 0.106214*xv(mgs,ls)**(2./3.) + cx(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xmas(mgs,ls)) + xdn(mgs,ls) = 0.0346159*Sqrt(cx(mgs,ls)/(qx(mgs,ls)*rho0(mgs)) ) + xdia(mgs,ls,1) = Sqrt( xmas(mgs,ls)/0.069 ) + ENDIF + + xdia(mgs,ls,3) = xdia(mgs,ls,1) + + ELSE + xdia(mgs,ls,1) = & + & (qx(mgs,ls)*rho0(mgs)/(pi*xdn(mgs,ls)*cnostmp(mgs)))**(0.25) + cx(mgs,ls) = cnostmp(mgs)*xdia(mgs,ls,1) + xv(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xdn(mgs,ls)*cx(mgs,ls)) + xdia(mgs,ls,3) = (xv(mgs,ls)*cwc0*6.0)**(1./3.) + end if + else + xdia(mgs,ls,1) = 1.e-9 + xdia(mgs,ls,3) = 1.e-9 + cx(mgs,ls) = 0.0 + + IF ( isnowdens == 2 ) THEN ! Set values according to Cox relationship + xdn(mgs,ls) = 90. + ENDIF + + end if + xdia(mgs,ls,2) = xdia(mgs,ls,1)**2 +! swdia3(mgs) = xdia(mgs,ls,2)*xdia(mgs,ls,1) +! xmas(mgs,ls) = xdn(mgs,ls)*(pi/6.)*swdia3(mgs) + end do + + ENDIF ! ls .gt 1 +! +! +! ################################################################ +! +! GRAUPEL +! + + IF ( lh .gt. 1 .and. ( ildo == 0 .or. ildo == lh ) ) THEN + + do mgs = 1,ngscnt + if ( qx(mgs,lh) .gt. qxmin(lh) ) then + if ( ipconc .ge. 5 ) then + + xv(mgs,lh) = rho0(mgs)*qx(mgs,lh)/(xdn(mgs,lh)*Max(1.0e-9,cx(mgs,lh))) + xmas(mgs,lh) = xv(mgs,lh)*xdn(mgs,lh) + + IF ( xv(mgs,lh) .lt. xvmn(lh) .or. xv(mgs,lh) .gt. xvmx(lh) ) THEN + xv(mgs,lh) = Min( xvmx(lh), Max( xvmn(lh),xv(mgs,lh) ) ) + xmas(mgs,lh) = xv(mgs,lh)*xdn(mgs,lh) + cx(mgs,lh) = rho0(mgs)*qx(mgs,lh)/(xmas(mgs,lh)) + ENDIF + + xdia(mgs,lh,3) = (xv(mgs,lh)*6.*pii)**(1./3.) ! mwfac*xdia(mgs,lh,1) ! (xv(mgs,lh)*cwc0*6.0)**(1./3.) + IF ( dmuh == 1.0 ) THEN + xdia(mgs,lh,1) = cwch(mgs)*xdia(mgs,lh,3) + ELSE + xdia(mgs,lh,1) = (xv(mgs,lh)*cwch(mgs))**(1./3.) + ENDIF + + ELSE + xdia(mgs,lh,1) = & + & (qx(mgs,lh)*rho0(mgs)/(pi*xdn(mgs,lh)*cno(lh)))**(0.25) + cx(mgs,lh) = cno(lh)*xdia(mgs,lh,1) + xv(mgs,lh) = Max(xvmn(lh), rho0(mgs)*qx(mgs,lh)/(xdn(mgs,lh)*cx(mgs,lh)) ) + xdia(mgs,lh,3) = (xv(mgs,lh)*6./pi)**(1./3.) + end if + else + xdia(mgs,lh,1) = 1.e-9 + xdia(mgs,lh,3) = 1.e-9 + end if + xdia(mgs,lh,2) = xdia(mgs,lh,1)**2 +! hwdia3(mgs) = xdia(mgs,lh,2)*xdia(mgs,lh,1) +! xmas(mgs,lh) = xdn(mgs,lh)*(pi/6.)*hwdia3(mgs) + end do + + ENDIF + +! +! ################################################################ +! +! HAIL +! + + IF ( lhl .gt. 1 .and. ( ildo == 0 .or. ildo == lhl ) ) THEN + + do mgs = 1,ngscnt + if ( qx(mgs,lhl) .gt. qxmin(lhl) ) then + if ( ipconc .ge. 5 ) then + + xv(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/(xdn(mgs,lhl)*Max(1.0e-9,cx(mgs,lhl))) + xmas(mgs,lhl) = xv(mgs,lhl)*xdn(mgs,lhl) +! write(0,*) 'setvt: xv = ',xv(mgs,lhl),xdn(mgs,lhl),cx(mgs,lhl),xmas(mgs,lhl),qx(mgs,lhl) + + IF ( xv(mgs,lhl) .lt. xvmn(lhl) .or. xv(mgs,lhl) .gt. xvmx(lhl) ) THEN + xv(mgs,lhl) = Min( xvmx(lhl), Max( xvmn(lhl),xv(mgs,lhl) ) ) + xmas(mgs,lhl) = xv(mgs,lhl)*xdn(mgs,lhl) + cx(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/(xmas(mgs,lhl)) + ENDIF + + xdia(mgs,lhl,3) = (xv(mgs,lhl)*6./pi)**(1./3.) ! mwfac*xdia(mgs,lh,1) ! (xv(mgs,lh)*cwc0*6.0)**(1./3.) + IF ( dmuhl == 1.0 ) THEN + xdia(mgs,lhl,1) = cwchl(mgs)*xdia(mgs,lhl,3) + ELSE + xdia(mgs,lhl,1) = (xv(mgs,lhl)*cwchl(mgs))**(1./3.) + ENDIF + +! write(0,*) 'setvt: xv = ',xv(mgs,lhl),xdn(mgs,lhl),cx(mgs,lhl),xdia(mgs,lhl,3) + ELSE + xdia(mgs,lhl,1) = & + & (qx(mgs,lhl)*rho0(mgs)/(pi*xdn(mgs,lhl)*cno(lhl)))**(0.25) + cx(mgs,lhl) = cno(lhl)*xdia(mgs,lhl,1) + xv(mgs,lhl) = Max(xvmn(lhl), rho0(mgs)*qx(mgs,lhl)/(xdn(mgs,lhl)*cx(mgs,lhl)) ) + xdia(mgs,lhl,3) = (xv(mgs,lhl)*6./pi)**(1./3.) + end if + else + xdia(mgs,lhl,1) = 1.e-9 + xdia(mgs,lhl,3) = 1.e-9 + end if + xdia(mgs,lhl,2) = xdia(mgs,lhl,1)**2 +! hwdia3(mgs) = xdia(mgs,lh,2)*xdia(mgs,lh,1) +! xmas(mgs,lh) = xdn(mgs,lh)*(pi/6.)*hwdia3(mgs) + end do + + ENDIF +! +! +! +! Set terminal velocities... +! also set drag coefficients (moved to start of subroutine) +! +! cdx(lr) = 0.60 +! cdx(lh) = 0.45 +! cdx(lhl) = 0.45 +! cdx(lf) = 0.45 +! cdx(lgh) = 0.60 +! cdx(lgm) = 0.80 +! cdx(lgl) = 0.80 +! cdx(lir) = 2.00 +! + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set terminal velocities' +! +! +! ################################################################ +! +! RAIN +! + IF ( ildo == 0 .or. ildo == lr ) THEN + do mgs = 1,ngscnt + if ( qx(mgs,lr) .gt. qxmin(lr) ) then + IF ( ipconc .lt. 3 ) THEN + vtxbar(mgs,lr,1) = rainfallfac*(ar*gf4br/6.0)*(xdia(mgs,lr,1)**br)*rhovt(mgs) +! write(91,*) 'vtxbar: ',vtxbar(mgs,lr,1),mgs,gf4br,xdia(mgs,lr,1),rhovt(mgs) + ELSE + + IF ( imurain == 1 ) THEN ! DSD of Diameter + + ! using functional form of arx*(1 - Exp(-frx*diameter) ), with arx = arx = 10. + ! and frx = 516.575 ! raind fit parameters for arx*(1 - Exp(-fx*d)), where d is rain diameter in meters. + ! Similar form as in Atlas et al. (1973), who had 9.65 - 10.3*Exp[-600 * d] + + + alp = alpha(mgs,lr) + + vtxbar(mgs,lr,1) = rhovt(mgs)*arx*(1.0 - (1.0 + frx*xdia(mgs,lr,1))**(-alp - 4.0) ) ! mass weighted + + IF ( infdo .ge. 1 .and. rssflg == 1 ) THEN + vtxbar(mgs,lr,2) = rhovt(mgs)*arx*(1.0 - (1.0 + frx*xdia(mgs,lr,1))**(-alp - 1.0) ) ! number weighted + ELSE + vtxbar(mgs,lr,2) = vtxbar(mgs,lr,1) + ENDIF + + IF ( infdo .ge. 2 .and. rssflg == 1 ) THEN + vtxbar(mgs,lr,3) = rhovt(mgs)*arx*(1.0 - (1.0 + frx*xdia(mgs,lr,1))**(-alp - 7.0) ) ! z-weighted + ELSE + vtxbar(mgs,lr,3) = vtxbar(mgs,lr,1) + ENDIF + +! write(91,*) 'setvt: alp,vn,vm,vz = ',alp,vtxbar(mgs,lr,2), vtxbar(mgs,lr,1), vtxbar(mgs,lr,3),alpha(mgs,lr) + + ELSEIF ( imurain == 3 ) THEN ! DSD of Volume + + IF ( lzr < 1 ) THEN ! not 3-moment rain + rwdia = Min( xdia(mgs,lr,1), 8.0e-3 ) + + vtxbar(mgs,lr,1) = rhovt(mgs)*6.0*pii*( 0.04771 + 3788.0*rwdia - & + & 1.105e6*rwdia**2 + 1.412e8*rwdia**3 - 6.527e9*rwdia**4) + + IF ( infdo .ge. 1 ) THEN + IF ( rssflg >= 1 ) THEN + vtxbar(mgs,lr,2) = (0.09112 + 2714.0*rwdia - 4.872e5*rwdia**2 + & + & 4.495e7*rwdia**3 - 1.626e9*rwdia**4)*rhovt(mgs) + ELSE + vtxbar(mgs,lr,2) = vtxbar(mgs,lr,1) + ENDIF + ENDIF + + IF ( infdo .ge. 2 ) THEN ! Z-weighted fall speed + vtxbar(mgs,lr,3) = rhovt(mgs)*( & + & 0.0911229 + & + & 9246.494*(rwdia) - & + & 3.2839926e6*(rwdia**2) + & + & 4.944093e8*(rwdia**3) - & + & 2.631718e10*(rwdia**4) ) + ENDIF + + ELSE ! 3-moment rain, gamma-volume + + vr = xv(mgs,lr) + rnux = alpha(mgs,lr) + + IF ( infdo .ge. 1 .and. rssflg == 1) THEN ! number-weighted; DTD: added size-sorting flag + vtxbar(mgs,lr,2) = rhovt(mgs)* & + & (((1. + rnux)/vr)**(-1.333333)* & + & (0.0911229*((1. + rnux)/vr)**1.333333*Gamma_sp(1. + rnux) + & + & (5430.3131*(1. + rnux)*Gamma_sp(4./3. + rnux))/ & + & vr - 1.0732802e6*((1. + rnux)/vr)**0.6666667* & + & Gamma_sp(1.666667 + rnux) + & + & 8.584110982429507e7*((1. + rnux)/vr)**(1./3.)* & + & Gamma_sp(2. + rnux) - & + & 2.3303765697228556e9*Gamma_sp(7./3. + rnux)))/ & + & Gamma_sp(1. + rnux) + ENDIF + +! mass-weighted + vtxbar(mgs,lr,1) = rhovt(mgs)* & + & (0.0911229*(1 + rnux)**1.3333333333333333*Gamma_sp(2. + rnux) + & + & 5430.313059683277*(1 + rnux)*vr**0.3333333333333333* & + & Gamma_sp(2.333333333333333 + rnux) - & + & 1.0732802065650471e6*(1 + rnux)**0.6666666666666666*vr**0.6666666666666666* & + & Gamma_sp(2.6666666666666667 + rnux) + & + & 8.584110982429507e7*(1 + rnux)**0.3333333333333333*vr*Gamma_sp(3 + rnux) - & + & 2.3303765697228556e9*vr**1.3333333333333333* & + & Gamma_sp(3.333333333333333 + rnux))/ & + & ((1 + rnux)**2.333333333333333*Gamma_sp(1 + rnux)) + + IF(infdo .ge. 1 .and. rssflg == 0) THEN ! No size-sorting, set N-weighted fall speed to mass-weighted + vtxbar(mgs,lr,2) = vtxbar(mgs,lr,1) + ENDIF + + IF ( infdo .ge. 2 .and. rssflg == 1) THEN ! Z-weighted fall speed + vtxbar(mgs,lr,3) = rhovt(mgs)* & + & ((1. + rnux)*(0.0911229*(1 + rnux)**1.3333333333333333*Gamma_sp(3. + rnux) + & + & 5430.313059683277*(1 + rnux)*vr**0.3333333333333333* & + & Gamma_sp(3.3333333333333335 + rnux) - & + & 1.0732802065650471e6*(1 + rnux)**0.6666666666666666* & + & vr**0.6666666666666666*Gamma_sp(3.6666666666666665 + rnux) + & + & 8.5841109824295e7*(1 + rnux)**0.3333333333333333*vr*Gamma_sp(4. + rnux) - & + & 2.3303765697228556e9*vr**1.3333333333333333* & + & Gamma_sp(4.333333333333333 + rnux)))/ & + & ((1 + rnux)**3.3333333333333335*(2 + rnux)*Gamma_sp(1 + rnux)) + +! write(0,*) 'setvt: mgs,lzr,infdo = ',mgs,lzr,infdo +! write(0,*) 'vt1,2,3 = ',vtxbar(mgs,lr,1),vtxbar(mgs,lr,2),vtxbar(mgs,lr,3) + + ELSEIF (infdo .ge. 2) THEN ! No size-sorting, set Z-weighted fall speed to mass-weighted + vtxbar(mgs,lr,3) = vtxbar(mgs,lr,1) + ENDIF + + + ENDIF + ENDIF ! imurain + +! IF ( rwrad*mwfac .gt. 6.0e-4 ) THEN +! vtxbar(mgs,lr,1) = 20.1*Sqrt(100.*rwrad*mwfac)*rhovt(mgs) +! ELSE +! vtxbar(mgs,lr,1) = 80.0e2*rwrad*rhovt(mgs)*mwfac +! ENDIF +! IF ( rwrad .gt. 6.0e-4 ) THEN +! vtxbar(mgs,lr,2) = 20.1*Sqrt(100.*rwrad)*rhovt(mgs) +! ELSE +! vtxbar(mgs,lr,2) = 80.0e2*rwrad*rhovt(mgs) +! ENDIF + ENDIF ! ipconc + else ! qr < qrmin + vtxbar(mgs,lr,1) = 0.0 + vtxbar(mgs,lr,2) = 0.0 + end if + end do + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set rain vt' + + ENDIF +! +! ################################################################ +! +! SNOW !Zrnic et al. (1993) +! + IF ( ls .gt. 1 .and. ( ildo == 0 .or. ildo == ls ) ) THEN + do mgs = 1,ngscnt + if ( qx(mgs,ls) .gt. qxmin(ls) ) then + IF ( ipconc .ge. 4 ) THEN + if ( mixedphase .and. qsvtmod ) then + else + IF ( isnowfall == 1 ) THEN + ! original (Zrnic et al. 1993) + vtxbar(mgs,ls,1) = 5.72462*rhovt(mgs)*(xv(mgs,ls))**(1./12.) + ELSEIF ( isnowfall == 2 ) THEN + ! Ferrier: + IF ( isnowdens == 1 ) THEN + vtxbar(mgs,ls,1) = 11.9495*rhovt(mgs)*(xv(mgs,ls))**(0.14) + ELSE + vtxbar(mgs,ls,1) = 11.9495*rhovt(mgs)*(xv(mgs,ls)*xdn(mgs,ls)/100.)**(0.14) + ENDIF + ELSEIF ( isnowfall == 3 ) THEN + ! Cox, mass distrib: + vtxbar(mgs,ls,1) = 50.092*rhovt(mgs)*(xmas(mgs,ls))**(0.2635) + ENDIF + + IF(Abs(sssflg) >= 1) THEN + IF ( isnowfall == 1 ) THEN + vtxbar(mgs,ls,2) = 4.04091*rhovt(mgs)*(xv(mgs,ls))**(1./12.) + ELSEIF ( isnowfall == 2 ) THEN + ! Ferrier: + IF ( isnowdens == 1 ) THEN + vtxbar(mgs,ls,2) = 7.02909*rhovt(mgs)*(xv(mgs,ls))**(0.14) ! bug fix 11/15/2015: was rewriting to mass fall speed vtxbar(mgs,ls,1) + ELSE + vtxbar(mgs,ls,2) = 7.02909*rhovt(mgs)*(xv(mgs,ls)*xdn(mgs,ls)/100.)**(0.14) ! bug fix 11/15/2015: was rewriting to mass fall speed vtxbar(mgs,ls,1) + ENDIF + ELSEIF ( isnowfall == 3 ) THEN + ! Cox, mass distrib: + vtxbar(mgs,ls,2) = 21.6147*rhovt(mgs)*(xmas(mgs,ls))**(0.2635) + ENDIF + ELSE + vtxbar(mgs,ls,2) = vtxbar(mgs,ls,1) + ENDIF + IF ( infdo >= 2 ) THEN + IF ( isnowfall == 1 ) THEN + vtxbar(mgs,ls,3) = 6.12217*rhovt(mgs)*(xv(mgs,ls))**(1./12.) ! Zrnic et al 93 + ELSEIF ( isnowfall == 2 ) THEN + vtxbar(mgs,ls,3) = 13.3436*rhovt(mgs)*(xv(mgs,ls))**(0.14) ! Ferrier 94 + ELSEIF ( isnowfall == 3 ) THEN + ! Cox, mass distrib: + vtxbar(mgs,ls,3) = 61.0914*rhovt(mgs)*(xmas(mgs,ls))**(0.2635) + ENDIF + ENDIF + + IF ( sssflg < 0 .and. temcg(mgs) > Abs(sssflg) ) THEN ! above a given temperature, effectively turn off size sorting + vtxbar(mgs,ls,2) = vtxbar(mgs,ls,1) + vtxbar(mgs,ls,3) = vtxbar(mgs,ls,1) + ENDIF + + endif + ELSE ! single-moment: + vtxbar(mgs,ls,1) = (cs*gf4ds/6.0)*(xdia(mgs,ls,1)**ds)*rhovt(mgs) + vtxbar(mgs,ls,2) = vtxbar(mgs,ls,1) + ENDIF + else + vtxbar(mgs,ls,1) = 0.0 + end if + + IF ( snowfallfac /= 1.0 ) THEN + vtxbar(mgs,ls,1) = snowfallfac*vtxbar(mgs,ls,1) + vtxbar(mgs,ls,2) = snowfallfac*vtxbar(mgs,ls,2) + vtxbar(mgs,ls,3) = snowfallfac*vtxbar(mgs,ls,3) + ENDIF + + + end do + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set snow vt' + + ENDIF ! ls .gt. 1 +! +! +! ################################################################ +! +! GRAUPEL !Wisner et al. (1972) +! + IF ( lh .gt. 1 .and. ( ildo == 0 .or. ildo == lh ) ) THEN + + do mgs = 1,ngscnt + vtxbar(mgs,lh,1) = 0.0 + if ( qx(mgs,lh) .gt. qxmin(lh) ) then + cd = cdx(lh) + IF ( icdx .eq. 1 ) THEN + cd = cdx(lh) + ELSEIF ( icdx .eq. 2 ) THEN +! cd = Max(0.6, Min(1.0, 0.6 + 0.4*(xdnmx(lh) - xdn(mgs,lh))/(xdnmx(lh)-xdnmn(lh)) ) ) +! cd = Max(0.6, Min(1.0, 0.6 + 0.4*(900.0 - xdn(mgs,lh))/(900. - 300.) ) ) + cd = Max(0.45, Min(1.0, 0.45 + 0.35*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 500.) ) ) +! cd = Max(0.55, Min(1.0, 0.55 + 0.25*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 500.) ) ) + ELSEIF ( icdx .eq. 3 ) THEN +! cd = Max(0.45, Min(1.0, 0.45 + 0.55*(800.0 - Max( 300., Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 300.) ) ) + cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hdnmn, Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) ) + ELSEIF ( icdx .eq. 4 ) THEN + cd = Max(cdhmin, Min(cdhmax, cdhmin + (cdhmax-cdhmin)* & + & (cdhdnmax - Max( cdhdnmin, Min( cdhdnmax, xdn(mgs,lh) ) ) )/(cdhdnmax - cdhdnmin) ) ) + ELSEIF ( icdx .eq. 5 ) THEN + cd = cdx(lh)*(xdn(mgs,lh)/rho_qh)**(2./3.) + ELSEIF ( icdx .eq. 6 ) THEN ! Milbrandt and Morrison (2013) + indxr = Int( (xdn(mgs,lh)-50.)/100. ) + 1 + indxr = Min( ngdnmm, Max(1,indxr) ) + + + delrho = Max( 0.0, 0.01*(xdn(mgs,lh) - mmgraupvt(indxr,1)) ) + IF ( indxr < ngdnmm ) THEN + + axx(mgs,lh) = mmgraupvt(indxr,2) + delrho*(mmgraupvt(indxr+1,2) - mmgraupvt(indxr,2) ) + bxx(mgs,lh) = mmgraupvt(indxr,3) + delrho*(mmgraupvt(indxr+1,3) - mmgraupvt(indxr,3) ) + + + ELSE + axx(mgs,lh) = mmgraupvt(indxr,2) + bxx(mgs,lh) = mmgraupvt(indxr,3) + ENDIF + + aax = axx(mgs,lh) + bbx = bxx(mgs,lh) + + cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hdnmn, Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) ) + + ELSEIF ( icdx <= 0 ) THEN ! + aax = ax(lh) + bbx = bx(lh) + cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hdnmn, Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) ) + ELSE + cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hdnmn, Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) ) + ENDIF + + cdxgs(mgs,lh) = cd + IF ( alpha(mgs,lh) .eq. 0.0 .and. icdx > 0 .and. icdx /= 6 ) THEN +! axx(mgs,lh) = (gf4p5/6.0)* & +! & Sqrt( (xdn(mgs,lh)*4.0*gr) / & +! & (3.0*cd*rho0(mgs)) ) + axx(mgs,lh) = Sqrt(4.0*xdn(mgs,lh)*gr/(3.0*cd*rho00)) + bxx(mgs,lh) = 0.5 + vtxbar(mgs,lh,1) = (gf4p5/6.0)* rhovt(mgs)*axx(mgs,lh) * Sqrt(xdia(mgs,lh,1)) +! vtxbar(mgs,lh,1) = (gf4p5/6.0)* & +! & Sqrt( (xdn(mgs,lh)*xdia(mgs,lh,1)*4.0*gr) / & +! & (3.0*cd*rho0(mgs)) ) + ELSE + IF ( icdx /= 6 ) bbx = bx(lh) + tmp = 4. + alpha(mgs,lh) + bbx + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = 4. + alpha(mgs,lh) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + +! aax = Max( 1.0, Min(2.0, (xdn(mgs,lh)/400.) ) ) +! vtxbar(mgs,lh,1) = rhovt(mgs)*aax*ax(lh)*(xdia(mgs,lh,1)**bx(lh)*x)/y + + IF ( icdx > 0 .and. icdx /= 6) THEN + aax = Sqrt(4.0*xdn(mgs,lh)*gr/(3.0*cd*rho00)) + vtxbar(mgs,lh,1) = rhovt(mgs)*aax* Sqrt(xdia(mgs,lh,1)) * x/y + axx(mgs,lh) = aax + bxx(mgs,lh) = bbx + ELSEIF (icdx == 6 ) THEN + vtxbar(mgs,lh,1) = rhovt(mgs)*aax* xdia(mgs,lh,1)**bbx * x/y + ELSE ! icdx < 0 + axx(mgs,lh) = ax(lh) + bxx(mgs,lh) = bx(lh) + vtxbar(mgs,lh,1) = rhovt(mgs)*ax(lh)*(xdia(mgs,lh,1)**bx(lh)*x)/y + ENDIF + +! & Gamma_sp(4.0 + dnu(lh) + 0.6))/Gamma_sp(4. + dnu(lh)) + ENDIF + + IF ( lwsm6 .and. ipconc == 0 ) THEN +! vtxbar(mgs,lh,1) = (330.*gf4ds/6.0)*(xdia(mgs,ls,1)**ds)*rhovt(mgs) + vtxbar(mgs,lh,1) = (330.*gf4br/6.0)*(xdia(mgs,lh,1)**br)*rhovt(mgs) + ENDIF + + end if + end do + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set hail vt' + + ENDIF ! lh .gt. 1 +! +! +! ################################################################ +! +! HAIL +! + IF ( lhl .gt. 1 .and. ( ildo == 0 .or. ildo == lhl ) ) THEN + + do mgs = 1,ngscnt + vtxbar(mgs,lhl,1) = 0.0 + if ( qx(mgs,lhl) .gt. qxmin(lhl) ) then + + IF ( icdxhl .eq. 1 ) THEN + cd = cdx(lhl) + ELSEIF ( icdxhl .eq. 3 ) THEN +! cd = Max(0.45, Min(1.0, 0.45 + 0.55*(800.0 - Max( 300., Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 300.) ) ) + cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hldnmn, Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 170.0) ) ) + ELSEIF ( icdxhl .eq. 4 ) THEN + cd = Max(cdhlmin, Min(cdhlmax, cdhlmin + (cdhlmax-cdhlmin)* & + & (cdhldnmax - Max( cdhldnmin, Min( cdhldnmax, xdn(mgs,lhl) ) ) )/(cdhldnmax - cdhldnmin) ) ) + ELSEIF ( icdxhl .eq. 5 ) THEN + cd = cdx(lh)*(xdn(mgs,lhl)/rho_qh)**(2./3.) + ELSEIF ( icdxhl .eq. 6 ) THEN ! Milbrandt and Morrison (2013) + indxr = Int( (xdn(mgs,lhl)-50.)/100. ) + 1 + indxr = Min( ngdnmm, Max(1,indxr) ) + + + delrho = Max( 0.0, 0.01*(xdn(mgs,lhl) - mmgraupvt(indxr,1)) ) + IF ( indxr < ngdnmm ) THEN + + axx(mgs,lhl) = mmgraupvt(indxr,2) + delrho*(mmgraupvt(indxr+1,2) - mmgraupvt(indxr,2) ) + bxx(mgs,lhl) = mmgraupvt(indxr,3) + delrho*(mmgraupvt(indxr+1,3) - mmgraupvt(indxr,3) ) + + + ELSE + axx(mgs,lhl) = mmgraupvt(indxr,2) + bxx(mgs,lhl) = mmgraupvt(indxr,3) + ENDIF + + aax = axx(mgs,lhl) + bbx = bxx(mgs,lhl) + + cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hldnmn, Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 170.0) ) ) + + ELSE +! cd = Max(0.6, Min(1.0, 0.6 + 0.4*(900.0 - xdn(mgs,lhl))/(900. - 300.) ) ) +! cd = Max(0.5, Min(0.8, 0.5 + 0.3*(xdnmx(lhl) - xdn(mgs,lhl))/(xdnmx(lhl)-xdnmn(lhl)) ) ) +! cd = Max(0.45, Min(0.6, 0.45 + 0.15*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 500.) ) ) + cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hldnmn, Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 170.0) ) ) + ENDIF + + cdxgs(mgs,lhl) = cd + + IF ( alpha(mgs,lhl) .eq. 0.0 .and. icdxhl > 0 .and. icdxhl /= 6) THEN +! axx(mgs,lhl) = (gf4p5/6.0)* & +! & Sqrt( (xdn(mgs,lhl)*4.0*gr) / & +! & (3.0*cd*rho0(mgs)) ) + axx(mgs,lhl) = Sqrt(4.0*xdn(mgs,lhl)*gr/(3.0*cd*rho00)) + bxx(mgs,lhl) = 0.5 + vtxbar(mgs,lhl,1) = (gf4p5/6.0)* rhovt(mgs)*axx(mgs,lhl) * Sqrt(xdia(mgs,lhl,1)) + ELSE + IF ( icdxhl /= 6 ) bbx = bx(lhl) + tmp = 4. + alpha(mgs,lhl) + bbx + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = 4. + alpha(mgs,lhl) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + IF ( icdxhl > 0 .and. icdxhl /= 6) THEN + aax = Sqrt(4.0*xdn(mgs,lhl)*gr/(3.0*cd*rho00)) + vtxbar(mgs,lhl,1) = rhovt(mgs)*aax* Sqrt(xdia(mgs,lhl,1)) * x/y + axx(mgs,lhl) = aax + bxx(mgs,lhl) = bbx + ELSEIF ( icdxhl == 6 ) THEN + vtxbar(mgs,lhl,1) = rhovt(mgs)*aax* (xdia(mgs,lhl,1))**bbx * x/y + ELSE + axx(mgs,lhl) = ax(lhl) + bxx(mgs,lhl) = bx(lhl) + vtxbar(mgs,lhl,1) = rhovt(mgs)*(ax(lhl)*xdia(mgs,lhl,1)**bx(lhl)*x)/y + ENDIF + +! & Gamma_sp(4.0 + dnu(lh) + 0.6))/Gamma_sp(4. + dnu(lh)) + ENDIF + + + end if + end do + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set hail vt' + + ENDIF ! lhl .gt. 1 + + + IF ( infdo .ge. 1 ) THEN + +! DO il = lc,lhab +! IF ( il .ne. lr ) THEN + DO mgs = 1,ngscnt + IF ( ildo == 0 .or. ildo == lc ) THEN + vtxbar(mgs,lc,2) = vtxbar(mgs,lc,1) + ENDIF + IF ( li .gt. 1 ) THEN +! vtxbar(mgs,li,2) = rhovt(mgs)*49420.*1.25447*xdia(mgs,li,1)**(1.415) ! n-wgt (Ferrier 94) +! vtxbar(mgs,li,2) = vtxbar(mgs,li,1) + +! test print stuff... +! IF ( xdia(mgs,li,1) .gt. 200.e-6 ) THEN +! tmp = (xv(mgs,li)*cwc0)**(1./3.) +! x = rhovt(mgs)*49420.*40.0005/5.40662*tmp**(1.415) +! y = rhovt(mgs)*49420.*1.25447*tmp**(1.415) +! write(6,*) 'Ice fall: ',vtxbar(mgs,li,1),x,y,tmp,xdia(mgs,li,1) +! ENDIF + ENDIF +! vtxbar(mgs,ls,2) = vtxbar(mgs,ls,1) + ENDDO + + IF ( lg .gt. lr ) THEN + + DO il = lg,lhab + IF ( ildo == 0 .or. ildo == il ) THEN + + DO mgs = 1,ngscnt + IF ( qx(mgs,il) .gt. qxmin(il) ) THEN + IF ( (il .eq. lh .and. hssflg == 1) .or. ( lhl .gt. 1 .and. il .eq. lhl .and. hlssflg == 1) ) THEN ! DTD: added flag for size-sorting + + ! DTD: allow for setting of number-weighted and z-weighted fall speeds to the mass-weighted value, + ! effectively turning off size-sorting + + IF ( il .eq. lh ) THEN ! { + + IF ( icdx .eq. 1 ) THEN + cd = cdx(lh) + ELSEIF ( icdx .eq. 2 ) THEN +! cd = Max(0.6, Min(1.0, 0.6 + 0.4*(xdnmx(lh) - xdn(mgs,lh))/(xdnmx(lh)-xdnmn(lh)) ) ) +! cd = Max(0.6, Min(1.0, 0.6 + 0.4*(900.0 - xdn(mgs,lh))/(900. - 300.) ) ) + cd = Max(0.45, Min(1.0, 0.45 + 0.35*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 500.) ) ) +! cd = Max(0.55, Min(1.0, 0.55 + 0.25*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 500.) ) ) + ELSEIF ( icdx .eq. 3 ) THEN +! cd = Max(0.45, Min(1.0, 0.45 + 0.55*(800.0 - Max( 170.0, Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) ) + cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hdnmn, Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) ) + ELSEIF ( icdx .eq. 4 ) THEN + cd = Max(cdhmin, Min(cdhmax, cdhmin + (cdhmax-cdhmin)* & + & (cdhdnmax - Max( cdhdnmin, Min( cdhdnmax, xdn(mgs,lh) ) ) )/(cdhdnmax - cdhdnmin) ) ) + ELSEIF ( icdx .eq. 5 ) THEN + cd = cdx(lh)*(xdn(mgs,lh)/rho_qh)**(2./3.) + ELSEIF ( icdx .eq. 6 ) THEN ! Milbrandt and Morrison (2013) + aax = axx(mgs,lh) + bbx = bxx(mgs,lh) + ELSEIF ( icdx <= 0 ) THEN ! + aax = ax(lh) + bbx = bx(lh) + ENDIF + + ELSEIF ( lhl .gt. 1 .and. il .eq. lhl ) THEN + + IF ( icdxhl .eq. 1 ) THEN + cd = cdx(lhl) + ELSEIF ( icdxhl .eq. 3 ) THEN +! cd = Max(0.45, Min(1.0, 0.45 + 0.55*(800.0 - Max( 300., Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 300.) ) ) + cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hldnmn, Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 170.0) ) ) + ELSEIF ( icdxhl .eq. 4 ) THEN + cd = Max(cdhlmin, Min(cdhlmax, cdhlmin + (cdhlmax-cdhlmin)* & + & (cdhldnmax - Max( cdhldnmin, Min( cdhldnmax, xdn(mgs,lhl) ) ) )/(cdhldnmax - cdhldnmin) ) ) + ELSEIF ( icdxhl == 5 ) THEN +! cd = Max(0.6, Min(1.0, 0.6 + 0.4*(900.0 - xdn(mgs,lhl))/(900. - 300.) ) ) +! cd = Max(0.5, Min(0.8, 0.5 + 0.3*(xdnmx(lhl) - xdn(mgs,lhl))/(xdnmx(lhl)-xdnmn(lhl)) ) ) + cd = Max(0.45, Min(0.6, 0.45 + 0.15*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 500.) ) ) + ELSEIF ( icdxhl .eq. 6 ) THEN ! Milbrandt and Morrison (2013) + aax = axx(mgs,lhl) + bbx = bxx(mgs,lhl) + ENDIF + + ENDIF ! } + + IF ( alpha(mgs,il) .eq. 0. .and. infdo .lt. 2 .and. & + ( ( il==lh .and. icdx > 0 .and. icdx /= 6) .or. ( il==lhl .and. icdxhl > 0 .and. icdxhl /= 6 ) ) ) THEN ! { + vtxbar(mgs,il,2) = & + & Sqrt( (xdn(mgs,il)*xdia(mgs,il,1)*pi*gr) / & + & (3.0*cd*Max(0.05,rho0(mgs))) ) + + ELSE + IF ( il == lh .and. icdx /= 6 ) bbx = bx(il) + IF ( il == lhl .and. icdxhl /= 6 ) bbx = bx(il) + tmp = 1. + alpha(mgs,il) + bbx + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = 1. + alpha(mgs,il) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + IF ( il .eq. lh .or. il .eq. lhl) THEN ! { + IF ( ( il==lh .and. icdx > 0 ) ) THEN + IF ( icdx /= 6 ) THEN + aax = Sqrt(4.0*xdn(mgs,il)*gr/(3.0*cd*rho00)) + vtxbar(mgs,il,2) = rhovt(mgs)*aax* xdia(mgs,il,1)**bx(il) * x/y + ELSE ! (icdx == 6 ) THEN + vtxbar(mgs,il,2) = rhovt(mgs)*aax* xdia(mgs,il,1)**bbx * x/y + ENDIF + + ELSEIF ( ( il==lhl .and. icdxhl > 0 ) ) THEN + IF ( icdxhl /= 6 ) THEN + aax = Sqrt(4.0*xdn(mgs,il)*gr/(3.0*cd*rho00)) + vtxbar(mgs,il,2) = rhovt(mgs)*aax* xdia(mgs,il,1)**bx(il) * x/y + ELSE ! ( icdxhl == 6 ) + vtxbar(mgs,il,2) = rhovt(mgs)*aax* xdia(mgs,il,1)**bbx * x/y + ENDIF + ELSE ! get here if il==lh and icdx < 0 -- or -- il==lhl and icdxhl < 0 + aax = ax(il) + vtxbar(mgs,il,2) = rhovt(mgs)*ax(il)*(xdia(mgs,il,1)**bx(il)*x)/y + ENDIF +! vtxbar(mgs,il,2) = & +! & rhovt(mgs)*(xdn(mgs,il)/400.)*(75.715*xdia(mgs,il,1)**0.6* & +! & x)/y +! vtxbar(mgs,il,2) = & +! & rhovt(mgs)*(xdn(mgs,il)/400.)*(ax(il)*xdia(mgs,il,1)**bx(il)* & +! & x)/y + IF ( infdo .ge. 2 ) THEN ! Z-weighted + + tmp = 7. + alpha(mgs,il) + bbx + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = 7. + alpha(mgs,il) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + vtxbar(mgs,il,3) = rhovt(mgs)* & + & (aax*(xdia(mgs,il,1) )**bbx * & + & x)/y +! & Gamma(7.0 + alpha(mgs,il) + bbx)/Gamma(7. + alpha(mgs,il)) + IF ( .not. (vtxbar(mgs,il,1) > -1. .and. vtxbar(mgs,il,1) < 200. ) .or. & + .not. (vtxbar(mgs,il,3) > -1. .and. vtxbar(mgs,il,3) < 200. ) ) THEN + write(0,*) 'Setvtz: problem with vtxbar1/3: ',il,vtxbar(mgs,il,1),vtxbar(mgs,il,3),aax,bbx,x,y + write(0,*) 'q, number, diam1,3(mm) = ', qx(mgs,il),cx(mgs,il),1000.*xdia(mgs,il,1),1000.*xdia(mgs,il,3) + ! call commasmpi_abort() + ENDIF +! & (aax*(1.0/xdia(mgs,il,1) )**(- bx(il))* & +! & Gamma_sp(7.0 + alpha(mgs,il) + bx(il)))/Gamma_sp(7. + alpha(mgs,il)) + ENDIF + + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set hail vt3' + + ELSE ! hail + vtxbar(mgs,il,2) = & + & rhovt(mgs)*(ax(il)*xdia(mgs,il,1)**bx(il)* & + & x)/y + + IF ( infdo .ge. 2 ) THEN ! Z-weighted + vtxbar(mgs,il,3) = rhovt(mgs)* & + & (aax*(1.0/xdia(mgs,il,1) )**(- bbx)* & + & Gamma_sp(7.0 + alpha(mgs,il) + bbx))/Gamma_sp(7. + alpha(mgs,il)) +! & (ax(il)*(1.0/xdia(mgs,il,1) )**(- bx(il))* & +! & Gamma_sp(7.0 + alpha(mgs,il) + bx(il)))/Gamma_sp(7. + alpha(mgs,il)) + ENDIF + + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set hail vt4' + + ENDIF ! } +! & Gamma_sp(1.0 + dnu(il) + 0.6)/Gamma_sp(1. + dnu(il)) + ENDIF ! } + +! IF ( infdo .ge. 2 ) THEN ! Z-weighted +! vtxbar(mgs,il,3) = rhovt(mgs)* & +! & (ax(il)*(1.0/xdia(mgs,il,1) )**(- bx(il))* & +! & Gamma_sp(7.0 + alpha(mgs,il) + bx(il)))/Gamma_sp(7. + alpha(mgs,il)) +! ENDIF + +! IF ( lhl .gt. 1 .and. il .eq. lhl ) THEN +! write(0,*) 'setvt: ',qx(mgs,il),xdia(mgs,il,1),xdia(mgs,il,3),dnu(il),ax(il),bx(il) +! ENDIF + ELSEIF ( (il .eq. lh .and. hssflg == 0) .or. ( lhl .gt. 1 .and. il .eq. lhl .and. hlssflg == 0) ) THEN ! no size-sorting for graupel or hail + vtxbar(mgs,il,2) = vtxbar(mgs,il,1) + vtxbar(mgs,il,3) = vtxbar(mgs,il,1) + ELSE ! not lh or lhl + vtxbar(mgs,il,2) = & + & Sqrt( (xdn(mgs,il)*xdia(mgs,il,1)*pi*gr) / & + & (3.0*cdx(il)*Max(0.05,rho0(mgs))) ) + vtxbar(mgs,il,3) = vtxbar(mgs,il,1) + + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set graupel vt5' + + + ENDIF + ELSE ! qx < qxmin + vtxbar(mgs,il,2) = 0.0 + + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set graupel vt6' + + ENDIF + ENDDO ! mgs + + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set graupel vt7' + + ENDIF + ENDDO ! il + + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set graupel vt8' + + ENDIF ! lg .gt. 1 + +! ENDIF +! ENDDO + + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set graupel vt9' + +! DO mgs = 1,ngscnt +! IF ( qx(mgs,lr) > qxmin(lr) ) THEN +! write(0,*) 'setvt2: mgs,lzr,infdo = ',mgs,lzr,infdo +! write(0,*) 'vt1,2,3 = ',vtxbar(mgs,lr,1),vtxbar(mgs,lr,2),vtxbar(mgs,lr,3) +! ENDIF +! ENDDO + + ENDIF ! infdo .ge. 1 + + IF ( lh > 0 .and. graupelfallfac /= 1.0 ) THEN + DO mgs = 1,ngscnt + vtxbar(mgs,lh,1) = graupelfallfac*vtxbar(mgs,lh,1) + vtxbar(mgs,lh,2) = graupelfallfac*vtxbar(mgs,lh,2) + vtxbar(mgs,lh,3) = graupelfallfac*vtxbar(mgs,lh,3) + axx(mgs,lh) = graupelfallfac*axx(mgs,lh) + ENDDO + ENDIF + + IF ( lhl > 0 .and. hailfallfac /= 1.0 ) THEN + DO mgs = 1,ngscnt + vtxbar(mgs,lhl,1) = hailfallfac*vtxbar(mgs,lhl,1) + vtxbar(mgs,lhl,2) = hailfallfac*vtxbar(mgs,lhl,2) + vtxbar(mgs,lhl,3) = hailfallfac*vtxbar(mgs,lhl,3) + axx(mgs,lhl) = hailfallfac*axx(mgs,lhl) + ENDDO + ENDIF + + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: END OF ROUTINE' + +!############ SETVTZ ############################ + + RETURN + END SUBROUTINE setvtz +!-------------------------------------------------------------------------- + +! +! ############################################################################## + +! +! subroutine to calculate fall speeds of hydrometeors +! + +!>\ingroup mod_nsslmp +!! Column-wise front end to setvtz for sedimentation + subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & + & xvt, rhovtzx, & + & an,dn,ipconc0,t0,t7,cwmasn,cwmasx, & + & cwradn, & + & qxmin,xdnmx,xdnmn,cdx,cno,xdn0,xvmn,xvmx, & + & ngs,qx,qxw,cx,xv,vtxbar,xmas,xdn,xdia,vx,alpha,zx,igs,kgs, & + & rho0,temcg,temg,rhovt,cwnc,cinc,fadvisc,cwdia,cipmas,cnina,cimas, & + & cnostmp, & + & infdo,ildo,timesetvt) + +! 12.16.2005: .F version use in transitional SWM model +! +! 10.10.2003: Added cimn and cimx to setting for cci and cip. +! +! TO DO LIST: +! +! need to set up values for: +! : cipdia,cidia,cwdia,cwmas,vtwbar, +! : rho0,temcg,cip,cci +! +! and need to put fallspeed values in cwvt etc. +! + + implicit none + integer ng1 + parameter(ng1 = 1) + + integer, intent(in) :: ixcol ! which column to return + integer, intent(in) :: ildo + + integer nx,ny,nz,nor,norz,ngt,jgs,na + real an(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor,na) + real dn(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) + real t0(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) + real t7(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) + real dtp,dtz1 + + real :: rhovtzx(nz,nx) + + integer ndebugzf + parameter (ndebugzf = 0) + + integer ix,jy,kz,i,j,k,il + integer infdo +! +! + real xvt(nz+1,nx,3,lc:lhab) ! 1=mass-weighted, 2=number-weighted + + real qxmin(lc:lhab) + real xdn0(lc:lhab) + real xvmn(lc:lhab), xvmx(lc:lhab) + double precision,optional :: timesetvt + + integer :: ngs + integer :: ngscnt,mgs,ipconc0 +! parameter ( ngs=200 ) + + real :: qx(ngs,lv:lhab) + real :: qxw(ngs,ls:lhab) + real :: cx(ngs,lc:lhab) + real :: xv(ngs,lc:lhab) + real :: vtxbar(ngs,lc:lhab,3) + real :: xmas(ngs,lc:lhab) + real :: xdn(ngs,lc:lhab) + real :: cdxgs(ngs,lc:lhab) + real :: xdia(ngs,lc:lhab,3) + real :: vx(ngs,li:lhab) + real :: alpha(ngs,lc:lhab) + real :: zx(ngs,lr:lhab) + + real xdnmx(lc:lhab), xdnmn(lc:lhab) + real :: axx(ngs,lh:lhab), bxx(ngs,lh:lhab) +! real axh(ngs),bxh(ngs),axhl(ngs),bxhl(ngs) + +! +! drag coefficients +! + real cdx(lc:lhab) +! +! Fixed intercept values for single moment scheme +! + real cno(lc:lhab) + + real cwccn0,cwmasn,cwmasx,cwradn +! real cwc0 + + integer nxmpb,nzmpb,nxz,numgs,inumgs + integer kstag + parameter (kstag=1) + + integer igs(ngs),kgs(ngs) + + real rho0(ngs),temcg(ngs) + + real temg(ngs) + + real rhovt(ngs) + + real cwnc(ngs),cinc(ngs) + real fadvisc(ngs),cwdia(ngs),cipmas(ngs) + +! real cimasn,cimasx, + real :: cnina(ngs),cimas(ngs) + + real :: cnostmp(ngs) + +! real pii +! +! +! general constants for microphysics +! + +! +! Miscellaneous +! + + logical flag + logical ldoliq + + + real chw, qr, z, rd, alp, z1, g1, vr, nrx, tmp + + real vtmax + real xvbarmax + + integer l1, l2 + + double precision :: dpt1, dpt2 + + +!----------------------------------------------------------------------------- +! MPI LOCAL VARIABLES + + integer :: ixb, jyb, kzb + integer :: ixe, jye, kze + + logical :: debug_mpi = .false. + + + if (ndebugzf .gt. 0 ) write(0,*) "ZIEGFALL: ENTERED SUBROUTINE" + +! ##################################################################### +! BEGIN EXECUTABLE +! ##################################################################### +! + +! constants +! + + ldoliq = .false. + IF ( ls .gt. 1 ) THEN + DO il = ls,lhab + ldoliq = ldoliq .or. ( lliq(il) .gt. 1 ) + ENDDO + ENDIF + +! poo = 1.0e+05 +! cp608 = 0.608 +! cp = 1004.0 +! cv = 717.0 +! dnz00 = 1.225 +! rho00 = 1.225 +! cs = 4.83607122 +! ds = 0.25 +! new values for cs and ds +! cs = 12.42 +! ds = 0.42 +! pi = 4.0*atan(1.0) +! pii = piinv ! 1./pi +! pid4 = pi/4.0 +! qccrit = 2.0e-03 +! qscrit = 6.0e-04 +! cwc0 = pii + +! +! +! general constants for microphysics +! + +! +! ci constants in mks units +! +! cimasn = 6.88e-13 +! cimasx = 1.0e-8 +! +! Set terminal velocities... +! also set drag coefficients +! + jy = jgs + nxmpb = ixcol + nzmpb = 1 + nxz = 1*nz +! ngs = nz + numgs = 1 + + IF ( ildo == 0 ) THEN + l1 = lc + l2 = lhab + ELSE + l1 = ildo + l2 = ildo + ENDIF + + + do inumgs = 1,numgs + ngscnt = 0 + + + do kz = nzmpb,nz + do ix = ixcol,ixcol + flag = .false. + + + DO il = l1,l2 + flag = flag .or. ( an(ix,jy,kz,il) .gt. qxmin(il) ) + ENDDO + + if ( flag ) then +! load temp quantities + + ngscnt = ngscnt + 1 + igs(ngscnt) = ix + kgs(ngscnt) = kz + if ( ngscnt .eq. ngs ) goto 1100 + end if + end do !!ix + nxmpb = 1 + end do !! kz + +! if ( jy .eq. (ny-jstag) ) iend = 1 + + 1100 continue + + if ( ngscnt .eq. 0 ) go to 9998 +! +! set temporaries for microphysics variables +! + + +! +! Reconstruct various quantities +! + do mgs = 1,ngscnt + + rho0(mgs) = dn(igs(mgs),jy,kgs(mgs)) + rhovt(mgs) = rhovtzx(kgs(mgs),ixcol) ! Sqrt(rho00/rho0(mgs)) + temg(mgs) = t0(igs(mgs),jy,kgs(mgs)) + temcg(mgs) = temg(mgs) - tfr + + +! + end do +! +! only need fadvisc for + IF ( lc .gt. 1 .and. (ildo == 0 .or. ildo == lc ) ) then + do mgs = 1,ngscnt + fadvisc(mgs) = advisc0*(416.16/(temg(mgs)+120.0))* & + & (temg(mgs)/296.0)**(1.5) + end do + ENDIF + + IF ( ipconc .eq. 0 ) THEN + do mgs = 1,ngscnt + cnina(mgs) = t7(igs(mgs),jgs,kgs(mgs)) + end do + ENDIF + + + IF ( ildo > 0 ) THEN + vtxbar(:,ildo,:) = 0.0 + ELSE + vtxbar(:,:,:) = 0.0 + ENDIF + +! do mgs = 1,ngscnt +! qx(mgs,lv) = max(an(igs(mgs),jy,kgs(mgs),lv), 0.0) +! ENDDO + DO il = l1,l2 + do mgs = 1,ngscnt + qx(mgs,il) = max(an(igs(mgs),jy,kgs(mgs),il), 0.0) + ENDDO + end do + + cnostmp(:) = cno(ls) + IF ( ipconc < 1 .and. lwsm6 .and. (ildo == 0 .or. ildo == ls )) THEN + DO mgs = 1,ngscnt + tmp = Min( 0.0, temcg(mgs) ) + cnostmp(mgs) = Min( 2.e8, 2.e6*exp(0.12*tmp) ) + ENDDO + ENDIF + + +! +! set concentrations +! + cx(:,:) = 0.0 + + if ( ipconc .ge. 1 .and. li .gt. 1 .and. (ildo == 0 .or. ildo == li ) ) then + do mgs = 1,ngscnt + cx(mgs,li) = Max(an(igs(mgs),jy,kgs(mgs),lni), 0.0) + end do + end if + if ( ipconc .ge. 2 .and. lc .gt. 1 .and. (ildo == 0 .or. ildo == lc ) ) then + do mgs = 1,ngscnt + cx(mgs,lc) = Max(an(igs(mgs),jy,kgs(mgs),lnc), 0.0) +! cx(mgs,lc) = Min( ccwmx, cx(mgs,lc) ) + end do + end if + if ( ipconc .ge. 3 .and. lr .gt. 1 .and. (ildo == 0 .or. ildo == lr ) ) then + do mgs = 1,ngscnt + cx(mgs,lr) = Max(an(igs(mgs),jy,kgs(mgs),lnr), 0.0) +! IF ( qx(mgs,lr) .le. qxmin(lr) ) THEN +! ELSE +! cx(mgs,lr) = Max( 0.0, cx(mgs,lr) ) +! ENDIF + end do + end if + if ( ipconc .ge. 4 .and. ls .gt. 1 .and. (ildo == 0 .or. ildo == ls ) ) then + do mgs = 1,ngscnt + cx(mgs,ls) = Max(an(igs(mgs),jy,kgs(mgs),lns), 0.0) +! IF ( qx(mgs,ls) .le. qxmin(ls) ) THEN +! ELSE +! cx(mgs,ls) = Max( 0.0, cx(mgs,ls) ) +! ENDIF + end do + end if + + if ( ipconc .ge. 5 .and. lh .gt. 1 .and. (ildo == 0 .or. ildo == lh ) ) then + do mgs = 1,ngscnt + + cx(mgs,lh) = Max(an(igs(mgs),jy,kgs(mgs),lnh), 0.0) +! IF ( qx(mgs,lh) .le. qxmin(lh) ) THEN +! ELSE +! cx(mgs,lh) = Max( 0.0, cx(mgs,lh) ) +! ENDIF + + end do + ENDIF + + if ( ipconc .ge. 5 .and. lhl .gt. 1 .and. (ildo == 0 .or. ildo == lhl ) ) then + do mgs = 1,ngscnt + + cx(mgs,lhl) = Max(an(igs(mgs),jy,kgs(mgs),lnhl), 0.0) +! IF ( qx(mgs,lhl) .le. qxmin(lhl) ) THEN +! cx(mgs,lhl) = 0.0 +! ELSEIF ( cx(mgs,lhl) .eq. 0.0 .and. qx(mgs,lhl) .lt. 3.0*qxmin(lhl) ) THEN +! qx(mgs,lhl) = 0.0 +! ELSE +! cx(mgs,lhl) = Max( 0.0, cx(mgs,lhl) ) +! ENDIF + + end do + end if + + do mgs = 1,ngscnt + xdn(mgs,lc) = xdn0(lc) + xdn(mgs,lr) = xdn0(lr) +! IF ( ls .gt. 1 .and. lvs .eq. 0 ) xdn(mgs,ls) = xdn0(ls) +! IF ( lh .gt. 1 .and. lvh .eq. 0 ) xdn(mgs,lh) = xdn0(lh) + IF ( li .gt. 1 ) xdn(mgs,li) = xdn0(li) + IF ( ls .gt. 1 ) xdn(mgs,ls) = xdn0(ls) + IF ( lh .gt. 1 ) xdn(mgs,lh) = xdn0(lh) + IF ( lhl .gt. 1 ) xdn(mgs,lhl) = xdn0(lhl) + end do + +! +! Set mean particle volume +! + IF ( ldovol .and. (ildo == 0 .or. ildo >= li ) ) THEN + + vx(:,:) = 0.0 + + DO il = l1,l2 + + IF ( lvol(il) .ge. 1 ) THEN + + DO mgs = 1,ngscnt + vx(mgs,il) = Max(an(igs(mgs),jy,kgs(mgs),lvol(il)), 0.0) + IF ( vx(mgs,il) .gt. rho0(mgs)*qxmin(il)*1.e-3 .and. qx(mgs,il) .gt. qxmin(il) ) THEN + xdn(mgs,il) = Min( xdnmx(il), Max( xdnmn(il), rho0(mgs)*qx(mgs,il)/vx(mgs,il) ) ) + ENDIF + ENDDO + + ENDIF + + ENDDO + + ENDIF + + DO il = lg,lhab + DO mgs = 1,ngscnt + alpha(mgs,il) = dnu(il) + ENDDO + ENDDO + + IF ( imurain == 1 ) THEN + alpha(:,lr) = alphar + ELSEIF ( imurain == 3 ) THEN + alpha(:,lr) = xnu(lr) + ENDIF + + + + + + + +! +! Set density +! + if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: call setvtz' +! + + call setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & + & xmas,vtxbar,xdn,xvmn,xvmx,xv,cdx,cdxgs, & + & ipconc,ndebugzf,ngs,nz,kgs,fadvisc, & + & cwmasn,cwmasx,cwradn,cnina,cimn,cimx, & + & itype1,itype2,temcg,infdo,alpha,ildo,axx,bxx) +! & itype1,itype2,temcg,infdo,alpha,ildo,axh,bxh,axhl,bxhl) + + + +! +! put fall speeds into the x-z arrays +! + DO il = l1,l2 + do mgs = 1,ngscnt + + vtmax = 150.0 + + + IF ( vtxbar(mgs,il,2) .gt. vtxbar(mgs,il,1) .or. & + & ( vtxbar(mgs,il,1) .gt. vtxbar(mgs,il,3) .and. vtxbar(mgs,il,3) > 0.0) ) THEN + + + + vtxbar(mgs,il,1) = Max( vtxbar(mgs,il,1), vtxbar(mgs,il,2) ) + vtxbar(mgs,il,3) = Max( vtxbar(mgs,il,3), vtxbar(mgs,il,1) ) + + ENDIF + + + IF ( vtxbar(mgs,il,1) .gt. vtmax .or. vtxbar(mgs,il,2) .gt. vtmax .or. & + & vtxbar(mgs,il,3) .gt. vtmax ) THEN + + vtxbar(mgs,il,1) = Min(vtmax,vtxbar(mgs,il,1) ) + vtxbar(mgs,il,2) = Min(vtmax,vtxbar(mgs,il,2) ) + vtxbar(mgs,il,3) = Min(vtmax,vtxbar(mgs,il,3) ) + +! call commasmpi_abort() + ENDIF + + + xvt(kgs(mgs),igs(mgs),1,il) = vtxbar(mgs,il,1) + xvt(kgs(mgs),igs(mgs),2,il) = vtxbar(mgs,il,2) + IF ( infdo .ge. 2 ) THEN + xvt(kgs(mgs),igs(mgs),3,il) = vtxbar(mgs,il,3) + ELSE + xvt(kgs(mgs),igs(mgs),3,il) = 0.0 + ENDIF + +! xvt(kgs(mgs),igs(mgs),2,il) = xvt(kgs(mgs),igs(mgs),1,il) + + enddo + ENDDO + + + if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: COPIED FALL SPEEDS' + + + + 9998 continue + + if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: DONE WITH LOOP' + + if ( kz .gt. nz-1 ) then + go to 1200 + else + nzmpb = kz + end if + + if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: SET NZMPB' + + end do !! inumgs + + if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: SET NXMPB' + + 1200 continue + + +! ENDDO ! ix +! ENDDO ! kz + + + if (ndebugzf .gt. 0 ) write(0,*) "ZIEGFALL: EXITING SUBROUTINE" + + + RETURN + END subroutine ziegfall1d + +! ##################################################################### +! ##################################################################### + + +! ##################################################################### +! ##################################################################### + +! ############################################################################## +!>\ingroup mod_nsslmp +!! Radar reflectivity calculation. Assumes ideal Rayleigh scattering. + subroutine radardd02(nx,ny,nz,nor,na,an,temk, & + & dbz,db,nzdbz,cnoh0t,hwdn1t,ipconc,ke_diag, iunit) +! +! 11.13.2005: Changed values of indices for reordering of lip +! +! 07.13.2005: Fixed an error where cnoh was being used for graupel and frozen drops +! +! 01.24.2005: add ice crystal reflectivity using parameterization of +! Heymsfield (JAS, 1977). Could also try Ferrier for this, too. +! +! 09.28.2002 Test alterations for dry ice following Ferrier (1994) +! for equivalent melted diameter reflectivity. +! Converted to Fortran by ERM. +! +!Date: Tue, 21 Nov 2000 10:13:36 -0600 (CST) +!From: Matthew Gilmore +! +!PRO RF_SPEC ; Computes Radar Reflectivity +!COMMON MAINB, data, x1d, y1d, z1d, iconst, rconst, labels, nx, ny, nz, dshft +! +!;MODIFICATION HISTORY +!; 5/99 -Svelta Veleva introduces variable dielf (const_ki_x) as a (weak) +!; function of density. This leads to slight modification of dielf such +!; that the snow reflectivity is slightly increased - not a big effect. +!; This is believed to be more accurate than assuming the dielectric +!; constant for snow is the same as for hail in previous versions. +! +!;On 6/13/99 I added the VIL computation (k=0 in vil array) +!;On 6/15/99 I removed the number concentration dependencies as a function +!; of temperature (only use for ferrier!) +!;On 6/15/99 I added the Composite reflectivity (k=1 in VIL array) +!;On 6/15/99 I added the Severe Hail Index computation (k=2 in vil array) +!; +!; 6/99 - Veleva and Seo argue that since graupel is more similar to +!; snow (in number conc and size density) than it is to hail, we +!; should not weight wetted graupel with the .95 exponent correction +!; factor as in the case of hail. An if-statement checks the size +!; density for wet hail/graupel and treats them appropriately. +!; +!; 6/22/99 - Added function to compute height of max rf and 40 dbz echo top +!; Also added vilqr which is the model vertical integrated liquid only +!; using qr. Will need to check...does not seem consistent with vilZ +!; + + + implicit none + + character(LEN=15), parameter :: microp = 'ZVD' + integer nx,ny,nz,nor,na,ngt + integer nzdbz ! how many levels actually to process + + integer ng1,n10 + integer iunit + integer, parameter :: printyn = 0 + + parameter( ng1 = 1 ) + + real cnoh0t,hwdn1t + integer ke_diag + integer ipconc + real vr + + + integer imapz,mzdist + + integer vzflag + integer, parameter :: norz = 3 + real an(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor,na) + real db(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) ! air density +! real gt(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor,ngt) + real temk(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) ! air temperature (kelvin) + real dbz(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) ! reflectivity + real gz(-nor+1:nz+nor) ! ,z1d(-nor+1:nz+nor,4) + +! real g,rgas,eta,inveta + real cr1, cr2 , hwdnsq,swdnsq + real rwdnsq, dhmin, qrmin, qsmin, qhmin, qhlmin, tfr, tfrh, zrc + real reflectmin, kw_sq + real const_ki_sn, const_ki_h, ki_sq_sn + real ki_sq_h, dielf_sn, dielf_h + real pi + logical ltest + +! Other data arrays + real gtmp (nx,nz) + real dtmp (nx,nz) + real tmp + + real*8 dtmps, dtmpr, dtmph, dtmphl, g1, zx, ze, x + + integer i,j,k,ix,jy,kz,ihcnt + + real*8 xcnoh, xcnos, dadh, dads, zhdryc, zsdryc, zhwetc,zswetc + real*8 dadr + real dbzmax,dbzmin + parameter ( dbzmin = 0 ) + + real cnow,cnoi,cnoip,cnoir,cnor,cnos + real cnogl,cnogm,cnogh,cnof,cnoh,cnohl + + real swdn, rwdn ,hwdn,gldn,gmdn,ghdn,fwdn,hldn + real swdn0 + + real rwdnmx,cwdnmx,cidnmx,xidnmx,swdnmx,gldnmx,gmdnmx + real ghdnmx,fwdnmx,hwdnmx,hldnmx + real rwdnmn,cwdnmn,cidnmn,xidnmn,swdnmn,gldnmn,gmdnmn + real ghdnmn,fwdnmn,hwdnmn,hldnmn + + real gldnsq,gmdnsq,ghdnsq,fwdnsq,hldnsq + + real dadgl,dadgm,dadgh,dadhl,dadf + real zgldryc,zglwetc,zgmdryc, zgmwetc,zghdryc,zghwetc + real zhldryc,zhlwetc,zfdryc,zfwetc + + real dielf_gl,dielf_gm,dielf_gh,dielf_hl,dielf_fw + + integer imx,jmx,kmx + + real swdia,gldia,gmdia,ghdia,fwdia,hwdia,hldia + + real csw,cgl,cgm,cgh,cfw,chw,chl + real xvs,xvgl,xvgm,xvgh,xvf,xvh,xvhl + + real cwc0 + integer izieg + integer ice10 + real rhos + parameter ( rhos = 0.1 ) + + real qxw,qxw1 ! temp value for liquid water on ice mixing ratio + real :: dnsnow + real qh + + real, parameter :: cwmasn = 5.23e-13 ! minimum mass, defined by radius of 5.0e-6 + real, parameter :: cwmasx = 5.25e-10 ! maximum mass, defined by radius of 50.0e-6 + real, parameter :: cwradn = 5.0e-6 ! minimum radius + + real cwnccn(nz) + + real :: vzsnow, vzrain, vzgraupel, vzhail + real :: ksq + real :: dtp + + +! ######################################################################### + + vzflag = 0 + + izieg = 0 + ice10 = 0 +! g=9.806 ! g: gravity constant +! rgas=287.04 ! rgas: gas constant for dry air +! rcp=rgas/cp ! rcp: gamma constant +! eta=0.622 +! inveta = 1./eta +! rcpinv = 1./rcp +! cpr=cp/rgas +! cvr=cv/rgas + pi = 4.0*ATan(1.) + cwc0 = piinv ! 1./pi ! 6.0/pi + + cnoh = cnoh0t + hwdn = hwdn1t + + rwdn = 1000.0 + swdn = 100.0 + + qrmin = 1.0e-05 + qsmin = 1.0e-06 + qhmin = 1.0e-05 + +! +! default slope intercepts +! + cnow = 1.0e+08 + cnoi = 1.0e+08 + cnoip = 1.0e+08 + cnoir = 1.0e+08 + cnor = 8.0e+06 + cnos = 8.0e+06 + cnogl = 4.0e+05 + cnogm = 4.0e+05 + cnogh = 4.0e+05 + cnof = 4.0e+05 + cnohl = 1.0e+03 + + + imx = 1 + jmx = 1 + kmx = 1 + i = 1 + + + IF ( microp(1:4) .eq. 'ZIEG' ) THEN ! na .ge. 14 .and. ipconc .ge. 3 ) THEN + +! write(0,*) 'Set reflectivity for ZIEG' + izieg = 1 + + hwdn = hwdn1t ! 500. + + + cnor = cno(lr) + cnos = cno(ls) + cnoh = cno(lh) + qrmin = qxmin(lr) + qsmin = qxmin(ls) + qhmin = qxmin(lh) + IF ( lhl .gt. 1 ) THEN + cnohl = cno(lhl) + qhlmin = qxmin(lhl) + ENDIF + + ELSEIF ( microp(1:3) .eq. 'ZVD' ) THEN ! na .ge. 14 .and. ipconc .ge. 3 ) THEN + + izieg = 1 + + swdn0 = swdn + + cnor = cno(lr) + cnos = cno(ls) + cnoh = cno(lh) + + qrmin = qxmin(lr) + qsmin = qxmin(ls) + qhmin = qxmin(lh) + IF ( lhl .gt. 1 ) THEN + cnohl = cno(lhl) + qhlmin = qxmin(lhl) + ENDIF +! write(*,*) 'radardbz: ',db(1,1,1),temk(1,1,1),an(1,1,1,lr),an(1,1,1,ls),an(1,1,1,lh) + + + ENDIF + + +! cdx(lr) = 0.60 +! +! IF ( lh > 1 ) THEN +! cdx(lh) = 0.8 ! 1.0 ! 0.45 +! cdx(ls) = 2.00 +! ENDIF +! +! IF ( lhl .gt. 1 ) cdx(lhl) = 0.45 +! +! xvmn(lc) = xvcmn +! xvmn(lr) = xvrmn +! +! xvmx(lc) = xvcmx +! xvmx(lr) = xvrmx +! +! IF ( lh > 1 ) THEN +! xvmn(ls) = xvsmn +! xvmn(lh) = xvhmn +! xvmx(ls) = xvsmx +! xvmx(lh) = xvhmx +! ENDIF +! +! IF ( lhl .gt. 1 ) THEN +! xvmn(lhl) = xvhlmn +! xvmx(lhl) = xvhlmx +! ENDIF +! +! xdnmx(lr) = 1000.0 +! xdnmx(lc) = 1000.0 +! IF ( lh > 1 ) THEN +! xdnmx(li) = 917.0 +! xdnmx(ls) = 300.0 +! xdnmx(lh) = 900.0 +! ENDIF +! IF ( lhl .gt. 1 ) xdnmx(lhl) = 900.0 +!! +! xdnmn(:) = 900.0 +! +! xdnmn(lr) = 1000.0 +! xdnmn(lc) = 1000.0 +! IF ( lh > 1 ) THEN +! xdnmn(li) = 100.0 +! xdnmn(ls) = 100.0 +! xdnmn(lh) = hdnmn +! ENDIF +! IF ( lhl .gt. 1 ) xdnmn(lhl) = 500.0 +! +! xdn0(:) = 900.0 +! +! xdn0(lc) = 1000.0 +! xdn0(lr) = 1000.0 +! IF ( lh > 1 ) THEN +! xdn0(li) = 900.0 +! xdn0(ls) = 100.0 ! 100.0 +! xdn0(lh) = hwdn1t ! (0.5)*(xdnmn(lh)+xdnmx(lh)) +! ENDIF +! IF ( lhl .gt. 1 ) xdn0(lhl) = 800.0 + +! +! slope intercepts +! +! cnow = 1.0e+08 +! cnoi = 1.0e+08 +! cnoip = 1.0e+08 +! cnoir = 1.0e+08 +! cnor = 8.0e+06 +! cnos = 8.0e+06 +! cnogl = 4.0e+05 +! cnogm = 4.0e+05 +! cnogh = 4.0e+05 +! cnof = 4.0e+05 +!c cnoh = 4.0e+04 +! cnohl = 1.0e+03 +! +! +! density maximums and minimums +! + rwdnmx = 1000.0 + cwdnmx = 1000.0 + cidnmx = 917.0 + xidnmx = 917.0 + swdnmx = 200.0 + gldnmx = 400.0 + gmdnmx = 600.0 + ghdnmx = 800.0 + fwdnmx = 900.0 + hwdnmx = 900.0 + hldnmx = 900.0 +! + rwdnmn = 1000.0 + cwdnmn = 1000.0 + xidnmn = 001.0 + cidnmn = 001.0 + swdnmn = 001.0 + gldnmn = 200.0 + gmdnmn = 400.0 + ghdnmn = 600.0 + fwdnmn = 700.0 + hwdnmn = 700.0 + hldnmn = 900.0 + + + gldn = (0.5)*(gldnmn+gldnmx) ! 300. + gmdn = (0.5)*(gmdnmn+gmdnmx) ! 500. + ghdn = (0.5)*(ghdnmn+ghdnmx) ! 700. + fwdn = (0.5)*(fwdnmn+fwdnmx) ! 800. + hldn = (0.5)*(hldnmn+hldnmx) ! 900. + + + cr1 = 7.2e+20 + cr2 = 7.295e+19 + hwdnsq = hwdn**2 + swdnsq = swdn**2 + rwdnsq = rwdn**2 + + gldnsq = gldn**2 + gmdnsq = gmdn**2 + ghdnsq = ghdn**2 + fwdnsq = fwdn**2 + hldnsq = hldn**2 + + dhmin = 0.005 + tfr = 273.16 + tfrh = tfr - 8.0 + zrc = cr1*cnor + reflectmin = 0.0 + kw_sq = 0.93 + dbzmax = dbzmin + + ihcnt=0 + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Dielectric Factor - Formulas implemented by Svetla Veleva +! following Battan, "Radar Meteorology" - p. 40 +! The result of these calculations is that the dielf numerator (ki_sq) without +! the density ratio is .2116 for hail if using 917 density and .25 for +! snow if using 220 density. +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + const_ki_sn = 0.5 - (0.5-0.46)/(917.-220.)*(swdn-220.) + const_ki_h = 0.5 - (0.5-0.46)/(917.-220.)*(hwdn-220.) + ki_sq_sn = (swdnsq/rwdnsq) * const_ki_sn**2 + ki_sq_h = (hwdnsq/rwdnsq) * const_ki_h**2 + dielf_sn = ki_sq_sn / kw_sq + dielf_h = ki_sq_h / kw_sq + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Use the next line if you want to hardwire dielf for dry hail for both dry +! snow and dry hail. +! This would be equivalent to what Straka had originally. (i.e, .21/.93) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + dielf_sn = (swdnsq/rwdnsq)*.21/ kw_sq + dielf_h = (hwdnsq/rwdnsq)*.21/ kw_sq + + dielf_gl = (gldnsq/rwdnsq)*.21/ kw_sq + dielf_gm = (gmdnsq/rwdnsq)*.21/ kw_sq + dielf_gh = (ghdnsq/rwdnsq)*.21/ kw_sq + dielf_hl = (hldnsq/rwdnsq)*.21/ kw_sq + dielf_fw = (fwdnsq/rwdnsq)*.21/ kw_sq + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Notes on dielectric factors - from Eun-Kyoung Seo +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! constants for both snow and hail would be (x=s,h)..... +! xwdnsq/rwdnsq *0.21/kw_sq ! Straka/Smith - the original +! xwdnsq/rwdnsq *0.224 ! Ferrier - for particle sizes in equiv. drop diam +! xwdnsq/rwdnsq *0.176/kw_sq ! =0.189 in Smith - for particle sizes in equiv +! ice spheres +! xwdnsq/rwdnsq *0.208/kw_sq ! Smith 1984 - for particle sizes in equiv melted drop diameter +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +! VIL algorithm constants +! Ztop = 10.**(56./10) !56 dbz is the max rf used by WATADS in cell vil + + +! Hail detection algorithm constants +! ZL = 40. +! ZU = 50. +! Ho = 3400. !WATADS Defaults +! Hm20 = 6200. !WATADS Defaults + +! DO kz = 1,Min(nzdbz,nz-1) + + DO jy=1,1 + + DO kz = 1,ke_diag ! nz + + DO ix=1,nx + dbz(ix,jy,kz) = 0.0 + + vzsnow = 0.0 + vzrain = 0.0 + vzgraupel = 0.0 + vzhail = 0.0 + + dtmph = 0.0 + dtmps = 0.0 + dtmphl = 0.0 + dtmpr = 0.0 + dadr = (db(ix,jy,kz)/(pi*rwdn*cnor))**(0.25) +!----------------------------------------------------------------------- +! Compute Rain Radar Reflectivity +!----------------------------------------------------------------------- + + dtmp(ix,kz) = 0.0 + gtmp(ix,kz) = 0.0 + IF ( an(ix,jy,kz,lr) .ge. qrmin ) THEN + IF ( ipconc .le. 2 ) THEN + gtmp(ix,kz) = dadr*an(ix,jy,kz,lr)**(0.25) + dtmp(ix,kz) = zrc*gtmp(ix,kz)**7 + ELSEIF ( an(ix,jy,kz,lnr) .gt. 1.e-3 ) THEN + IF ( imurain == 3 ) THEN + vr = db(ix,jy,kz)*an(ix,jy,kz,lr)/(1000.*an(ix,jy,kz,lnr)) + dtmp(ix,kz) = 3.6e18*(rnu+2.)*an(ix,jy,kz,lnr)*vr**2/(rnu+1.) + ELSE ! imurain == 1 + g1 = (6.0 + alphar)*(5.0 + alphar)*(4.0 + alphar)/((3.0 + alphar)*(2.0 + alphar)*(1.0 + alphar)) + zx = g1*(db(ix,jy,kz)*an(ix,jy,kz,lr))**2/an(ix,jy,kz,lnr) + ze =1.e18*zx*(6./(pi*1000.))**2 ! note: using 1000. here for water density + dtmp(ix,kz) = ze + ENDIF + ENDIF + dtmpr = dtmp(ix,kz) + ENDIF + +!----------------------------------------------------------------------- +! Compute snow and graupel reflectivity +! +! Lou modified to look at parcel temperature rather than base state +!----------------------------------------------------------------------- + + IF( lhab .gt. lr ) THEN + +! qs2d = reform(data[*,*,k,10],[nx*ny]) +! qh2d = reform(data[*,*,k,11],[nx*ny]) + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Only use the following lines if running Straka GEMS microphysics +! (Sam 1-d version modified by L Wicker does not use this) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! ;xcnoh = cnoh*exp(-0.025*(temp-tfr)) +! ;xcnos = cnos*exp(-0.038*(temp-tfr)) +! ;good = where(temp GT tfr, n_elements) +! ;IF n_elements NE 0 THEN xcnoh(good) = cnoh*exp(-0.075*(temp(good)-tfr)) +! ;IF n_elements NE 0 THEN xcnos(good) = cnos*exp(-0.088*(temp(good)-tfr)) + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Only use the following lines if running Ferrier micro with No=No(T) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! ; NOSE = -.15 +! ; NOGE = .0 +! ; xcnoh = cnoh*(1.>exp(NOGE*(temp-tfr)) ) +! ; xcnos = cnos*(1.>exp(NOSE*(temp-tfr)) ) + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Use the following lines if Nos and Noh are constant +! (As in Svetla version of Ferrier, GCE Tao, and SAM 1-d) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + xcnoh = cnoh + xcnos = cnos + +! +! Temporary fix for predicted number concentration -- need a +! more appropriate reflectivity equation! +! +! IF ( an(ix,jy,kz,lns) .lt. 0.1 ) THEN +! swdia = (xvrmn*cwc0)**(1./3.) +! xcnos = an(ix,jy,kz,ls)*db(ix,jy,kz)/(xvrmn*swdn*swdia) +! ELSE +! ! changed back to diameter of mean volume!!! +! swdia = +! > (an(ix,jy,kz,ls)*db(ix,jy,kz) +! > /(pi*swdn*an(ix,jy,kz,lns)))**(1./3.) +! +! xcnos = an(ix,jy,kz,lns)/swdia +! ENDIF + + IF ( ls .gt. 1 ) THEN ! { + + IF ( lvs .gt. 1 ) THEN + IF ( an(ix,jy,kz,lvs) .gt. 0.0 ) THEN + swdn = db(ix,jy,kz)*an(ix,jy,kz,ls)/an(ix,jy,kz,lvs) + swdn = Min( 300., Max( 100., swdn ) ) + ELSE + swdn = swdn0 + ENDIF + + ENDIF + + IF ( ipconc .ge. 5 ) THEN ! { + + xvs = db(ix,jy,kz)*an(ix,jy,kz,ls)/ & + & (swdn*Max(1.0e-3,an(ix,jy,kz,lns))) + IF ( xvs .lt. xvsmn .or. xvs .gt. xvsmx ) THEN + xvs = Min( xvsmx, Max( xvsmn,xvs ) ) + csw = db(ix,jy,kz)*an(ix,jy,kz,ls)/(xvs*swdn) + ENDIF + + swdia = (xvs*cwc0)**(1./3.) + xcnos = an(ix,jy,kz,ls)*db(ix,jy,kz)/(xvs*swdn*swdia) + + ENDIF ! } + ENDIF ! } + +! IF ( an(ix,jy,kz,lnh) .lt. 0.1 ) THEN +! hwdia = (xvrmn*cwc0)**(1./3.) +! xcnoh = an(ix,jy,kz,lh)*db(ix,jy,kz)/(xvrmn*hwdn*hwdia) +! ELSE +! ! changed back to diameter of mean volume!!! +! hwdia = +! > (an(ix,jy,kz,lh)*db(ix,jy,kz) +! > /(pi*hwdn*an(ix,jy,kz,lnh)))**(1./3.) +! +! xcnoh = an(ix,jy,kz,lnh)/hwdia +! ENDIF + + IF ( lh .gt. 1 ) THEN ! { + + IF ( lvh .gt. 1 ) THEN + IF ( an(ix,jy,kz,lvh) .gt. 0.0 ) THEN + hwdn = db(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh) + hwdn = Min( 900., Max( hdnmn, hwdn ) ) + ELSE + hwdn = 500. ! hwdn1t + ENDIF + ELSE + hwdn = hwdn1t + ENDIF + + IF ( ipconc .ge. 5 ) THEN ! { + + xvh = db(ix,jy,kz)*an(ix,jy,kz,lh)/ & + & (hwdn*Max(1.0e-3,an(ix,jy,kz,lnh))) + IF ( xvh .lt. xvhmn .or. xvh .gt. xvhmx ) THEN + xvh = Min( xvhmx, Max( xvhmn,xvh ) ) + chw = db(ix,jy,kz)*an(ix,jy,kz,lh)/(xvh*hwdn) + ENDIF + + hwdia = (xvh*cwc0)**(1./3.) + xcnoh = an(ix,jy,kz,lh)*db(ix,jy,kz)/(xvh*hwdn*hwdia) + + ENDIF ! } ipconc .ge. 5 + + ENDIF ! } + + dadh = 0.0 + dadhl = 0.0 + dads = 0.0 + IF ( xcnoh .gt. 0.0 ) THEN + dadh = ( db(ix,jy,kz) /(pi*hwdn*xcnoh) )**(.25) + zhdryc = 0.224*cr2*(db(ix,jy,kz)/rwdn)**2/xcnoh ! dielf_h*cr1*xcnoh ! SV - equiv formula as before but + ! ratio of densities included in + ! dielf_h rather than here following + ! Battan. + ELSE + dadh = 0.0 + zhdryc = 0.0 + ENDIF + + IF ( xcnos .gt. 0.0 ) THEN + dads = ( db(ix,jy,kz) /(pi*swdn*xcnos) )**(.25) + zsdryc = 0.224*cr2*(db(ix,jy,kz)/rwdn)**2/xcnos ! dielf_sn*cr1*xcnos ! SV - similar change as above + ELSE + dads = 0.0 + zsdryc = 0.0 + ENDIF + zhwetc = zhdryc ! cr1*xcnoh !Hail/graupel version with .95 power bug removed + zswetc = zsdryc ! cr1*xcnos +! +! snow contribution +! + IF ( ls .gt. 1 ) THEN + + gtmp(ix,kz) = 0.0 + qxw = 0.0 + qxw1 = 0.0 + dtmps = 0.0 + IF ( an(ix,jy,kz,ls) .ge. qsmin ) THEN !{ + IF ( ipconc .ge. 4 ) THEN ! (Ferrier 94) !{ + + if (lsw .gt. 1) THEN + qxw = an(ix,jy,kz,lsw) + qxw1 = 0.0 + ELSEIF ( ( iusewetsnow == 1 .or. iusewetsnow == 3) .and. temk(ix,jy,kz) .gt. tfr+1. & + & .and. an(ix,jy,kz,ls) > an(ix,jy,kz,lr) .and. an(ix,jy,kz,lr) > qsmin) THEN + qxw = Min(0.5*an(ix,jy,kz,ls), an(ix,jy,kz,lr)) + qxw1 = qxw + ENDIF + + vr = xvs ! db(ix,jy,kz)*an(ix,jy,kz,lr)/(1000.*an(ix,jy,kz,lnr)) +! gtmp(ix,kz) = 3.6e18*(0.243*rhos**2/0.93)*(snu+2.)*an(ix,jy,kz,lns)*vr**2/(snu+1.) + + ksq = 0.189 ! Smith (1984, JAMC) for equiv. ice sphere + IF ( an(ix,jy,kz,lns) .gt. 1.e-7 ) THEN + ! IF ( .true. ) THEN + IF ( qxw > qsmin .or. iusewetsnow >= 2 ) THEN ! old version +! gtmp(ix,kz) = 3.6e18*(snu+2.)*( 0.224*an(ix,jy,kz,ls) + 0.776*qxw)*an(ix,jy,kz,ls)/ & +! & (an(ix,jy,kz,lns)*(snu+1.)*rwdn**2)*db(ix,jy,kz)**2 + gtmp(ix,kz) = 3.6e18*(snu+2.)*( 0.224*(an(ix,jy,kz,ls)+qxw1) + 0.776*qxw)*(an(ix,jy,kz,ls)+qxw1)/ & + & (an(ix,jy,kz,lns)*(snu+1.)*rwdn**2)*db(ix,jy,kz)**2 + + ELSE ! new form using a mass relationship m = p d^2 (instead of d^3 -- Cox 1988 QJRMS) so that density depends on size + ! p = 0.106214 for m = p v^(2/3) + dnsnow = 0.346159*sqrt(an(ix,jy,kz,lns)/(an(ix,jy,kz,ls)*db(ix,jy,kz)) ) + IF ( .true. .or. dnsnow < 900. ) THEN + gtmp(ix,kz) = 1.e18*323.3226* 0.106214**2*(ksq*an(ix,jy,kz,ls) + & + & (1.-ksq)*qxw)*an(ix,jy,kz,ls)*db(ix,jy,kz)**2*gsnow73/ & + & (an(ix,jy,kz,lns)*(917.)**2* gsnow1*(1.0+snu)**(4./3.)) + ELSE ! otherwise small enough to assume ice spheres? + gtmp(ix,kz) = (36./pi**2) * 1.e18*(snu+2.)*( 0.224*(an(ix,jy,kz,ls)+qxw1) + 0.776*qxw)*(an(ix,jy,kz,ls)+qxw1)/ & + & (an(ix,jy,kz,lns)*(snu+1.)*rwdn**2)*db(ix,jy,kz)**2 + ENDIF + + ENDIF + + ENDIF + +! tmp = Min(1.0,1.e3*(an(ix,jy,kz,ls))*db(ix,jy,kz)) +! gtmp(ix,kz) = Max( 1.0*gtmp(ix,kz), 750.0*(tmp)**1.98) + dtmps = gtmp(ix,kz) + dtmp(ix,kz) = dtmp(ix,kz) + gtmp(ix,kz) + ELSE ! }{ single-moment snow: + gtmp(ix,kz) = dads*an(ix,jy,kz,ls)**(0.25) + + IF ( gtmp(ix,kz) .gt. 0.0 ) THEN !{ + dtmps = zsdryc*an(ix,jy,kz,ls)**2/gtmp(ix,kz) + IF ( temk(ix,jy,kz) .lt. tfr ) THEN + dtmp(ix,kz) = dtmp(ix,kz) + & + & zsdryc*an(ix,jy,kz,ls)**2/gtmp(ix,kz) + ELSE + dtmp(ix,kz) = dtmp(ix,kz) + & + & zswetc*an(ix,jy,kz,ls)**2/gtmp(ix,kz) + ENDIF + ENDIF !} + ENDIF !} + + ENDIF !} + + ENDIF + + +! +! ice crystal contribution (Heymsfield, 1977, JAS) +! + IF ( li .gt. 1 .and. idbzci .ne. 0 ) THEN + + IF ( idbzci == 1 .and. lni > 0 ) THEN + ! assume spherical ice with density of 900 for dbz calc + IF ( an(ix,jy,kz,li) > qxmin(li) .and. an(ix,jy,kz,lni) > 1.0 ) THEN + vr = db(ix,jy,kz)*an(ix,jy,kz,li)/(900.*an(ix,jy,kz,lni)) + dtmp(ix,kz) = dtmp(ix,kz) + & + & 0.224*3.6e18*(cinu+2.)*an(ix,jy,kz,lni)*vr**2/(cinu+1.)*(900./1000.)**2 + ENDIF + + ELSEIF ( idbzci == 2 ) THEN +! +! ice crystal contribution (Heymsfield, 1977, JAS) +! + gtmp(ix,kz) = 0.0 + IF ( an(ix,jy,kz,li) .ge. 0.1e-3 ) THEN + gtmp(ix,kz) = Min(1.0,1.e3*(an(ix,jy,kz,li))*db(ix,jy,kz)) + dtmp(ix,kz) = dtmp(ix,kz) + 750.0*(gtmp(ix,kz))**1.98 + ENDIF + + ENDIF + + ENDIF + +! +! graupel/hail contribution +! + IF ( lh .gt. 1 ) THEN ! { + gtmp(ix,kz) = 0.0 + dtmph = 0.0 + qxw = 0.0 + + IF ( izieg .ge. 1 .and. ipconc .ge. 5 ) THEN + + ltest = .false. + + IF ( ltest .or. (an(ix,jy,kz,lh) .ge. qhmin .and. an(ix,jy,kz,lnh) .ge. cxmin )) THEN + + IF ( lvh .gt. 1 ) THEN + + IF ( an(ix,jy,kz,lvh) .gt. 0.0 ) THEN + hwdn = db(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh) + hwdn = Min( 900., Max( 100., hwdn ) ) + ELSE + hwdn = 500. ! hwdn1t + ENDIF + + ENDIF + + chw = an(ix,jy,kz,lnh) + IF ( chw .gt. 0.0 ) THEN ! (Ferrier 94) + xvh = db(ix,jy,kz)*an(ix,jy,kz,lh)/(hwdn*Max(1.0e-3,chw)) + IF ( xvh .lt. xvhmn .or. xvh .gt. xvhmx ) THEN + xvh = Min( xvhmx, Max( xvhmn,xvh ) ) + chw = db(ix,jy,kz)*an(ix,jy,kz,lh)/(xvh*hwdn) + ENDIF + + qh = an(ix,jy,kz,lh) + + IF ( lhw .gt. 1 ) THEN + IF ( iusewetgraupel .eq. 1 ) THEN + qxw = an(ix,jy,kz,lhw) + ELSEIF ( iusewetgraupel .eq. 2 ) THEN + IF ( hwdn .lt. 300. ) THEN + qxw = an(ix,jy,kz,lhw) + ENDIF + ENDIF + ELSEIF ( iusewetgraupel .eq. 3 ) THEN + IF ( hwdn .lt. 300. .and. temk(ix,jy,kz) > tfr .and. an(ix,jy,kz,lr) > qhmin ) THEN + qxw = Min( an(ix,jy,kz,lh), an(ix,jy,kz,lr)) + qh = qh + qxw + ENDIF + ELSEIF ( iusewetgraupel == 4 .and. temk(ix,jy,kz) .gt. tfr+0.25 .and. an(ix,jy,kz,lh) > an(ix,jy,kz,lr) & + & .and. an(ix,jy,kz,lr) > qhmin) THEN + qxw = Min(0.5*an(ix,jy,kz,lh), an(ix,jy,kz,lr)) + qh = qh + qxw + + ENDIF + + IF ( lzh .gt. 1 ) THEN + ELSE + g1 = (6.0 + alphah)*(5.0 + alphah)*(4.0 + alphah)/((3.0 + alphah)*(2.0 + alphah)*(1.0 + alphah)) +! zx = g1*(db(ix,jy,kz)*an(ix,jy,kz,lh))**2/chw +! ze = 0.224*1.e18*zx*(6./(pi*1000.))**2 + zx = g1*db(ix,jy,kz)**2*( 0.224*qh + 0.776*qxw)*qh/chw + ze =1.e18*zx*(6./(pi*1000.))**2 + dtmp(ix,kz) = dtmp(ix,kz) + ze + dtmph = ze + ENDIF + + ENDIF + + ! IF ( an(ix,jy,kz,lh) .gt. 1.0e-3 ) write(0,*) 'Graupel Z : ',dtmph,ze + ENDIF + + ELSE + + dtmph = 0.0 + + IF ( an(ix,jy,kz,lh) .ge. qhmin ) THEN + gtmp(ix,kz) = dadh*an(ix,jy,kz,lh)**(0.25) + IF ( gtmp(ix,kz) .gt. 0.0 ) THEN + dtmph = zhdryc*an(ix,jy,kz,lh)**2/gtmp(ix,kz) + IF ( temk(ix,jy,kz) .lt. tfr ) THEN + dtmp(ix,kz) = dtmp(ix,kz) + & + & zhdryc*an(ix,jy,kz,lh)**2/gtmp(ix,kz) + ELSE +! IF ( hwdn .gt. 700.0 ) THEN + dtmp(ix,kz) = dtmp(ix,kz) + & + & zhdryc*an(ix,jy,kz,lh)**2/gtmp(ix,kz) +! +! & (zhwetc*gtmp(ix,kz)**7)**0.95 +! ELSE +! dtmp(ix,kz) = dtmp(ix,kz) + zhwetc*gtmp(ix,kz)**7 +! ENDIF + ENDIF + ENDIF + ENDIF + + + + ENDIF + + + ENDIF ! } + + ENDIF ! na .gt. 5 + + + IF ( izieg .ge. 1 .and. lhl .gt. 1 ) THEN + + hldn = 900.0 + gtmp(ix,kz) = 0.0 + dtmphl = 0.0 + qxw = 0.0 + + + IF ( lvhl .gt. 1 ) THEN + IF ( an(ix,jy,kz,lvhl) .gt. 0.0 ) THEN + hldn = db(ix,jy,kz)*an(ix,jy,kz,lhl)/an(ix,jy,kz,lvhl) + hldn = Min( 900., Max( 300., hldn ) ) + ELSE + hldn = 900. + ENDIF + ELSE + hldn = rho_qhl + ENDIF + + + IF ( ipconc .ge. 5 ) THEN + + ltest = .false. + + IF ( ltest .or. ( an(ix,jy,kz,lhl) .ge. qhlmin .and. an(ix,jy,kz,lnhl) .gt. 0.) ) THEN !{ + chl = an(ix,jy,kz,lnhl) + IF ( chl .gt. 0.0 ) THEN !{ + xvhl = db(ix,jy,kz)*an(ix,jy,kz,lhl)/ & + & (hldn*Max(1.0e-9,an(ix,jy,kz,lnhl))) + IF ( xvhl .lt. xvhlmn .or. xvhl .gt. xvhlmx ) THEN ! { + xvhl = Min( xvhlmx, Max( xvhlmn,xvhl ) ) + chl = db(ix,jy,kz)*an(ix,jy,kz,lhl)/(xvhl*hldn) + ! do not update state in dbz calc. ! an(ix,jy,kz,lnhl) = chl + ENDIF ! } + + IF ( lhlw .gt. 1 ) THEN + IF ( iusewethail .eq. 1 ) THEN + qxw = an(ix,jy,kz,lhlw) + ELSEIF ( iusewethail .eq. 2 ) THEN + IF ( hldn .lt. 300. ) THEN + qxw = an(ix,jy,kz,lhlw) + ENDIF + ENDIF + ENDIF + + IF ( lzhl .gt. 1 ) THEN !{ + ELSE !} + + g1 = (6.0 + alphahl)*(5.0 + alphahl)*(4.0 + alphahl)/((3.0 + alphahl)*(2.0 + alphahl)*(1.0 + alphahl)) + zx = g1*db(ix,jy,kz)**2*( 0.224*an(ix,jy,kz,lhl) + 0.776*qxw)*an(ix,jy,kz,lhl)/chl +! zx = g1*(db(ix,jy,kz)*an(ix,jy,kz,lhl))**2/chl + ze = 1.e18*zx*(6./(pi*1000.))**2 ! 3/28/2016 removed extra factor of 0.224 + dtmp(ix,kz) = dtmp(ix,kz) + ze + dtmphl = ze + + ENDIF !} + ENDIF!} + ! IF ( an(ix,jy,kz,lh) .gt. 1.0e-3 ) write(0,*) 'Graupel Z : ',dtmph,ze + ENDIF + + + ELSE + + + IF ( an(ix,jy,kz,lhl) .ge. qhlmin ) THEN ! { + dadhl = ( db(ix,jy,kz) /(pi*hldn*cnohl) )**(.25) + gtmp(ix,kz) = dadhl*an(ix,jy,kz,lhl)**(0.25) + IF ( gtmp(ix,kz) .gt. 0.0 ) THEN ! { + + zhldryc = 0.224*cr2*( db(ix,jy,kz)/rwdn)**2/cnohl + + dtmphl = zhldryc*an(ix,jy,kz,lhl)**2/gtmp(ix,kz) + + IF ( temk(ix,jy,kz) .lt. tfr ) THEN + dtmp(ix,kz) = dtmp(ix,kz) + & + & zhldryc*an(ix,jy,kz,lhl)**2/gtmp(ix,kz) + ELSE +! IF ( hwdn .gt. 700.0 ) THEN + dtmp(ix,kz) = dtmp(ix,kz) + & + & zhldryc*an(ix,jy,kz,lhl)**2/gtmp(ix,kz) +! +! : (zhwetc*gtmp(ix,kz)**7)**0.95 +! ELSE +! dtmp(ix,kz) = dtmp(ix,kz) + zhwetc*gtmp(ix,kz)**7 +! ENDIF + ENDIF + ENDIF ! } + + ENDIF ! } + + ENDIF ! ipconc .ge. 5 + + + ENDIF ! izieg .ge. 1 .and. lhl .gt. 1 + + + + IF ( dtmp(ix,kz) .gt. 0.0 ) THEN + dbz(ix,jy,kz) = Max(dbzmin, 10.0*Log10(dtmp(ix,kz)) ) + + IF ( dbz(ix,jy,kz) .gt. dbzmax ) THEN + dbzmax = Max(dbzmax,dbz(ix,jy,kz)) + imx = ix + jmx = jy + kmx = kz + ENDIF + ELSE + dbz(ix,jy,kz) = dbzmin + IF ( lh > 1 .and. lhl > 1) THEN + IF ( an(ix,jy,kz,lh) > 1.0e-3 ) THEN + write(0,*) 'radardbz: qr,qh,qhl = ',an(ix,jy,kz,lr), an(ix,jy,kz,lh),an(ix,jy,kz,lhl) + write(0,*) 'radardbz: dtmps,dtmph,dadh,dadhl,dtmphl = ',dtmps,dtmph,dadh,dadhl,dtmphl + + IF ( lzh>1 .and. lzhl>1 ) write(0,*) 'radardbz: zh, zhl = ',an(ix,jy,kz,lzh),an(ix,jy,kz,lzhl) + ENDIF + ENDIF + ENDIF + +! IF ( an(ix,jy,kz,lh) .gt. 1.e-4 .and. +! & dbz(ix,jy,kz) .le. 0.0 ) THEN +! write(0,*) 'dbz = ',dbz(ix,jy,kz) +! write(0,*) 'Hail intercept: ',xcnoh,ix,kz +! write(0,*) 'Hail,snow q: ',an(ix,jy,kz,lh),an(ix,jy,kz,ls) +! write(0,*) 'Hail,snow c: ',an(ix,jy,kz,lnh),an(ix,jy,kz,lns) +! write(0,*) 'dtmps,dtmph = ',dtmps,dtmph +! ENDIF + IF ( .not. dtmp(ix,kz) .lt. 1.e30 .or. dbz(ix,jy,kz) > 190.0 ) THEN +! IF ( ix == 31 .and. kz == 20 .and. jy == 23 ) THEN +! write(0,*) 'my_rank = ',my_rank + write(0,*) 'ix,jy,kz = ',ix,jy,kz + write(0,*) 'dbz = ',dbz(ix,jy,kz) + write(0,*) 'db, zhdryc = ',db(ix,jy,kz),zhdryc + write(0,*) 'Hail intercept: ',xcnoh,ix,kz + write(0,*) 'Hail,snow q: ',an(ix,jy,kz,lh),an(ix,jy,kz,ls) + write(0,*) 'graupel density hwdn = ',hwdn + write(0,*) 'rain q: ',an(ix,jy,kz,lr) + write(0,*) 'ice q: ',an(ix,jy,kz,li) + IF ( lhl .gt. 1 ) write(0,*) 'Hail (lhl): ',an(ix,jy,kz,lhl) + IF (ipconc .ge. 3 ) write(0,*) 'rain c: ',an(ix,jy,kz,lnr) + IF ( lzr > 1 ) write(0,*) 'rain Z: ',an(ix,jy,kz,lzr) + IF ( ipconc .ge. 5 ) THEN + write(0,*) 'Hail,snow c: ',an(ix,jy,kz,lnh),an(ix,jy,kz,lns) + IF ( lhl .gt. 1 ) write(0,*) 'Hail (lnhl): ',an(ix,jy,kz,lnhl) + IF ( lzhl .gt. 1 ) THEN + write(0,*) 'Hail (lzhl): ',an(ix,jy,kz,lzhl) + write(0,*) 'chl,xvhl,dhl = ',chl,xvhl,(xvhl*6./3.14159)**(1./3.) + write(0,*) 'xvhlmn,xvhlmx = ',xvhlmn,xvhlmx + ENDIF + ENDIF + write(0,*) 'chw,xvh = ', chw,xvh + write(0,*) 'dtmps,dtmph,dadh,dadhl,dtmphl = ',dtmps,dtmph,dadh,dadhl,dtmphl + write(0,*) 'dtmpr = ',dtmpr + write(0,*) 'gtmp = ',gtmp(ix,kz),dtmp(ix,kz) + IF ( .not. (dbz(ix,jy,kz) .gt. -100 .and. dbz(ix,jy,kz) .lt. 200 ) ) THEN + write(0,*) 'dbz out of bounds!' + ENDIF + ENDIF + + + ENDDO ! ix + ENDDO ! kz + ENDDO ! jy + + + + +! write(0,*) 'na,lr = ',na,lr + IF ( printyn .eq. 1 ) THEN +! IF ( dbzmax .gt. dbzmin ) THEN + write(iunit,*) 'maxdbz,ijk = ',dbzmax,imx,jmx,kmx + write(iunit,*) 'qrw = ',an(imx,jmx,kmx,lr) + + IF ( lh .gt. 1 ) THEN + write(iunit,*) 'qi = ',an(imx,jmx,kmx,li) + write(iunit,*) 'qsw = ',an(imx,jmx,kmx,ls) + write(iunit,*) 'qhw = ',an(imx,jmx,kmx,lh) + IF ( lhl .gt. 1 ) write(iunit,*) 'qhl = ',an(imx,jmx,kmx,lhl) + ENDIF + + + ENDIF + + + RETURN + END subroutine radardd02 + + +! ############################################################################## +! ############################################################################## + + +!>\ingroup mod_nsslmp +!! Droplet nucleation routine. Explicit condensation/evaporation. Tiny mixing ratio cleanup. +! ##################################################################### +! ##################################################################### +! +! Subroutine for explicit cloud condensation and droplet nucleation +! + SUBROUTINE NUCOND & + & (nx,ny,nz,na,jyslab & + & ,nor,norz,dtp,nxi & + & ,dz3d & + & ,t0,t9 & + & ,an,dn,p2 & + & ,pn,w & + & ,axtra,io_flag & + & ,ssfilt,t00,t77,flag_qndrop & + & ) + + + implicit none + +! real :: cwmasn = 1000.*0.523599*(2.*2.e-6)**3 + integer :: nx,ny,nz,na,nxi + integer :: nor,norz, jyslab ! ,nht,ngt,igsr + real :: dtp ! time step + logical :: flag_qndrop + + integer, parameter :: ng1 = 1 + + +! +! external temporary arrays +! + real t00(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real t77(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + + real t0(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) +! real t1(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) +! real t2(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) +! real t3(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) +! real t4(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) +! real t5(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) +! real t6(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) +! real t7(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) +! real t8(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real t9(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + + + real p2(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) ! perturbation Pi + real pn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) + real dn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + + real w(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) +! real qv(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + + real ssfilt(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + + + real pb(-norz+ng1:nz+norz) + real pinit(-norz+ng1:nz+norz) + + real dz3d(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + + + ! local + + + real axtra(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz,nxtra) + logical :: io_flag + + real :: dv + +! +! declarations microphysics and for gather/scatter +! + real, parameter :: cwmas30 = 1000.*0.523599*(2.*30.e-6)**3 ! mass of 30-micron radius droplet, for sat. adj. + real, parameter :: cwmas20 = 1000.*0.523599*(2.*20.e-6)**3 ! mass of 20-micron radius droplet, for sat. adj. + integer nxmpb,nzmpb,nxz + integer mgs,ngs,numgs,inumgs + parameter (ngs=500) + integer ngscnt,igs(ngs),kgs(ngs) + integer kgsp(ngs),kgsm(ngs) + integer nsvcnt + + integer ix,kz,i,n, kp1, km1 + integer :: jy, jgs + integer ixb,ixe,jyb,jye,kzb,kze + + integer itile,jtile,ktile + integer ixend,jyend,kzend,kzbeg + integer nxend,nyend,nzend,nzbeg + +! +! Variables for Ziegler warm rain microphysics +! + + + real ccnc(ngs), ccna(ngs), cnuc(ngs), cwnccn(ngs) + real ccncuf(ngs) + real sscb ! 'cloud base' SS threshold + parameter ( sscb = 2.0 ) + integer idecss ! flag to turn on (=1) decay of ssmax when no cloud or ice crystals + parameter ( idecss = 1 ) + integer iba ! flag to do condensation/nucleation in 1st or 2nd loop + ! =0 to use ad to calculate SS + ! =1 to use an at end of main jy loop to calculate SS + parameter (iba = 1) + integer ifilt ! =1 to filter ssat, =0 to set ssfilt=ssat + parameter ( ifilt = 0 ) + real temp1,temp2 ! ,ssold + real :: ssmax(ngs) = 0.0 ! maximum SS experienced by a parcel + real ssmx + real dnnet,dqnet +! real cnu,rnu,snu,cinu +! parameter ( cnu = 0.0, rnu = -0.8, snu = -0.8, cinu = 0.0 ) + real ventrx(ngs) + real ventrxn(ngs) + real volb, t2s + real, parameter :: aa1 = 9.44e15, aa2 = 5.78e3 ! a1 in Ziegler + + real ec0, ex1, ft, rhoinv(ngs) + + real chw, g1, rd1 + + real ac1,bc, taus, c1,d1,e1,f1,p380,tmp,tmp2 ! , sstdy, super + real tmpmx, fw, qctmp + real x,y,del,r,alpr + double precision :: vent1,vent2 + real g1palp + real bs + real v1, v2 + real d1r, d1i, d1s, e1i + integer nc ! condensation step + real dtcon,dtcon1,dtcon2 ! condensation time step (dtcon*nc = dtp) + real delta + integer ltemq1,ltemq1m ! ,ltemq1m2 + real dqv,qv1,ss1,ss2,qvs1,dqvs,dtemp,dt1 ! temporaries for condensation + + real ssi1, ssi2, dqvi, dqvis, dqvii,qis1 + real dqvr, dqc, dqr, dqi, dqs + real qv1m,qvs1m,ss1m,ssi1m,qis1m + real cwmastmp + real dcloud,dcloud2 ! ,as, bs + real dcrit + real cn(ngs), cnuf(ngs) + real :: ccwmax + + integer ltemq + + integer il + + real es(ngs) ! ss(ngs), +! real eis(ngs) + real ssf(ngs),ssfkp1(ngs),ssfkm1(ngs),ssat0(ngs) + real, parameter :: ssfcut = 4.0 + real ssfjp1(ngs),ssfjm1(ngs) + real ssfip1(ngs),ssfim1(ngs) + + real supcb, supmx + parameter (supcb=0.5,supmx=238.0) + real r2dxm, r2dym, r2dzm + real dssdz, dssdy, dssdx +! real tqvcon + real epsi,d + parameter (epsi = 0.622, d = 0.266) + real r1,qevap ! ,slv + + real vr,nrx,qr,z1,z2,rdi,alp,xnutmp,xnuc + real ctmp, ccwtmp + real f5, qvs0 ! Kessler condensation factor + real :: t0p1, t0p3 + real qvex + +! real, dimension(ngs) :: temp, tempc, elv, elf, els, pqs, theta, temg, temcg + real dqvcnd(ngs),dqwv(ngs),dqcw(ngs),dqci(ngs) + real temp(ngs),tempc(ngs) + real temg(ngs),temcg(ngs),theta(ngs),qvap(ngs) ! ,tembzg(ngs) + real temgx(ngs),temcgx(ngs) + real qvs(ngs),qis(ngs),qss(ngs),pqs(ngs) + real felv(ngs),felf(ngs),fels(ngs) + real felvcp(ngs),felvpi(ngs) + real gamw(ngs),gams(ngs) ! qciavl(ngs), + real tsqr(ngs),ssi(ngs),ssw(ngs) + real cc3(ngs),cqv1(ngs),cqv2(ngs) + real qcwtmp(ngs),qtmp + + real fvent(ngs) !,fraci(ngs),fracl(ngs) + real fwvdf(ngs),ftka(ngs),fthdf(ngs) + real fadvisc(ngs),fakvisc(ngs) + real fci(ngs),fcw(ngs) + real fschm(ngs),fpndl(ngs) + + real pres(ngs),pipert(ngs) + real pk(ngs) + real rho0(ngs),pi0(ngs) + real rhovt(ngs) + real thetap(ngs),theta0(ngs),qwvp(ngs),qv0(ngs) + real thsave(ngs) + real qss0(ngs) + real fcqv1(ngs) + real wvel(ngs),wvelkm1(ngs) + + real wvdf(ngs),tka(ngs) + real advisc(ngs) + + real rwvent(ngs) + + + real :: qx(ngs,lv:lhab) + real :: cx(ngs,lc:lhab) + real :: xv(ngs,lc:lhab) + real :: xmas(ngs,lc:lhab) + real :: xdn(ngs,lc:lhab) + real :: xdia(ngs,lc:lhab,3) + real :: alpha(ngs,lc:lhab) + real :: zx(ngs,lr:lhab) + + + logical zerocx(lc:lqmx) + + logical :: lprint + + integer, parameter :: iunit = 0 + + real :: frac, hwdn, tmpg + + real :: cvm,cpm,rmm + + real, parameter :: cpv = 1885.0 ! specific heat of water vapor at constant pressure + + integer :: kstag + + integer :: count + + +! ------------------------------------------------------------------------------- + itile = nxi + jtile = ny + ktile = nz + ixend = nxi + jyend = ny + kzend = nz + nxend = nxi + 1 + nyend = ny + 1 + nzend = nz + kzbeg = 1 + nzbeg = 1 + + f5 = 237.3 * 17.27 * 2.5e6 / cp ! combined constants for rain condensation (Soong and Ogura 73) + + jy = 1 + kstag = 0 + pb(:) = 0.0 + pinit(:) = 0.0 + + IF ( ipconc <= 1 .or. isedonly == 2 ) GOTO 2200 + +! +! Ziegler nucleation +! + +! ssfilt(:,:,:) = 0.0 + ssmx = 0 + count = 0 + + do kz = 1,nz-kstag + do ix = 1,nxi + + temp1 = an(ix,jy,kz,lt)*t77(ix,jy,kz) + t0(ix,jy,kz) = temp1 + ltemq = Int( (temp1-163.15)/fqsat+1.5 ) + ltemq = Min( nqsat, Max(1,ltemq) ) + + c1 = t00(ix,jy,kz)*tabqvs(ltemq) + + IF ( c1 > 0. ) THEN + ssfilt(ix,jy,kz) = 100.*(an(ix,jy,kz,lv)/c1 - 1.0) ! from "new" values + ENDIF + + ENDDO + ENDDO + + +! +! jy = 1 ! working on a 2d slab +!! VERY IMPORTANT: SET jgs = jy + + jgs = jy + +! +!..Gather microphysics +! + if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_DR: Gather stage' + + nxmpb = 1 + nzmpb = 1 + nxz = nxi*nz + numgs = nxz/ngs + 1 + + + do 2000 inumgs = 1,numgs + + ngscnt = 0 + + + kzb = nzmpb + kze = nz-kstag + ! if (kzbeg .le. nzmpb .and. kzend .gt. nzmpb) kzb = nzmpb + + ixb = nxmpb + ixe = itile + + do kz = kzb,kze + do ix = nxmpb,nxi + + pqs(1) = 380.0/(pn(ix,jy,kz) + pb(kz)) + theta(1) = an(ix,jy,kz,lt) + temg(1) = t0(ix,jy,kz) + + temcg(1) = temg(1) - tfr + ltemq = (temg(1)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + qvs(1) = pqs(1)*tabqvs(ltemq) + qis(1) = pqs(1)*tabqis(ltemq) + + qss(1) = qvs(1) + + + if ( temg(1) .lt. tfr ) then + end if +! + if ( (temg(1) .gt. tfrh .or. an(ix,jy,kz,lv)/qvs(1) > maxlowtempss ) .and. & + & ( an(ix,jy,kz,lv) .gt. qss(1) .or. & + & an(ix,jy,kz,lc) .gt. qxmin(lc) .or. & + & ( an(ix,jy,kz,lr) .gt. qxmin(lr) .and. rcond == 2 ) & + & )) then + ngscnt = ngscnt + 1 + igs(ngscnt) = ix + kgs(ngscnt) = kz + if ( ngscnt .eq. ngs ) goto 2100 + end if + + end do !ix + + nxmpb = 1 + end do !kz +! if ( jy .eq. (ny-jstag) ) iend = 1 + 2100 continue + + if ( ngscnt .eq. 0 ) go to 29998 + + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_DR: dbg = 8' + +! write(0,*) 'NUCOND: dbg = 8, ngscnt,ssmx = ',ngscnt,ssmx + + + qx(:,:) = 0.0 + cx(:,:) = 0.0 + + xv(:,:) = 0.0 + xmas(:,:) = 0.0 + + IF ( imurain == 1 ) THEN + alpha(:,lr) = alphar + ELSEIF ( imurain == 3 ) THEN + alpha(:,lr) = xnu(lr) + ENDIF + +! +! define temporaries for state variables to be used in calculations +! + DO mgs = 1,ngscnt + qx(mgs,lv) = an(igs(mgs),jy,kgs(mgs),lv) + DO il = lc,lhab + qx(mgs,il) = max(an(igs(mgs),jy,kgs(mgs),il), 0.0) + ENDDO + + qcwtmp(mgs) = qx(mgs,lc) + + + theta0(mgs) = an(igs(mgs),jy,kgs(mgs),lt) ! + thetap(mgs) = 0.0 + theta(mgs) = an(igs(mgs),jy,kgs(mgs),lt) + qv0(mgs) = qx(mgs,lv) + qwvp(mgs) = qx(mgs,lv) - qv0(mgs) + + pres(mgs) = pn(igs(mgs),jy,kgs(mgs)) + pb(kgs(mgs)) + pipert(mgs) = p2(igs(mgs),jy,kgs(mgs)) + rho0(mgs) = dn(igs(mgs),jy,kgs(mgs)) + rhoinv(mgs) = 1.0/rho0(mgs) + rhovt(mgs) = Sqrt(rho00/rho0(mgs)) + pi0(mgs) = p2(igs(mgs),jy,kgs(mgs)) + pinit(kgs(mgs)) + temg(mgs) = t0(igs(mgs),jy,kgs(mgs)) +! pk(mgs) = t77(igs(mgs),jy,kgs(mgs)) ! ( pres(mgs) / poo ) ** cap + pk(mgs) = p2(igs(mgs),jy,kgs(mgs)) + pinit(kgs(mgs)) ! t77(igs(mgs),jy,kgs(mgs)) + temcg(mgs) = temg(mgs) - tfr + qss0(mgs) = (380.0)/(pres(mgs)) + pqs(mgs) = (380.0)/(pres(mgs)) + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + qis(mgs) = pqs(mgs)*tabqis(ltemq) +! + qvap(mgs) = max( (qwvp(mgs) + qv0(mgs)), 0.0 ) + es(mgs) = 6.1078e2*tabqvs(ltemq) + qss(mgs) = qvs(mgs) + + + temgx(mgs) = min(temg(mgs),313.15) + temgx(mgs) = max(temgx(mgs),233.15) + felv(mgs) = 2500837.367 * (273.15/temgx(mgs))**((0.167)+(3.67e-4)*temgx(mgs)) +! + IF ( eqtset <= 1 ) THEN + felvcp(mgs) = felv(mgs)*cpi + ELSE ! equation set 2 in cm1 + tmp = qx(mgs,li)+qx(mgs,ls)+qx(mgs,lh) + IF ( lhl > 1 ) tmp = tmp + qx(mgs,lhl) + cvm = cv+cvv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) & + +cpigb*(tmp) + cpm = cp+cpv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) & + +cpigb*(tmp) + rmm=rd+rw*qx(mgs,lv) + + IF ( eqtset == 2 ) THEN + + felvcp(mgs) = (felv(mgs)-rw*temg(mgs))/cvm + + ELSE + felvcp(mgs) = (felv(mgs)*cv/(cp) - rw*temg(mgs)*(1.0-rovcp*cpm/rmm))/cvm + felvpi(mgs) = pi0(mgs)*rovcp*(felv(mgs)/(temg(mgs)) - rw*cpm/rmm)/cvm + ENDIF + + ENDIF + + temcgx(mgs) = min(temg(mgs),273.15) + temcgx(mgs) = max(temcgx(mgs),223.15) + temcgx(mgs) = temcgx(mgs)-273.15 + felf(mgs) = 333690.6098 + (2030.61425)*temcgx(mgs) - (10.46708312)*temcgx(mgs)**2 +! + fels(mgs) = felv(mgs) + felf(mgs) + fcqv1(mgs) = 4098.0258*felv(mgs)*cpi + + wvdf(mgs) = (2.11e-05)*((temg(mgs)/tfr)**1.94)* & + & (101325.0/(pb(kgs(mgs)) + pn(igs(mgs),jgs,kgs(mgs)))) ! diffusivity of water vapor, Hall and Pruppacher (76) + advisc(mgs) = advisc0*(416.16/(temg(mgs)+120.0))* & + & (temg(mgs)/296.0)**(1.5) ! dynamic viscosity (SMT; see Beard & Pruppacher 71) + tka(mgs) = tka0*advisc(mgs)/advisc1 ! thermal conductivity + + + ENDDO + + + +! +! load concentrations +! + if ( ipconc .ge. 1 ) then + do mgs = 1,ngscnt + cx(mgs,li) = Max(an(igs(mgs),jy,kgs(mgs),lni), 0.0) + end do + end if + if ( ipconc .ge. 2 ) then + do mgs = 1,ngscnt + cx(mgs,lc) = Max(an(igs(mgs),jy,kgs(mgs),lnc), 0.0) + cwnccn(mgs) = cwccn*rho0(mgs)/rho00 ! background ccn count + cn(mgs) = 0.0 + IF ( lss > 1 ) THEN + ssmax(mgs) = an(igs(mgs),jy,kgs(mgs),lss) + ELSE + ssmax(mgs) = 0.0 + ENDIF + IF ( lccn .gt. 1 ) THEN + ccnc(mgs) = an(igs(mgs),jy,kgs(mgs),lccn) + ELSE + ccnc(mgs) = cwnccn(mgs) + ENDIF + IF ( lccnuf .gt. 1 ) THEN + ccncuf(mgs) = an(igs(mgs),jy,kgs(mgs),lccnuf) + ELSE + ccncuf(mgs) = 0.0 + ENDIF + cnuf(mgs) = 0.0 + IF ( lccna > 1 ) THEN + ccna(mgs) = an(igs(mgs),jy,kgs(mgs),lccna) ! predicted count of activated ccn + ELSE + IF ( lccn > 1 ) THEN + ccna(mgs) = cwnccn(mgs) - ccnc(mgs) ! diagnose activated ccn as background value - remaining unactivated ccn + ELSE + ccna(mgs) = cx(mgs,lc) ! approximation of number of activated ccn + ENDIF + ENDIF + end do + end if + if ( ipconc .ge. 3 ) then + do mgs = 1,ngscnt + cx(mgs,lr) = Max(an(igs(mgs),jy,kgs(mgs),lnr), 0.0) + end do + end if + +! cnuc(1:ngscnt) = cwccn*rho0(mgs)/rho00*(1. - renucfrac) + ccnc(1:ngscnt)*renucfrac + DO mgs = 1,ngscnt + ! default value of renucfrac is 0.0 + IF ( irenuc /= 6 ) THEN + cnuc(mgs) = Max(ccnc(mgs),cwnccn(mgs))*(1. - renucfrac) + ccnc(mgs)*renucfrac + ELSE + cnuc(mgs) = Max(ccnc(mgs),cwnccn(mgs))*(1. - renucfrac) + Max(0.0,ccnc(mgs) - ccna(mgs))*renucfrac + ENDIF + IF ( renucfrac >= 0.999 ) THEN + IF ( temg(mgs) < 265. ) THEN + IF ( qx(mgs,lc) > 10.*qxmin(lc) .and. w(igs(mgs),jgs,kgs(mgs)) > 2.0 ) THEN + cnuc(mgs) = 0.0 ! Min(cnuc(mgs), 0.5*cx(mgs,lc) ) ! Hack to reduce nucleation at low temp in updraft when ccn are not predicted + ELSE + cnuc(mgs) = 0.1*cnuc(mgs) + ENDIF + ENDIF + ENDIF + ENDDO + +! Set density +! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_DR: Set density' + + do mgs = 1,ngscnt + xdn(mgs,lc) = xdn0(lc) + xdn(mgs,lr) = xdn0(lr) + end do + + ventrx(:) = ventr + ventrxn(:) = ventrn + + + +! write(0,*) 'NUCOND: Set ssf variables, ssmxinit =',ssmxinit + ssmx = 0.0 + DO mgs = 1,ngscnt + + kp1 = Min(nz, kgs(mgs)+1 ) + wvel(mgs) = (0.5)*(w(igs(mgs),jgs,kp1) & + & +w(igs(mgs),jgs,kgs(mgs))) + wvelkm1(mgs) = (0.5)*(w(igs(mgs),jgs,kgs(mgs)) & + & +w(igs(mgs),jgs,Max(1,kgs(mgs)-1))) + + ssat0(mgs) = ssfilt(igs(mgs),jgs,kgs(mgs)) + ssf(mgs) = ssfilt(igs(mgs),jgs,kgs(mgs)) +! ssmx = Max( ssmx, ssf(mgs) ) + + + ssfkp1(mgs) = ssfilt(igs(mgs),jgs,Min(nz-1,kgs(mgs)+1)) + ssfkm1(mgs) = ssfilt(igs(mgs),jgs,Max(1,kgs(mgs)-1)) + + + ENDDO + + + +! +! cloud water variables +! + + if ( ndebug .gt. 0 )write(0,*) 'ICEZVD_DR: Set cloud water variables' + + do mgs = 1,ngscnt + xv(mgs,lc) = 0.0 + IF ( ipconc .ge. 2 .and. cx(mgs,lc) .gt. 1.0e6 ) THEN + xmas(mgs,lc) = & + & min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),cwmasn),cwmasx ) + xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) + ELSE + IF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. cxmin ) THEN + xmas(mgs,lc) = & + & min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),xdn(mgs,lc)*xvmn(lc)), & + & xdn(mgs,lc)*xvmx(lc) ) + + cx(mgs,lc) = qx(mgs,lc)*rho0(mgs)/xmas(mgs,lc) + + ELSEIF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .le. cxmin ) THEN +! xmas(mgs,lc) = xdn(mgs,lc)*4.*pi/3.*(5.0e-6)**3 +! cx(mgs,lc) = rho0(mgs)*qx(mgs,lc)/xmas(mgs,lc) + cx(mgs,lc) = Max( cxmin, rho0(mgs)*qx(mgs,lc)/cwmasx ) + xmas(mgs,lc) = & + & min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),cwmasn),cwmasx ) + xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) + + ELSE + xmas(mgs,lc) = cwmasn + ENDIF + ENDIF + xdia(mgs,lc,1) = (xmas(mgs,lc)*cwc1)**c1f3 + + + end do +! +! rain +! + do mgs = 1,ngscnt + if ( qx(mgs,lr) .gt. qxmin(lr) ) then + + if ( ipconc .ge. 3 ) then + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*Max(1.0e-9,cx(mgs,lr))) +! parameter( xvmn(lr)=2.8866e-13, xvmx(lr)=4.1887e-9 ) ! mks + IF ( xv(mgs,lr) .gt. xvmx(lr) ) THEN + xv(mgs,lr) = xvmx(lr) + cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmx(lr)*xdn(mgs,lr)) + ELSEIF ( xv(mgs,lr) .lt. xvmn(lr) ) THEN + xv(mgs,lr) = xvmn(lr) + cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmn(lr)*xdn(mgs,lr)) + ENDIF + + xmas(mgs,lr) = xv(mgs,lr)*xdn(mgs,lr) + xdia(mgs,lr,3) = (xmas(mgs,lr)*cwc1)**(1./3.) ! xdia(mgs,lr,1) + IF ( imurain == 3 ) THEN +! xdia(mgs,lr,1) = (6.*pii*xv(mgs,lr)/(alpha(mgs,lr)+1.))**(1./3.) + xdia(mgs,lr,1) = xdia(mgs,lr,3) ! formulae for Ziegler (1985) use mean volume diameter, not lambda**(-1) + ELSE ! imurain == 1, Characteristic diameter (1/lambda) + xdia(mgs,lr,1) = (6.*piinv*xv(mgs,lr)/((alpha(mgs,lr)+3.)*(alpha(mgs,lr)+2.)*(alpha(mgs,lr)+1.)))**(1./3.) + ENDIF +! rwrad(mgs) = 0.5*xdia(mgs,lr,1) + +! Inverse exponential version: +! xdia(mgs,lr,1) = +! > (qx(mgs,lr)*rho0(mgs) +! > /(pi*xdn(mgs,lr)*cx(mgs,lr)))**(0.333333) + ELSE + xdia(mgs,lr,1) = & + & (qx(mgs,lr)*rho0(mgs)/(pi*xdn(mgs,lr)*cno(lr)))**(0.25) + end if + else + xdia(mgs,lr,1) = 1.e-9 +! rwrad(mgs) = 0.5*xdia(mgs,lr,1) + end if + + end do + + +! +! Ventilation coefficients + + do mgs = 1,ngscnt + + + fadvisc(mgs) = advisc0*(416.16/(temg(mgs)+120.0))* & + & (temg(mgs)/296.0)**(1.5) + + fakvisc(mgs) = fadvisc(mgs)*rhoinv(mgs) + + fwvdf(mgs) = (2.11e-05)*((temg(mgs)/tfr)**1.94)* & + & (101325.0/(pres(mgs))) + + fschm(mgs) = (fakvisc(mgs)/fwvdf(mgs)) + + fvent(mgs) = (fschm(mgs)**(1./3.)) * (fakvisc(mgs)**(-0.5)) + + end do +! +! +! Ziegler nucleation +! +! +! cloud evaporation, condensation, and nucleation +! sqsat -> qss(mgs) + + DO mgs=1,ngscnt + dcloud = 0.0 + ! Skip points at low temperature if SS stays less than 1.08, + ! otherwise allow nucleation at low temp (will freeze at next time step) + IF ( temg(mgs) .le. tfrh .and. qx(mgs,lv)/qvs(mgs) < maxlowtempss ) THEN + CYCLE + ENDIF + + IF( ssat0(mgs) .GT. 0. .OR. ssf(mgs) .GT. 0. ) GO TO 620 +!6/4 IF( qvap(mgs) .EQ. qss(mgs) ) GO TO 631 +! +!.... EVAPORATION. QV IS LESS THAN qss(mgs). +!.... EVAPORATE CLOUD FIRST +! + IF ( qx(mgs,lc) .LE. 0. ) GO TO 631 +!.... CLOUD EVAPORATION. +! convert input 'cp' to cgs + R1=1./(1. + caw*(273.15 - cbw)*qss(mgs)*felv(mgs)/ & + & (cp*(temg(mgs) - cbw)**2)) + QEVAP= Min( qx(mgs,lc), R1*(qss(mgs)-qvap(mgs)) ) + + + IF ( qx(mgs,lc) .LT. QEVAP ) THEN ! GO TO 63 + qwvp(mgs) = qwvp(mgs) + qx(mgs,lc) + thetap(mgs) = thetap(mgs) - felv(mgs)*qx(mgs,lc)/(cp*pi0(mgs)) + IF ( io_flag .and. nxtra > 1 ) THEN + axtra(igs(mgs),jy,kgs(mgs),1) = -qx(mgs,lc)/dtp + ENDIF + qx(mgs,lc) = 0. + IF ( restoreccn ) THEN + IF ( irenuc <= 2 ) THEN + IF ( .not. invertccn ) THEN + ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + cx(mgs,lc) ) ) + ELSE + ccnc(mgs) = ccnc(mgs) + cx(mgs,lc) + ENDIF + ENDIF + IF ( lccna > 1 ) THEN + ccna(mgs) = ccna(mgs) - cx(mgs,lc) + ENDIF + ENDIF + cx(mgs,lc) = 0. + ELSE + qctmp = qx(mgs,lc) + qwvp(mgs) = qwvp(mgs) + QEVAP + qx(mgs,lc) = qx(mgs,lc) - QEVAP + IF ( qx(mgs,lc) .le. 0. ) THEN + IF ( restoreccn ) THEN + IF ( irenuc <= 2 ) THEN +! ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + cx(mgs,lc) ) ) +! ccnc(mgs) = ccnc(mgs) + cx(mgs,lc) + IF ( .not. invertccn ) THEN + ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + cx(mgs,lc) ) ) + ELSE + ccnc(mgs) = ccnc(mgs) + cx(mgs,lc) + ENDIF + ENDIF + IF ( lccna > 1 ) THEN + ccna(mgs) = ccna(mgs) - cx(mgs,lc) + ENDIF + ENDIF + cx(mgs,lc) = 0. + ELSE + tmp = 0.9*QEVAP*cx(mgs,lc)/qctmp ! let droplets get smaller but also remove some. A factor of 1.0 would maintain same size + IF ( restoreccn ) THEN + IF ( irenuc <= 2 ) THEN + ! ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + tmp ) ) +! ccnc(mgs) = ccnc(mgs) + tmp + IF ( .not. invertccn ) THEN + ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + tmp ) ) + ELSE + ccnc(mgs) = ccnc(mgs) + tmp + ENDIF + ENDIF + IF ( lccna > 1 ) THEN + ccna(mgs) = ccna(mgs) - tmp + ENDIF + ENDIF + cx(mgs,lc) = cx(mgs,lc) - tmp + ENDIF + thetap(mgs) = thetap(mgs) - felv(mgs)*QEVAP/(CP*pi0(mgs)) + IF ( io_flag .and. nxtra > 1 ) THEN + axtra(igs(mgs),jy,kgs(mgs),1) = -QEVAP/dtp + ENDIF + + ENDIF + + GO TO 631 + + + 620 CONTINUE + +!.... CLOUD CONDENSATION + + IF ( qx(mgs,lc) .GT. qxmin(lc) .and. cx(mgs,lc) .ge. 1. ) THEN + + + +! ac1 = xdn(mgs,lc)*elv(kgs(mgs))**2*epsi/ +! : (tka(kgs(mgs))*rw*temg(mgs)**2) +! took out xdn factor because it cancels later... + ac1 = felv(mgs)**2/(tka(mgs)*rw*temg(mgs)**2) + + +! bc = xdn(mgs,lc)*rw*temg(mgs)/ +! : (epsi*wvdf(kgs(mgs))*es(mgs)) +! took out xdn factor because it cancels later... + bc = rw*temg(mgs)/(wvdf(mgs)*es(mgs)) + +! bs = rho0(mgs)*((rd*temg(mgs)/(epsi*es(mgs)))+ +! : (epsi*elv(kgs(mgs))**2/(pres(mgs)*temg(mgs)*cp))) + +! taus = Min(dtp, xdn(mgs,lc)*rho0(mgs)*(ac1+bc)/ +! : (4*pi*0.89298*BS*0.5*xdia(mgs,lc,1)*cx(mgs,lc)*xdn(mgs,lc))) + +! + IF ( ssf(mgs) .gt. 0.0 .or. ssat0(mgs) .gt. 0.0 ) THEN + IF ( ny .le. 2 ) THEN +! write(0,*) 'undershoot: ',ssf(mgs), +! : ( (qx(mgs,lv) - dcloud)/c1 - 1.0)*100. + ENDIF + + + + IF ( qx(mgs,lc) .gt. qxmin(lc) ) THEN + + IF ( xdia(mgs,lc,1) .le. 0.0 ) THEN + xmas(mgs,lc) = cwmasn + xdia(mgs,lc,1) = (xmas(mgs,lc)*cwc1)**c1f3 + ENDIF + d1 = (1./(ac1 + bc))*4.0*pi*ventc & + & *0.5*xdia(mgs,lc,1)*cx(mgs,lc)*rhoinv(mgs) + + ELSE + d1 = 0.0 + ENDIF + + IF ( rcond .eq. 2 .and. qx(mgs,lr) .gt. qxmin(lr) .and. cx(mgs,lr) > 1.e-9 ) THEN + IF ( imurain == 3 ) THEN + IF ( izwisventr == 1 ) THEN + rwvent(mgs) = ventrx(mgs)*(1.6 + 124.9*(1.e-3*rho0(mgs)*qx(mgs,lr))**.2046) + ELSE ! izwisventr = 2 +! Following Wisner et al. (1972) but using gamma of volume. Note that Ferrier rain fall speed does not integrate with gamma of volume, so using Vr = ar*d^br + rwvent(mgs) = & + & (0.78*ventrx(mgs) + 0.308*ventrxn(mgs)*fvent(mgs) & + & *Sqrt((ar*rhovt(mgs))) & + & *(xdia(mgs,lr,1)**((1.0+br)/2.0)) ) + ENDIF + + ELSE ! imurain == 1 + + IF ( iferwisventr == 1 ) THEN + alpr = Min(alpharmax,alpha(mgs,lr) ) +! alpr = alpha(mgs,lr) + x = 1. + alpr + + tmp = 1 + alpr + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = 2.5 + alpr + 0.5*bx(lr) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = (gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami)/g1palp ! ratio of gamma functions + +! vent1 = dble(xdia(mgs,lr,1))**(-2. - alpr) ! Actually OK +! vent2 = dble(1./xdia(mgs,lr,1) + 0.5*fx(lr))**dble(2.5+alpr+0.5*bx(lr)) ! Actually OK + vent1 = dble(xdia(mgs,lr,1))**(0.5 + 0.5*bx(lr)) ! 2016.2.26 Changed for consistency with derivation (recast formula) + vent2 = dble(1. + 0.5*fx(lr)*xdia(mgs,lr,1))**dble(2.5+alpr+0.5*bx(lr)) + + + rwvent(mgs) = & + & 0.78*x + & + & 0.308*fvent(mgs)*y* & + & Sqrt(ax(lr)*rhovt(mgs))*(vent1/vent2) + + ELSEIF ( iferwisventr == 2 ) THEN + +! Following Wisner et al. (1972) but using gamma of volume. Note that Ferrier rain fall speed does not integrate with gamma of volume, so using Vr = ar*d^br + x = 1. + alpha(mgs,lr) + + rwvent(mgs) = & + & (0.78*x + 0.308*ventrxn(mgs)*fvent(mgs) & + & *Sqrt((ar*rhovt(mgs))) & + & *(xdia(mgs,lr,1)**((1.0+br)/2.0)) ) + + + ENDIF ! iferwisventr + + ENDIF ! imurain + + d1r = (1./(ac1 + bc))*4.0*pi*rwvent(mgs) & + & *0.5*xdia(mgs,lr,1)*cx(mgs,lr)*rhoinv(mgs) + ELSE + d1r = 0.0 + ENDIF + + + e1 = felvcp(mgs)/(pi0(mgs)) + f1 = pk(mgs) ! (pres(mgs)/poo)**cap + +! +! fifth trial to see what happens: +! + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + ltemq1 = ltemq + temp1 = temg(mgs) + p380 = 380.0/pres(mgs) + +! taus = Max( 0.05*dtp, Min(taus, 0.25*dtp ) ) +! nc = NInt(dtp/Min(1.0,0.5*taus)) +! dtcon = dtp/float(nc) + ss1 = qx(mgs,lv)/qvs(mgs) + ss2 = ss1 + temp2 = temp1 + qv1 = qx(mgs,lv) + qvs1 = qvs(mgs) + qis1 = qis(mgs) + dt1 = 0.0 + + +! dtcon = Max(dtcon,0.2) +! nc = Nint(dtp/dtcon) + + ltemq1 = ltemq +! want to start out with a small time step to handle the steep slope +! and fast changes, then can switch to a larger step (dtcon2) for the +! rest of the big time step. +! base the initial time step (dtcon1) on the slope (delta) + IF ( Abs(ss1 - 1.0) .gt. 1.e-5 ) THEN + delta = 0.5*(qv1-qvs1)/(d1*(ss1 - 1.0)) + ELSE + delta = 0.1*dtp + ENDIF +! delta is the extrapolated time to get halfway from qv1 to qvs1 +! want at least 5 time steps to the halfway point, so multiply by 0.2 +! for the initial time step + dtcon1 = Min(0.05,0.2*delta) + nc = Max(5,2*NInt( (dtp-4.0*dtcon1)/delta)) + dtcon2 = (dtp-4.0*dtcon1)/nc + + n = 1 + dt1 = 0.0 + nc = 0 + dqc = 0.0 + dqr = 0.0 + dqi = 0.0 + dqs = 0.0 + dqvii = 0.0 + dqvis = 0.0 + + RK2c: DO WHILE ( dt1 .lt. dtp ) + nc = 0 + IF ( n .le. 4 ) THEN + dtcon = dtcon1 + ELSE + dtcon = dtcon2 + ENDIF + 609 dqv = -(ss1 - 1.)*d1*dtcon + dqvr = -(ss1 - 1.)*d1r*dtcon + dtemp = -0.5*e1*f1*(dqv + dqvr) +! write(0,*) 'RK2c dqv1 = ',dqv +! calculate midpoint values: + ! ltemq1m = ltemq1 + Nint(dtemp*fqsat + 0.5) + + ! 7.6.2016: Test full calc of ltemq + ltemq1m = (temp1+dtemp-163.15)*fqsati+1.5 + ltemq1m = Min( nqsat, Max(1,ltemq1m) ) + + IF ( ltemq1m .lt. 1 .or. ltemq1m .gt. nqsat ) THEN + write(0,*) 'STOP in nucond line 1192 ' + write(0,*) ' ltemq1m,icond = ',ltemq1m,icond + write(0,*) ' dtemp,e1,f1,dqv,dqvr = ', dtemp,e1,f1,dqv,dqvr + write(0,*) ' d1,d1r,dtcon,ss1 = ',d1,d1r,dtcon,ss1 + write(0,*) ' dqc, dqr = ',dqc,dqr + write(0,*) ' qv,qc,qr = ',qx(mgs,lv)*1000.,qx(mgs,lc)*1000.,qx(mgs,lr)*1000. + write(0,*) ' i, j, k = ',igs(mgs),jy,kgs(mgs) + write(0,*) ' dtcon1,dtcon2,delta = ',dtcon1,dtcon2,delta + write(0,*) ' nc,dtp = ',nc,dtp + write(0,*) ' rwvent,xdia,crw,ccw = ', rwvent(mgs),xdia(mgs,lr,1),cx(mgs,lr),cx(mgs,lc) + write(0,*) ' fvent,alphar = ',fvent(mgs),alpha(mgs,lr) + write(0,*) ' xvr,xmasr,xdnr,cwc1 = ',xv(mgs,lr),xmas(mgs,lr),xdn(mgs,lr),cwc1 + ENDIF + dqvs = dtemp*p380*dtabqvs(ltemq1m) + qv1m = qv1 + dqv + dqvr +! qv1mr = qv1r + dqvr + + qvs1m = qvs1 + dqvs + ss1m = qv1m/qvs1m + + ! check for undersaturation when no ice is present, if so, then reduce time step + IF ( ss1m .lt. 1. .and. (dqvii + dqvis) .eq. 0.0 ) THEN + dtcon = (0.5*dtcon) + IF ( dtcon .ge. dtcon1 ) THEN + GOTO 609 + ELSE + EXIT + ENDIF + ENDIF +! calculate full step: + dqv = -(ss1m - 1.)*d1*dtcon + dqvr = -(ss1m - 1.)*d1r*dtcon + + +! write(0,*) 'RK2a dqv1m = ',dqv + dtemp = -e1*f1*(dqv + dqvr) + + ! ltemq1 = ltemq1 + Nint(dtemp*fqsat + 0.5) + + ! 7.6.2016: Test full calc of ltemq + ltemq1 = (temp1+dtemp-163.15)*fqsati+1.5 + ltemq1 = Min( nqsat, Max(1,ltemq1) ) + + IF ( ltemq1 .lt. 1 .or. ltemq1 .gt. nqsat ) THEN + write(0,*) 'STOP in nucond line 1230 ' + write(0,*) ' ltemq1m,icond = ',ltemq1m,icond + write(0,*) ' dtemp,e1,dqv,dqvr = ', dtemp,e1,dqv,dqvr + ENDIF + dqvs = dtemp*p380*dtabqvs(ltemq1) + + qv1 = qv1 + dqv + dqvr + + dqc = dqc - dqv + dqr = dqr - dqvr + + qvs1 = qvs1 + dqvs + ss1 = qv1/qvs1 + temp1 = temp1 + dtemp + IF ( temp2 .eq. temp1 .or. ss2 .eq. ss1 .or. & + & ss1 .eq. 1.00 .or. & + & ( n .gt. 10 .and. ss1 .lt. 1.0005 ) ) THEN +! write(0,*) 'RK2c break' + EXIT + ELSE + ss2 = ss1 + temp2 = temp1 + dt1 = dt1 + dtcon + n = n + 1 + ENDIF + ENDDO RK2c + + + dcloud = dqc ! qx(mgs,lv) - qv1 + thetap(mgs) = thetap(mgs) + e1*(DCLOUD + dqr) + + + IF ( eqtset > 2 ) THEN + pipert(mgs) = pipert(mgs) + felvpi(mgs)*(DCLOUD + dqr) + ENDIF + IF ( io_flag .and. nxtra > 1 ) THEN + axtra(igs(mgs),jy,kgs(mgs),1) = DCLOUD/dtp + axtra(igs(mgs),jy,kgs(mgs),2) = axtra(igs(mgs),jy,kgs(mgs),2) + dqr/dtp + ENDIF + qwvp(mgs) = qwvp(mgs) - (DCLOUD + dqr) + qx(mgs,lc) = qx(mgs,lc) + DCLOUD + qx(mgs,lr) = qx(mgs,lr) + dqr +! t9(igs(mgs),jy,kgs(mgs)) = t9(igs(mgs),jy,kgs(mgs)) + (DCLOUD + dqr)/dtp*felv(mgs)/(cp*pi0(mgs)) !* & +!! & dx*dy*dz3d(igs(mgs),jy,kgs(mgs)) + + + theta(mgs) = thetap(mgs) + theta0(mgs) + temg(mgs) = theta(mgs)*f1 + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) +! es(mgs) = 6.1078e2*tabqvs(ltemq) + +! + + ENDIF ! dcloud .gt. 0. + + + ELSE ! qc .le. qxmin(lc) + +! IF ( ssf(mgs) .gt. 0.0 .and. .not. flag_qndrop ) THEN ! flag_qndrop turns off primary nucleation when using wrf-chem with progn=1 + IF ( ssf(mgs) .gt. 0.0 ) THEN ! .and. ssmax(mgs) .lt. sscb ) THEN ! except that wrf-chem does not seem to initialize qc for activated aerosols, so keep this, after all + + IF ( iqcinit == 1 ) THEN + + qvs0 = 380.*exp(17.27*(temg(mgs)-273.)/(temg(mgs)- 36.))/pk(mgs) + + dcloud = Max(0.0, (qx(mgs,lv)-qvs0) / (1.+qvs0*f5/(temg(mgs)-36.)**2) ) + + ELSEIF ( iqcinit == 3 ) THEN + R1=1./(1. + caw*(273.15 - cbw)*qss(mgs)*felvcp(mgs)/ & + & ((temg(mgs) - cbw)**2)) + DCLOUD=R1*(qvap(mgs) - qvs(mgs)) ! KW model adjustment; + ! this will put mass into qc if qv > sqsat exists + + ELSEIF ( iqcinit == 2 ) THEN +! R1=1./(1. + caw*(273.15 - cbw)*qss(mgs)*felv(mgs)/ +! : (cp*(temg(mgs) - cbw)**2)) +! DCLOUD=R1*(qvap(mgs) - qvs(mgs)) ! KW model adjustment; + ! this will put mass into qc if qv > sqsat exists + ssmx = ssmxinit + +! IF ( ssf(mgs) > ssmx .and. ssmax(mgs) < 3.0 ) THEN +! IF ( ssf(mgs) > ssmx .and. ccnc(mgs) > 1.0 ) THEN +! IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 5.0 .and. ccnc(mgs) > 0.1*cwnccn(mgs) ) THEN ! this one works +! IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 20.0 ) THEN ! test -- fails +! IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 20.0 .and. ccnc(mgs) > 0.1*cwnccn(mgs)) THEN ! test -- is OK + IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 20.0 .and. ccnc(mgs) > 0.05*cwnccn(mgs)) THEN ! test +! IF ( ssf(mgs) > ssmx ) THEN ! original condition + CALL QVEXCESS(ngs,mgs,qwvp,qv0,qx(1,lc),pres,thetap,theta0,dcloud, & + & pi0,tabqvs,nqsat,fqsat,cbw,fcqv1,felvcp,ssmx,pk,ngscnt) + ELSE + dcloud = 0.0 + ENDIF + ENDIF + ELSE + dcloud = 0.0 + ENDIF + + thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) + qwvp(mgs) = qwvp(mgs) - DCLOUD + qx(mgs,lc) = qx(mgs,lc) + DCLOUD + IF ( io_flag .and. nxtra > 1 ) THEN + axtra(igs(mgs),jy,kgs(mgs),1) = DCLOUD/dtp + ENDIF + theta(mgs) = thetap(mgs) + theta0(mgs) + temg(mgs) = theta(mgs)*pk(mgs) !( pres(mgs) / poo ) ** cap +! temg(mgs) = theta2temp( theta(mgs), pres(mgs) ) + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) +! es(mgs) = 6.1078e2*tabqvs(ltemq) + +!.... S. TWOMEY (1959) +! Note: get here if there is no previous cloud water and w > 0. + cn(mgs) = 0.0 + + IF ( ncdebug .ge. 1 ) THEN + write(iunit,*) 'at 613: ',qx(mgs,lc),cx(mgs,lc),wvel(mgs),ssmax(mgs),kgs(mgs) + ENDIF + + IF ( .not. flag_qndrop ) THEN ! { do not calculate number of droplets if using wrf-chem + + +! IF ( ssmax(mgs) .lt. sscb .and. qx(mgs,lc) .gt. qxmin(lc)) THEN + IF ( dcloud .gt. qxmin(lc) .and. wvel(mgs) > 0.0) THEN +! CN(mgs) = CCNE*wvel(mgs)**cnexp ! *Min(1.0,1./dtp) ! 0.3465 + CN(mgs) = CCNE0*cnuc(mgs)**(2./(2.+cck))*wvel(mgs)**cnexp ! *Min(1.0,1./dtp) ! 0.3465 + IF ( ny .le. 2 .and. cn(mgs) .gt. 0.0 & + & .and. ncdebug .ge. 1 ) THEN + write(iunit,*) 'CN: ',cn(mgs)*1.e-6, cx(mgs,lc)*1.e-6, qx(mgs,lc)*1.e3, & + & wvel(mgs), dcloud*1.e3 + IF ( cn(mgs) .gt. 1.0 ) write(iunit,*) 'cwrad = ', & + & 1.e6*(rho0(mgs)*qx(mgs,lc)/cn(mgs)*cwc1)**c1f3, & + & igs(mgs),kgs(mgs),temcg(mgs), & + & 1.e3*an(igs(mgs),jgs,kgs(mgs)-1,lc) + ENDIF + IF ( iccwflg .eq. 1 ) THEN + cn(mgs) = Min(cwccn*rho0(mgs)/rho00, Max(cn(mgs), & + & rho0(mgs)*qx(mgs,lc)/(xdn(mgs,lc)*(4.*pi/3.)*(4.e-6)**3))) + ENDIF + ELSE + cn(mgs) = 0.0 + dcloud = 0.0 +! cn(mgs) = Min(cwccn, & +! & rho0(mgs)*dcloud/(xdn(mgs,lc)*(4.*pi/3.)*(4.e-6)**3) ) + ENDIF + + IF ( cn(mgs) .gt. 0.0 ) THEN + IF ( cn(mgs) .gt. ccnc(mgs) ) THEN + cn(mgs) = ccnc(mgs) +! ccnc(mgs) = 0.0 + ENDIF +! cx(mgs,lc) = cx(mgs,lc) + cn(mgs) + IF ( irenuc <= 2 ) ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + ccna(mgs) = ccna(mgs) + cn(mgs) + ENDIF + +! write(91,*) 'nuc1: cn, ix, kz = ',cn(mgs),igs(mgs),kgs(mgs),wvel(mgs),cnexp,ccnc(mgs) + + IF( CN(mgs) .GT. cx(mgs,lc) ) cx(mgs,lc) = CN(mgs) + IF( cx(mgs,lc) .GT. 0. .AND. qx(mgs,lc) .le. qxmin(lc) ) THEN + cx(mgs,lc) = 0. + ELSE + cx(mgs,lc) = Min(cx(mgs,lc),rho0(mgs)*Max(0.0,qx(mgs,lc))/cwmasn) + ENDIF + + ENDIF ! }.not. flag_qndrop + + GOTO 613 + + END IF ! qc .gt. 0. + +! ES=EES(PIB(K)*PT) +! SQSAT=EPSI*ES/(PB(K)*1000.-ES) + +!.... CLOUD NUCLEATION +! T=PIB(K)*PT +! ES=1.E3*PB(K)*QV/EPSI + + IF ( wvel(mgs) .le. 0. ) GO TO 616 + IF ( cx(mgs,lc) .le. 0. ) GO TO 613 !TWOMEY (1959) Nucleation + IF ( kzbeg-1+kgs(mgs) .GT. 1 .and. qx(mgs,lc) .le. qxmin(lc)) GO TO 613 !TWOMEY (1959) Nucleation + IF ( kzbeg-1+kgs(mgs) .eq. 1 .and. wvel(mgs) .gt. 0. ) GO TO 613 !TWOMEY (1959) Nucleation +!.... ATTEMPT ZIEGLER CLOUD NUCLEATION IN CLOUD INTERIOR UNLESS... + 616 IF ( ssf(mgs) .LE. SUPCB .AND. wvel(mgs) .GT. 0. ) GO TO 631 !... weakly saturated updraft + IF ( kzbeg-1+kgs(mgs) .GT. 1 .AND. kzbeg-1+kgs(mgs) .LT. nzend-1 .AND. & + & (ssfkp1(mgs) .GE. SUPMX .OR. & + & ssf(mgs) .GE. SUPMX .OR. & + & ssfkm1(mgs) .GE. SUPMX)) GO TO 631 !... too much vapour + IF (ssf(mgs) .LT. 1.E-10 .OR. ssf(mgs) .GE. SUPMX) GO TO 631 !... at the extremes for ss + +! +! get here if ( qc > 0 and ss > supcb) or (w < 0) +! + + if (ndebug .gt. 0) write(0,*) "ICEZVD_DR: Entered Ziegler Cloud Nucleation" !mpidebug + + DSSDZ=0. + r2dzm=0.50/dz3d(igs(mgs),jy,kgs(mgs)) + IF ( irenuc >= 0 .and. .not. flag_qndrop) THEN ! turn off nucleation when flag_qndrop (using WRF-CHEM for activation) + + IF ( irenuc < 2 ) THEN !{ + + IF ( kzend == nzend ) THEN + t0p3 = t0(igs(mgs),jgs,Min(kze,kgs(mgs)+3)) + t0p1 = t0(igs(mgs),jgs,Min(kze,kgs(mgs)+1)) + ELSE + t0p3 = t0(igs(mgs),jgs,kgs(mgs)+3) + t0p1 = t0(igs(mgs),jgs,kgs(mgs)+1) + ENDIF + + IF ( ( ssf(mgs) .gt. ssmax(mgs) .or. irenuc .eq. 1 ) & + & .and. ( ( lccn .lt. 1 .and. & + & cx(mgs,lc) .lt. cwccn*(Min(1.0,rho0(mgs)))) .or. & + & ( lccn .gt. 1 .and. ccnc(mgs) .gt. 0. ) ) & + & ) THEN + IF( kzbeg-1+kgs(mgs) .GT. 1 .AND. kzbeg-1+kgs(mgs) .LT. nzend-1 & + & .and. ssf(mgs) .gt. 0.0 & + & .and. ssfkp1(mgs) .LT. SUPMX .and. ssfkp1(mgs) .ge. 0.0 & + & .AND. ssfkm1(mgs) .LT. SUPMX .AND. ssfkm1(mgs) .ge. 0.0 & + & .AND. ssfkp1(mgs) .gt. ssfkm1(mgs) & + & .and. t0p3 .gt. 233.2) THEN + DSSDZ = (ssfkp1(mgs) - ssfkm1(mgs))*R2DZM +! +! otherwise check for cloud base condition with updraft: +! + ELSEIF( kzbeg-1+kgs(mgs) .GT. 1 .AND. kzbeg-1+kgs(mgs) .LT. nzend-1 & +! IF( kgs(mgs) .GT. 1 .AND. kgs(mgs) .LT. NZ-1 & !) + & .and. ssf(mgs) .gt. 0.0 .and. wvel(mgs) .gt. 0.0 & + & .and. ssfkp1(mgs) .gt. 0.0 & + & .AND. ssfkm1(mgs) .le. 0.0 .and. wvelkm1(mgs) .gt. 0.0 & + & .AND. ssf(mgs) .gt. ssfkm1(mgs) & + & .and. t0p1 .gt. 233.2) THEN + DSSDZ = 2.*(ssf(mgs) - ssfkm1(mgs))*R2DZM ! 1-sided difference + ENDIF + + ENDIF +! +!CLZ IF(wijk.LE.0.) CN=CCN*ssfilt(ix,jy,kz)**CCK +! note: CCN -> cwccn, DELT -> dtp + c1 = Max(0.0, rho0(mgs)*(qx(mgs,lv) - qss(mgs))/ & + & (xdn(mgs,lc)*(4.*pi/3.)*(4.e-6)**3)) + IF ( lccn .lt. 1 ) THEN + CN(mgs) = cwccn*rho0(mgs)/rho00*CCK*ssf(mgs)**CCKM*dtp* & + & Max(0.0, & + & (wvel(mgs)*DSSDZ) ) ! probably the vertical gradient dominates + ELSE + CN(mgs) = & + & Min(ccnc(mgs), cnuc(mgs)*CCK*ssf(mgs)**CCKM*dtp* & + & Max(0.0, & + & ( wvel(mgs)*DSSDZ) ) ) +! IF ( cn(mgs) .gt. 0 ) ccnc(mgs) = ccnc(mgs) - cn(mgs) + ENDIF + + IF ( cn(mgs) .gt. 0.0 ) THEN + IF ( ccnc(mgs) .lt. 5.e7 .and. cn(mgs) .ge. 5.e7 ) THEN + cn(mgs) = 5.e7 + ccnc(mgs) = 0.0 + ELSEIF ( cn(mgs) .gt. ccnc(mgs) ) THEN + cn(mgs) = ccnc(mgs) + ccnc(mgs) = 0.0 + ENDIF + cx(mgs,lc) = cx(mgs,lc) + cn(mgs) + ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + ENDIF + + ELSEIF ( irenuc == 2 ) THEN !} { + ! simple Twomey scheme +! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs) + CN(mgs) = CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp ! *Min(1.0,1./dtp) ! 0.3465 +! ccne = ccnefac*1.e6*(1.e-6*Abs(cwccn))**(2./(2.+cck)) +!!! CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) ) ! this was from + ! Philips, Donner et al. 2007, but results in too much limitation of + ! nucleation + CN(mgs) = Min(cn(mgs), ccnc(mgs)) + cn(mgs) = Min(cn(mgs), 0.5*dqc/cwmasn) ! limit the nucleation mass to half of the condensation mass + + IF ( .false. .and. ny <= 2 ) THEN + write(0,*) 'i,k, cwmasn = ',igs(mgs),kgs(mgs),cwmasn + write(0,*) 'wvel, cnuc, cn = ',wvel(mgs),cnuc(mgs),cn(mgs) + write(0,*) 'ccne0,cnexp,cck = ',ccne0,cnexp,cck + write(0,*) 'part1, part2 = ',CCNE0*cnuc(mgs)**(2./(2.+cck)), Max(0.0,wvel(mgs))**cnexp + write(0,*) 'ccnc, dqc, dqc/cwmasn = ',ccnc(mgs), dqc, 0.5*dqc/cwmasn + ENDIF + + IF ( icnuclimit > 0 ) THEN + tmp = ccnc(mgs) + cx(mgs,lc) + IF ( tmp < 330.34e6 ) THEN + ccwmax = 1.1173e6 * (1.e-6*tmp)**0.9504 + ELSE + ccwmax = 21.57e6 * (1.e-6*tmp)**0.44 + ENDIF + +! IF ( cn(mgs) > 0. ) THEN +! write(0,*) 'cn,tmp,ccwmax,cx,c-cx = ',cn(mgs),tmp,ccwmax,cx(mgs,lc),ccwmax - cx(mgs,lc) +! ENDIF + + cn(mgs) = Max( 0.0, Min( cn(mgs), ccwmax - cx(mgs,lc) ) ) + + ENDIF + + cx(mgs,lc) = cx(mgs,lc) + cn(mgs) + + ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + + ELSEIF ( irenuc == 5 ) THEN !} { + + ! modification of Phillips Donner Garner 2007 +! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs) +! CN(mgs) = Min( 0.91*cnuc(mgs), CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465 + CN(mgs) = Min( cnuc(mgs), CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp ) + + + IF ( ccna(mgs) >= cnuc(mgs) ) THEN ! apply limit after all "base" CCN have been depleted + temp1 = (theta0(mgs)+thetap(mgs))*pk(mgs) ! t77(ix,jy,kz) + ltemq = Int( (temp1-163.15)/fqsat+1.5 ) + ltemq = Min( nqsat, Max(1,ltemq) ) + + c1= pqs(mgs)*tabqvs(ltemq) + IF ( c1 > 0. ) THEN + ssf(mgs) = Max(0.0, 100.*((qv0(mgs) + qwvp(mgs))/c1 - 1.0) ) ! from "new" values + ELSE + ssf(mgs) = 0.0 + ENDIF + + + CN(mgs) = Max( cn(mgs), cnuc(mgs)*Min(ssf2kmax, ssf(mgs)**cck) ) ! this allows cn(mgs) > cnuc(mgs) + + ! cn(mgs) = Min( cn(mgs), cnuc(mgs) ) + +! IF ( ccna(mgs) >= cnuc(mgs) ) THEN ! apply limit after all "base" CCN have been depleted + CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) ) ! this was from + + ELSE + CN(mgs) = Min( cn(mgs), cnuc(mgs) - ccna(mgs) ) ! no more than remaining "base" CCN + ENDIF + ! Philips, Donner et al. 2007, but results in too much limitation of + ! nucleation +! CN(mgs) = Min(cn(mgs), ccnc(mgs)) +! cn(mgs) = Min(cn(mgs), 0.5*dqc/cwmasn) ! limit the nucleation mass to half of the condensation mass + dcrit = 2.0*2.0e-6 + dcloud = 1000.*dcrit**3*Pi/6. + ! cn(mgs) = Min(cn(mgs), 0.5*dqc/dcloud) ! limit the nucleation mass to half of the condensation mass + ! check new droplet size: + ! tmp is number of droplets at diameter dcrit + tmp = Max(0.0, rho0(mgs)*qx(mgs,lc)/dcloud - cx(mgs,lc)) ! (cx(mgs,lc) + cn(mgs)) + cn(mgs) = Min(tmp, cn(mgs) ) + + + IF ( cn(mgs) > 0.0 ) THEN + cx(mgs,lc) = cx(mgs,lc) + cn(mgs) + + dcrit = 2.5e-7 + + dcloud = 1000.*dcrit**3*Pi/6.*cn(mgs) + qx(mgs,lc) = qx(mgs,lc) + DCLOUD + thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) + qwvp(mgs) = qwvp(mgs) - DCLOUD + ENDIF + ! 6/13/2016: Phillips et al. appears not to decrement CCN, but only increments CCNa. + ! This would allow an initially non-homogeneous (vertically, e.g.) initial value of CCN/rho_air + ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + ELSEIF ( irenuc == 7 ) THEN !} { + + ! simple Twomey scheme but limit activation to try to do most activation near cloud base, but keep some CCN available for renuclation +! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs) + cn(mgs) = 0.0 +! IF ( ccna(mgs) < 0.7*cnuc(mgs) .and. ccnc(mgs) > 0.69*cnuc(mgs) - ccna(mgs)) THEN ! here, assume we are near cloud base and use Twomey formulation + IF ( ccna(mgs) < 0.9*cnuc(mgs) ) THEN ! { here, assume we are near cloud base and use Twomey formulation + CN(mgs) = Min( 0.91*cnuc(mgs), CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465 +! IF ( cn(mgs) + ccna(mgs) > 0.71*cnuc ) THEN + ! prevent this branch from activating more than 70% of CCN + CN(mgs) = Min( CN(mgs), Max(0.0, (0.9*cnuc(mgs) - ccna(mgs) )) ) +! CN(mgs) = Min( CN(mgs), Max(0.0, 0.71*ccnc(mgs) - ccna(mgs) ) ) + ! write(0,*) '1: k,cn = ',kgs(mgs),cn(mgs),ssf(mgs) +!! IF ( ccncuf(mgs) > 0.0 .and. cn(mgs) < 1.e-3 .and. ssmax(mgs) > 1.0 ) THEN +! IF ( ccncuf(mgs) > 0.0 .and. ssf(mgs) > ssmxuf .and. ssmax(mgs) > ssmxuf ) THEN +! CNuf(mgs) = Min( ccncuf(mgs), CCNE0*ccncuf(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465 + ! IF ( cnuf(mgs) >= 0.0 ) write(0,*) '1: cnuf, k = ',cnuf(mgs),ccncuf(mgs),kgs(mgs) +! ENDIF + + + ELSE ! }{ + ! if a large fraction of CCN have been activated, then assume we are in the cloud interior and use local SSw as in Phillips et al. 2007. + + temp1 = (theta0(mgs)+thetap(mgs))*pk(mgs) ! t77(ix,jy,kz) +! t0(ix,jy,kz) = temp1 + ltemq = Int( (temp1-163.15)/fqsat+1.5 ) + ltemq = Min( nqsat, Max(1,ltemq) ) + + ! c1 = t00(igs(mgs),jy,kgs(mgs))*tabqvs(ltemq) + c1= pqs(mgs)*tabqvs(ltemq) + + ssf(mgs) = 0.0 + IF ( c1 > 0. ) THEN + ssf(mgs) = 100.*(qx(mgs,lv)/c1 - 1.0) ! from "new" values + ENDIF + +! IF ( ssf(mgs) <= 1.0 .or. cnuc(mgs) > ccna(mgs) ) THEN + IF ( ssf(mgs) <= 1.0 ) THEN + CN(mgs) = cnuc(mgs)*Min(1.0, Max(0.0,ssf(mgs))**cck ) ! + ELSE + CN(mgs) = cnuc(mgs)*Min(2.0, Max(0.0,0.03*(ssf(mgs)-1.0)+1.)**cck ) ! +! write(0,*) 'iren7: ssf,ssmx = ',ssf(mgs),ssmax(mgs),cn(mgs),ccna(mgs),cnuc(mgs) +! write(0,*) 'c1,qv = ',c1,qx(mgs,lv),temp1,ltemq + ENDIF + + ! write(0,*) 'k,cn = ',kgs(mgs),cn(mgs),ssf(mgs) + ! write(0,*) 'ccn-ccna = ',cnuc(mgs) - ccna(mgs),ccnc(mgs) - ccna(mgs) +! IF ( ccncuf(mgs) > 0.0 .and. cn(mgs) < 1.e-3 .and. ssmax(mgs) > 1.0 ) THEN + IF ( ccncuf(mgs) > 0.0 .and. ssf(mgs) > ssmxuf .and. ssmax(mgs) > ssmxuf ) THEN + CNuf(mgs) = Min( ccncuf(mgs), CCNE0*ccncuf(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465 + ! IF ( cnuf(mgs) >= 0.0 ) write(0,*) 'cnuf, k = ',cnuf(mgs),ccncuf(mgs),kgs(mgs) + ENDIF + + +! CN(mgs) = Min( Min(0.1,ssf(mgs)-1.)*cnuc(mgs), Max( 0.0, CN(mgs) - ccna(mgs) ) ) ! this was from +! CN(mgs) = Min( Min(0.5*cx(mgs,lc), Min(0.1,ssf(mgs)/100.)*cnuc(mgs)), Max( 0.0, CN(mgs) - ccna(mgs) ) ) ! this was from + + CN(mgs) = Min(0.01*cnuc(mgs), Max( 0.0, CN(mgs) - ccna(mgs) ) ) ! this was from + + ENDIF ! } +! ccne = ccnefac*1.e6*(1.e-6*Abs(cwccn))**(2./(2.+cck)) +!!! CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) ) ! this was from + ! Philips, Donner et al. 2007, but results in too much limitation of + ! nucleation +! CN(mgs) = Min(cn(mgs), ccnc(mgs)) +! cn(mgs) = Min(cn(mgs), 0.5*dqc/cwmasn) ! limit the nucleation mass to half of the condensation mass + + + IF ( icnuclimit > 0 ) THEN +! max droplet conc. based on Chandrakar et al. (2016) and Konwar et al. (2012) + tmp = ccnc(mgs) - ccna(mgs) + cx(mgs,lc) + IF ( tmp < 330.34e6 ) THEN + ccwmax = 1.1173e6 * (1.e-6*tmp)**0.9504 + ELSE + ccwmax = 21.57e6 * (1.e-6*tmp)**0.44 + ENDIF + + cn(mgs) = Max( 0.0, Min( cn(mgs), ccwmax - cx(mgs,lc) ) ) + + ENDIF + + IF ( cn(mgs) + cnuf(mgs) > 0.0 ) THEN + + dcrit = 2.0*2.0e-6 + dcloud = 1000.*dcrit**3*Pi/6. + ! cn(mgs) = Min(cn(mgs), 0.5*dqc/dcloud) ! limit the nucleation mass to half of the condensation mass + ! check new droplet size: + ! tmp is number of droplets at diameter dcrit + tmp = Max(0.0, rho0(mgs)*qx(mgs,lc)/dcloud - cx(mgs,lc)) ! (cx(mgs,lc) + cn(mgs)) + cn(mgs) = Min(tmp, cn(mgs) ) + + cx(mgs,lc) = cx(mgs,lc) + cn(mgs) + cnuf(mgs) + + + ! create some small droplets at minimum size (CP 2000), although it adds very little liquid + + + dcrit = 2.0*2.5e-7 + dcloud = 1000.*dcrit**3*Pi/6.*(cn(mgs) + cnuf(mgs) ) + qx(mgs,lc) = qx(mgs,lc) + DCLOUD + thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) + qwvp(mgs) = qwvp(mgs) - DCLOUD + ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + ccncuf(mgs) = Max(0.0, ccncuf(mgs) - cnuf(mgs)) + ENDIF + + ELSEIF ( irenuc == 8 ) THEN !} { + ! simple Twomey scheme +! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs) + + cn(mgs) = 0.0 + + IF ( ccnc(mgs) > 0. ) THEN + CN(mgs) = CCNE0*ccnc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp ! *Min(1.0,1./dtp) ! 0.3465 +! ccne = ccnefac*1.e6*(1.e-6*Abs(cwccn))**(2./(2.+cck)) +!!! CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) ) ! this was from + ! Philips, Donner et al. 2007, but results in too much limitation of + ! nucleation + CN(mgs) = Min(cn(mgs), ccnc(mgs)) + + ELSEIF ( cx(mgs,lc) < 0.01e9 ) THEN + + ! if a large fraction of CCN have been activated, then assume we are in the cloud interior and use local SSw as in Phillips et al. 2007. + + temp1 = (theta0(mgs)+thetap(mgs))*pk(mgs) ! t77(ix,jy,kz) +! t0(ix,jy,kz) = temp1 + ltemq = Int( (temp1-163.15)/fqsat+1.5 ) + ltemq = Min( nqsat, Max(1,ltemq) ) + + ! c1 = t00(igs(mgs),jy,kgs(mgs))*tabqvs(ltemq) + c1= pqs(mgs)*tabqvs(ltemq) + + ssf(mgs) = 0.0 + IF ( c1 > 0. ) THEN + ssf(mgs) = 100.*(qx(mgs,lv)/c1 - 1.0) ! from "new" values + ENDIF + +! IF ( ssf(mgs) <= 1.0 .or. cnuc(mgs) > ccna(mgs) ) THEN + IF ( ssf(mgs) <= 1.0 ) THEN + CN(mgs) = 0.0 + ELSE +! CN(mgs) = 0.01e9*rho0(mgs)/rho00*Min(2.0, Max(0.0,0.03*(ssf(mgs)-1.0)+1.)**cck ) - cx(mgs,lc) ! + CN(mgs) = 0.01e9*Min(2.0, Max(0.0,0.03*(ssf(mgs)-1.0)+1.)**cck ) - cx(mgs,lc) ! + ENDIF + + ENDIF + + IF ( cn(mgs) > 0.0 ) THEN + cx(mgs,lc) = cx(mgs,lc) + cn(mgs) + + ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + + ! create some small droplets at minimum size (CP 2000), although it adds very little liquid + + dcrit = 2.0*2.5e-7 + + dcloud = 1000.*dcrit**3*Pi/6.*cn(mgs) + qx(mgs,lc) = qx(mgs,lc) + DCLOUD + thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) + qwvp(mgs) = qwvp(mgs) - DCLOUD + ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + ENDIF + + + + ENDIF ! } + + ccna(mgs) = ccna(mgs) + cn(mgs) + + + + ENDIF ! irenuc >= 0 .and. .not. flag_qndrop + + IF( cx(mgs,lc) .GT. 0. .AND. qx(mgs,lc) .LE. qxmin(lc)) cx(mgs,lc)=0. + GO TO 631 +!.... NUCLEATION ON CLOUD INFLOW BOUNDARY POINT + + 613 CONTINUE + + 631 CONTINUE + +! +! Check for supersaturation greater than ssmx and adjust down +! + ssmx = maxsupersat + qv1 = qv0(mgs) + qwvp(mgs) + qvs1 = qvs(mgs) + +! IF ( flag_qndrop .and. do_satadj_for_wrfchem ) ssmx = 1.04 ! set lower threshold for progn=1 when using WRF-CHEM + + IF ( qv1 .gt. (ssmx*qvs1) ) THEN +! use line below to disable saturation adjustment when flag_qndrop is true +! IF ( qv1 .gt. (ssmx*qvs1) .and. .not. flag_qndrop ) THEN + + ss1 = qv1/qvs1 + + ssmx = 100.*(ssmx - 1.0) + + qvex = 0.0 + + CALL QVEXCESS(ngs,mgs,qwvp,qv0,qx(1,lc),pres,thetap,theta0,qvex, & + & pi0,tabqvs,nqsat,fqsat,cbw,fcqv1,felvcp,ssmx,pk,ngscnt) + + + + IF ( qvex .gt. 0.0 ) THEN + thetap(mgs) = thetap(mgs) + felvcp(mgs)*qvex/(pi0(mgs)) + IF ( io_flag .and. nxtra > 1 ) THEN + axtra(igs(mgs),jy,kgs(mgs),1) = axtra(igs(mgs),jy,kgs(mgs),1) + qvex/dtp + ENDIF + qwvp(mgs) = qwvp(mgs) - qvex + qx(mgs,lc) = qx(mgs,lc) + qvex + IF ( .not. flag_qndrop) THEN + IF ( imaxsupopt == 1 ) THEN + cn(mgs) = Min( Max(ccnc(mgs),cwnccn(mgs)), rho0(mgs)*qvex/Max( cwmasn5, xmas(mgs,lc) ) ) + ELSEIF ( imaxsupopt == 2 ) THEN + cn(mgs) = Min( Max(ccnc(mgs),cwnccn(mgs)), rho0(mgs)*qvex/Max( cwmasn5, Max(cwmas30,xmas(mgs,lc)) ) ) + ELSEIF ( imaxsupopt == 3 ) THEN + cn(mgs) = Min( Max(ccnc(mgs),cwnccn(mgs)), rho0(mgs)*qvex/Max( cwmasn5, Max(cwmasx,xmas(mgs,lc)) ) ) +! cn(mgs) = 1.5*cxmin + ELSEIF ( imaxsupopt == 4 ) THEN + cn(mgs) = Min( Max(ccnc(mgs),cwnccn(mgs)), rho0(mgs)*qvex/Max( cwmasn5, Max(cwmas20,xmas(mgs,lc)) ) ) + ENDIF + ccnc(mgs) = Max( 0.0, ccnc(mgs) - cn(mgs) ) + cx(mgs,lc) = cx(mgs,lc) + cn(mgs) + ENDIF + +! write(iunit,*) 'theta = ',theta0(mgs) + thetap(mgs) + +! temg(mgs) = theta(mgs)*( pres(mgs) / poo ) ** cap + + ENDIF + + + ENDIF + +! +! Calculate droplet volume and check if it is within bounds. +! Adjust if necessary +! +! if (ndebug .gt. 0) write(0,*) "ICEZVD_DR: check droplet volume" + + +! cx(mgs,lc) = Min( cwnccn(mgs), cx(mgs,lc) ) + IF( cx(mgs,lc) > cxmin .AND. qx(mgs,lc) .GT. qxmin(lc)) THEN +! SVC(mgs) = rho0(mgs)*qx(mgs,lc)/(cx(mgs,lc)*xdn(mgs,lc)) + xmas(mgs,lc) = rho0(mgs)*qx(mgs,lc)/(cx(mgs,lc)) + + IF ( xmas(mgs,lc) < cwmasn .or. xmas(mgs,lc) > cwmasx ) THEN + tmp = cx(mgs,lc) + xmas(mgs,lc) = Min( xmas(mgs,lc), cwmasx ) + xmas(mgs,lc) = Max( xmas(mgs,lc), cwmasn ) + cx(mgs,lc) = rho0(mgs)*qx(mgs,lc)/xmas(mgs,lc) +! IF ( cx(mgs,lc) > tmp*1.1 ) THEN +! write(0,*) 'nucond: kgs, ccw1,2 = ',kgs(mgs),tmp,cx(mgs,lc) +! ENDIF + ENDIF + ENDIF + + +! IF( cx(mgs,lc) .GT. 10.e6 .AND. qx(mgs,lc) .GT. qxmin(lc) ) GO TO 681 +! ccwtmp = cx(mgs,lc) +! cwmastmp = xmas(mgs,lc) +! xmas(mgs,lc) = Max(xmas(mgs,lc), cwmasn) +! IF (qx(mgs,lc) .GT. qxmin(lc) .AND. cx(mgs,lc) .le. 0.) THEN +! cx(mgs,lc) = Min(0.5*cwccn,rho0(mgs)*qx(mgs,lc)/xmas(mgs,lc)) +! xmas(mgs,lc) = rho0(mgs)*qx(mgs,lc)/cx(mgs,lc) +! ENDIF +! IF (cx(mgs,lc) .GT. 0. .AND. qx(mgs,lc) .GT. qxmin(lc)) & +! & xmas(mgs,lc) = rho0(mgs)*qx(mgs,lc)/cx(mgs,lc) +! IF (qx(mgs,lc) .GT. qxmin(lc) .AND. xmas(mgs,lc) .LT. cwmasn) & +! & xmas(mgs,lc) = cwmasn +! IF (qx(mgs,lc) .GT. qxmin(lc) .AND. xmas(mgs,lc) .GT. cwmasx) & +! & xmas(mgs,lc) = cwmasx +! IF ( qx(mgs,lc) .gt. qxmin(lc) ) THEN +! cx(mgs,lc) = rho0(mgs)*qx(mgs,lc)/Max(cwmasn,xmas(mgs,lc)) +! ENDIF +! +! +! 681 CONTINUE + + + IF ( ipconc .ge. 3 .and. rcond == 2 ) THEN + + + IF (cx(mgs,lr) .GT. 0. .AND. qx(mgs,lr) .GT. qxmin(lr)) & + & xv(mgs,lr)=rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*cx(mgs,lr)) + IF (xv(mgs,lr) .GT. xvmx(lr)) xv(mgs,lr) = xvmx(lr) + IF (xv(mgs,lr) .LT. xvmn(lr)) xv(mgs,lr) = xvmn(lr) + + ENDIF + + + + ENDDO ! mgs + + +! ################################################################ + DO mgs=1,ngscnt + IF ( lss > 1 .and. ssf(mgs) .gt. ssmax(mgs) & + & .and. ( idecss .eq. 0 .or. qx(mgs,lc) .gt. qxmin(lc)) ) THEN + ssmax(mgs) = ssf(mgs) + ENDIF + ENDDO +! + + do mgs = 1,ngscnt + an(igs(mgs),jy,kgs(mgs),lt) = theta0(mgs) + thetap(mgs) + an(igs(mgs),jy,kgs(mgs),lv) = qv0(mgs) + qwvp(mgs) +! tmp3d(igs(mgs),jy,kgs(mgs)) = tmp3d(igs(mgs),jy,kgs(mgs)) + t9(igs(mgs),jy,kgs(mgs)) ! pi0(mgs) ! wvdf(mgs) ! ssf(mgs) ! cn(mgs) +! + IF ( eqtset > 2 ) THEN + p2(igs(mgs),jy,kgs(mgs)) = pipert(mgs) + ENDIF + + if ( ido(lc) .eq. 1 ) then + an(igs(mgs),jy,kgs(mgs),lc) = qx(mgs,lc) + & + & min( an(igs(mgs),jy,kgs(mgs),lc), 0.0 ) +! qx(mgs,lc) = an(igs(mgs),jy,kgs(mgs),lc) + end if +! + + if ( ido(lr) .eq. 1 .and. rcond == 2 ) then + an(igs(mgs),jy,kgs(mgs),lr) = qx(mgs,lr) + & + & min( an(igs(mgs),jy,kgs(mgs),lr), 0.0 ) +! qx(mgs,lr) = an(igs(mgs),jy,kgs(mgs),lr) + end if + + + + IF ( ipconc .ge. 2 ) THEN + an(igs(mgs),jy,kgs(mgs),lnc) = Max(cx(mgs,lc) , 0.0) + IF ( lss > 1 ) an(igs(mgs),jy,kgs(mgs),lss) = Max( 0.0, ssmax(mgs) ) + IF ( lccn .gt. 1 ) THEN + an(igs(mgs),jy,kgs(mgs),lccn) = Max(0.0, ccnc(mgs) ) + ENDIF + IF ( lccnuf .gt. 1 ) THEN + an(igs(mgs),jy,kgs(mgs),lccnuf) = Max(0.0, ccncuf(mgs) ) + ENDIF + IF ( lccna .gt. 1 ) THEN + an(igs(mgs),jy,kgs(mgs),lccna) = Max(0.0, ccna(mgs) ) + ENDIF + ENDIF + IF ( ipconc .ge. 3 .and. rcond == 2 ) THEN + an(igs(mgs),jy,kgs(mgs),lnr) = Max(cx(mgs,lr) , 0.0) + ENDIF + end do + + +29998 continue + + + if ( kz .gt. nz-1 .and. ix .ge. nxi) then + if ( ix .ge. nxi ) then + go to 2200 ! exit gather scatter + else + nzmpb = kz + endif + else + nzmpb = kz + end if + + if ( ix .ge. nxi ) then + nxmpb = 1 + nzmpb = kz+1 + else + nxmpb = ix+1 + end if + + 2000 continue ! inumgs + 2200 continue +! +! end of gather scatter (for this jy slice) + + +!#ifdef COMMAS +! GOTO 9999 +!#endif + +! Redistribute inappreciable cloud particles and charge +! +! Redistribution everywhere in the domain... +! + IF ( .true. ) THEN + + frac = 1.0 ! 0.25 ! 1.0 ! 0.2 +! +! alternate test version for ipconc .ge. 3 +! just vaporize stuff to prevent noise in the number concentrations + + + do kz = 1,nz +! do jy = 1,1 + do ix = 1,nxi + + t0(ix,jy,kz) = an(ix,jy,kz,lt)*t77(ix,jy,kz) + + zerocx(:) = .false. + DO il = lc,lhab + IF ( iresetmoments == 1 .or. iresetmoments == il ) THEN + IF ( ln(il) > 1 ) zerocx(il) = ( an(ix,jy,kz,ln(il)) < cxmin ) + IF ( lz(il) > 1 ) zerocx(il) = ( zerocx(il) .or. an(ix,jy,kz,lz(il)) < zxmin ) + ELSE + IF ( il == lc ) THEN + IF ( ln(il) > 1 ) zerocx(il) = ( an(ix,jy,kz,ln(il)) <= 0 ) .and. .not. flag_qndrop ! do not reset if progn=1 (WRF-CHEM) + ELSE + IF ( ln(il) > 1 ) zerocx(il) = ( an(ix,jy,kz,ln(il)) <= 0 ) + ENDIF + ENDIF + ENDDO + + IF ( lhl .gt. 1 ) THEN + + + if ( an(ix,jy,kz,lhl) .lt. frac*qxmin(lhl) .or. zerocx(lhl) ) then + +! IF ( an(ix,jy,kz,lhl) .gt. 0 ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lhl) + an(ix,jy,kz,lhl) = 0.0 +! ENDIF + + IF ( ipconc .ge. 5 ) THEN ! .and. an(ix,jy,kz,lnh) .gt. 0.0 ) THEN + an(ix,jy,kz,lnhl) = 0.0 + ENDIF + + IF ( lvhl .gt. 1 ) THEN + an(ix,jy,kz,lvhl) = 0.0 + ENDIF + + IF ( lhlw .gt. 1 ) THEN + an(ix,jy,kz,lhlw) = 0.0 + ENDIF + + IF ( lnhlf .gt. 1 ) THEN + an(ix,jy,kz,lnhlf) = 0.0 + ENDIF + + IF ( lzhl .gt. 1 ) THEN + an(ix,jy,kz,lzhl) = 0.0 + ENDIF + + ELSE + IF ( lvol(lhl) .gt. 1 ) THEN ! check density + IF ( an(ix,jy,kz,lvhl) .gt. 0.0 ) THEN + tmp = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/an(ix,jy,kz,lvhl) + ELSE ! in case volume is zero but mass is above threshold (should not happen, of course) + tmp = rho_qhl + an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp + ENDIF + + IF ( tmp .lt. xdnmn(lhl) ) THEN + tmp = Max( xdnmn(lhl), tmp ) + an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp + ENDIF + + IF ( tmp .gt. xdnmx(lhl) .and. lhlw .le. 0 ) THEN ! no liquid allowed on hail + tmp = Min( xdnmx(lhl), tmp ) + an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp + ELSEIF ( tmp .gt. xdnmx(lhl) .and. lhlw .gt. 1 ) THEN ! allow for liquid on hail + fw = an(ix,jy,kz,lhlw)/an(ix,jy,kz,lhl) +! tmpmx = xdnmx(lhl) + fw*(xdnmx(lr) - xdnmx(lhl)) ! maximum possible average density + ! it is not exactly linear, but approx. is close enough for this +! tmpmx = 1./( (1. - fw)/900. + fw/1000. ) is exact max, where 900 is xdnmx + + tmpmx = xdnmx(lhl)/( 1. - fw*(1. - xdnmx(lhl)/xdnmx(lr) )) + + IF ( tmp .gt. tmpmx ) THEN + an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmpmx + ENDIF + +! IF ( tmp .gt. xdnmx(lhl) .and. an(ix,jy,kz,lhlw) .lt. qxmin(lhl) ) THEN +! tmp = Min( xdnmx(lhl), tmp ) +! an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp +! ELSEIF ( tmp .gt. xdnmx(lr) ) THEN +! tmp = xdnmx(lr) +! an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp +! ENDIF + ENDIF + + IF ( lhlw .gt. 1 ) THEN ! check if basically pure water + IF ( an(ix,jy,kz,lhlw) .gt. 0.98*an(ix,jy,kz,lhl) ) THEN + tmp = xdnmx(lr) + an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp + ENDIF + ENDIF + + ENDIF + + +! CHECK INTERCEPT + IF ( ipconc == 5 .and. an(ix,jy,kz,lhl) .gt. qxmin(lhl) .and. alphahl .le. 0.1 .and. lnhl .gt. 1 .and. lzhl == 0 ) THEN + + IF ( lvhl .gt. 1 ) THEN + hwdn = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/an(ix,jy,kz,lvhl) + ELSE + hwdn = xdn0(lhl) + ENDIF + tmp = (hwdn*an(ix,jy,kz,lnhl))/(dn(ix,jy,kz)*an(ix,jy,kz,lhl)) + tmpg = an(ix,jy,kz,lnhl)*(tmp*(3.14159))**(1./3.) + IF ( tmpg .lt. cnohlmn ) THEN + tmp = ( (hwdn)/(dn(ix,jy,kz)*an(ix,jy,kz,lhl))*(3.14159))**(1./3.) + an(ix,jy,kz,lnhl) = (cnohlmn/tmp)**(3./4.) + ENDIF + + ENDIF +! ELSE ! check mean size here? + + end if + + ENDIF !lhl + + + + + if ( an(ix,jy,kz,lh) .lt. frac*qxmin(lh) .or. zerocx(lh) ) then + +! IF ( an(ix,jy,kz,lh) .gt. 0 ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lh) + an(ix,jy,kz,lh) = 0.0 +! ENDIF + + IF ( ipconc .ge. 5 ) THEN ! .and. an(ix,jy,kz,lnh) .gt. 0.0 ) THEN + an(ix,jy,kz,lnh) = 0.0 + ENDIF + + IF ( lvh .gt. 1 ) THEN + an(ix,jy,kz,lvh) = 0.0 + ENDIF + + IF ( lhw .gt. 1 ) THEN + an(ix,jy,kz,lhw) = 0.0 + ENDIF + + IF ( lnhf .gt. 1 ) THEN + an(ix,jy,kz,lnhf) = 0.0 + ENDIF + + IF ( lzh .gt. 1 ) THEN + an(ix,jy,kz,lzh) = 0.0 + ENDIF + + ELSE + IF ( lvol(lh) .gt. 1 ) THEN ! check density + IF ( an(ix,jy,kz,lvh) .gt. 0.0 ) THEN + tmp = dn(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh) + ELSE + tmp = rho_qh + an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp + ENDIF + + IF ( tmp .lt. xdnmn(lh) ) THEN + tmp = Max( xdnmn(lh), tmp ) + an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp + ENDIF + + IF ( tmp .gt. xdnmx(lh) .and. lhw .le. 0 ) THEN ! no liquid allowed on graupel + tmp = Min( xdnmx(lh), tmp ) + an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp + ELSEIF ( tmp .gt. xdnmx(lh) .and. lhw .gt. 1 ) THEN ! allow for liquid on graupel + fw = an(ix,jy,kz,lhw)/an(ix,jy,kz,lh) +! tmpmx = xdnmx(lh) + fw*(xdnmx(lr) - xdnmx(lh)) ! maximum possible average density + ! it is not exactly linear, but approx. is close enough for this +! tmpmx = 1./( (1. - fw)/900. + fw/1000. ) is exact max, where 900 is xdnmx + tmpmx = xdnmx(lh)/( 1. - fw*(1. - xdnmx(lh)/xdnmx(lr) )) + + IF ( tmp .gt. tmpmx ) THEN + an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmpmx + ENDIF + +! IF ( tmp .gt. xdnmx(lh) .and. an(ix,jy,kz,lhw) .lt. qxmin(lh) ) THEN +! tmp = Min( xdnmx(lh), tmp ) +! an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp +! ELSEIF ( tmp .gt. xdnmx(lr) ) THEN +! tmp = xdnmx(lr) +! an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp +! ENDIF + + ENDIF + + IF ( lhw .gt. 1 ) THEN ! check if basically pure water + IF ( an(ix,jy,kz,lhw) .gt. 0.98*an(ix,jy,kz,lh) ) THEN + tmp = xdnmx(lr) + an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp + ENDIF + ENDIF + + ENDIF + +! CHECK INTERCEPT + IF ( ipconc == 5 .and. an(ix,jy,kz,lh) .gt. qxmin(lh) .and. alphah .le. 0.1 .and. lnh .gt. 1 .and. lzh == 0 ) THEN + + IF ( lvh .gt. 1 ) THEN + IF ( an(ix,jy,kz,lvh) .gt. 0.0 ) THEN + hwdn = dn(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh) + ELSE + hwdn = xdn0(lh) + ENDIF + hwdn = Max( xdnmn(lh), hwdn ) + ELSE + hwdn = xdn0(lh) + ENDIF + tmp = (hwdn*an(ix,jy,kz,lnh))/(dn(ix,jy,kz)*an(ix,jy,kz,lh)) + tmpg = an(ix,jy,kz,lnh)*(tmp*(3.14159))**(1./3.) + IF ( tmpg .lt. cnohmn ) THEN +! tmpg = an(ix,jy,kz,lnh)*( (hwdn*an(ix,jy,kz,lnh))/(dn(ix,jy,kz)*an(ix,jy,kz,lh))*(3.14159))**(1./3.) +! tmpg = an(ix,jy,kz,lnh)**(4./3.)*( (hwdn)/(dn(ix,jy,kz)*an(ix,jy,kz,lh))*(3.14159))**(1./3.) + tmp = ( (hwdn)/(dn(ix,jy,kz)*an(ix,jy,kz,lh))*(3.14159))**(1./3.) + an(ix,jy,kz,lnh) = (cnohmn/tmp)**(3./4.) + ENDIF + + ENDIF + + end if + + + if ( an(ix,jy,kz,ls) .lt. frac*qxmin(ls) .or. zerocx(ls) & ! .or. an(ix,jy,kz,lns) .lt. 0.1 ! .and. + & ) then + IF ( t0(ix,jy,kz) .lt. 273.15 ) THEN +! IF ( an(ix,jy,kz,ls) .gt. 0 ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,ls) + an(ix,jy,kz,ls) = 0.0 +! ENDIF + + IF ( ipconc .ge. 4 ) THEN ! .and. an(ix,jy,kz,lns) .gt. 0.0 ) THEN ! +! an(ix,jy,kz,lni) = an(ix,jy,kz,lni) + an(ix,jy,kz,lns) + an(ix,jy,kz,lns) = 0.0 + ENDIF + + IF ( lvs .gt. 1 ) THEN + an(ix,jy,kz,lvs) = 0.0 + ENDIF + + IF ( lsw .gt. 1 ) THEN + an(ix,jy,kz,lsw) = 0.0 + ENDIF + + ELSE +! IF ( an(ix,jy,kz,ls) .gt. 0 ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,ls) + an(ix,jy,kz,ls) = 0.0 +! ENDIF + + IF ( lvs .gt. 1 ) THEN + an(ix,jy,kz,lvs) = 0.0 + ENDIF + + IF ( lsw .gt. 1 ) THEN + an(ix,jy,kz,lsw) = 0.0 + ENDIF + + IF ( ipconc .ge. 4 ) THEN ! .and. an(ix,jy,kz,lns) .gt. 0.0 ) THEN ! +! an(ix,jy,kz,lnr) = an(ix,jy,kz,lnr) + an(ix,jy,kz,lns) + an(ix,jy,kz,lns) = 0.0 + ENDIF + + ENDIF + + + ELSEIF ( lvol(ls) .gt. 1 ) THEN ! check density + IF ( an(ix,jy,kz,lvs) .gt. 0.0 ) THEN + tmp = dn(ix,jy,kz)*an(ix,jy,kz,ls)/an(ix,jy,kz,lvs) + IF ( tmp .gt. xdnmx(ls) .or. tmp .lt. xdnmn(ls) ) THEN + tmp = Min( xdnmx(ls), Max( xdnmn(ls), tmp ) ) + an(ix,jy,kz,lvs) = dn(ix,jy,kz)*an(ix,jy,kz,ls)/tmp + ENDIF + ELSE + tmp = rho_qs + an(ix,jy,kz,lvs) = dn(ix,jy,kz)*an(ix,jy,kz,ls)/tmp + ENDIF + + + end if + + + if ( an(ix,jy,kz,lr) .lt. frac*qxmin(lr) .or. zerocx(lr) & + & ) then + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lr) + an(ix,jy,kz,lr) = 0.0 + IF ( ipconc .ge. 3 ) THEN +! an(ix,jy,kz,lnc) = an(ix,jy,kz,lnc) + an(ix,jy,kz,lnr) + an(ix,jy,kz,lnr) = 0.0 + ENDIF + + end if + +! +! for qci +! + IF ( an(ix,jy,kz,li) .le. frac*qxmin(li) .or. zerocx(li) & ! .or. an(ix,jy,kz,lni) .lt. 0.1 + & ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,li) + an(ix,jy,kz,li)= 0.0 + IF ( ipconc .ge. 1 ) THEN + an(ix,jy,kz,lni) = 0.0 + ENDIF + ENDIF + +! +! for qis +! + IF ( lis > 1 ) THEN ! { + IF ( an(ix,jy,kz,lis) .le. frac*qxmin(lis) .or. zerocx(lis) & ! .or. an(ix,jy,kz,lni) .lt. 0.1 + & ) THEN ! { { + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lis) + an(ix,jy,kz,lis)= 0.0 + IF ( ipconc .ge. 1 ) THEN + an(ix,jy,kz,lnis) = 0.0 + ENDIF + + ELSEIF ( icespheres >= 2 ) THEN ! } { + km1 = Max(1, kz-1) + IF ( 0.5*( w(ix,jy,kz) + w(ix,jy,kz+1)) < -1.0 .or. & + & (icespheres == 3 .and. ( t0(ix,jy,kz) < 232.15 .or. an(ix,jy,kz,lc) < qxmin(lc) ) ) .or. & + & (icespheres == 5 .and. ( t0(ix,jy,kz) < 232.15 .or. & + & ( an(ix,jy,kz,lc) < qxmin(lc) .and. an(ix,jy,km1,lc) < qxmin(lc) )) ) .or. & + & (icespheres == 4 .and. ( t0(ix,jy,kz) < 235.15 )) ) THEN ! transfer to regular ice crystals in downdraft or at low temp + an(ix,jy,kz,li) = an(ix,jy,kz,li) + an(ix,jy,kz,lis) + an(ix,jy,kz,lni) = an(ix,jy,kz,lni) + an(ix,jy,kz,lnis) + an(ix,jy,kz,lis)= 0.0 + an(ix,jy,kz,lnis)= 0.0 + + ENDIF + + ENDIF ! } } + ENDIF ! } + +! +! for qcw +! + + IF ( an(ix,jy,kz,lc) .le. frac*qxmin(lc) .or. zerocx(lc) & + & ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lc) + an(ix,jy,kz,lc)= 0.0 + IF ( ipconc .ge. 2 ) THEN + IF ( lccn .gt. 1 ) THEN + an(ix,jy,kz,lccn) = & + & an(ix,jy,kz,lccn) + Max(0.0,an(ix,jy,kz,lnc)) + ENDIF + an(ix,jy,kz,lnc) = 0.0 + + IF ( lccna > 0 ) THEN ! apply exponential decay to activated CCN to restore to environmental value + tmp = an(ix,jy,kz,li) + an(ix,jy,kz,ls) + + IF ( an(ix,jy,kz,lccna) > 1. .and. tmp < qxmin(li) ) an(ix,jy,kz,lccna) = an(ix,jy,kz,lccna)*Exp(-dtp/ccntimeconst) + + ELSEIF ( lccn > 1 .and. restoreccn ) THEN + ! in this case, we are treating the ccn field as ccna + tmp = an(ix,jy,kz,li) + an(ix,jy,kz,ls) +! IF ( ny == 2 .and. ix == nx/2 ) THEN +! write(0,*) 'restore: k, qccn,exp = ',kz,qccn,dn(ix,jy,kz)*qccn,Exp(-dtp/ccntimeconst) +! write(0,*) 'ccn1,ccn2 = ',an(ix,jy,kz,lccn),dn(ix,jy,kz)*qccn - Max(0.0 , dn(ix,jy,kz)*qccn - an(ix,jy,kz,lccn))*Exp(-dtp/ccntimeconst) +! ENDIF + IF ( an(ix,jy,kz,lccn) > 1. .and. tmp < qxmin(li) .and. ( an(ix,jy,kz,lccn) < dn(ix,jy,kz)*qccn .or. .not. invertccn ) ) THEN + ! an(ix,jy,kz,lccn) = & + ! an(ix,jy,kz,lccn) + Max(0.0 , dn(ix,jy,kz)*qccn - an(ix,jy,kz,lccn))*(1.0 - Exp(-dtp/ccntimeconst)) + ! Equivalent form after expanding last term: + an(ix,jy,kz,lccn) = & + dn(ix,jy,kz)*qccn - Max(0.0 , dn(ix,jy,kz)*qccn - an(ix,jy,kz,lccn))*Exp(-dtp/ccntimeconst) + ENDIF + + ENDIF + + ENDIF + + ENDIF + + end do +! end do + end do + + ENDIF ! true/false + + IF ( ndebug .ge. 1 ) write(6,*) 'END OF ICEZVD_DR' +! +! + + + 9999 RETURN + + END SUBROUTINE NUCOND + + +! ##################################################################### +! ##################################################################### +!>\ingroup mod_nsslmp +!! Main microphysical processes routine + + + + +!c-------------------------------------------------------------------------- +! +! +!-------------------------------------------------------------------------- +! + + subroutine nssl_2mom_gs & + & (nx,ny,nz,na,jyslab & + & ,nor,norz & + & ,dtp,gz & + & ,t0,t1,t2,t3,t4,t5,t6,t7,t8,t9 & + & ,an,dn,p2 & + & ,pn,w,iunit & + & ,t00,t77, & + & ventr,ventc,c1sw,jgs,ido, & + & xdnmx,xdnmn, & +! & ln,ipc,lvol,lz,lliq, & + & cdx, & + & xdn0,tmp3d,tkediss & + & ,thproc,numproc,dx1,dy1 & + & ,timevtcalc,axtra,io_flag & + & , has_wetscav,rainprod2d, evapprod2d & + & ,errmsg,errflg & + & ,elec,its,ids,ide,jds,jde & + & ) + + +! +!-------------------------------------------------------------------------- +! +! Ziegler 1985 parameterized microphysics (also Zrnic et al. 1993) +! 1) cloud water +! 2) rain +! 3) column ice +! 6) snow +! 11) graupel/hail +! +!-------------------------------------------------------------------------- +! +! Notes: +! +! 4/27/2009: allows for liquid water to be advected on snow and graupel particles using flag "mixedphase" +! +! 3/14/2007: (APS) added qproc temp to make microphysic process timeseries +! +! 10/17/2006: added flag (iehw) to select how to calculate ehw +! +! 10/5/2006: switched chacr to integrated version rather than assuming that average rain +! drop mass does not change. This acts to reduce rain size somewhat via graupel +! collection. +! Use Mason data for ehw, with scaling toward ehw=1 as air density decreases. +! +! 10/3/2006: Turned off Meyers nucleation for T > -5 (can turn on with imeyers5 flag) +! Turned off contact nucleation in updrafts +! +! 7/24/2006: Turned on Meyers nucleation for -5 < T < 0 +! +! 5/12/2006: Converted qsacw/csacw and qsaci/csaci to Z93 +! +! 5/12/2006: Put a threshold on Bigg rain freezing. If the frozen drops +! have an average volume less than xvhmn, then the drops are put +! into snow instead of graupel/hail. +! +! Fixed bug when vapor deposition was limited. +! +! 5/13/2006: Note that qhacr has a large effect, but Z85 did not include it. +! Turned off qsacr (set to zero). +! +! 9/14/2007: erm: recalculate vx(lh) after setting xdn(lh) in case xdn was out of allowed range. +! added parameter rimc3 for minimum rime density. Default value set at 170. kg/m**3 +! instead of previous use of 100. (Farley, 1987) +! +!-------------------------------------------------------------------------- +! +! general declarations +! +!-------------------------------------------------------------------------- +! +! +! + + + implicit none +! +! integer icond +! parameter ( icond = 2 ) + + integer, parameter :: ng1 = 1 + + integer nx,ny,nz,na,nba,nv + integer nor,norz,istag,jstag,kstag ! ,nht,ngt,igsr + integer iwrite + real dtp,dx,dy,dz + + logical, intent(in) :: io_flag + + integer itile,jtile,ktile + integer ixbeg,jybeg + integer ixend,jyend,kzend,kzbeg + integer nxend,nyend,nzend,nzbeg + integer :: my_rank = 0 + integer, parameter :: myprock = 1, nprock = 1 + logical, intent(in) :: has_wetscav + integer, intent(in) :: numproc + real, intent(inout) :: thproc(nz,numproc) + real, intent(in) :: dx1,dy1 + real rainprod2d(-nor+1:nx+nor,-norz+ng1:nz+norz) + real evapprod2d(-nor+1:nx+nor,-norz+ng1:nz+norz) + + real tkediss(-nor+1:nx+nor,-norz+ng1:nz+norz) + real axtra(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz,nxtra) + + real :: galpharaut + real :: xvbarmax + + integer jyslab,its,ids,ide,jds,jde ! domain boundaries + integer, intent(in) :: iunit !,iunit0 + real qvex + integer iraincv, icgxconv + parameter ( iraincv = 1, icgxconv = 1) + real ffrz + real :: ffrzh = 1.0 + + real qcitmp,cirdiatmp ! ,qiptmp,qirtmp + real ccwtmp,ccitmp ! ,ciptmp,cirtmp + real cpqc,cpci ! ,cpip,cpir + real cpqc0,cpci0 ! ,cpip0,cpir0 + real scfac ! ,cpip1 + + double precision dp1 + + double precision frac, frach, xvfrz, xvbiggsnow + + double precision :: timevtcalc + double precision :: dpt1,dpt2 + + logical, parameter :: gammacheck = .false. + integer :: luindex + double precision :: tmpgam + logical, parameter :: usegamxinfcnu = .false. + logical, parameter :: usegamxinf = .false. + logical, parameter :: usegamxinf2 = .false. + logical, parameter :: usegamxinf3 = .false. +! real rar ! rime accretion rate as calculated from qxacw + + ! CCPP error handling + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg +! a few vars for time-split fallout + real vtmax + integer n,ndfall + + double precision chgneg,chgpos,sctot + + real temgtmp + + real pb(-norz+ng1:nz+norz) + real pinit(-norz+ng1:nz+norz) + + real gz(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) ! dz + + real qimax,xni0,roqi0 + + + real dv + + real dtptmp + integer itest,nidx,id1,jd1,kd1 + parameter (itest=1) + parameter (nidx=10) + parameter (id1=1,jd1=1,kd1=1) + integer ierr + integer iend + + integer ix,kz, il, ic, ir, icp1, irp1, ip1,jp1,kp1 + integer :: jy + integer i,j,k,i1 + integer kzb,kze + real slope1, slope2 + real x1, x2, x3 + real eps,eps2 + parameter (eps=1.e-20,eps2=1.e-5) +! +! Other elec. vars +! + real temele + real trev + + logical ldovol, ishail, ltest, wtest + logical , parameter :: alp0flag = .false. +! +! +! wind indicies +! + integer mu,mv,mw + parameter (mu=1,mv=2,mw=3) +! +! conversion parameters +! + integer mqcw,mqxw,mtem,mrho,mtim + parameter (mqcw=21,mqxw=21,mtem=21,mrho=5,mtim=6) + + real xftim,xftimi,yftim, xftem,yftem, xfqcw,yfqcw, xfqxw,yfqxw + parameter (xftim=0.05,xftimi = 1./xftim,yftim=1.) + parameter (xftem=0.5,yftem=1.) + parameter (xfqcw=2000.,yfqcw=1.) + parameter (xfqxw=2000.,yfqxw=1.) + real dtfac + parameter ( dtfac = 1.0 ) + integer ido(lc:lqmx) + +! integer iexy(lc:lqmx,lc:lqmx) +! integer ieswi, ieswir, ieswip, ieswc, ieswr +! integer ieglsw, iegli, ieglir, ieglip, ieglc, ieglr +! integer iegmsw, iegmi, iegmir, iegmip, iegmc, iegmr +! integer ieghsw, ieghi, ieghir, ieghip, ieghc, ieghr +! integer iefwsw, iefwi, iefwir, iefwip, iefwc, iefwr +! integer iehwsw, iehwi, iehwir, iehwip, iehwc, iehwr +! integer iehlsw, iehli, iehlir, iehlip, iehlc, iehlr +! real delqnsa, delqxsa, delqnsb, delqxsb, delqnia, delqxia +! real delqnra, delqxra + + real delqnxa(lc:lqmx) + real delqxxa(lc:lqmx) +! +! external temporary arrays +! + real t00(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t77(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + + real t0(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t1(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t2(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t3(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t4(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t5(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t6(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t7(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t8(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t9(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + + real p2(-nor+1:nx+nor,-nor+1:ny+nor,-norz+ng1:nz+norz) ! perturbation Pi + real pn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+ng1:nz+norz) + real an(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz,na) + real dn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+ng1:nz+norz) + real w(-nor+1:nx+nor,-nor+1:ny+nor,-norz+ng1:nz+norz) + + real tmp3d(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + +! +! declarations microphyscs and for gather/scatter +! + integer nxmpb,nzmpb,nxz + integer jgs,mgs,ngs,numgs + parameter (ngs=500) !500) + integer, parameter :: ngsz = 500 + integer ntt + parameter (ntt=300) + + real dvmgs(ngs) + + integer ngscnt,igs(ngs),kgs(ngs) + integer kgsp(ngs),kgsm(ngs),kgsm2(ngs) + integer ncuse + parameter (ncuse=0) + integer il0(ngs),il5(ngs),il2(ngs),il3(ngs) +! integer il1m(ngs),il2m(ngs),il3m(ngs),il4m(ngs),il5m(ngs) +! + real tdtol,temsav,tfrcbw,tfrcbi + real, parameter :: thnuc = 235.15 +! +! Ice Multiplication Arrays. +! + real fimt1(ngs),fimta(ngs),fimt2(ngs) !,qmul1(ngs),qmul2(ngs) + real xcwmas +! +! +! Variables for Ziegler warm rain microphysics +! + + + real ccnc(ngs),ccin(ngs),cina(ngs),ccna(ngs) + real cwnccn(ngs) + real sscb ! 'cloud base' SS threshold + parameter ( sscb = 2.0 ) + integer idecss ! flag to turn on (=1) decay of ssmax when no cloud or ice crystals + parameter ( idecss = 1 ) + integer iba ! flag to do condensation/nucleation in 1st or 2nd loop + ! =0 to use ad to calculate SS + ! =1 to use an at end of main jy loop to calculate SS + parameter (iba = 1) + integer ifilt ! =1 to filter ssat, =0 to set ssfilt=ssat + parameter ( ifilt = 0 ) + real temp1,temp2 ! ,ssold + real :: mwat, mice, dice, mwshed, fwmax, fw, mwcrit, massfactor, tmpdiam + real, parameter :: shedalp = 3. ! set 3 for maximum mass diameter (same as area-weighted diameter), 4 for mass-weighted diameter + real ssmax(ngs) ! maximum SS experienced by a parcel + real ssmx + real dnnet,dqnet +! real cnu,rnu,snu,cinu +! parameter ( cnu = 0.0, rnu = -0.8, snu = -0.8, cinu = 0.0 ) + real bfnu, bfnu0, bfnu1 + parameter ( bfnu0 = (rnu + 2.0)/(rnu + 1.0) ) + real ventr, ventc + real volb + double precision t2s, xdp + double precision xl2p(ngs),rb(ngs) + real, parameter :: aa1 = 9.44e15, aa2 = 5.78e3 ! a1 in Ziegler +! snow parameters: + real, parameter :: cexs = 0.1, cecs = 0.5 + real, parameter :: rvt = 0.104 ! ratio of collection kernels (Zrnic et al, 1993) + real, parameter :: kfrag = 1.0e-6 ! rate coefficent for collisional splintering (Schuur & Rutledge 00b) + real, parameter :: mfrag = 1.0e-10 ! assumed ice fragment mass for collisional splintering (Schuur & Rutledge 00b) + double precision cautn(ngs), rh(ngs), nh(ngs) + real ex1, ft, rhoinv(ngs) + double precision ec0(ngs) + + real ac1,bc, taus, c1,d1,e1,f1,p380,tmp,tmp1,tmp2,tmp3,tmp4,tmp5,temp3 ! , sstdy, super + real dw,dwr + double precision :: tmpz, tmpzmlt + real ratio, delx, dely + real dbigg,volt + real chgtmp,fac,mixedphasefac + real x,y,y2,del,r,rtmp,alpr + double precision :: vent1,vent2 + double precision :: g1palp,g4palp + double precision :: g1palpinf,g4palpinf + real fqt !charge separation as fn of temperature from Dong and Hallett 1992 + real bs + real v1, v2 + real d1r, d1i, d1s, e1i + real c1sw ! integration factor for snow melting with snu = -0.8 + real, parameter :: vr1mm = 5.23599e-10 ! volume of 1mm diameter sphere (m**3) + real, parameter :: vr3mm = 5.23599e-10*(3.0/1.)**3 ! volume of a 3 mm diameter sphere (m**3) (Rasmussen et al. 1984b, JAS) + real, parameter :: vr4p5mm = 5.23599e-10*(4.5/1.)**3 ! volume of 4.5mm diameter sphere (m**3) (Rasmussen et al. 1984b, JAS) + real vmlt,vshd, vshdgs(ngs,lh:lhab), maxmassfac(lc:lhab) + real rhosm + parameter ( rhosm = 500. ) + integer nc ! condensation step + real dtcon,dtcon1,dtcon2 ! condensation time step (dtcon*nc = dtp) + real delta + integer ltemq1,ltemq1m ! ,ltemq1m2 + real dqv,qv1,ss1,ss2,qvs1,dqvs,dtemp,dt1 ! temporaries for condensation + real ssi1, ssi2, dqvi, dqvis, dqvii,qis1 + real dqvr, dqc, dqr, dqi, dqs + real qv1m,qvs1m,ss1m,ssi1m,qis1m + real cwmastmp + real dcloud,dcloud2 ! ,as, bs + real cn(ngs) + double precision xvc, xvr + real mwfac +! real es(ngs) ! ss(ngs), +! real eis(ngs) + + real rwmasn,rwmasx + + real vgra,vfrz + parameter ( vgra = 0.523599*(1.0e-3)**3 ) + +! real, parameter :: epsi = 0.622 +! real, parameter :: d = 0.266 + real :: d, dold, denom,denominv,vth + double precision :: h1, h2, h3, h4,denomdp, denominvdp + real r1,qevap ! ,slv + + real vr,nrx,chw,g1,qr,z,z1,rdi,alp,xnutmp,xnuc,g1r,rd1,rdia,rmas + real :: snowmeltmass = 0 + +! real, parameter :: rhofrz = 900. ! density of graupel from newly-frozen rain + real, parameter :: rimedens = 500. ! default rime density + +! real svc(ngs) ! droplet volume +! +! contact freezing nucleation +! + real raero,kaero !assumd aerosol radius, thermal conductivity + parameter ( raero = 3.e-7, kaero = 5.39e-3 ) + real kb ! Boltzman constant J K-1 + parameter (kb = 1.3807e-23) + + real knud(ngs),knuda(ngs) !knudsen number and correction factor + real gtp(ngs) !G(T,p) = 1/(a' + b') Cotton 72b + real dfar(ngs) !aerosol diffusivity + real fn1(ngs),fn2(ngs),fnft(ngs) + + real ccia(ngs) + real ctfzbd(ngs),ctfzth(ngs),ctfzdi(ngs) +! +! misc +! + real ni,nis,nr,d0 + real dqvcnd(ngs),dqwv(ngs),dqcw(ngs),dqci(ngs),dqcitmp(ngs),dqwvtmp(ngs) + real tempc(ngs) + real temg(ngs),temcg(ngs),theta(ngs),qvap(ngs) + real temgkm1(ngs), temgkm2(ngs) + real temgx(ngs),temcgx(ngs) + real qvs(ngs),qis(ngs),qss(ngs),pqs(ngs) + real elv(ngs),elf(ngs),els(ngs) + real tsqr(ngs),ssi(ngs),ssw(ngs) + real qcwtmp(ngs),qtmp,qtot(ngs) + real qcond(ngs) + real ctmp, sctmp + real cimasn,cimasx,ccimx + real pid4 + real cs,ds,gf7,gf6,gf5,gf4,gf3,gf2,gf1 + real gcnup1,gcnup2 + real gf73rds, gf83rds + real gamice73fac, gamsnow73fac + real gf43rds, gf53rds + real aradcw,bradcw,cradcw,dradcw,cwrad,rwrad,rwradmn + parameter ( rwradmn = 50.e-6 ) + real dh0 + real dg0(ngs),df0(ngs) + + real clionpmx,clionnmx + parameter (clionpmx=1.e9,clionnmx=1.e9) ! Takahashi 84 +! +! other arrays + + real fwet1(ngs),fwet2(ngs) + real fmlt1(ngs),fmlt2(ngs) + real fvds(ngs),fvce(ngs),fiinit(ngs) + real fvent(ngs),fraci(ngs),fracl(ngs) +! + real fai(ngs),fav(ngs),fbi(ngs),fbv(ngs) + real felv(ngs),fels(ngs),felf(ngs) + real felvcp(ngs),felscp(ngs),felfcp(ngs) + real felvpi(ngs),felspi(ngs),felfpi(ngs) + real felvs(ngs),felss(ngs) ! ,felfs(ngs) + real fwvdf(ngs),ftka(ngs),fthdf(ngs) + real fadvisc(ngs),fakvisc(ngs) + real fci(ngs),fcw(ngs) ! heat capacities of ice and liquid + real fschm(ngs),fpndl(ngs) + real fgamw(ngs),fgams(ngs) + real fcqv1(ngs),fcqv2(ngs),fcc3(ngs) + + real cvm,cpm,rmm + + real, parameter :: cpv = 1885.0 ! specific heat of water vapor at constant pressure +! + real fcci(ngs), fcip(ngs) +! + real :: sfm1(ngs),sfm2(ngs) + real :: gfm1(ngs),gfm2(ngs) + real :: hfm1(ngs),hfm2(ngs) + + logical :: wetsfc(ngs),wetsfchl(ngs),wetsfcf(ngs) + logical :: wetgrowth(ngs), wetgrowthhl(ngs), wetgrowthf(ngs) + + real qitmp(ngs),qistmp(ngs) + + real rzxh(ngs), rzxhl(ngs), rzxhlh(ngs), rzxhlf(ngs) + real rzxs(ngs), rzxf(ngs) +! real axh(ngs),bxh(ngs),axhl(ngs),bxhl(ngs) + real cdh(ngs),cdhl(ngs) + real :: axx(ngs,lh:lhab),bxx(ngs,lh:lhab) + real vt2ave(ngs) + + real :: qcwresv(ngs), ccwresv(ngs) ! "reserved" droplet mass and number that are too small for accretion + + real :: lfsave(ngs,6) + real :: qx(ngs,lv:lhab) + real :: qxw(ngs,ls:lhab) + real :: qxwlg(ngs,lh:lhab) + real :: chxf(ngs,lh:lhab) + real :: cx(ngs,lc:lhab) + real :: cxmxd(ngs,lc:lhab) + real :: qxmxd(ngs,lv:lhab) + real :: scx(ngs,lc:lhab) + real :: xv(ngs,lc:lhab) + real :: vtxbar(ngs,lc:lhab,3) + real :: xmas(ngs,lc:lhab) + real :: xdn(ngs,lc:lhab) + real :: xdntmp(ngs,lc:lhab) + real :: cdxgs(ngs,lc:lhab) + real :: xdia(ngs,lc:lhab,3) + real :: vtwtdia(ngs,lr:lhab) ! sweep-out volume weighted diameter + real :: rarx(ngs,ls:lhab) + real :: vx(ngs,li:lhab) + real :: rimdn(ngs,li:lhab) + real :: raindn(ngs,li:lhab) + real :: alpha(ngs,lc:lhab) + real :: dab0lh(ngs,lc:lhab,lc:lhab) + real :: dab1lh(ngs,lc:lhab,lc:lhab) + + real :: qsimxdep(ngs) ! max sublimation of qi+qs+qis + real :: qsimxsub(ngs) ! max depositionof qi+qs+qis + logical,parameter :: DoSublimationFix = .true. + real :: qrtmp(ngs),qvtmp(ngs),qctmp(ngs) + real :: felvcptmp,felscptmp,qsstmp + real :: thetatmp, thetaptmp, temcgtmp,qvaptmp + real :: qvstmp, qisstmp, qvptmp, qitmp1, qctmp1 + + real :: galphrout + + real ventrx(ngs) + real ventrxn(ngs) + real g1shr, alphashr + real g1mlr, alphamlr + real massfacshr, massfacmlr + + real :: qhgt8mm ! ice mass greater than 8mm + real :: qhwgt8mm ! ice + max water mass greater than 8mm + real :: qhgt10mm ! mass greater than 10mm + real :: qhgt20mm ! mass greater than 20mm + real :: fwmhtmp + real, parameter :: fwmhtmptem = -15. ! temperature at which fwmhtmp fully switches to liquid water only being on large particles + real, parameter :: d1t = (6.0 * 0.268e-3/(917.* pi))**(1./3.) ! d1t is the diameter of the ice sphere with the mass (0.268e-3 kg) of an 8mm spherical drop + real, parameter :: srasheym = 0.1389 ! slope fraction from Rasmussen and Heymsfield +! + real swvent(ngs),hwvent(ngs),rwvent(ngs),hlvent(ngs),hwventy(ngs),hlventy(ngs),rwventz(ngs) + integer, parameter :: ndiam = 10 + integer :: numdiam + real hwvent0(ndiam+4),hlvent0 ! 0 to d1 + real hwvent1,hlvent1 ! d1 to infinity + real hwvent2,hlvent2 ! d2 to infinity + real gama0,gamb0 + real gama1,gamb1 + real gama2,gamb2 +! real, parameter :: mltdiam1 = 9.0e-3, mltdiam1p5 = 16.0e-3, mltdiam2 = 19.0e-3, mltdiam3 = 200.0e-3, mltdiam05 = 4.5e-3 + real :: mltdiam(ndiam+4) + real mltmass0inv,mltmass1inv,mltmass2inv, mltmass1cgs, mltmass2cgs,mltmass3inv, mltmass3cgs + real qhmlr0, qhmlr05, qhmlr1, qhmlr2,qhmlr3, qhmlr12, qhmlr23 + real qhlmlr0, qhlmlr05, qhlmlr1, qhlmlr2,qhlmlr3, qhlmlr12, qhlmlr23 + real qxd1, cxd1, zxd1 ! mass and number up to mltdiam1 + real qxd05, cxd05 ! mass and number up to mltdiam1/2 + + real :: qxd(ndiam+4), cxd(ndiam+4), qhml(ndiam+4), qhml0(ndiam+4) + real :: dqxd(ndiam+4), dcxd(ndiam+4), dqhml(ndiam+4) + + + real civent(ngs) + real isvent(ngs) +! + real xmascw(ngs) + real xdnmx(lc:lhab), xdnmn(lc:lhab) + real dnmx + real :: xdiamxmas(ngs,lc:lhab) +! + real cilen(ngs) ! ,ciplen(ngs) +! +! + real rwcap(ngs),swcap(ngs) + real hwcap(ngs) + real hlcap(ngs) + real cicap(ngs) + real iscap(ngs) + + real qvimxd(ngs) + real qimxd(ngs),qismxd(ngs),qcmxd(ngs),qrmxd(ngs),qsmxd(ngs),qhmxd(ngs),qhlmxd(ngs) + real cimxd(ngs),ccmxd(ngs),crmxd(ngs),csmxd(ngs),chmxd(ngs) + real cionpmxd(ngs),cionnmxd(ngs) + real clionpmxd(ngs),clionnmxd(ngs) + + + real elec(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) ! Ez (elecsave) + +! +! + ! Hallett-Mossop arrays + real chmul1(ngs),chlmul1(ngs),csmul1(ngs),csmul(ngs) + real qhmul1(ngs),qhlmul1(ngs),qsmul1(ngs),qsmul(ngs) + + ! splinters from drop freezing + real csplinter(ngs),qsplinter(ngs) + real csplinter2(ngs),qsplinter2(ngs) +! +! +! concentration arrays... +! + real :: chlcnh(ngs), vhlcnh(ngs), vhlcnhl(ngs) + real :: chlcnhhl(ngs) ! number of new hail particles (may be different from number of lost graupel) + real cracif(ngs), ciacrf(ngs) + real cracr(ngs) + +! + real ciint(ngs), crfrz(ngs), crfrzf(ngs), crfrzs(ngs) + real cicint(ngs) + real cipint(ngs) + real ciacw(ngs), cwacii(ngs) + real ciacr(ngs), craci(ngs) + real csacw(ngs) + real csacr(ngs) + real csaci(ngs), csacs(ngs) + real cracw(ngs) + real chacw(ngs), chacr(ngs) + real :: chlacw(ngs) + real chaci(ngs), chacs(ngs) +! + real :: chlacr(ngs) + real :: chlaci(ngs), chlacs(ngs) + real crcnw(ngs) + real cidpv(ngs),cisbv(ngs) + real cisdpv(ngs),cissbv(ngs) + real cimlr(ngs),cismlr(ngs) + + real chlsbv(ngs), chldpv(ngs) + real chlmlr(ngs), chlmlrr(ngs) + real chlfmlr(ngs) +! real chlmlrsave(ngs),chlsave(ngs),qhlsave(ngs) + real chlshr(ngs), chlshrr(ngs) + + + real chdpv(ngs),chsbv(ngs) + real chmlr(ngs),chcev(ngs) + real chmlrr(ngs) + real chshr(ngs), chshrr(ngs) + + real csdpv(ngs),cssbv(ngs) + real csmlr(ngs),csmlrr(ngs),cscev(ngs) + real csshr(ngs), csshrr(ngs) + + real crcev(ngs) + real crshr(ngs) + real cwshw(ngs), qwshw(ngs) +! +! +! arrays for w-ac-x ; x-ac-w +! +! +! + real qrcnw(ngs), qwcnr(ngs) + real zrcnw(ngs),zracr(ngs),zracw(ngs),zrcev(ngs) + + + real qracw(ngs) ! qwacr(ngs), + real qiacw(ngs) !, qwaci(ngs) + + real qsacw(ngs) ! ,qwacs(ngs), + real qhacw(ngs) ! qwach(ngs), + real :: qhlacw(ngs) ! + real vhacw(ngs), vsacw(ngs), vhlacw(ngs), vhlacr(ngs) + + real qfmul1(ngs),cfmul1(ngs) +! + real qsacws(ngs) + +! +! arrays for x-ac-r and r-ac-x; +! + real qsacr(ngs),qracs(ngs) + real qhacr(ngs),qhacrmlr(ngs) ! ,qrach(ngs) + real vhacr(ngs), zhacr(ngs), zhacrf(ngs), zrach(ngs), zrachl(ngs) + real qiacr(ngs),qraci(ngs) + + real ziacr(ngs) + + real qracif(ngs),qiacrf(ngs),qiacrs(ngs),ciacrs(ngs) + + real :: qhlacr(ngs),qhlacrmlr(ngs) + real qsacrs(ngs) !,qracss(ngs) +! +! ice - ice interactions +! + real qsaci(ngs) + real qsacis(ngs) + real qhaci(ngs) + real qhacs(ngs) + + real :: qhacis(ngs) + real :: chacis(ngs) + real :: chacis0(ngs) + + real :: csaci0(ngs) ! collision rate only + real :: chaci0(ngs) ! collision rate only + real :: chacs0(ngs) ! collision rate only + real :: chlaci0(ngs) + real :: chlacis(ngs) + real :: chlacis0(ngs) + real :: chlacs0(ngs) + + real :: qsaci0(ngs) ! collision rate only + real :: qsacis0(ngs) ! collision rate only + real :: qhaci0(ngs) ! collision rate only + real :: qhacis0(ngs) ! collision rate only + real :: qhacs0(ngs) ! collision rate only + real :: qhlaci0(ngs) + real :: qhlacis0(ngs) + real :: qhlacs0(ngs) + + real :: qhlaci(ngs) + real :: qhlacis(ngs) + real :: qhlacs(ngs) +! +! conversions +! + real qrfrz(ngs) ! , qirirhr(ngs) + real zrfrz(ngs), zrfrzf(ngs), zrfrzs(ngs) + real ziacrf(ngs), zhcnsh(ngs), zhcnih(ngs) + real zhacw(ngs), zhacs(ngs), zhaci(ngs) + real zhmlr(ngs), zhdsv(ngs), zhsbv(ngs), zhlcnh(ngs), zhshr(ngs) + real zfacw(ngs), zfacs(ngs), zfaci(ngs) + real zfmlr(ngs), zfdsv(ngs), zfsbv(ngs), zhlcnf(ngs), zfshr(ngs), zfshrr(ngs) + real zhmlrtmp,zhmlr0inf,zhlmlr0inf + real zhmlrr(ngs),zhlmlrr(ngs),zhshrr(ngs),zhlshrr(ngs),zfmlrr(ngs) + real zsmlr(ngs), zsmlrr(ngs), zsshr(ngs) + real zhcns(ngs), zhcni(ngs) + real zhwdn(ngs), zfwdn(ngs) ! change in Z due to density changes + real zhldn(ngs) ! change in Z due to density changes + + real zhlacw(ngs), zhlacs(ngs), zhlacr(ngs) + real zhlmlr(ngs), zhldsv(ngs), zhlsbv(ngs), zhlshr(ngs) + + + real vrfrzf(ngs), viacrf(ngs) + real qrfrzs(ngs), qrfrzf(ngs) + real qwfrz(ngs), qwctfz(ngs) + real cwfrz(ngs), cwctfz(ngs) + real qwfrzis(ngs), qwctfzis(ngs) ! droplet freezing to ice spheres + real cwfrzis(ngs), cwctfzis(ngs) + real qwfrzc(ngs), qwctfzc(ngs) ! droplet freezing to columns + real cwfrzc(ngs), cwctfzc(ngs) + real qwfrzp(ngs), qwctfzp(ngs) ! droplet freezing to plates + real cwfrzp(ngs), cwctfzp(ngs) + real xcolmn(ngs), xplate(ngs) + real ciihr(ngs), qiihr(ngs) + real cicichr(ngs), qicichr(ngs) + real cipiphr(ngs), qipiphr(ngs) + real qscni(ngs), cscni(ngs), cscnis(ngs) + real qscnvi(ngs), cscnvi(ngs), cscnvis(ngs) + real qhcns(ngs), chcns(ngs), chcnsh(ngs), vhcns(ngs) + real qscnh(ngs), cscnh(ngs), vscnh(ngs) + real qhcni(ngs), chcni(ngs), chcnih(ngs), vhcni(ngs) + real qiint(ngs),qipipnt(ngs),qicicnt(ngs) + real cninm(ngs),cnina(ngs),cninp(ngs),wvel(ngs),wvelkm1(ngs) + real tke(ngs) + real uvel(ngs),vvel(ngs) +! + real qidpv(ngs),qisbv(ngs) ! qicnv(ngs),qievv(ngs), + real qimlr(ngs),qidsv(ngs),qisdsv(ngs),qidsvp(ngs) ! ,qicev(ngs) + real qismlr(ngs) + +! +! + real :: qhldpv(ngs), qhlsbv(ngs) ! qhlcnv(ngs),qhlevv(ngs), + real :: qhlmlr(ngs), qhldsv(ngs), qhlmlrsave(ngs) + real :: qhlwet(ngs), qhldry(ngs), qhlshr(ngs) +! + real :: qrfz(ngs),qsfz(ngs),qhfz(ngs),qhlfz(ngs) +! + real qhdpv(ngs),qhsbv(ngs) ! qhcnv(ngs),qhevv(ngs), + real qhmlr(ngs),qhdsv(ngs),qhcev(ngs),qhcndv(ngs),qhevv(ngs) + real qhlcev(ngs), chlcev(ngs) + real qhwet(ngs),qhdry(ngs),qhshr(ngs) + real qhshrp(ngs) + real qhshh(ngs) !accreted water that remains on graupel + real qhmlh(ngs) !melt water that remains on graupel + real qhfzh(ngs) !water that freezes on mixed-phase graupel + real qhlfzhl(ngs) !water that freezes on mixed-phase hail + + real qhmlrlg(ngs),qhlmlrlg(ngs) ! melting from the larger diameters + real qhfzhlg(ngs) !water that freezes on mixed-phase graupel (large sizes) + real qhlfzhllg(ngs) !water that freezes on mixed-phase hail (large sizes) + real qhlcevlg(ngs), chlcevlg(ngs) + real qhcevlg(ngs), chcevlg(ngs) + + real vhfzh(ngs), vffzf(ngs) ! change in volume from water that freezes on mixed-phase graupel, frozen drops + real vhlfzhl(ngs) ! change in volume from water that freezes on mixed-phase hail + + real vhshdr(ngs) !accreted water that leaves on graupel (mixedphase) + real vhlshdr(ngs) !accreted water that leaves on hail (mixedphase) + real vhmlr(ngs) !melt water that leaves graupel (single phase) + real vhlmlr(ngs) !melt water that leaves hail (single phase) + real vhsoak(ngs) ! aquired water that seeps into graupel. + real vhlsoak(ngs) ! aquired water that seeps into hail. + +! + real qsdpv(ngs),qssbv(ngs) ! qscnv(ngs),qsevv(ngs), + real qsmlr(ngs),qsdsv(ngs),qscev(ngs),qscndv(ngs),qsevv(ngs) + real qswet(ngs),qsdry(ngs),qsshr(ngs) + real qsshrp(ngs) + real qsfzs(ngs) +! +! + real qipdpv(ngs),qipsbv(ngs) + real qipmlr(ngs),qipdsv(ngs) +! + real qirdpv(ngs),qirsbv(ngs) + real qirmlr(ngs),qirdsv(ngs),qirmlw(ngs) +! + real qgldpv(ngs),qglsbv(ngs) + real qglmlr(ngs),qgldsv(ngs) + real qglwet(ngs),qgldry(ngs),qglshr(ngs) + real qglshrp(ngs) +! + real qgmdpv(ngs),qgmsbv(ngs) + real qgmmlr(ngs),qgmdsv(ngs) + real qgmwet(ngs),qgmdry(ngs),qgmshr(ngs) + real qgmshrp(ngs) + real qghdpv(ngs),qghsbv(ngs) + real qghmlr(ngs),qghdsv(ngs) + real qghwet(ngs),qghdry(ngs),qghshr(ngs) + real qghshrp(ngs) +! + real qrztot(ngs),qrzmax(ngs),qrzfac(ngs) + real qrcev(ngs) + real qrshr(ngs) + real fsw(ngs),fhw(ngs),fhlw(ngs),ffw(ngs) !liquid water fractions + real fswmax(ngs),fhwmax(ngs),fhlwmax(ngs) !liquid water fractions + real qhcnf(ngs) + real :: qhlcnh(ngs) + real qhcngh(ngs),qhcngm(ngs),qhcngl(ngs) + + real :: qhcnhl(ngs), chcnhl(ngs), zhcnhl(ngs), vhcnhl(ngs) ! conversion of low-density hail back to graupel + + real eiw(ngs),eii(ngs),eiri(ngs),eipir(ngs),eisw(ngs) + real erw(ngs),esw(ngs),eglw(ngs),eghw(ngs),efw(ngs) + real ehxw(ngs),ehlw(ngs),egmw(ngs),ehw(ngs) + real err(ngs),esr(ngs),eglr(ngs),eghr(ngs),efr(ngs) + real ehxr(ngs),ehlr(ngs),egmr(ngs) + real eri(ngs),esi(ngs),egli(ngs),eghi(ngs),efi(ngs),efis(ngs) + real ehxi(ngs),ehli(ngs),egmi(ngs),ehi(ngs),ehis(ngs),ehlis(ngs) + real ers(ngs),ess(ngs),egls(ngs),eghs(ngs),efs(ngs),ehs(ngs) + real ehscnv(ngs) + real ehxs(ngs),ehls(ngs),egms(ngs),egmip(ngs) + + real ehsclsn(ngs),ehiclsn(ngs),ehisclsn(ngs) + real efsclsn(ngs),eficlsn(ngs),efisclsn(ngs) + real ehlsclsn(ngs),ehliclsn(ngs),ehlisclsn(ngs) + real esiclsn(ngs) + + real :: ehs_collsn = 0.5, ehi_collsn = 1.0 + real :: efs_collsn = 0.5, efi_collsn = 1.0 + real :: ehls_collsn = 1.0, ehli_collsn = 1.0 + real :: esi_collsn = 1.0 + + real ew(8,6) + real cwr(8,2) ! radius and inverse of interval + data cwr / 2.0, 3.0, 4.0, 6.0, 8.0, 10.0, 15.0, 20.0 , & ! radius + & 1.0, 1.0, 0.5, 0.5, 0.5, 0.2, 0.2, 1. / ! inverse of interval + integer icwr(ngs), igwr(ngs), irwr(ngs), ihlr(ngs), ifwr(ngs) + real grad(6,2) ! graupel radius and inverse of interval + data grad / 100., 200., 300., 400., 600., 1000., & + & 1.e-2,1.e-2,1.e-2,5.e-3,2.5e-3, 1. / +!droplet radius: 2 3 4 6 8 10 15 20 + data ew /0.03, 0.07, 0.17, 0.41, 0.58, 0.69, 0.82, 0.88, & ! 100 +! : 0.07, 0.13, 0.27, 0.48, 0.65, 0.73, 0.84, 0.91, ! 150 + & 0.10, 0.20, 0.34, 0.58, 0.70, 0.78, 0.88, 0.92, & ! 200 + & 0.15, 0.31, 0.44, 0.65, 0.75, 0.83, 0.96, 0.91, & ! 300 + & 0.17, 0.37, 0.50, 0.70, 0.81, 0.87, 0.93, 0.96, & ! 400 + & 0.17, 0.40, 0.54, 0.71, 0.83, 0.88, 0.94, 0.98, & ! 600 + & 0.15, 0.37, 0.52, 0.74, 0.82, 0.88, 0.94, 0.98 / ! 1000 +! : 0.11, 0.34, 0.49, 0.71, 0.83, 0.88, 0.94, 0.95 / ! 1400 + + + real da0lr(ngs),da1lr(ngs) + real da0lc(ngs),da1lc(ngs) + real da0lh(ngs) + real da0lhl(ngs) + real da0lf(ngs) + real :: da0lx(ngs,lr:lhab) + + real va0 (lc:lqmx) ! collection coefficients from Seifert 2005 + real vab0(lc:lqmx,lc:lqmx) ! collection coefficients from Seifert 2005 + real vab1(lc:lqmx,lc:lqmx) ! collection coefficients from Seifert 2005 + real va1 (lc:lqmx) ! collection coefficients from Seifert 2005 + real ehip(ngs),ehlip(ngs),ehlir(ngs) + real erir(ngs),esir(ngs),eglir(ngs),egmir(ngs),eghir(ngs) + real efir(ngs),ehir(ngs),eirw(ngs),eirir(ngs),ehr(ngs) + real erip(ngs),esip(ngs),eglip(ngs),eghip(ngs) + real efip(ngs),eipi(ngs),eipw(ngs),eipip(ngs) +! +! arrays for production terms +! + real ptotal(ngs) ! , pqtot(ngs) +! + real pqcwi(ngs),pqcii(ngs),pqrwi(ngs),pqisi(ngs) + real pqswi(ngs),pqhwi(ngs),pqwvi(ngs) + real pqgli(ngs),pqghi(ngs),pqfwi(ngs) + real pqgmi(ngs),pqhli(ngs) ! ,pqhxi(ngs) + real pqiri(ngs),pqipi(ngs) ! pqwai(ngs), + real pqlwsi(ngs),pqlwhi(ngs),pqlwhli(ngs) + + real pqlwlghi(ngs),pqlwlghli(ngs) + real pqlwlghd(ngs),pqlwlghld(ngs) + + + + real pvhwi(ngs), pvhwd(ngs) + real pvfwi(ngs), pvfwd(ngs) + real pvhli(ngs), pvhld(ngs) + real pvswi(ngs), pvswd(ngs) +! + real pqcwd(ngs),pqcid(ngs),pqrwd(ngs),pqisd(ngs), pqcwdacc(ngs) + real pqswd(ngs),pqhwd(ngs),pqwvd(ngs) + real pqgld(ngs),pqghd(ngs),pqfwd(ngs) + real pqgmd(ngs),pqhld(ngs) ! ,pqhxd(ngs) + real pqird(ngs),pqipd(ngs) ! pqwad(ngs), + real pqlwsd(ngs),pqlwhd(ngs),pqlwhld(ngs) +! +! real pqxii(ngs,nhab),pqxid(ngs,nhab) +! + real pctot(ngs) + real pcipi(ngs), pcipd(ngs) + real pciri(ngs), pcird(ngs) + real pccwi(ngs), pccwd(ngs), pccwdacc(ngs) + real pccii(ngs), pccid(ngs) + real pcisi(ngs), pcisd(ngs) + real pccin(ngs) + real pcrwi(ngs), pcrwd(ngs) + real pcswi(ngs), pcswd(ngs) + real pchwi(ngs), pchwd(ngs) + real pchli(ngs), pchld(ngs) + real pcfwi(ngs), pcfwd(ngs) + real pcgli(ngs), pcgld(ngs) + real pcgmi(ngs), pcgmd(ngs) + real pcghi(ngs), pcghd(ngs) + + real pzrwi(ngs), pzrwd(ngs) + real pzhwi(ngs), pzhwd(ngs) + real pzfwi(ngs), pzfwd(ngs) + real pzhli(ngs), pzhld(ngs) + real pzswi(ngs), pzswd(ngs) + +! +! other arrays +! + real dqisdt(ngs) !,advisc(ngs) !dqwsdt(ngs), ,schm(ngs),pndl(ngs) + + real qss0(ngs) + + real qsacip(ngs) + real pres(ngs),pipert(ngs) + real pk(ngs) + real rho0(ngs),pi0(ngs) + real rhovt(ngs),sqrtrhovt + real thetap(ngs),theta0(ngs),qwvp(ngs),qv0(ngs) + real thsave(ngs) + real ptwfzi(ngs),ptimlw(ngs) + real psub(ngs),pvap(ngs),pfrz(ngs),ptem(ngs),pmlt(ngs),pevap(ngs),pdep(ngs),ptem2(ngs) + + real cnostmp(ngs) ! for diagnosed snow intercept +! +! iholef = 1 to do hole filling technique version 1 +! which uses all hydrometerors to do hole filling of all hydrometeors +! iholef = 2 to do hole filling technique version 2 +! which uses an individual hydrometeror species to do hole +! filling of a species of a hydrometeor +! +! iholen = interval that hole filling is done +! + integer iholef + integer iholen + parameter (iholef = 1) + parameter (iholen = 1) + real cqtotn,cqtotn1 + real cctotn + real citotn + real crtotn + real cstotn + real cvtotn + real cftotn + real cgltotn + real cghtotn + real chtotn + real cqtotp,cqtotp1 + real cctotp + real citotp + real ciptotp + real crtotp + real cstotp + real cvtotp + real cftotp + real chltotp + real cgltotp + real cgmtotp + real cghtotp + real chtotp + real cqfac + real ccfac + real cifac + real cipfac + real crfac + real csfac + real cvfac + real cffac + real cglfac + real cghfac + real chfac + + real ssifac, qvapor +! +! Miscellaneous variables +! + real, parameter :: cwmas30 = 1000.*0.523599*(2.*30.e-6)**3 ! mass of 30-micron radius droplet, for sat. adj. + real, parameter :: cwmas20 = 1000.*0.523599*(2.*20.e-6)**3 ! mass of 20-micron radius droplet, for sat. adj. + integer ireadqf,lrho,lqsw,lqgl,lqgm ,lqgh + integer lqrw + real vt + real arg ! gamma is a function + real erbnd1, fdgt1, costhe1 + real qeps + real dyi2,dzi2,bta1,cnit,dragh,dnz00,pii ! ,cp608 + real qccrit,gf4br,gf4ds,gf4p5, gf3ds, gf1ds + real gf1palp(ngs) ! for storing Gamma[1.0 + alphar] + + + real xdn0(lc:lhab) + real xdn_new,drhodt + + integer l ,ltemq,inumgs, idelq + + real brz,arz,temq + + real ssival,tqvcon + real cdx(lc:lhab) + real cnox + real cval,aval,eval,fval,gval ,qsign,ftelwc,qconkq,elecfac,altelecfac + real qconm,qconn,cfce15,gf8,gf4i,gf3p5,gf1a,gf1p5,qdiff,argrcnw + real c4,bradp,bl2,bt2,dthr,hrifac, hdia0,hdia1,civenta,civentb + real civentc,civentd,civente,civentf,civentg,cireyn,xcivent + real cipventa,cipventb,cipventc,cipventd,cipreyn,cirventa + real cirventb + integer igmrwa,igmrwb,igmswa, igmswb,igmfwa,igmfwb,igmhwa,igmhwb + real rwventa ,rwventb,swventa,swventb,fwventa,fwventb,fwventc + real hwventa,hwventb + real hwventc, hlventa, hlventb, hlventc + real glventa, glventb, glventc + real gmventa, gmventb, gmventc, ghventa, ghventb, ghventc + real dzfacp, dzfacm, cmassin, cwdiar + real rimmas, rhobar + real argtim, argqcw, argqxw, argtem + real frcswsw, frcswgl, frcswgm, frcswgh, frcswfw, frcswsw1 + real frcglgl, frcglgm, frcglgh, frcglfw, frcglgl1 + real frcgmgl, frcgmgm, frcgmgh, frcgmfw, frcgmgm1 + real frcghgl, frcghgm, frcghgh, frcghfw, frcghgh1 + real frcfwgl, frcfwgm, frcfwgh, frcfwfw, frcfwfw1 + real frcswrsw, frcswrgl, frcswrgm, frcswrgh, frcswrfw + real frcswrsw1 + real frcrswsw, frcrswgl, frcrswgm, frcrswgh, frcrswfw + real frcrswsw1 + real frcglrgl, frcglrgm, frcglrgh, frcglrfw, frcglrgl1 + real frcrglgl + real frcrglgm, frcrglgh, frcrglfw, frcrglgl1 + real frcgmrgl, frcgmrgm, frcgmrgh, frcgmrfw, frcgmrgm1 + real frcrgmgl, frcrgmgm, frcrgmgh, frcrgmfw, frcrgmgm1 + real sum, qweps, gf2a, gf4a, dqldt, dqidt, dqdt + real frcghrgl, frcghrgm, frcghrgh, frcghrfw, frcghrgh1, frcrghgl + real frcrghgm, frcrghgh, frcrghfw, frcrghgh1 + real a1,a2,a3,a4,a5,a6 + real gamss + real cdw, cdi, denom1, denom2, delqci1, delqip1 + real cirtotn, ciptotn, cgmtotn, chltotn, cirtotp + real cgmfac, chlfac, cirfac + integer igmhla, igmhlb, igmgla, igmglb, igmgma, igmgmb + integer igmgha, igmghb + integer idqis, item, itim0 + integer iqgl, iqgm, iqgh, iqrw, iqsw + integer itertd, ia + + integer :: infdo + + real tau, ewtmp + + integer cntnic_noliq + real q_noliqmn, q_noliqmx + real scsacimn, scsacimx + + real :: dtpinv + +! arrays for temporary bin space + + real :: xden,xmlt,cmlt,cmlttot,fventm,fventh,am,ah,felfinv,dmwdt + + real :: qhmlrtmp,qhmlrtmp2, chmlrtmp, chmlrtmpd1inf, chlmlrtmp, zhlmlrtmp, zhlmlrrtmp, qvs0,tmpcmlt + + real :: term1,term2,term3,term4 + real :: qaacw ! combined qsacw-qhacw for WSM6 variation + + + +! +! #################################################################### +! +! Start routine +! +! #################################################################### + + + +! + + pb(:) = 0.0 + pinit(:) = 0.0 + itile = nx + jtile = ny + ktile = nz + ixend = nx + jyend = ny + kzend = nz + nxend = nx + 1 + nyend = ny + 1 + nzend = nz + kzbeg = 1 + nzbeg = 1 + + istag = 0 + jstag = 0 + kstag = 1 + + + +! +! slope intercepts +! + + IF ( ngs .lt. nz ) THEN +! write(0,*) 'Error in ICEZVD: Must have ngs .ge. nz!' +! STOP + ENDIF + + cntnic_noliq = 0 + q_noliqmn = 0.0 + q_noliqmx = 0.0 + scsacimn = 0.0 + scsacimx = 0.0 + + ldovol = .false. + + DO il = lc,lhab + ldovol = ldovol .or. ( lvol(il) .gt. 1 ) + ENDDO + + + ffrzh = 1 +! DO il = lc,lhab +! write(iunit,*) 'delqnxa(',il,') = ',delqnxa(il) +! ENDDO + +! +! density maximums and minimums +! + +! +! Set terminal velocities... +! also set drag coefficients +! + + dtpinv = 1.d0/dtp + +! + +! +! electricity constants +! +! mixing ratio epsilon +! + qeps = 1.0e-20 + +! rebound efficiency (erbnd) +! +! +! +! constants +! + +! cp608 = 0.608 + aradcw = -0.27544 + bradcw = 0.26249e+06 + cradcw = -1.8896e+10 + dradcw = 4.4626e+14 + bta1 = 0.6 + cnit = 1.0e-02 + dragh = 0.60 + dnz00 = 1.225 +! cs = 4.83607122 +! ds = 0.25 +! new values for cs and ds + cs = 12.42 + ds = 0.42 + pii = piinv ! 1./pi + pid4 = pi/4.0 +! qscrit = 6.0e-04 + gf1 = 1.0 ! gamma(1.0) + gf1p5 = 0.8862269255 ! gamma(1.5) + gf2 = 1.0 ! gamma(2.0) + gf3 = 2.0 ! gamma(3.0) + gf3p5 = 3.32335097 ! gamma(3.5) + gf4 = 6.00 ! gamma(4.0) + gf5 = 24.0 ! gamma(5.0) + gf6 = 120.0 ! gamma(6.0) + gf7 = 720.0 ! gamma(7.0) + gf4br = 17.837861981813607 ! gamma(4.0+br) + gf4ds = 10.41688578110938 ! gamma(4.0+ds) + gf4p5 = 11.63172839656745 ! gamma(4.0+0.5) + gf3ds = 3.0458730354120997 ! gamma(3.0+ds) + gf1ds = 0.8863557896089221 ! gamma(1.0+ds) + + gf43rds = 0.8929795116 ! gamma(4./3.) + gf53rds = 0.9027452930 ! gamma(5./3.) + gf73rds = 1.190639349 ! gamma(7./3.) + gf83rds = 1.504575488 ! gamma(8./3.) + + gamice73fac = (Gamma_sp(7./3. + cinu))**3/ (Gamma_sp(1. + cinu)**3 * (1. + cinu)**4) + gamsnow73fac = (Gamma_sp(7./3. + snu))**3/ (Gamma_sp(1. + snu)**3 * (1. + snu)**4) + +! gcnup1 = Gamma_sp(cnu + 1.) +! gcnup2 = Gamma_sp(cnu + 2.) +! +! constants +! +! +! general constants for microphysics +! + brz = 100.0 + arz = 0.66 + + bfnu1 = (4. + alphar)*(5. + alphar)*(6. + alphar)/ & + & ((1. + alphar)*(2. + alphar)*(3. + alphar)) + + galpharaut = (6.+alpharaut)*(5.+alpharaut)*(4.+alpharaut)/ & + & ((3.+alpharaut)*(2.+alpharaut)*(1.+alpharaut)) + + vfrz = 0.523599*(dfrz)**3 + vmlt = Min(xvmx(lr), 0.523599*(dmlt)**3 ) + vshd = Min(xvmx(lr), 0.523599*(dshd)**3 ) + + snowmeltmass = pi/6.0 * 1000. * snowmeltdia**3 ! maximum rain particle mass from melting snow (if snowmeltdia > 0) + + tdtol = 1.0e-05 + tfrcbw = tfr - cbw + tfrcbi = tfr - cbi +! +! +! #ifdef COMMAS +! print*,'ventr,ventc = ',ventr,ventc + +! +! Set up look up tables for supersaturation w.r.t. liq and ice +! +!VD$L SKIP +! do l = 1,nqsat +! temq = 163.15 + (l-1)*fqsat +! tabqvs(l) = exp(caw*(temq-273.15)/(temq-cbw)) +! tabqis(l) = exp(cai*(temq-273.15)/(temq-cbi)) +! end do + + mltmass0inv = 1.0/( 1000.0* xvmx(lr) ) ! for drops melting from ice with diameter > 1.9cm + mltmass1inv = 1.0/( 1000.0*(4.0*pi/3.0)*((0.01*0.5*takshedsize1)**3) ) ! for drops melting from ice with diameter > 1.9cm; 0.01 converts cm to m, 0.5 conv. diam to radius + mltmass2inv = 1.0/( 1000.0*(4.0*pi/3.0)*((0.01*0.5*takshedsize2)**3) ) ! for drops melting from ice with 0.9cm < d < 1.9cm (or 1.6cm to 1.9cm) + mltmass3inv = 1.0/( 1000.0*(4.0*pi/3.0)*((0.01*0.5*takshedsize3)**3) ) ! for drops melting from ice with 0.9cm < d < 1.6cm + mltmass1cgs = 1.0*(4.0*pi/3.0)*((0.5*takshedsize1)**3) + mltmass2cgs = 1.0*(4.0*pi/3.0)*((0.5*takshedsize2)**3) + mltmass3cgs = 1.0*(4.0*pi/3.0)*((0.5*takshedsize3)**3) + +! real, parameter :: mltdiam1 = 9.0e-3, mltdiam2 = 19.0e-3, mltdiam05 = 4.5e-3 + + IF ( ibinnum == 1 ) THEN + numdiam = 1 ! must have numdiam < ndiam because numdiam+1 holds values for the interval of mltdiam(numdiam) to mltdiam(ndiam+1) + mltdiam(1) = 4.5e-3 + ELSEIF ( ibinnum == 2 ) THEN + numdiam = 2 ! must have numdiam < ndiam because numdiam+1 holds values for the interval of mltdiam(numdiam) to mltdiam(ndiam+1) + mltdiam(1) = mltdiam1/6. ! 1.5e-3 + mltdiam(2) = mltdiam1/2. ! 4.5e-3 + ELSEIF ( ibinnum > 2 ) THEN + numdiam = Min(ibinnum, ndiam) + DO k = 1,numdiam + mltdiam(k) = (k - 0.5)*mltdiam1/float(numdiam) + ENDDO + + ELSE + numdiam = 5 ! must have numdiam < ndiam because numdiam+1 holds values for the interval of mltdiam(numdiam) to mltdiam(ndiam+1) + mltdiam(1) = 0.5e-3 + mltdiam(2) = 1.0e-3 + mltdiam(3) = 2.0e-3 + mltdiam(4) = 4.0e-3 + mltdiam(5) = 6.0e-3 + ENDIF + + + IF ( numshedregimes == 2 ) THEN + mltdiam(ndiam+1) = mltdiam1 ! 9.0e-3 + mltdiam(ndiam+2) = mltdiam3 ! 19.0e-3 + mltdiam(ndiam+3) = mltdiam4 !100.0e-3 + ELSEIF ( numshedregimes == 3 ) THEN + mltdiam(ndiam+1) = mltdiam1 ! 9.0e-3 + mltdiam(ndiam+2) = mltdiam2 ! 16.0e-3 + mltdiam(ndiam+3) = mltdiam3 ! 19.0e-3 + mltdiam(ndiam+4) = mltdiam4 !200.0e-3 + ENDIF + + kzb = 1 + kze = ktile +! if (kzend .eq. nzend) kze = kzend-kzbeg+1-kstag + +! +! cw constants in mks units +! +! cwmasn = 4.25e-15 ! radius of 1.0e-6 + mwfac = 6.0**(1./3.) + IF ( ipconc .ge. 2 ) THEN +! cwmasn = xvmn(lc)*1000. +! cwradn = 1.0e-6 +! cwmasx = xvmx(lc)*1000. + ENDIF + rwmasn = xvmn(lr)*1000. + rwmasx = xvmx(lr)*1000. + + IF ( biggsnowdiam > 0.0 ) THEN + xvbiggsnow = (pi/6.0)*biggsnowdiam**3 + ELSE + xvbiggsnow = xvmn(lh) + ENDIF + +! +! ci constants in mks units +! + cimasn = Min(cimas0, cimas1) ! 12 microns for 0.1871*(xmas(mgs,li)**(0.3429)) + cimasx = 1.0e-8 ! 338 microns + ccimx = 5000.0e3 ! max of 5000 per liter + +! +! constants for paramerization +! +! +! set save counter (number of saves): nsvcnt +! +! nsvcnt = 0 + iend = 0 + + +! timetd1 = etime(tarray) +! timetd1 = tarray(1) + +! +!*********************************************************** +! start jy loop +!*********************************************************** +! + +! do 9999 jy = 1,ny-jstag +! +! VERY IMPORTANT: SET jy = jgs +! + jy = jgs + + +! t1(:,:,:) = 0 +! t2(:,:,:) = 0 +! t3(:,:,:) = 0 +! t4(:,:,:) = 0 +! t5(:,:,:) = 0 +! t6(:,:,:) = 0 +! t8(:,:,:) = 0 + + IF ( ipconc < 2 ) THEN ! Make a copy of cloud droplet mixing ratio to use for homogeneous freezing + DO kz = 1,kze + DO ix = 1,itile + t9(ix,jy,kz) = an(ix,jy,kz,lc) + ENDDO + ENDDO + ENDIF + +! +!..Gather microphysics +! + if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: ENTER GATHER STAGE' + + + + nxmpb = 1 + nzmpb = 1 + nxz = itile*nz + numgs = nxz/ngs + 1 +! write(0,*) 'ICEZVD_GS: ENTER GATHER STAGE: nx,nz,nxz,numgs,ngs = ',nx,nz,nxz,numgs,ngs + + do 1000 inumgs = 1,numgs + ngscnt = 0 + + do kz = nzmpb,kze + do ix = nxmpb,itile + + pqs(1) = t00(ix,jy,kz) +! pqs(kz) = t00(ix,jy,kz) + + theta(1) = an(ix,jy,kz,lt) + temg(1) = t0(ix,jy,kz) + temcg(1) = temg(1) - tfr + tqvcon = temg(1)-cbw + ltemq = (temg(1)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + qvs(1) = pqs(1)*tabqvs(ltemq) + qis(1) = pqs(1)*tabqis(ltemq) + + qss(1) = qvs(1) + +! IF ( jy .eq. 1 .and. ix .eq. 24 ) THEN +! write(91,*) 'kz,qv,th: ',kz,an(ix,jy,kz,lv),an(ix,jy,kz,lt),pqs(kz),tabqvs(ltemq),qvs(kz) +! ENDIF + + if ( temg(1) .lt. tfr ) then +! if( qcw(kz) .le. qxmin(lc) .and. qci(kz) .gt. qxmin(li)) +! > qss(kz) = qis(kz) +! if( qcw(kz) .gt. qxmin(lc) .and. qci(kz) .gt. qxmin(li)) +! > qss(kz) = (qcw(kz)*qvs(kz) + qci(kz)*qis(kz)) / +! > (qcw(kz) + qci(kz)) + qss(1) = qis(1) + else +! IF ( an(ix,jy,kz,lv) .gt. qss(kz) ) THEN +! write(iunit,*) 'qss exceeded at ',ix,jy,kz,qss(kz),an(ix,jy,kz,lv),temg(kz) +! write(iunit,*) 'other temg = ',theta(kz)*(pinit(kz)+p2(ix,jy,kz)) +! ENDIF + end if +! + ishail = .false. + IF ( lhl > 1 ) THEN + IF ( an(ix,jy,kz,lhl) .gt. qxmin(lhl) ) ishail = .true. + ENDIF + + + + if ( an(ix,jy,kz,lv) .gt. qss(1) .or. & + & an(ix,jy,kz,lc) .gt. qxmin(lc) .or. & + & an(ix,jy,kz,li) .gt. qxmin(li) .or. & + & an(ix,jy,kz,lr) .gt. qxmin(lr) .or. & + & an(ix,jy,kz,ls) .gt. qxmin(ls) .or. & + & an(ix,jy,kz,lh) .gt. qxmin(lh) .or. ishail ) then + ngscnt = ngscnt + 1 + igs(ngscnt) = ix + kgs(ngscnt) = kz + if ( ngscnt .eq. ngs ) goto 1100 + end if + enddo !ix + nxmpb = 1 + enddo !kz + 1100 continue + + if ( ngscnt .eq. 0 ) go to 9998 + + if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: dbg = 5, ngscnt = ',ngscnt + +! write(0,*) 'allocating qc' + + + xv(:,:) = 0.0 + xmas(:,:) = 0.0 + vtxbar(:,:,:) = 0.0 + xdia(:,:,:) = 0.0 + raindn(:,:) = 900. + cx(:,:) = 0.0 + IF ( lnhf > 1 .or. lnhlf > 1 ) chxf(:,:) = 0.0 + alpha(:,:) = 0.0 + DO il = li,lhab + DO mgs = 1,ngscnt + rimdn(mgs,il) = rimedens ! xdn0(il) + ENDDO + ENDDO +! +! define temporaries for state variables to be used in calculations +! + if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: dbg = def temps' + do mgs = 1,ngscnt + kgsm(mgs) = max(kgs(mgs)-1,1) + kgsp(mgs) = min(kgs(mgs)+1,nz-1) + kgsm2(mgs) = Max(kgs(mgs)-2,1) + theta0(mgs) = an(igs(mgs),jy,kgs(mgs),lt) + thetap(mgs) = an(igs(mgs),jy,kgs(mgs),lt) - theta0(mgs) + theta(mgs) = an(igs(mgs),jy,kgs(mgs),lt) + qv0(mgs) = an(igs(mgs),jy,kgs(mgs),lv) + qwvp(mgs) = an(igs(mgs),jy,kgs(mgs),lv) - qv0(mgs) ! qv0(mgs) is full qv, so qwvp starts as zero! + + pres(mgs) = pn(igs(mgs),jy,kgs(mgs)) + pb(kgs(mgs)) + pipert(mgs) = p2(igs(mgs),jy,kgs(mgs)) + rho0(mgs) = dn(igs(mgs),jy,kgs(mgs)) + rhoinv(mgs) = 1.0/rho0(mgs) + rhovt(mgs) = Sqrt(rho00/Max(0.05,rho0(mgs))) ! prevent excessive rhovt + pi0(mgs) = p2(igs(mgs),jy,kgs(mgs)) + pinit(kgs(mgs)) + temg(mgs) = t0(igs(mgs),jy,kgs(mgs)) + temgkm1(mgs) = t0(igs(mgs),jy,kgsm(mgs)) + temgkm2(mgs) = t0(igs(mgs),jy,kgsm2(mgs)) + pk(mgs) = p2(igs(mgs),jy,kgs(mgs)) + pinit(kgs(mgs)) ! t77(igs(mgs),jy,kgs(mgs)) + temcg(mgs) = temg(mgs) - tfr + qss0(mgs) = (380.0)/(pres(mgs)) + pqs(mgs) = (380.0)/(pres(mgs)) + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + qis(mgs) = pqs(mgs)*tabqis(ltemq) + qss(mgs) = qvs(mgs) +! es(mgs) = 6.1078e2*tabqvs(ltemq) +! eis(mgs) = 6.1078e2*tabqis(ltemq) + cnostmp(mgs) = cno(ls) +! + + il5(mgs) = 0 + if ( temg(mgs) .lt. tfr ) then + il5(mgs) = 1 + end if + enddo !mgs + + IF ( ipconc < 1 .and. lwsm6 ) THEN + DO mgs = 1,ngscnt + tmp = Min( 0.0, temcg(mgs) ) + cnostmp(mgs) = Min( 2.e8, 2.e6*exp(0.12*tmp) ) + ENDDO + ENDIF + + +! +! zero arrays that are used but not otherwise set (tm) +! + do mgs = 1,ngscnt + qhshr(mgs) = 0.0 + end do +! +! set temporaries for microphysics variables +! + DO il = lv,lhab + do mgs = 1,ngscnt + qx(mgs,il) = max(an(igs(mgs),jy,kgs(mgs),il), 0.0) + ENDDO + end do + + qxw(:,:) = 0.0 + qxwlg(:,:) = 0.0 + + + + scx(:,:) = 0.0 +! +! set shape parameters +! + IF ( imurain == 1 ) THEN + alpha(:,lr) = alphar + ELSEIF ( imurain == 3 ) THEN + alpha(:,lr) = xnu(lr) + ENDIF + + alpha(:,li) = xnu(li) + alpha(:,lc) = xnu(lc) + + IF ( imusnow == 1 ) THEN + alpha(:,ls) = alphas + ELSEIF ( imusnow == 3 ) THEN + alpha(:,ls) = xnu(ls) + ENDIF + + DO il = lr,lhab + do mgs = 1,ngscnt + IF ( il .ge. lg ) alpha(mgs,il) = dnu(il) + + + DO ic = lc,lhab + dab0lh(mgs,il,ic) = dab0(il,ic) ! dab0(ic,il) + dab1lh(mgs,il,ic) = dab1(il,ic) ! dab1(ic,il) + ENDDO + ENDDO + end do + + +! DO mgs = 1,ngscnt + DO il = lr,lhab + da0lx(:,il) = da0(il) + ENDDO + da0lh(:) = da0(lh) + da0lr(:) = da0(lr) + da1lr(:) = da1(lr) + da0lc(:) = da0(lc) + da1lc(:) = da1(lc) + + + IF ( lzh < 1 .or. lzhl < 1 ) THEN + rzxhlh(:) = rzhl/rz + ELSEIF ( lzh > 1 .and. lzhl > 1 ) THEN + rzxhlh(:) = 1. + ENDIF + IF ( lzr > 1 ) THEN + rzxh(:) = 1. + rzxhl(:) = 1. + ELSE + rzxh(:) = rz + rzxhl(:) = rzhl + ENDIF + + IF ( imurain == 1 .and. imusnow == 3 .and. lzr < 1 ) THEN + rzxs(:) = rzs + ELSEIF ( imurain == imusnow .or. lzr > 1 ) THEN + rzxs(:) = 1. + ENDIF + ! ENDDO + + IF ( lhl .gt. 1 ) THEN + DO mgs = 1,ngscnt + da0lhl(mgs) = da0(lhl) + ENDDO + ENDIF + + ventrx(:) = ventr + ventrxn(:) = ventrn + gf1palp(:) = gamma_sp(1.0 + alphar) + +! +! set concentrations +! +! ssmax = 0.0 + + + if ( ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) 'ICEZVD_GS: dbg = 5b' + + if ( ipconc .ge. 1 ) then + do mgs = 1,ngscnt + cx(mgs,li) = Max(an(igs(mgs),jy,kgs(mgs),lni), 0.0) + IF ( qx(mgs,li) .le. qxmin(li) ) THEN + cx(mgs,li) = 0.0 + ENDIF + + IF ( lcina .gt. 1 ) THEN + cina(mgs) = an(igs(mgs),jy,kgs(mgs),lcina) + ELSE + cina(mgs) = cx(mgs,li) + ENDIF + IF ( lcin > 1 ) THEN + ccin(mgs) = an(igs(mgs),jy,kgs(mgs),lcin) + ENDIF + end do + end if + if ( ipconc .ge. 2 ) then + do mgs = 1,ngscnt + cx(mgs,lc) = Max(an(igs(mgs),jy,kgs(mgs),lnc), 0.0) +! cx(mgs,lc) = Min( ccwmx, cx(mgs,lc) ) + IF ( qx(mgs,lc) .le. qxmin(lc) ) THEN + cx(mgs,lc) = 0.0 + ENDIF + IF ( lss > 1 ) THEN + ssmax(mgs) = an(igs(mgs),jy,kgs(mgs),lss) + ENDIF + IF ( lccn .gt. 1 ) THEN + ccnc(mgs) = an(igs(mgs),jy,kgs(mgs),lccn) + ELSE + ccnc(mgs) = 0.0 + ENDIF + IF ( lccna .gt. 1 ) THEN + ccna(mgs) = an(igs(mgs),jy,kgs(mgs),lccna) + ELSE + ccna(mgs) = cx(mgs,lc) + ENDIF + end do +! ELSE +! cx(mgs,lc) = Abs(ccn) + end if + if ( ipconc .ge. 3 ) then + do mgs = 1,ngscnt + cx(mgs,lr) = Max(an(igs(mgs),jy,kgs(mgs),lnr), 0.0) + IF ( qx(mgs,lr) .le. qxmin(lr) ) THEN +! cx(mgs,lr) = 0.0 + ELSEIF ( cx(mgs,lr) .eq. 0.0 .and. qx(mgs,lr) .lt. 3.0*qxmin(lr) ) THEN + qx(mgs,lv) = qx(mgs,lv) + qx(mgs,lr) + qx(mgs,lr) = 0.0 + ELSE + cx(mgs,lr) = Max( 1.e-9, cx(mgs,lr) ) + ENDIF + end do + end if + if ( ipconc .ge. 4 ) then + do mgs = 1,ngscnt + cx(mgs,ls) = Max(an(igs(mgs),jy,kgs(mgs),lns), 0.0) + IF ( qx(mgs,ls) .le. qxmin(ls) ) THEN +! cx(mgs,ls) = 0.0 + ELSEIF ( cx(mgs,ls) .eq. 0.0 .and. qx(mgs,ls) .lt. 3.0*qxmin(ls) ) THEN + qx(mgs,lv) = qx(mgs,lv) + qx(mgs,ls) + qx(mgs,ls) = 0.0 + ELSE + cx(mgs,ls) = Max( 1.e-9, cx(mgs,ls) ) + + IF ( ilimit .ge. ipc(ls) ) THEN + tmp = (xdn0(ls)*cx(mgs,ls))/(rho0(mgs)*qx(mgs,ls)) + tmp2 = (tmp*(3.14159))**(1./3.) + cnox = cx(mgs,ls)*(tmp2) + IF ( cnox .gt. 3.0*cno(ls) ) THEN + cx(mgs,ls) = 3.0*cno(ls)/tmp2 + ENDIF + ENDIF + ENDIF + end do + end if + if ( ipconc .ge. 5 ) then + do mgs = 1,ngscnt + + cx(mgs,lh) = Max(an(igs(mgs),jy,kgs(mgs),lnh), 0.0) + IF ( qx(mgs,lh) .le. qxmin(lh) ) THEN +! cx(mgs,lh) = 0.0 + ELSEIF ( cx(mgs,lh) .eq. 0.0 .and. qx(mgs,lh) .lt. 3.0*qxmin(lh) ) THEN + qx(mgs,lv) = qx(mgs,lv) + qx(mgs,lh) + qx(mgs,lh) = 0.0 + ELSE + cx(mgs,lh) = Max( 1.e-9, cx(mgs,lh) ) + IF ( ilimit .ge. ipc(lh) ) THEN + tmp = (xdn0(lh)*cx(mgs,lh))/(rho0(mgs)*qx(mgs,lh)) + tmp2 = (tmp*(3.14159))**(1./3.) + cnox = cx(mgs,lh)*(tmp2) + IF ( cnox .gt. 3.0*cno(lh) ) THEN + cx(mgs,lh) = 3.0*cno(lh)/tmp2 + ENDIF + ENDIF + ENDIF + + + end do + + + end if + + if ( lhl .gt. 1 .and. ipconc .ge. 5 ) then + do mgs = 1,ngscnt + + cx(mgs,lhl) = Max(an(igs(mgs),jy,kgs(mgs),lnhl), 0.0) + IF ( qx(mgs,lhl) .le. qxmin(lhl) ) THEN + cx(mgs,lhl) = 0.0 + ELSEIF ( cx(mgs,lhl) .eq. 0.0 .and. qx(mgs,lhl) .lt. 3.0*qxmin(lhl) ) THEN + qx(mgs,lv) = qx(mgs,lv) + qx(mgs,lhl) + qx(mgs,lhl) = 0.0 + ELSE + cx(mgs,lhl) = Max( 1.e-9, cx(mgs,lhl) ) + IF ( ilimit .ge. ipc(lhl) ) THEN + tmp = (xdn0(lhl)*cx(mgs,lhl))/(rho0(mgs)*qx(mgs,lhl)) + tmp2 = (tmp*(3.14159))**(1./3.) + cnox = cx(mgs,lhl)*(tmp2) + IF ( cnox .gt. 3.0*cno(lhl) ) THEN + cx(mgs,lhl) = 3.0*cno(lhl)/tmp2 + ENDIF + ENDIF + ENDIF + + + end do + end if + +! +! Set mean particle volume +! + IF ( ldovol ) THEN + + vx(:,:) = 0.0 + + DO il = li,lhab + + IF ( lvol(il) .ge. 1 ) THEN + + DO mgs = 1,ngscnt + vx(mgs,il) = Max(an(igs(mgs),jy,kgs(mgs),lvol(il)), 0.0) + ENDDO + + ENDIF + + ENDDO + + ENDIF + + +! +! Set liquid water fraction +! + fhw(:) = 0.0 + fsw(:) = 0.0 + fhlw(:) = 0.0 + + + + +! +! set factors +! + do mgs = 1,ngscnt +! + ssi(mgs) = qx(mgs,lv)/qis(mgs) + ssw(mgs) = qx(mgs,lv)/qvs(mgs) +! + tsqr(mgs) = temg(mgs)**2 +! + temgx(mgs) = min(temg(mgs),313.15) + temgx(mgs) = max(temgx(mgs),233.15) + felv(mgs) = 2500837.367 * (273.15/temgx(mgs))**((0.167)+(3.67e-4)*temgx(mgs)) +! + temcgx(mgs) = min(temg(mgs),273.15) + temcgx(mgs) = max(temcgx(mgs),223.15) + temcgx(mgs) = temcgx(mgs)-273.15 + +! felf = latent heat of fusion, fels = LH of sublimation, felv = LH of vaporization + felf(mgs) = 333690.6098 + (2030.61425)*temcgx(mgs) - (10.46708312)*temcgx(mgs)**2 +! + fels(mgs) = felv(mgs) + felf(mgs) +! + felvs(mgs) = felv(mgs)*felv(mgs) + felss(mgs) = fels(mgs)*fels(mgs) + + IF ( eqtset <= 1 ) THEN + felvcp(mgs) = felv(mgs)*cpi + felscp(mgs) = fels(mgs)*cpi + felfcp(mgs) = felf(mgs)*cpi + ELSE + + ! equations from appendix in Bryan and Morrison (2012, MWR) + ! note that rw is Rv in the paper, and rd is R. + + tmp = qx(mgs,li)+qx(mgs,ls)+qx(mgs,lh) + IF ( lhl > 1 ) tmp = tmp + qx(mgs,lhl) + cvm = cv+cvv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) & + +cpigb*(tmp) + + IF ( eqtset == 2 ) THEN ! compact form from treating dT/dt = theta*d(pi)/dt + pi*d(theta)dt and then applied to theta assuming constant pi + felvcp(mgs) = (felv(mgs)-rw*temg(mgs))/cvm + felscp(mgs) = (fels(mgs)-rw*temg(mgs))/cvm + felfcp(mgs) = felf(mgs)/cvm + + ELSE + ! equivalent version that applies separate updates of latent heating to theta and pi, when both are returned. + + cpm = cp+cpv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) & + +cpigb*(tmp) + rmm=rd+rw*qx(mgs,lv) + + felvcp(mgs) = (felv(mgs)*cv/(cp) - rw*temg(mgs)*(1.0-rovcp*cpm/rmm))/cvm + felscp(mgs) = (fels(mgs)*cv/(cp) - rw*temg(mgs)*(1.0-rovcp*cpm/rmm))/cvm + felfcp(mgs) = felf(mgs)*cv/(cp*cvm) + + felvpi(mgs) = pi0(mgs)*rovcp*(felv(mgs)/(temg(mgs)) - rw*cpm/rmm)/cvm + felspi(mgs) = pi0(mgs)*rovcp*(fels(mgs)/(temg(mgs)) - rw*cpm/rmm)/cvm + felfpi(mgs) = pi0(mgs)*rovcp*(felf(mgs)/(cvm*temg(mgs))) + + ENDIF + + ENDIF +! + fgamw(mgs) = felvcp(mgs)/pi0(mgs) + fgams(mgs) = felscp(mgs)/pi0(mgs) +! + fcqv1(mgs) = 4098.0258*pi0(mgs)*fgamw(mgs) + fcqv2(mgs) = 5807.6953*pi0(mgs)*fgams(mgs) + fcc3(mgs) = felfcp(mgs)/pi0(mgs) +! +! fwvdf = water vapor diffusivity + fwvdf(mgs) = (2.11e-05)*((temg(mgs)/tfr)**1.94)*(101325.0/(pres(mgs))) +! +! fadvisc = 'd' for dynamic viscosity +! fakvisc = 'k' for kinematic viscosity + fadvisc(mgs) = advisc0*(416.16/(temg(mgs)+120.0))*(temg(mgs)/296.0)**(1.5) ! dynamic visc. +! + fakvisc(mgs) = fadvisc(mgs)*rhoinv(mgs) ! divide by rho_air to get kinematic visc. (note the 'k' vs. 'd') +! + temcgx(mgs) = min(temg(mgs),273.15) + temcgx(mgs) = max(temcgx(mgs),233.15) + temcgx(mgs) = temcgx(mgs)-273.15 + fci(mgs) = (2.118636 + 0.007371*(temcgx(mgs)))*(1.0e+03) +! + if ( temg(mgs) .lt. 273.15 ) then + temcgx(mgs) = min(temg(mgs),273.15) + temcgx(mgs) = max(temcgx(mgs),233.15) + temcgx(mgs) = temcgx(mgs)-273.15 + fcw(mgs) = 4203.1548 + (1.30572e-2)*((temcgx(mgs)-35.)**2) & + & + (1.60056e-5)*((temcgx(mgs)-35.)**4) + end if + if ( temg(mgs) .ge. 273.15 ) then + temcgx(mgs) = min(temg(mgs),308.15) + temcgx(mgs) = max(temcgx(mgs),273.15) + temcgx(mgs) = temcgx(mgs)-273.15 + fcw(mgs) = 4243.1688 + (3.47104e-1)*(temcgx(mgs)**2) + end if +! + ftka(mgs) = tka0*fadvisc(mgs)/advisc1 ! thermal conductivity: proportional to dynamic viscosity + fthdf(mgs) = ftka(mgs)*cpi*rhoinv(mgs) +! + fschm(mgs) = (fakvisc(mgs)/fwvdf(mgs)) ! Schmidt number + fpndl(mgs) = (fakvisc(mgs)/fthdf(mgs)) ! Prandl number (only used for bin melting) +! + fai(mgs) = (fels(mgs)**2)/(ftka(mgs)*rw*temg(mgs)**2) + fbi(mgs) = (1.0/(rho0(mgs)*fwvdf(mgs)*qis(mgs))) + fav(mgs) = (felv(mgs)**2)/(ftka(mgs)*rw*temg(mgs)**2) + fbv(mgs) = (1.0/(rho0(mgs)*fwvdf(mgs)*qvs(mgs))) + + kp1 = Min(nz, kgs(mgs)+1 ) + wvel(mgs) = (0.5)*(w(igs(mgs),jgs,kp1) & + & +w(igs(mgs),jgs,kgs(mgs))) + +! + end do +! +! +! ice habit fractions +! +! +! +! Set density +! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: Set density' +! + + do mgs = 1,ngscnt + xdn(mgs,li) = xdn0(li) + xdn(mgs,lc) = xdn0(lc) + xdn(mgs,lr) = xdn0(lr) + xdn(mgs,ls) = xdn0(ls) + xdn(mgs,lh) = xdn0(lh) + IF ( lvol(ls) .gt. 1 ) THEN + IF ( vx(mgs,ls) .gt. 0.0 .and. qx(mgs,ls) .gt. qxmin(ls) ) THEN + xdn(mgs,ls) = Min( xdnmx(ls), Max( xdnmn(ls), rho0(mgs)*qx(mgs,ls)/vx(mgs,ls) ) ) + ENDIF + ENDIF + + IF ( lvol(lh) .gt. 1 ) THEN + IF ( vx(mgs,lh) .gt. 0.0 .and. qx(mgs,lh) .gt. qxmin(lh) ) THEN + IF ( mixedphase ) THEN + ELSE + dnmx = xdnmx(lh) + ENDIF + xdn(mgs,lh) = Min( dnmx, Max( xdnmn(lh), rho0(mgs)*qx(mgs,lh)/vx(mgs,lh) ) ) + vx(mgs,lh) = rho0(mgs)*qx(mgs,lh)/xdn(mgs,lh) + + ELSEIF ( vx(mgs,lh) == 0.0 .and. qx(mgs,lh) .gt. qxmin(lh) ) THEN ! if volume is zero, need to initialize the default value + + vx(mgs,lh) = rho0(mgs)*qx(mgs,lh)/xdn(mgs,lh) + + ENDIF + ENDIF + + + IF ( lhl .gt. 1 ) THEN + + xdn(mgs,lhl) = xdn0(lhl) + xdntmp(mgs,lhl) = xdn0(lhl) + + IF ( lvol(lhl) .gt. 1 ) THEN + IF ( vx(mgs,lhl) .gt. 0.0 .and. qx(mgs,lhl) .gt. qxmin(lhl) ) THEN + + IF ( mixedphase .and. lhlw > 1 ) THEN + ELSE + dnmx = xdnmx(lhl) + ENDIF + + xdn(mgs,lhl) = Min( dnmx, Max( xdnmn(lhl), rho0(mgs)*qx(mgs,lhl)/vx(mgs,lhl) ) ) + vx(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/xdn(mgs,lhl) + xdntmp(mgs,lhl) = xdn(mgs,lhl) + + ELSEIF ( vx(mgs,lhl) == 0.0 .and. qx(mgs,lhl) .gt. qxmin(lhl) ) THEN ! if volume is zero, need to initialize the default value + + vx(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/xdn(mgs,lhl) + + ENDIF + ENDIF + + ENDIF + + + end do + + + IF ( imurain == 3 ) THEN + IF ( lzr > 1 ) THEN + alphashr = 0.0 + alphamlr = -2.0/3.0 + ELSE + alphashr = xnu(lr) + alphamlr = xnu(lr) + ENDIF +! massfacshr = ( (2. + 3.*(1. +alphashr) )/( 3.*(1. + alphashr) ) )**(1./3.) ! this is the diameter factor +! massfacmlr = ( (2. + 3.*(1. +alphamlr) )/( 3.*(1. + alphamlr) ) )**(1./3.) + massfacshr = ( (2. + 3.*(1. +alphashr) )**3/( 3.*(1. + alphashr) ) ) ! this is the mass or volume factor + massfacmlr = ( (2. + 3.*(1. +alphamlr) )**3/( 3.*(1. + alphamlr) ) ) + ELSEIF ( imurain == 1 ) THEN + IF ( lzr > 1 ) THEN + alphashr = 4.0 + alphamlr = 4.0 + ELSE + alphashr = alphar + alphamlr = alphar + ENDIF +! massfacshr = (3.0 + alphashr)*((3.+alphashr)*(2.+alphashr)*(1. + alphashr) )**(-1./3.) ! this is the diameter factor +! massfacmlr = (3.0 + alphamlr)*((3.+alphamlr)*(2.+alphamlr)*(1. + alphamlr) )**(-1./3.) + massfacshr = (3.0 + alphashr)**3/((3.+alphashr)*(2.+alphashr)*(1. + alphashr) ) ! this is the mass or volume factor + massfacmlr = (3.0 + alphamlr)**3/((3.+alphamlr)*(2.+alphamlr)*(1. + alphamlr) ) + ENDIF + + +! +! set some values for ice nucleation +! + do mgs = 1,ngscnt + kp1 = Min(nz, kgs(mgs)+1 ) +! wvel(mgs) = (0.5)*(w(igs(mgs),jgs,kp1) & +! & +w(igs(mgs),jgs,kgs(mgs))) + + + wvelkm1(mgs) = (0.5)*(w(igs(mgs),jgs,kgs(mgs)) & + & +w(igs(mgs),jgs,kgsm(mgs))) + cninm(mgs) = t7(igs(mgs),jgs,kgsm(mgs)) + cnina(mgs) = t7(igs(mgs),jgs,kgs(mgs)) + cninp(mgs) = t7(igs(mgs),jgs,kgsp(mgs)) + end do + +! +! Set a couple of cloud variables... +! + +! SUBROUTINE setvt(ngscnt,qx,qxmin,cx,rho0,rhovt,xdia,cno, +! : xmas,xdn,xvmn,xvmx,xv,cdx, +! : ipconc,ndebug) +! SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno, & +! & xmas,vtxbar,xdn,xvmn,xvmx,xv,cdx, & +! & ipconc1,ndebug1,ngs,nz,kgs,cwnccn,fadvisc, & +! & cwmasn,cwmasx,cwradn,cnina,cimna,cimxa, & +! & itype1a,itype2a,temcg,infdo,alpha) + + + infdo = 0 + IF ( rimdenvwgt > 0 ) infdo = 1 + + call setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & + & xmas,vtxbar,xdn,xvmn,xvmx,xv,cdx,cdxgs, & + & ipconc,ndebug,ngs,nz,kgs,fadvisc, & + & cwmasn,cwmasx,cwradn,cnina,cimn,cimx, & + & itype1,itype2,temcg,infdo,alpha,0,axx,bxx) ! ,cdh,cdhl) +! & itype1,itype2,temcg,infdo,alpha,0,axh,bxh,axhl,bxhl) ! ,cdh,cdhl) + + + IF ( lwsm6 .and. ipconc == 0 ) THEN + tmp = Max(qxmin(lh), qxmin(ls)) + DO mgs = 1,ngscnt + sum = qx(mgs,lh) + qx(mgs,ls) + IF ( sum > tmp ) THEN + vt2ave(mgs) = (qx(mgs,lh)*vtxbar(mgs,lh,1) + qx(mgs,ls)*vtxbar(mgs,ls,1))/sum + ELSE + vt2ave(mgs) = 0.0 + ENDIF + ENDDO + ENDIF + + +! +! Set number concentrations (need xdia from setvt) +! + if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: Set concentration' + IF ( ipconc .lt. 1 ) THEN + cina(1:ngscnt) = cx(1:ngscnt,li) + ENDIF + if ( ipconc .lt. 5 ) then + do mgs = 1,ngscnt + + + IF ( ipconc .lt. 3 ) THEN +! cx(mgs,lr) = 0.0 + if ( qx(mgs,lr) .gt. qxmin(lh) ) then +! cx(mgs,lr) = cno(lr)*xdia(mgs,lr,1) +! xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*cx(mgs,lr)) + end if + ENDIF + + IF ( ipconc .lt. 4 ) THEN +! tmp = cx(mgs,ls) +! cx(mgs,ls) = 0.0 + if ( qx(mgs,ls) .gt. qxmin(ls) ) then +! cx(mgs,ls) = cno(ls)*xdia(mgs,ls,1) +! xv(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xdn(mgs,ls)*cx(mgs,ls)) + end if + ENDIF ! ( ipconc .lt. 4 ) + + IF ( ipconc .lt. 5 ) THEN + + +! cx(mgs,lh) = 0.0 + if ( qx(mgs,lh) .gt. qxmin(lh) ) then +! cx(mgs,lh) = cno(lh)*xdia(mgs,lh,1) +! xv(mgs,lh) = Max(xvmn(lh), rho0(mgs)*qx(mgs,lh)/(xdn(mgs,lh)*cx(mgs,lh)) ) +! xdia(mgs,lh,3) = (xv(mgs,lh)*6./pi)**(1./3.) + end if + + ENDIF ! ( ipconc .lt. 5 ) + + end do + end if + + IF ( ipconc .ge. 2 ) THEN + DO mgs = 1,ngscnt + + rb(mgs) = 0.5*xdia(mgs,lc,1)*(1./(1.+alpha(mgs,lc)))**(1./6.) + xl2p(mgs) = Max(0.0d0, 2.7e-2*xdn(mgs,lc)*cx(mgs,lc)*xv(mgs,lc)* & + & ((0.5e20*rb(mgs)**3*xdia(mgs,lc,1))-0.4) ) + IF ( rb(mgs) .gt. 3.51e-6 ) THEN +! rh(mgs) = Max( 0.5d0*xdia(mgs,lc,1), 6.3d-4/(1.d6*(rb(mgs) - 3.5d-6)) ) + rh(mgs) = Max( 41.d-6, 6.3d-4/(1.d6*(rb(mgs) - 3.5d-6)) ) + ELSE + rh(mgs) = 41.d-6 + ENDIF + IF ( xl2p(mgs) .gt. 0.0 ) THEN + nh(mgs) = 4.2d9*xl2p(mgs) + ELSE + nh(mgs) = 1.e30 + ENDIF + ENDDO + ENDIF + +! +! +! +! +! maximum depletion tendency by any one source +! +! + if( ndebug .ge. 0 ) THEN +!mpi! write(0,*) 'Set depletion max/min1' + endif + do mgs = 1,ngscnt + qvimxd(mgs) = 0.70*(qx(mgs,lv)-qis(mgs))*dtpinv ! depletion by all vap. dep to ice. + + IF ( qx(mgs,lc) < qxmin(lc) ) qvimxd(mgs) = 0.99*(qx(mgs,lv)-qis(mgs))*dtpinv ! this makes virtually no difference whatsoever, but what the heck + + qvimxd(mgs) = max(qvimxd(mgs), 0.0) + + frac = 0.1d0 + qimxd(mgs) = frac*qx(mgs,li)*dtpinv + qcmxd(mgs) = frac*qx(mgs,lc)*dtpinv + qrmxd(mgs) = frac*qx(mgs,lr)*dtpinv + qsmxd(mgs) = frac*qx(mgs,ls)*dtpinv + qhmxd(mgs) = frac*qx(mgs,lh)*dtpinv + IF ( lhl > 1 ) qhlmxd(mgs) = frac*qx(mgs,lhl)*dtpinv + end do +! + if( ndebug .ge. 0 ) THEN +!mpi! write(0,*) 'Set depletion max/min2' + endif + + do mgs = 1,ngscnt +! + if ( qx(mgs,lc) .le. qxmin(lc) ) then + ccmxd(mgs) = 0.20*cx(mgs,lc)*dtpinv + else + IF ( ipconc .ge. 2 ) THEN + ccmxd(mgs) = frac*cx(mgs,lc)*dtpinv + ELSE + ccmxd(mgs) = frac*qx(mgs,lc)/(xmas(mgs,lc)*rho0(mgs)*dtp) + ENDIF + end if +! + if ( qx(mgs,li) .le. qxmin(li) ) then + cimxd(mgs) = frac*cx(mgs,li)*dtpinv + else + IF ( ipconc .ge. 1 ) THEN + cimxd(mgs) = frac*cx(mgs,li)*dtpinv + ELSE + cimxd(mgs) = frac*qx(mgs,li)/(xmas(mgs,li)*rho0(mgs)*dtp) + ENDIF + end if +! +! + crmxd(mgs) = 0.10*cx(mgs,lr)*dtpinv + csmxd(mgs) = frac*cx(mgs,ls)*dtpinv + chmxd(mgs) = frac*cx(mgs,lh)*dtpinv + + ccmxd(mgs) = frac*cx(mgs,lc)*dtpinv + cimxd(mgs) = frac*cx(mgs,li)*dtpinv + crmxd(mgs) = frac*cx(mgs,lr)*dtpinv + csmxd(mgs) = frac*cx(mgs,ls)*dtpinv + chmxd(mgs) = frac*cx(mgs,lh)*dtpinv + + qxmxd(mgs,lv) = Max(0.0, 0.1*(qx(mgs,lv) - qvs(mgs))*dtpinv) + + DO il = lc,lhab + qxmxd(mgs,il) = frac*qx(mgs,il)*dtpinv + cxmxd(mgs,il) = frac*cx(mgs,il)*dtpinv + ENDDO + + end do + + + + + + + + + ! default factors between mean volume and maximum mass volume + maxmassfac(lc) = ( (2. + 3.*(1. + xnu(lc)) )**3/( 3.*(1. + xnu(lc)) ) ) + maxmassfac(li) = ( (2. + 3.*(1. + xnu(li)) )**3/( 3.*(1. + xnu(li)) ) ) + + IF ( imurain == 3 ) THEN + maxmassfac(lr) = ( (2. + 3.*(1. + xnu(lr)) )**3/( 3.*(1. + xnu(lr)) ) ) + ELSE + maxmassfac(lr) = (3.0 + alphar)**3/ & + & ((3.+alphar)*(2.+alphar)*(1. + alphar) ) + ENDIF + + IF ( imusnow == 3 ) THEN + maxmassfac(ls) = ( (2. + 3.*(1. + alphas) )**3/( 3.*(1. + alphas) ) ) + ELSE + maxmassfac(ls) = (3.0 + alphas)**3/ & + & ((3.+alphas)*(2.+alphas)*(1. + alphas) ) + ENDIF + + maxmassfac(lh) = (3.0 + alphah)**3/ & + & ((3.+alphah)*(2.+alphah)*(1. + alphah) ) + + IF ( lhl > 1 ) THEN + maxmassfac(lhl) = (3.0 + alphahl)**3/ & + & ((3.+alphahl)*(2.+alphahl)*(1. + alphahl) ) + ENDIF + + + + DO mgs = 1,ngscnt + DO il = lh,lhab ! graupel and hail only (and frozen drops) + + vshdgs(mgs,il) = vshd ! base value + + IF ( qx(mgs,il) > qxmin(il) ) THEN + + ! tmpdiam is weighted diameter of d^(shedalp-1), so for shedalp=3, this is the area-weighted diameter or maximum mass diameter. + tmpdiam = (shedalp+alpha(mgs,il))*xdia(mgs,il,1)*( xdn(mgs,il)/917. )**(1./3.) ! erm added density factor for equiv. solid ice sphere 10.12.2015 + + IF ( tmpdiam > sheddiam0 ) THEN + vshdgs(mgs,il) = 0.523599*(1.5e-3)**3/massfacshr ! 1.5mm drops from very large ice + ELSEIF ( tmpdiam > sheddiam ) THEN ! intermediate size + vshdgs(mgs,il) = 0.523599*(3.0e-3)**3/massfacshr ! 3.0mm drops from medium-large ice + ELSE +! vshdgs(mgs,il) = Min( xvmx(lr), xv(mgs,il)*xdn(mgs,il)*0.001 ) ! size of drop from melted mean ice particle + vshdgs(mgs,il) = Min( xvmx(lr), 6./pi*xdn(mgs,il)*0.001*tmpdiam**3 )/massfacshr ! size of drop from melted mean ice particle; 0.001 is 1/rhow + ENDIF + ENDIF + ENDDO + ENDDO + +! +! +! microphysics source terms (1/s) for mixing ratios +! +! +! +! Collection efficiencies: +! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: Set collection efficiencies' +! + do mgs = 1,ngscnt +! +! +! + qcwresv(mgs) = 0.0 + ccwresv(mgs) = 0.0 + + erw(mgs) = 0.0 + esw(mgs) = 0.0 + ehw(mgs) = 0.0 + efw(mgs) = 0.0 + ehlw(mgs) = 0.0 +! ehxw(mgs) = 0.0 +! + err(mgs) = 0.0 + esr(mgs) = 0.0 + il2(mgs) = 0 + il3(mgs) = 0 + ehr(mgs) = 0.0 + ehlr(mgs) = 0.0 +! ehxr(mgs) = 0.0 +! + eri(mgs) = 0.0 + esi(mgs) = 0.0 + ehi(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehi*ehiclsn + ehis(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehi*ehiclsn + ehli(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehli*ehliclsn + ehlis(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehli*ehliclsn +! ehxi(mgs) = 0.0 +! + ers(mgs) = 0.0 + ess(mgs) = 0.0 + ehs(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehs*ehsclsn + ehls(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehls*ehlsclsn + ehscnv(mgs) = 0.0 +! ehxs(mgs) = 0.0 +! + eiw(mgs) = 0.0 + eii(mgs) = 0.0 + + ehsclsn(mgs) = 0.0 + ehiclsn(mgs) = 0.0 + ehlsclsn(mgs) = 0.0 + ehliclsn(mgs) = 0.0 + esiclsn(mgs) = 0.0 + + +! reserve droplets + IF ( exwmindiam > 0 .and. qx(mgs,lc) > qxmin(lc) ) THEN + tmp = cx(mgs,lc)*Exp(- (exwmindiam/xdia(mgs,lc,1))**3 ) + ccwresv(mgs) = Min( cx(mgs,lc), Max( 2.e6, cx(mgs,lc) - tmp ) ) + + tmp = cx(mgs,lc) - ccwresv(mgs) + + volt = pi/6.*(exwmindiam)**3 + qcwresv(mgs) = qx(mgs,lc) - tmp*xdn0(lc)*rhoinv(mgs)*(volt + xv(mgs,lc)) + + + IF ( .false. .and. qx(mgs,lc) > 0.1e-3 ) THEN + + write(0,*) 'cx,qx,crsv,qrsv = ',cx(mgs,lc),qx(mgs,lc),ccwresv(mgs),qcwresv(mgs) + + ENDIF + + ENDIF + + + icwr(mgs) = 1 + IF ( qx(mgs,lc) .gt. qxmin(lc) ) THEN + cwrad = 0.5*xdia(mgs,lc,1) + DO il = 1,8 + IF ( cwrad .ge. 1.e-6*cwr(il,1) ) icwr(mgs) = il + ENDDO + ENDIF + + + irwr(mgs) = 1 + IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN + rwrad = 0.5*xdia(mgs,lr,3) ! changed to mean volume diameter (10/6/06) + DO il = 1,6 + IF ( rwrad .ge. 1.e-6*grad(il,1) ) irwr(mgs) = il + ENDDO + ENDIF + + + igwr(mgs) = 1 +! IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN +! rwrad = 0.5*xdia(mgs,lr,1) +! setting erw = 1 always, so now use igwr for graupel + IF ( qx(mgs,lh) .gt. qxmin(lh) ) THEN + rwrad = 0.5*xdia(mgs,lh,3) ! changed to mean volume diameter (10/6/06) + DO il = 1,6 + IF ( rwrad .ge. 1.e-6*grad(il,1) ) igwr(mgs) = il + ENDDO + ENDIF + + + IF ( lhl .gt. 1 ) THEN ! hail is turned on + ihlr(mgs) = 1 + IF ( qx(mgs,lhl) .gt. qxmin(lhl) ) THEN + rwrad = 0.5*xdia(mgs,lhl,3) ! changed to mean volume diameter (10/6/06) + DO il = 1,6 + IF ( rwrad .ge. 1.e-6*grad(il,1) ) ihlr(mgs) = il + ENDDO + ENDIF + ENDIF + +! +! +! Ice-Ice: Collection (cxc) efficiencies +! +! + if ( qx(mgs,li) .gt. qxmin(li) ) then +! IF ( ipconc .ge. 14 ) THEN +! eii(mgs)=0.1*exp(0.1*temcg(mgs)) +! if ( temg(mgs) .lt. 243.15 .and. qx(mgs,lc) .gt. 1.e-6 ) then +! eii(mgs)=0.1 +! end if +! +! ELSE + eii(mgs) = exp(0.025*Min(temcg(mgs),0.0)) ! alpha1 from LFO83 (21) +! ENDIF + if ( temg(mgs) .gt. 273.15 ) eii(mgs) = 1.0 + end if +! +! +! +! Ice-cloud water: Collection (cxc) efficiencies +! +! + eiw(mgs) = 0.0 + if ( qx(mgs,li).gt.qxmin(li) .and. qx(mgs,lc).gt.qxmin(lc) ) then + + + if (xdia(mgs,lc,1).gt.15.0e-06 .and. xdia(mgs,li,1).gt.30.0e-06) then +! erm 5/10/2007 test following change: +! if (xdia(mgs,lc,1).gt.12.0e-06 .and. xdia(mgs,li,1).gt.50.0e-06) then + eiw(mgs) = 0.5 + end if + if ( temg(mgs) .ge. 273.15 ) eiw(mgs) = 0.0 + end if + +! +! +! +! Rain: Collection (cxc) efficiencies +! +! + if ( qx(mgs,lr).gt.qxmin(lr) .and. qx(mgs,lc).gt.qxmin(lc) ) then + + IF ( lnr .gt. 1 ) THEN + erw(mgs) = 1.0 + + ELSE + +! cwrad = 0.5*xdia(mgs,lc,1) +! erw(mgs) = +! > min((aradcw + cwrad*(bradcw + cwrad* +! < (cradcw + cwrad*(dradcw)))), 1.0) +! IF ( xdia(mgs,lc,1) .lt. 2.4e-06 .or. xdia(mgs,lr,1) .le. 50.0e-6 ) THEN +! erw(mgs)=0.0 +! ENDIF +! erw(mgs) = ew(icwr(mgs),igwr(mgs)) +! interpolate along droplet radius + ic = icwr(mgs) + icp1 = Min( 8, ic+1 ) + ir = irwr(mgs) + irp1 = Min( 6, ir+1 ) + cwrad = 0.5*xdia(mgs,lc,3) + rwrad = 0.5*xdia(mgs,lr,3) + + slope1 = (ew(icp1, ir ) - ew(ic,ir ))*cwr(ic,2) + slope2 = (ew(icp1, irp1) - ew(ic,irp1))*cwr(ic,2) + +! write(iunit,*) 'slop1: ',slope1,slope2,ew(ic,ir),cwr(ic,2) + + x1 = ew(ic, ir) + slope1*Max(0.0, (cwrad - cwr(ic,1)) ) + x2 = ew(icp1,ir) + slope2*Max(0.0, (cwrad - cwr(ic,1)) ) + + slope1 = (x2 - x1)*grad(ir,2) + + erw(mgs) = Max(0.0, x1 + slope1*Max(0.0, (rwrad - grad(ir,1)) )) + +! write(iunit,*) 'erw: ',erw(mgs),1.e6*cwrad,1.e6*rwrad,ic,ir,x1,x2 +! write(iunit,*) + + erw(mgs) = Max(0.0, erw(mgs) ) + IF ( rwrad .lt. 50.e-6 ) THEN + erw(mgs) = 0.0 + ELSEIF ( rwrad .lt. 100.e-6 ) THEN ! linear change from zero at 50 to erw at 100 microns + erw(mgs) = erw(mgs)*(rwrad - 50.e-6)/50.e-6 + ENDIF + + ENDIF + end if + IF ( cx(mgs,lc) .le. 0.0 ) erw(mgs) = 0.0 +! + if ( qx(mgs,lr).gt.qxmin(lr) .and. qx(mgs,lr).gt.qxmin(lr) ) then + err(mgs)=1.0 + end if +! + if ( qx(mgs,lr).gt.qxmin(lr) .and. qx(mgs,ls).gt.qxmin(ls) ) then + ers(mgs)=1.0 + end if +! + if ( qx(mgs,lr).gt.qxmin(lr) .and. qx(mgs,li).gt.qxmin(li) ) then +! IF ( vtxbar(mgs,lr,1) .gt. vtxbar(mgs,li,1) .and. +! : xdia(mgs,lr,3) .gt. 200.e-6 .and. xdia(mgs,li,3) .gt. 100.e-6 ) THEN + eri(mgs) = eri0 +! cwrad = 0.5*xdia(mgs,li,3) +! eri(mgs) = +! > 1.0*min((aradcw + cwrad*(bradcw + cwrad* +! < (cradcw + cwrad*(dradcw)))), 1.0) +! ENDIF +! if ( xdia(mgs,li,1) .lt. 10.e-6 ) eri(mgs)=0.0 + if ( xdia(mgs,li,3) .lt. eri_cimin ) eri(mgs)=0.0 + end if +! +! +! Snow aggregates: Collection (cxc) efficiencies +! +! Modified by ERM with a linear function for small droplets and large +! snow agg. based numerical data from Wang and Ji (1992) in P&K 1997 (Fig. 14-13), which +! allows collection of very small droplets, albeit at low efficiency. But slow +! fall speeds of snow make up for the efficiency. +! + esw(mgs) = 0.0 + if ( qx(mgs,ls).gt.qxmin(ls) .and. qx(mgs,lc).gt.qxmin(lc) ) then + esw(mgs) = 0.5 + if ( xdia(mgs,lc,1) .gt. 15.e-6 .and. xdia(mgs,ls,1) .gt. 100.e-6) then + esw(mgs) = 0.5 + ELSEIF ( xdia(mgs,ls,1) .ge. 500.e-6 ) THEN + esw(mgs) = Min(0.5, 0.05 + (0.8-0.05)/(40.e-6)*xdia(mgs,lc,1) ) + ENDIF + end if +! + if ( qx(mgs,ls).gt.qxmin(ls) .and. qx(mgs,lr).gt.qxmin(lr) & + & .and. temg(mgs) .lt. tfr - 1. & + & ) then + esr(mgs)=Exp(-(40.e-6)**3/xv(mgs,lr))*Exp(-40.e-6/xdia(mgs,ls,1)) + IF ( qx(mgs,ls) < 1.e-4 .and. qx(mgs,lr) < 1.e-4 ) il2(mgs) = 1 + end if + + IF ( ipconc < 3 .and. temg(mgs) < tfr .and. qx(mgs,lr).gt.qxmin(lr) .and. qx(mgs,lr) < 1.e-4 ) THEN + il3(mgs) = 1 + ENDIF +! +! if ( qx(mgs,ls).gt.qxmin(ls) ) then + if ( temcg(mgs) < 0.0 ) then + + IF ( ipconc .lt. 4 .or. temcg(mgs) < esstem1 ) THEN + ess(mgs) = 0.0 +! ess(mgs)=0.1*exp(0.1*min(temcg(mgs),0.0)) +! ess(mgs)=min(0.1,ess(mgs)) + + ELSE + + fac = Abs(ess0) + IF ( .true. .and. ess0 < 0.0 ) THEN +! IF ( wvel(mgs) > 2.0 .or. wvel(mgs) < -0.5 .or. ssi(mgs) < 1.0 ) THEN + IF ( wvel(mgs) > 2.0 ) THEN + ! assume convective cell or downdraft + fac = 0.0 + ELSEIF ( wvel(mgs) > 1.0 ) THEN ! transition to stratiform range of values + fac = Max(0.0, 2.0 - wvel(mgs))*fac + ENDIF + ENDIF + + IF ( temcg(mgs) > esstem1 .and. temcg(mgs) < esstem2 ) THEN ! only nonzero for T > -25 + ess(mgs) = fac*Exp(ess1*(esstem2) )*(temcg(mgs) - esstem1)/(esstem2 - esstem1) ! linear ramp up from zero at esstem1 to value at esstem2 + ELSEIF ( temcg(mgs) >= esstem2 ) THEN + ess(mgs) = fac*Exp(ess1*Min( temcg(mgs), 0.0 ) ) + ENDIF + + ENDIF + end if +! + if ( qx(mgs,ls).gt.qxmin(ls) .and. qx(mgs,li).gt.qxmin(li) ) then + esiclsn(mgs) = esi_collsn +! IF ( ipconc .lt. 4 ) THEN + IF ( ipconc < 1 .and. lwsm6 ) THEN + esi(mgs) = exp(0.7*min(temcg(mgs),0.0)) + ELSE + esi(mgs) = esi0*exp(0.1*min(temcg(mgs),0.0)) + esi(mgs) = Min(0.1,esi(mgs)) + ENDIF + IF ( ipconc .le. 3 ) THEN + esi(mgs) = exp(0.025*min(temcg(mgs),0.0)) ! LFO +! esi(mgs) = Min(0.5, exp(0.025*min(temcg(mgs),0.0)) ) ! LFO +! esi(mgs)=0.5*exp(0.1*min(temcg(mgs),0.0)) ! 10ice + ENDIF +! ELSE ! zrnic/ziegler 1993 +! esi(mgs)= 0.1 ! 0.5*exp(0.1*min(temcg(mgs),0.0)) +! ENDIF + if ( temg(mgs) .gt. 273.15 ) esi(mgs) = 0.0 + end if +! +! +! +! +! Graupel: Collection (cxc) efficiencies +! +! + xmascw(mgs) = xmas(mgs,lc) + if ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lc).gt.qxmin(lc) ) then !{ + ehw(mgs) = 1.0 + IF ( iehw .eq. 0 ) THEN + ehw(mgs) = ehw0 ! default value is 1.0 + ELSEIF ( iehw .eq. 1 .or. iehw .eq. 10 ) THEN + cwrad = 0.5*xdia(mgs,lc,1) + ehw(mgs) = Min( ehw0, & + & ewfac*min((aradcw + cwrad*(bradcw + cwrad* & + & (cradcw + cwrad*(dradcw)))), 1.0) ) + + ELSEIF ( iehw .eq. 2 .or. iehw .eq. 10 ) THEN + ic = icwr(mgs) + icp1 = Min( 8, ic+1 ) + ir = igwr(mgs) + irp1 = Min( 6, ir+1 ) + cwrad = 0.5*xdia(mgs,lc,1) + rwrad = 0.5*xdia(mgs,lh,3) ! changed to mean volume diameter + + slope1 = (ew(icp1, ir ) - ew(ic,ir ))*cwr(ic,2) + slope2 = (ew(icp1, irp1) - ew(ic,irp1))*cwr(ic,2) + +! write(iunit,*) 'slop1: ',slope1,slope2,ew(ic,ir),cwr(ic,2) + + x1 = ew(ic, ir) + slope1*Max(0.0, (cwrad - cwr(ic,1)) ) + x2 = ew(icp1,ir) + slope2*Max(0.0, (cwrad - cwr(ic,1)) ) + + slope1 = (x2 - x1)*grad(ir,2) + + tmp = Max( 0.0, Min( 1.0, x1 + slope1*Max(0.0, (rwrad - grad(ir,1)) ) ) ) + ehw(mgs) = Min( ehw(mgs), tmp ) + +! write(iunit,*) 'ehw: ',ehw(mgs),1.e6*cwrad,1.e6*rwrad,ic,ir,x1,x2 +! write(iunit,*) + +! ehw(mgs) = Max( 0.2, ehw(mgs) ) +! assume that ehw = 1 for zero air resistance (rho0 = 0.0) and extrapolate toward that +! ehw(mgs) = ehw(mgs) + (ehw(mgs) - 1.0)*(rho0(mgs) - rho00)/rho00 +! ehw(mgs) = ehw(mgs) + (1.0 - ehw(mgs))*((Max(0.0,rho00 - rho0(mgs)))/rho00)**2 + + ELSEIF ( iehw .eq. 3 .or. iehw .eq. 10 ) THEN ! use fraction of droplets greater than dmincw diameter + tmp = Exp(- (dmincw/xdia(mgs,lc,1))**3) + xmascw(mgs) = xmas(mgs,lc) + xdn0(lc)*(pi*dmincw**3/6.0) ! this is the average mass of the droplets with d > dmincw + ehw(mgs) = Min( ehw(mgs), tmp ) + ELSEIF ( iehw .eq. 4 .or. iehw .eq. 10 ) THEN ! Cober and List 1993, eq. 19-20 + tmp = & + & 2.0*xdn(mgs,lc)*vtxbar(mgs,lh,1)*(0.5*xdia(mgs,lc,1))**2 & + & /(9.0*fadvisc(mgs)*0.5*xdia(mgs,lh,3)) + tmp = Max( 1.5, Min(10.0, tmp) ) + ehw(mgs) = Min( ehw(mgs), 0.55*Log10(2.51*tmp) ) + ENDIF + if ( xdia(mgs,lc,1) .lt. 2.4e-06 ) ehw(mgs)=0.0 + + ehw(mgs) = Min( ehw0, ehw(mgs) ) + + IF ( ibfc == -1 .and. temcg(mgs) < -41.0 ) THEN + ehw(mgs) = 0.0 + ENDIF + + end if !} +! + if ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lr).gt.qxmin(lr) & +! & .and. temg(mgs) .lt. tfr & + & ) then +! ehr(mgs) = Exp(-(40.e-6)**3/xv(mgs,lr))*Exp(-40.e-6/xdia(mgs,lh,1)) +! ehr(mgs) = 1.0 + ehr(mgs) = Exp(-(40.e-6)/xdia(mgs,lr,3))*Exp(-40.e-6/xdia(mgs,lh,3)) + ehr(mgs) = Min( ehr0, ehr(mgs) ) + end if +! + IF ( qx(mgs,ls).gt.qxmin(ls) ) THEN + IF ( ipconc .ge. 4 ) THEN + ehscnv(mgs) = ehs0*exp(ehs1*min(temcg(mgs),0.0)) ! for 2-moment, used as default for ehs and ehls. Otherwise not used for snow->graupel conversion + ELSE + ehscnv(mgs) = exp(0.09*min(temcg(mgs),0.0)) + ENDIF + if ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lc) > qxmin(lc) ) then + ehsclsn(mgs) = ehs_collsn + IF ( xdia(mgs,ls,3) < 40.e-6 ) THEN + ehsclsn(mgs) = 0.0 + ELSEIF ( xdia(mgs,ls,3) < 150.e-6 ) THEN + ehsclsn(mgs) = ehs_collsn*(xdia(mgs,ls,3) - 40.e-6)/(150.e-6 - 40.e-6) + ELSE + ehsclsn(mgs) = ehs_collsn + ENDIF +! ehs(mgs) = ehscnv(mgs)*Min(1.0, Max(0., xdn(mgs,lh) - xdnmn(lh)*1.2)/xdnmn(lh) ) ! shut off qhacs as graupel goes to lowest density + ehs(mgs) = ehscnv(mgs)*Min(1.0, Max(0.0,xdn(mgs,lh) - 300.)/300. ) ! shut off qhacs as graupel goes to low density +! ehs(mgs) = ehscnv(mgs) ! *Min(1.0, Max(0.0,xdn(mgs,lh) - 300.)/300. ) ! shut off qhacs as graupel goes to low density + ehs(mgs) = Min(ehs(mgs),ehsmax) + IF ( qx(mgs,lc) < qxmin(lc) ) ehs(mgs) = 0.0 + end if + ENDIF +! + if ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,li).gt.qxmin(li) ) then + ehiclsn(mgs) = ehi_collsn + ehi(mgs)=eii0*exp(eii1*min(temcg(mgs),0.0)) + ehi(mgs) = Min( ehimax, Max( ehi(mgs), ehimin ) ) + if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehi(mgs) = 0.0 + end if + + IF ( lis > 1 ) THEN + if ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lis).gt.qxmin(lis) ) then + ehisclsn(mgs) = ehi_collsn + ehis(mgs)=eii0*exp(eii1*min(temcg(mgs),0.0)) + ehis(mgs) = Min( ehimax, Max( ehis(mgs), ehimin ) ) + if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehis(mgs) = 0.0 + end if + ENDIF + + +! +! +! Hail: Collection (cxc) efficiencies +! +! + IF ( lhl .gt. 1 ) THEN + + if ( qx(mgs,lhl).gt.qxmin(lhl) .and. qx(mgs,lc).gt.qxmin(lc) ) then + IF ( iehw == 3 ) iehlw = 3 + IF ( iehw == 4 ) iehlw = 4 + ehlw(mgs) = ehlw0 + IF ( iehlw .eq. 0 ) THEN + ehlw(mgs) = ehlw0 ! default value is 1.0 + ELSEIF ( iehlw .eq. 1 .or. iehlw .eq. 10 ) THEN + cwrad = 0.5*xdia(mgs,lc,1) + ehlw(mgs) = Min( ehlw0, & + & ewfac*min((aradcw + cwrad*(bradcw + cwrad* & + & (cradcw + cwrad*(dradcw)))), 1.0) ) + + ELSEIF ( iehlw .eq. 2 .or. iehlw .eq. 10 ) THEN + ic = icwr(mgs) + icp1 = Min( 8, ic+1 ) + ir = ihlr(mgs) + irp1 = Min( 6, ir+1 ) + cwrad = 0.5*xdia(mgs,lc,1) + rwrad = 0.5*xdia(mgs,lhl,3) ! changed to mean volume diameter + + slope1 = (ew(icp1, ir ) - ew(ic,ir ))*cwr(ic,2) + slope2 = (ew(icp1, irp1) - ew(ic,irp1))*cwr(ic,2) + + x1 = ew(ic, ir) + slope1*(cwrad - cwr(ic,1)) + x2 = ew(icp1,ir) + slope2*(cwrad - cwr(ic,1)) + + slope1 = (x2 - x1)*grad(ir,2) + + tmp = Max( 0.0, Min( 1.0, x1 + slope1*(rwrad - grad(ir,1)) ) ) + ehlw(mgs) = Min( ehlw(mgs), tmp ) + ehlw(mgs) = Min( ehlw0, ehlw(mgs) ) +! ehw(mgs) = Max( 0.2, ehw(mgs) ) +! assume that ehw = 1 for zero air resistance (rho0 = 0.0) and extrapolate toward that +! ehw(mgs) = ehw(mgs) + (ehw(mgs) - 1.0)*(rho0(mgs) - rho00)/rho00 +! ehlw(mgs) = ehlw(mgs) + (1.0 - ehlw(mgs))*((Max(0.0,rho00 - rho0(mgs)))/rho00)**2 + + ELSEIF ( iehlw .eq. 3 .or. iehlw .eq. 10 ) THEN ! use fraction of droplets greater than 15 micron diameter + tmp = Exp(- (dmincw/xdia(mgs,lc,1))**3) + ehlw(mgs) = Min( ehlw(mgs), tmp ) + ELSEIF ( iehlw .eq. 4 .or. iehlw .eq. 10 ) THEN ! Cober and List 1993 + tmp = & + & 2.0*xdn(mgs,lc)*vtxbar(mgs,lhl,1)*(0.5*xdia(mgs,lc,1))**2 & + & /(9.0*fadvisc(mgs)*0.5*xdia(mgs,lhl,3)) + tmp = Max( 1.5, Min(10.0, tmp) ) + ehlw(mgs) = Min( ehlw(mgs), 0.55*Log10(2.51*tmp) ) + ENDIF + if ( xdia(mgs,lc,1) .lt. 2.4e-06 ) ehlw(mgs)=0.0 + ehlw(mgs) = Min( ehlw0, ehlw(mgs) ) + + IF ( ibfc == -1 .and. temcg(mgs) < -41.0 ) THEN + ehlw(mgs) = 0.0 + ENDIF + + end if +! + if ( qx(mgs,lhl).gt.qxmin(lhl) .and. qx(mgs,lr).gt.qxmin(lr) & +! & .and. temg(mgs) .lt. tfr & + & ) then + ehlr(mgs) = 1.0 + ehlr(mgs) = Min( ehlr0, ehlr(mgs) ) + end if +! + IF ( qx(mgs,ls).gt.qxmin(ls) ) THEN + if ( qx(mgs,lhl).gt.qxmin(lhl) ) then + ehlsclsn(mgs) = ehls_collsn + ehls(mgs) = ehscnv(mgs) + ehls(mgs) = Min(ehls(mgs),ehsmax) + end if + ENDIF +! + if ( qx(mgs,lhl).gt.qxmin(lhl) .and. qx(mgs,li).gt.qxmin(li) ) then + ehliclsn(mgs) = ehli_collsn + ehli(mgs)=eii0hl*exp(eii1hl*min(temcg(mgs),0.0)) + ehli(mgs) = Min( ehimax, Max( ehli(mgs), ehimin ) ) + if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehli(mgs) = 0.0 + end if + + IF ( lis > 1 ) THEN + if ( qx(mgs,lhl).gt.qxmin(lhl) .and. qx(mgs,lis).gt.qxmin(lis) ) then + ehlisclsn(mgs) = ehli_collsn + ehlis(mgs)=eii0*exp(eii1*min(temcg(mgs),0.0)) + ehlis(mgs) = Min( ehimax, Max( ehlis(mgs), ehimin ) ) + if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehlis(mgs) = 0.0 + end if + ENDIF + + + ENDIF ! lhl .gt. 1 + + ENDDO ! mgs loop for collection efficiencies + +! +! +! +! Set flags for plates vs. columns +! +! + do mgs = 1,ngscnt +! + xplate(mgs) = 0.0 + xcolmn(mgs) = 1.0 +! +! if ( temcg(mgs) .lt. 0. .and. temcg(mgs) .ge. -4. ) then +! xplate(mgs) = 1.0 +! xcolmn(mgs) = 0.0 +! end if +!c +! if ( temcg(mgs) .lt. -4. .and. temcg(mgs) .ge. -9. ) then +! xplate(mgs) = 0.0 +! xcolmn(mgs) = 1.0 +! end if +!c +! if ( temcg(mgs) .lt. -9. .and. temcg(mgs) .ge. -22.5 ) then +! xplate(mgs) = 1.0 +! xcolmn(mgs) = 0.0 +! end if +!c +! if ( temcg(mgs) .lt. -22.5 .and. temcg(mgs) .ge. -90. ) then +! xplate(mgs) = 0.0 +! xcolmn(mgs) = 1.0 +! end if +! + end do + + +! +! +! +! Collection growth equations.... +! +! + if (ndebug .gt. 0 ) write(0,*) 'Collection: rain collects xxxxx' +! + do mgs = 1,ngscnt + qracw(mgs) = 0.0 + IF ( qx(mgs,lr) .gt. qxmin(lr) .and. erw(mgs) .gt. 0.0 ) THEN + IF ( ipconc .lt. 3 ) THEN + IF ( erw(mgs) .gt. 0.0 .and. qx(mgs,lr) .gt. 1.e-7 ) THEN + vt = (ar*(xdia(mgs,lc,1)**br))*rhovt(mgs) + qracw(mgs) = & + & (0.25)*pi*erw(mgs)*(qx(mgs,lc)-qcwresv(mgs))*cx(mgs,lr) & +! > *abs(vtxbar(mgs,lr,1)-vtxbar(mgs,lc,1)) & + & *Max(0.0, vtxbar(mgs,lr,1)-vt) & + & *( gf3*xdia(mgs,lr,2) & + & + 2.0*gf2*xdia(mgs,lr,1)*xdia(mgs,lc,1) & + & + gf1*xdia(mgs,lc,2) ) +! qracw(mgs) = 0.0 +! write(iunit,*) 'qracw,cx =',qracw(mgs),1.e6*xdia(mgs,lr,1),erw(mgs) +! write(iunit,*) 'qracw,cx =',qracw(mgs),cx(mgs,lc),kgs(mgs),cx(mgs,lr),1.e6*xdia(mgs,lr,1),vtxbar(mgs,lr,1),vt +! write(iunit,*) 'vtr: ',vtxbar(mgs,lr,1), ar*gf4br/6.0*xdia(mgs,lr,1)**br, rhovt(mgs), +! : ar*gf4br/6.0*xdia(mgs,lr,1)**br * rhovt(mgs) + ENDIF + ELSE + + IF ( dmrauto <= 0 .or. rho0(mgs)*qx(mgs,lr) > 1.2*xl2p(mgs) ) THEN + rwrad = 0.5*xdia(mgs,lr,3) + IF ( rwrad .gt. rh(mgs) ) THEN ! .or. cx(mgs,lr) .gt. nh(mgs) ) THEN + IF ( rwrad .gt. rwradmn ) THEN +! DM1CCC=A2*XNC*XNR*XVC*(((CNU+2.)/(CNU+1.))*XVC+XVR) ! (A12) +! NOTE: Result is independent of imurain, assumes mucloud = 3 + qracw(mgs) = erw(mgs)*aa2*cx(mgs,lr)*cx(mgs,lc)*xmas(mgs,lc)* & + & ((alpha(mgs,lc) + 2.)*xv(mgs,lc)/(alpha(mgs,lc) + 1.) + xv(mgs,lr))/rho0(mgs) !*rhoinv(mgs) + ELSE + + IF ( imurain == 3 ) THEN + +! DM1CCC=A1*XNC*XNR*(((CNU+3.)*(CNU+2.)/(CNU+1.)**2)*XVC**3+ ! (A14) +! 1 ((RNU+2.)/(RNU+1.))*XVC*XVR**2) + +! qracw(mgs) = aa1*cx(mgs,lr)*cx(mgs,lc)*xdn(mgs,lc)* & +! & ((cnu + 3.)*(cnu + 2.)*xv(mgs,lc)**3/(cnu + 1.)**2 + & +! & (alpha(mgs,lr) + 2.)*xv(mgs,lc)*xv(mgs,lr)**2/(alpha(mgs,lr) + 1.))/rho0(mgs) !*rhoinv(mgs) +! save multiplies by converting cx*xdn*xv/rho0 to qx + qracw(mgs) = aa1*cx(mgs,lr)*(qx(mgs,lc)-qcwresv(mgs))* & + & ((alpha(mgs,lc) + 3.)*(alpha(mgs,lc) + 2.)*xv(mgs,lc)**2/(alpha(mgs,lc) + 1.)**2 + & + & (alpha(mgs,lr) + 2.)*xv(mgs,lr)**2/(alpha(mgs,lr) + 1.)) + + ELSE ! imurain == 1 + + qracw(mgs) = aa1*cx(mgs,lr)*(qx(mgs,lc)-qcwresv(mgs))* & + & ((alpha(mgs,lc) + 3.)*(alpha(mgs,lc) + 2.)*xv(mgs,lc)**2/(alpha(mgs,lc) + 1.)**2 + & + & (alpha(mgs,lr) + 6.)*(alpha(mgs,lr) + 5.)*(alpha(mgs,lr) + 4.)*xv(mgs,lr)**2/ & + & ((alpha(mgs,lr) + 3.)*(alpha(mgs,lr) + 2.)*(alpha(mgs,lr) + 1.))) + + ENDIF + + ENDIF + ENDIF + ENDIF + ENDIF +! qracw(mgs) = Min(qracw(mgs), qx(mgs,lc)) + qracw(mgs) = Min(qracw(mgs), qcmxd(mgs)) + ENDIF + end do +! + do mgs = 1,ngscnt + qraci(mgs) = 0.0 + craci(mgs) = 0.0 + IF ( eri(mgs) .gt. 0.0 .and. iacr .ge. 1 .and. xdia(mgs,lr,3) .gt. 2.*rwradmn ) THEN + IF ( ipconc .ge. 3 ) THEN + + tmp = eri(mgs)*aa2*cx(mgs,lr)*cx(mgs,li)* & + & ((cinu + 2.)*xv(mgs,li)/(cinu + 1.) + xv(mgs,lr)) + + qraci(mgs) = Min( qxmxd(mgs,li), tmp*xmas(mgs,li)*rhoinv(mgs) ) + craci(mgs) = Min( cxmxd(mgs,li), tmp ) + +! vt = Sqrt((vtxbar(mgs,lr,1)-vtxbar(mgs,li,1))**2 + +! : 0.04*vtxbar(mgs,lr,1)*vtxbar(mgs,li,1) ) +! +! qraci(mgs) = 0.25*pi*eri(mgs)*cx(mgs,lr)*qx(mgs,li)*vt* +! : ( da0(lr)*xdia(mgs,lr,3)**2 + +! : dab1(lr,li)*xdia(mgs,lr,3)*xdia(mgs,li,3) + +! : da1(li)*xdia(mgs,li,3)**2 ) +! +! +! vt = Sqrt((vtxbar(mgs,lr,1)-vtxbar(mgs,li,1))**2 + +! : 0.04*vtxbar(mgs,lr,1)*vtxbar(mgs,li,1) ) +! +! craci(mgs) = 0.25*pi*eri(mgs)*cx(mgs,lr)*cx(mgs,li)*vt* +! : ( da0(lr)*xdia(mgs,lr,3)**2 + +! : dab0(lr,li)*xdia(mgs,lr,3)*xdia(mgs,li,3) + +! : da0(li)*xdia(mgs,li,3)**2 ) +! +! qraci(mgs) = Min( qraci(mgs), qxmxd(mgs,li) ) +! craci(mgs) = Min( craci(mgs), cxmxd(mgs,li) ) + + ELSE + qraci(mgs) = & + & min( & + & (0.25)*pi*eri(mgs)*qx(mgs,li)*cx(mgs,lr) & + & *abs(vtxbar(mgs,lr,1)-vtxbar(mgs,li,1)) & + & *( gf3*xdia(mgs,lr,2) & + & + 2.0*gf2*xdia(mgs,lr,1)*xdia(mgs,li,1) & + & + gf1*xdia(mgs,li,2) ) & + & , qimxd(mgs)) + ENDIF + if ( temg(mgs) .gt. 268.15 ) then + qraci(mgs) = 0.0 + end if + ENDIF + end do +! + do mgs = 1,ngscnt + qracs(mgs) = 0.0 + IF ( ers(mgs) .gt. 0.0 .and. ipconc < 3 ) THEN + IF ( lwsm6 .and. ipconc == 0 ) THEN + vt = vt2ave(mgs) + ELSE + vt = vtxbar(mgs,ls,1) + ENDIF + qracs(mgs) = & + & min( & + & ((0.25)*pi/gf4)*ers(mgs)*qx(mgs,ls)*cx(mgs,lr) & + & *abs(vtxbar(mgs,lr,1)-vt) & + & *( gf6*gf1*xdia(mgs,ls,2) & + & + 2.0*gf5*gf2*xdia(mgs,ls,1)*xdia(mgs,lr,1) & + & + gf4*gf3*xdia(mgs,lr,2) ) & + & , qsmxd(mgs)) + ENDIF + end do + +! +! + if (ndebug .gt. 0 ) write(0,*) 'Collection: snow collects xxxxx' +! + do mgs = 1,ngscnt + qsacw(mgs) = 0.0 + csacw(mgs) = 0.0 + vsacw(mgs) = 0.0 + IF ( esw(mgs) .gt. 0.0 ) THEN + + IF ( ipconc .ge. 4 ) THEN +! QSACC=CECS*RVT*A2*XNC*XNS*XVC*ROS* +! * (((CNU+2.)/(CNU+1.))*XVC+XVS)/RO + +! tmp = esw(mgs)*rvt*aa2*cx(mgs,ls)*cx(mgs,lc)* +! : ((cnu + 2.)*xv(mgs,lc)/(cnu + 1.) + xv(mgs,ls)) + tmp = 1.0*rvt*aa2*cx(mgs,ls)*cx(mgs,lc)* & + & ((alpha(mgs,lc) + 2.)*xv(mgs,lc)/(alpha(mgs,lc) + 1.) + xv(mgs,ls)) + + qsacw(mgs) = Min( qxmxd(mgs,lc), tmp*xmas(mgs,lc)*rhoinv(mgs) ) + csacw(mgs) = Min( cxmxd(mgs,lc), tmp ) + + IF ( lvol(ls) .gt. 1 ) THEN + IF ( temg(mgs) .lt. 273.15) THEN + rimdn(mgs,ls) = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & + & *((0.60)*vtxbar(mgs,ls,1)) & + & /(temg(mgs)-273.15))**(rimc2) + rimdn(mgs,ls) = Min( Max( rimc3, rimdn(mgs,ls) ), rimc4 ) + ELSE + rimdn(mgs,ls) = 1000. + ENDIF + + vsacw(mgs) = rho0(mgs)*qsacw(mgs)/rimdn(mgs,ls) + + ENDIF + + +! qsacw(mgs) = cecs*aa2*cx(mgs,ls)*cx(mgs,lc)*xmas(mgs,lc)* +! : ((alpha(mgs,lc) + 2.)*xv(mgs,lc)/(alpha(mgs,lc) + 1.) + xv(mgs,ls))*rhoinv(mgs) + ELSE +! qsacw(mgs) = +! > min( +! > ((0.25)*pi)*esw(mgs)*qx(mgs,lc)*cx(mgs,ls) +! > *abs(vtxbar(mgs,ls,1)-vtxbar(mgs,lc,1)) +! > *( gf3*xdia(mgs,ls,2) +! > + 2.0*gf2*xdia(mgs,ls,1)*xdia(mgs,lc,1) +! > + gf1*xdia(mgs,lc,2) ) +! < , qcmxd(mgs)) + + vt = abs(vtxbar(mgs,ls,1)-vtxbar(mgs,lc,1)) + + qsacw(mgs) = 0.25*pi*esw(mgs)*cx(mgs,ls)*qx(mgs,lc)*vt* & + & ( da0(ls)*xdia(mgs,ls,3)**2 + & + & dab1(ls,lc)*xdia(mgs,ls,3)*xdia(mgs,lc,3) + & + & da1lc(mgs)*xdia(mgs,lc,3)**2 ) + qsacw(mgs) = Min( qsacw(mgs), qxmxd(mgs,ls) ) + csacw(mgs) = rho0(mgs)*qsacw(mgs)/xmas(mgs,lc) + ENDIF + ENDIF + end do +! +! + do mgs = 1,ngscnt + qsaci(mgs) = 0.0 + csaci(mgs) = 0.0 + csaci0(mgs) = 0.0 + IF ( ipconc .ge. 4 ) THEN + IF ( esi(mgs) .gt. 0.0 .or. ( ipelec > 0 .and. esiclsn(mgs) > 0.0 )) THEN +! QSCOI=CEXS*RVT*A2*XNCI*XNS*XVCI*ROS* +! * (((CINU+2.)/(CINU+1.))*VCIP+XVS)/RO + + tmp = esiclsn(mgs)*rvt*aa2*cx(mgs,ls)*cx(mgs,li)* & + & ((cinu + 2.)*xv(mgs,li)/(cinu + 1.) + xv(mgs,ls)) + + qsaci(mgs) = Min( qxmxd(mgs,li), esi(mgs)*tmp*xmas(mgs,li)*rhoinv(mgs) ) + csaci0(mgs) = tmp + csaci(mgs) = Min(cxmxd(mgs,li), esi(mgs)*tmp ) + +! qsaci(mgs) = +! > min( +! > ((0.25)*pi)*esi(mgs)*qx(mgs,li)*cx(mgs,ls) +! > *abs(vtxbar(mgs,ls,1)-vtxbar(mgs,li,1)) +! > *( gf3*xdia(mgs,ls,2) +! > + 2.0*gf2*xdia(mgs,ls,1)*xdia(mgs,li,1) +! > + gf1*xdia(mgs,li,2) ) +! < , qimxd(mgs)) + ENDIF + ELSE ! + IF ( esi(mgs) .gt. 0.0 ) THEN + qsaci(mgs) = & + & min( & + & ((0.25)*pi)*esi(mgs)*qx(mgs,li)*cx(mgs,ls) & + & *abs(vtxbar(mgs,ls,1)-vtxbar(mgs,li,1)) & + & *( gf3*xdia(mgs,ls,2) & + & + 2.0*gf2*xdia(mgs,ls,1)*xdia(mgs,li,1) & + & + gf1*xdia(mgs,li,2) ) & + & , qimxd(mgs)) + ENDIF + ENDIF + end do +! +! +! + do mgs = 1,ngscnt + qsacr(mgs) = 0.0 + qsacrs(mgs) = 0.0 + csacr(mgs) = 0.0 + IF ( esr(mgs) .gt. 0.0 ) THEN + IF ( ipconc .ge. 3 ) THEN +! vt = Sqrt((vtxbar(mgs,ls,1)-vtxbar(mgs,lr,1))**2 + +! : 0.04*vtxbar(mgs,ls,1)*vtxbar(mgs,lr,1) ) +! qsacr(mgs) = esr(mgs)*cx(mgs,ls)*vt* +! : qx(mgs,lr)*0.25*pi* +! : (3.02787*xdia(mgs,lr,2) + +! : 3.30669*xdia(mgs,ls,1)*xdia(mgs,lr,1) + +! : 2.*xdia(mgs,ls,2)) +! qsacr(mgs) = Min( qsacr(mgs), qrmxd(mgs) ) +! csacr(mgs) = qsacr(mgs)*cx(mgs,lr)/qx(mgs,lr) +! csacr(mgs) = min(csacr(mgs),crmxd(mgs)) + ELSE + IF ( lwsm6 .and. ipconc == 0 ) THEN + vt = vt2ave(mgs) + ELSE + vt = vtxbar(mgs,ls,1) + ENDIF + + qsacr(mgs) = & + & min( & + & ((0.25)*pi/gf4)*esr(mgs)*qx(mgs,lr)*cx(mgs,ls) & + & *abs(vtxbar(mgs,lr,1)-vt) & + & *( gf6*gf1*xdia(mgs,lr,2) & + & + 2.0*gf5*gf2*xdia(mgs,lr,1)*xdia(mgs,ls,1) & + & + gf4*gf3*xdia(mgs,ls,2) ) & + & , qrmxd(mgs)) + ENDIF + ENDIF + end do +! +! +! + + if (ndebug .gt. 0 ) write(0,*) 'Collection: graupel collects xxxxx' +! + do mgs = 1,ngscnt + qhacw(mgs) = 0.0 + rarx(mgs,lh) = 0.0 + vhacw(mgs) = 0.0 + vhsoak(mgs) = 0.0 + zhacw(mgs) = 0.0 + + IF ( .false. ) THEN + vtmax = (gz(igs(mgs),jgs,kgs(mgs))*dtpinv) + vtxbar(mgs,lh,1) = Min( vtmax, vtxbar(mgs,lh,1)) + vtxbar(mgs,lh,2) = Min( vtmax, vtxbar(mgs,lh,2)) + vtxbar(mgs,lh,3) = Min( vtmax, vtxbar(mgs,lh,3)) + ENDIF + IF ( ehw(mgs) .gt. 0.0 ) THEN + + IF ( ipconc .ge. 2 ) THEN + + IF ( .false. ) THEN + qhacw(mgs) = (ehw(mgs)*(qx(mgs,lc)-qcwresv(mgs))*cx(mgs,lh)*pi* & + & abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1))* & + & (2.0*xdia(mgs,lh,1)*(xdia(mgs,lh,1) + & + & xdia(mgs,lc,1)*gf73rds) + & + & xdia(mgs,lc,2)*gf83rds))/4. + + ELSE ! using Seifert coefficients + vt = abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1)) + + qhacw(mgs) = 0.25*pi*ehw(mgs)*cx(mgs,lh)*(qx(mgs,lc)-qcwresv(mgs))*vt* & + & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & dab1lh(mgs,lh,lc)*xdia(mgs,lh,3)*xdia(mgs,lc,3) + & + & da1lc(mgs)*xdia(mgs,lc,3)**2 ) + + ENDIF + qhacw(mgs) = Min( qhacw(mgs), 0.5*qx(mgs,lc)*dtpinv ) + + IF ( lzh .gt. 1 ) THEN + tmp = qx(mgs,lh)/cx(mgs,lh) + +!! g1 = (6.0 + alpha(mgs,lh))*(5.0 + alpha(mgs,lh))*(4.0 + alpha(mgs,lh))/ +!! : ((3.0 + alpha(mgs,lh))*(2.0 + alpha(mgs,lh))*(1.0 + alpha(mgs,lh))) +! alp = Max( 1.0, alpha(mgs,lh)+1. ) +! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/ +! : ((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) +! zhacw(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacw(mgs) ) + ENDIF + + ELSE + qhacw(mgs) = & + & min( & + & ((0.25)*pi)*ehw(mgs)*(qx(mgs,lc)-qcwresv(mgs))*cx(mgs,lh) & + & *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1)) & + & *( gf3*xdia(mgs,lh,2) & + & + 2.0*gf2*xdia(mgs,lh,1)*xdia(mgs,lc,1) & + & + gf1*xdia(mgs,lc,2) ) & + & , 0.5*(qx(mgs,lc)-qcwresv(mgs))*dtpinv) +! < , qxmxd(mgs,lc)) +! < , qcmxd(mgs)) + + + IF ( lwsm6 .and. qsacw(mgs) > 0.0 .and. qhacw(mgs) > 0.0) THEN + qaacw = ( qx(mgs,ls)*qsacw(mgs) + qx(mgs,lh)*qhacw(mgs) )/(qx(mgs,ls) + qx(mgs,lh)) +! qaacw = Min( qaacw, 0.5*(qsacw(mgs) + qhacw(mgs) ) ) + qsacw(mgs) = qaacw + qhacw(mgs) = qaacw + ENDIF + + ENDIF + + IF ( lvol(lh) .gt. 1 .or. lhl .gt. 1 ) THEN ! calculate rime density for graupel volume and/or for graupel conversion to hail + + IF ( temg(mgs) .lt. 273.15) THEN + IF ( irimdenopt == 1 ) THEN ! Heymsfield and Pflaum (1985) + vt = ( (1.0-rimdenvwgt)*vtxbar(mgs,lh,1) + rimdenvwgt*vtxbar(mgs,lh,2) ) + + rimdn(mgs,lh) = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & + & *((0.60)*vt ) & + & /(temg(mgs)-273.15))**(rimc2) +! rimdn(mgs,lh) = Min( Max( hdnmn, rimc3, rimdn(mgs,lh) ), rimc4 ) + rimdn(mgs,lh) = Min( Max( rimc3, rimdn(mgs,lh) ), rimc4 ) + +! IF ( igs(mgs) == 30 ) THEN +! write(0,*) 'k,vt: ',kgs(mgs),vt, vtxbar(mgs,lh,1),vtxbar(mgs,lh,2), rhovt(mgs)*axx(mgs,lh)*( (alpha(mgs,lh)+3.)*xdia(mgs,lh,1) )**bxx(mgs,lh) +! write(0,*) 'diam: char, mean, maxmass = ',xdia(mgs,lh,1),xdia(mgs,lh,3),(alpha(mgs,lh)+3.)*xdia(mgs,lh,1) +! write(0,*) 'ax,bx,cd,xdn = ',axx(mgs,lh),bxx(mgs,lh),cdxgs(mgs,lh),xdn(mgs,lh) +! write(0,*) 'vt_char,vt_mean = ',rhovt(mgs)*axx(mgs,lh)*( xdia(mgs,lh,1) )**bxx(mgs,lh),rhovt(mgs)*axx(mgs,lh)*( xdia(mgs,lh,3) )**bxx(mgs,lh) +! write(0,*) 'rimdn,alpha = ',rimdn(mgs,lh),alpha(mgs,lh) +! ENDIF + + ELSEIF ( irimdenopt == 2 ) THEN ! Cober and List (1993) + + tmp = (-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & + & *( (1.0-rimdenvwgt)*vtxbar(mgs,lh,1) + rimdenvwgt*vtxbar(mgs,lh,2) ) & + & /(temg(mgs)-273.15)) + tmp = Min( 5.5/0.6, Max( 0.3/0.6, tmp ) ) ! have to limit range of "R" because quadratic function starts to decrease (unphysically) at higher values + + rimdn(mgs,lh) = 1000.*(0.051 + 0.114*tmp - 0.0055*tmp**2) + + ELSEIF ( irimdenopt == 3 ) THEN ! Macklin + + tmp = (-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & + & *( (1.0-rimdenvwgt)*vtxbar(mgs,lh,1) + rimdenvwgt*vtxbar(mgs,lh,2) ) & + & /(temg(mgs)-273.15)) + ! tmp = Min( 5.5/0.6, Max( 0.3/0.6, tmp ) ) + + rimdn(mgs,lh) = Min(900., Max( 170., 110.*tmp**0.76 ) ) + + ENDIF + ELSE + rimdn(mgs,lh) = 1000. + ENDIF + + IF ( lvol(lh) > 1 ) vhacw(mgs) = rho0(mgs)*qhacw(mgs)/rimdn(mgs,lh) + + ENDIF + + IF ( qx(mgs,lh) .gt. qxmin(lh) .and. ipelec .ge. 1 ) THEN + rarx(mgs,lh) = & + & qhacw(mgs)*1.0e3*rho0(mgs)/((pi/2.0)*xdia(mgs,lh,2)*cx(mgs,lh)) + ENDIF + + ENDIF + end do +! +! + do mgs = 1,ngscnt + qhaci(mgs) = 0.0 + qhaci0(mgs) = 0.0 + IF ( ehi(mgs) .gt. 0.0 ) THEN + IF ( ipconc .ge. 5 ) THEN + + vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,li,1))**2 + & + & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,li,1) ) + + qhaci0(mgs) = 0.25*pi*ehiclsn(mgs)*cx(mgs,lh)*qx(mgs,li)*vt* & + & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & dab1lh(mgs,lh,li)*xdia(mgs,lh,3)*xdia(mgs,li,3) + & + & da1(li)*xdia(mgs,li,3)**2 ) + qhaci(mgs) = Min( ehi(mgs)*qhaci0(mgs), qimxd(mgs) ) + ELSE + qhaci(mgs) = & + & min( & + & ((0.25)*pi)*ehi(mgs)*ehiclsn(mgs)*qx(mgs,li)*cx(mgs,lh) & + & *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,li,1)) & + & *( gf3*xdia(mgs,lh,2) & + & + 2.0*gf2*xdia(mgs,lh,1)*xdia(mgs,li,1) & + & + gf1*xdia(mgs,li,2) ) & + & , qimxd(mgs)) + ENDIF + ENDIF + end do + + + IF ( lis > 1 .and. ipconc >= 5 ) THEN + do mgs = 1,ngscnt + qhacis(mgs) = 0.0 + qhacis0(mgs) = 0.0 + IF ( ehis(mgs) .gt. 0.0 ) THEN + + vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,lis,1))**2 + & + & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,lis,1) ) + + qhacis0(mgs) = 0.25*pi*ehisclsn(mgs)*cx(mgs,lh)*qx(mgs,lis)*vt* & + & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & dab1lh(mgs,lh,lis)*xdia(mgs,lh,3)*xdia(mgs,lis,3) + & + & da1(li)*xdia(mgs,lis,3)**2 ) + qhacis(mgs) = Min( ehis(mgs)*qhacis0(mgs), qxmxd(mgs,lis) ) + ENDIF + end do + ENDIF + +! +! + do mgs = 1,ngscnt + qhacs(mgs) = 0.0 + qhacs0(mgs) = 0.0 + IF ( ehs(mgs) .gt. 0.0 ) THEN + IF ( ipconc .ge. 5 ) THEN + + vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,ls,1))**2 + & + & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,ls,1) ) + + qhacs0(mgs) = 0.25*pi*ehsclsn(mgs)*cx(mgs,lh)*qx(mgs,ls)*vt* & + & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & dab1lh(mgs,lh,ls)*xdia(mgs,lh,3)*xdia(mgs,ls,3) + & + & da1(ls)*xdia(mgs,ls,3)**2 ) + + qhacs(mgs) = Min( ehs(mgs)*qhacs0(mgs), qsmxd(mgs) ) + + ELSE + qhacs(mgs) = & + & min( & + & ((0.25)*pi/gf4)*ehs(mgs)*ehsclsn(mgs)*qx(mgs,ls)*cx(mgs,lh) & + & *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,ls,1)) & + & *( gf6*gf1*xdia(mgs,ls,2) & + & + 2.0*gf5*gf2*xdia(mgs,ls,1)*xdia(mgs,lh,1) & + & + gf4*gf3*xdia(mgs,lh,2) ) & + & , qsmxd(mgs)) + ENDIF + ENDIF + end do +! + do mgs = 1,ngscnt + qhacr(mgs) = 0.0 + qhacrmlr(mgs) = 0.0 + vhacr(mgs) = 0.0 + chacr(mgs) = 0.0 + zhacr(mgs) = 0.0 + IF ( temg(mgs) .gt. tfr ) raindn(mgs,lh) = 1000.0 + + IF ( ehr(mgs) .gt. 0.0 ) THEN + IF ( ipconc .ge. 3 ) THEN + vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,lr,1))**2 + & + & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,lr,1) ) +! qhacr(mgs) = ehr(mgs)*cx(mgs,lh)*vt* +! : qx(mgs,lr)*0.25*pi* +! : (3.02787*xdia(mgs,lr,2) + +! : 3.30669*xdia(mgs,lh,1)*xdia(mgs,lr,1) + +! : 2.*xdia(mgs,lh,2)) + + qhacr(mgs) = 0.25*pi*ehr(mgs)*cx(mgs,lh)*qx(mgs,lr)*vt* & + & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & dab1lh(mgs,lh,lr)*xdia(mgs,lh,3)*xdia(mgs,lr,3) + & + & da1lr(mgs)*xdia(mgs,lr,3)**2 ) +! & da1(lr)*xdia(mgs,lr,3)**2 ) +! IF ( qhacr(mgs) .gt. 0. .or. tmp .gt. 0.0 ) write(0,*) 'qhacr= ',qhacr(mgs),tmp +!! qhacr(mgs) = Min( qhacr(mgs), qrmxd(mgs) ) +!! chacr(mgs) = qhacr(mgs)*cx(mgs,lr)/qx(mgs,lr) +!! chacr(mgs) = min(chacr(mgs),crmxd(mgs)) + + qhacr(mgs) = Min( qhacr(mgs), qxmxd(mgs,lr) ) + + qhacrmlr(mgs) = qhacr(mgs) + + IF ( temg(mgs) > tfr .and. iehr0c == 0 ) THEN + qhacr(mgs) = 0.0 + + IF ( iqhacrmlr == 0 ) THEN + qhacrmlr(mgs) = -qhacw(mgs) + ENDIF + + ELSE +! chacr(mgs) = Min( qhacr(mgs)*rho0(mgs)/xmas(mgs,lr), cxmxd(mgs,lr) ) + +! chacr(mgs) = ehr(mgs)*cx(mgs,lh)*vt* +! : cx(mgs,lr)*0.25*pi* +! : (0.69874*xdia(mgs,lr,2) + +! : 1.24001*xdia(mgs,lh,1)*xdia(mgs,lr,1) + +! : 2.*xdia(mgs,lh,2)) + + chacr(mgs) = 0.25*pi*ehr(mgs)*cx(mgs,lh)*cx(mgs,lr)*vt* & + & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & dab0lh(mgs,lh,lr)*xdia(mgs,lh,3)*xdia(mgs,lr,3) + & + & da0lr(mgs)*xdia(mgs,lr,3)**2 ) + +! IF ( qhacr(mgs) .gt. 0. .or. tmp .gt. 0.0 ) write(0,*) 'chacr= ',chacr(mgs),tmp + +! chacr(mgs) = qhacr(mgs)*cx(mgs,lr)/qx(mgs,lr) + chacr(mgs) = min(chacr(mgs),crmxd(mgs)) + + IF ( lzh .gt. 1 ) THEN + tmp = qx(mgs,lh)/cx(mgs,lh) + +! g1 = (6.0 + alpha(mgs,lh))*(5.0 + alpha(mgs,lh))*(4.0 + alpha(mgs,lh))/ +! : ((3.0 + alpha(mgs,lh))*(2.0 + alpha(mgs,lh))*(1.0 + alpha(mgs,lh))) +! alp = Max( 1.0, alpha(mgs,lh)+1. ) +! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/ +! : ((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) +! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( tmp ) * qhacr(mgs) - tmp**2 * chacr(mgs) ) +! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( tmp ) * qhacr(mgs) ) + ENDIF + ENDIF ! temg > tfr + + ELSE + IF ( lwsm6 .and. ipconc == 0 ) THEN + vt = vt2ave(mgs) + ELSE + vt = vtxbar(mgs,lh,1) + ENDIF + + qhacr(mgs) = & + & min( & + & ((0.25)*pi/gf4)*ehr(mgs)*qx(mgs,lr)*cx(mgs,lh) & + & *abs(vt-vtxbar(mgs,lr,1)) & + & *( gf6*gf1*xdia(mgs,lr,2) & + & + 2.0*gf5*gf2*xdia(mgs,lr,1)*xdia(mgs,lh,1) & + & + gf4*gf3*xdia(mgs,lh,2) ) & + & , qrmxd(mgs)) + + IF ( temg(mgs) > tfr ) THEN + IF ( iqhacrmlr >= 1 ) qhacrmlr(mgs) = qhacr(mgs) + qhacr(mgs) = 0.0 + ENDIF + + ENDIF + IF ( lvol(lh) .gt. 1 .or. lhl .gt. 1 ) THEN ! calculate rime density for graupel volume and/or for graupel conversion to hail + + IF ( temg(mgs) .lt. 273.15) THEN + raindn(mgs,lh) = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lr,3)) & + & *((0.60)*vt) & + & /(temg(mgs)-273.15))**(rimc2) + + raindn(mgs,lh) = Min( Max( rimc3, rimdn(mgs,lh) ), rimc4 ) + ELSE + raindn(mgs,lh) = 1000. + ENDIF + + IF ( lvol(lh) > 1 ) vhacr(mgs) = rho0(mgs)*qhacr(mgs)/raindn(mgs,lh) + ENDIF + ENDIF + end do + +! +! + if (ndebug .gt. 0 ) write(0,*) 'Collection: hail collects xxxxx' +! + + do mgs = 1,ngscnt + qhlacw(mgs) = 0.0 + vhlacw(mgs) = 0.0 + vhlsoak(mgs) = 0.0 + IF ( lhl > 1 .and. .true.) THEN + vtmax = (gz(igs(mgs),jgs,kgs(mgs))*dtpinv) + vtxbar(mgs,lhl,1) = Min( vtmax, vtxbar(mgs,lhl,1)) + vtxbar(mgs,lhl,2) = Min( vtmax, vtxbar(mgs,lhl,2)) + vtxbar(mgs,lhl,3) = Min( vtmax, vtxbar(mgs,lhl,3)) + ENDIF + + IF ( lhl > 0 ) THEN + rarx(mgs,lhl) = 0.0 + ENDIF + + IF ( lhl .gt. 1 .and. ehlw(mgs) .gt. 0.0 ) THEN + + +! IF ( ipconc .ge. 2 ) THEN + + vt = abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,lc,1)) + + qhlacw(mgs) = 0.25*pi*ehlw(mgs)*cx(mgs,lhl)*(qx(mgs,lc)-qcwresv(mgs))*vt* & + & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & dab1lh(mgs,lhl,lc)*xdia(mgs,lhl,3)*xdia(mgs,lc,3) + & + & da1lc(mgs)*xdia(mgs,lc,3)**2 ) + + + qhlacw(mgs) = Min( qhlacw(mgs), 0.5*qx(mgs,lc)*dtpinv ) + + IF ( lvol(lhl) .gt. 1 ) THEN + + IF ( temg(mgs) .lt. 273.15) THEN + IF ( irimdenopt == 1 ) THEN ! Rasmussen and Heymsfeld (1985) + rimdn(mgs,lhl) = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & + & *((0.60)*( (1.0-rimdenvwgt)*vtxbar(mgs,lhl,1) + rimdenvwgt*vtxbar(mgs,lhl,2) )) & + & /(temg(mgs)-273.15))**(rimc2) + rimdn(mgs,lhl) = Min( Max( hldnmn, rimc3, rimdn(mgs,lhl) ), rimc4 ) + + ELSEIF ( irimdenopt == 2 ) THEN ! Cober and List (1993) + tmp = -0.5*(1.e+06)*xdia(mgs,lc,1) & + & *( (1.0-rimdenvwgt)*vtxbar(mgs,lhl,1) + rimdenvwgt*vtxbar(mgs,lhl,2) ) & + & /(temg(mgs)-273.15) + tmp = Min( 5.5/0.6, Max( 0.3/0.6, tmp ) ) + + rimdn(mgs,lhl) = 1000.*(0.051 + 0.114*tmp - 0.005*tmp**2) + + ELSEIF ( irimdenopt == 3 ) THEN ! Macklin + tmp = -0.5*(1.e+06)*xdia(mgs,lc,1) & + & *( (1.0-rimdenvwgt)*vtxbar(mgs,lhl,1) + rimdenvwgt*vtxbar(mgs,lhl,2) ) & + & /(temg(mgs)-273.15) + ! tmp = Min( 5.5/0.6, Max( 0.3/0.6, tmp ) ) + + rimdn(mgs,lhl) = Min(900., Max( 170., 110.*tmp**0.76 ) ) + + ENDIF + ELSE + rimdn(mgs,lhl) = 1000. + ENDIF + + vhlacw(mgs) = rho0(mgs)*qhlacw(mgs)/rimdn(mgs,lhl) + + ENDIF + + + IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. ipelec .ge. 1 ) THEN + rarx(mgs,lhl) = & + & qhlacw(mgs)*1.0e3*rho0(mgs)/((pi/2.0)*xdia(mgs,lhl,2)*cx(mgs,lhl)) + ENDIF + + ENDIF + end do + + qhlaci(:) = 0.0 + qhlaci0(:) = 0.0 + IF ( lhl .gt. 1 ) THEN + do mgs = 1,ngscnt + IF ( ehli(mgs) .gt. 0.0 ) THEN + IF ( ipconc .ge. 5 ) THEN + + vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,li,1))**2 + & + & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,li,1) ) + + qhlaci0(mgs) = 0.25*pi*ehliclsn(mgs)*cx(mgs,lhl)*qx(mgs,li)*vt* & + & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & dab1lh(mgs,lhl,li)*xdia(mgs,lhl,3)*xdia(mgs,li,3) + & + & da1(li)*xdia(mgs,li,3)**2 ) + ! qhlaci(mgs) = Min( qhlaci(mgs), qimxd(mgs) ) + qhlaci(mgs) = Min( ehli(mgs)*qhlaci0(mgs), qimxd(mgs) ) + ENDIF + ENDIF + end do + ENDIF +! + qhlacs(:) = 0.0 + qhlacs0(:) = 0.0 + IF ( lhl .gt. 1 ) THEN + do mgs = 1,ngscnt + IF ( ehls(mgs) .gt. 0.0) THEN + IF ( ipconc .ge. 5 ) THEN + + vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,ls,1))**2 + & + & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,ls,1) ) + + qhlacs0(mgs) = 0.25*pi*ehlsclsn(mgs)*cx(mgs,lhl)*qx(mgs,ls)*vt* & + & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & dab1lh(mgs,lhl,ls)*xdia(mgs,lhl,3)*xdia(mgs,ls,3) + & + & da1(ls)*xdia(mgs,ls,3)**2 ) + + qhlacs(mgs) = Min( ehls(mgs)*qhlacs0(mgs), qsmxd(mgs) ) + ENDIF + ENDIF + end do + ENDIF + + + do mgs = 1,ngscnt + qhlacr(mgs) = 0.0 + qhlacrmlr(mgs) = 0.0 + chlacr(mgs) = 0.0 + vhlacr(mgs) = 0.0 + IF ( lhl .gt. 1 .and. temg(mgs) .gt. tfr ) raindn(mgs,lhl) = 1000.0 + + IF ( lhl .gt. 1 .and. ehlr(mgs) .gt. 0.0 ) THEN + IF ( ipconc .ge. 3 ) THEN + vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,lr,1))**2 + & + & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,lr,1) ) + + qhlacr(mgs) = 0.25*pi*ehlr(mgs)*cx(mgs,lhl)*qx(mgs,lr)*vt* & + & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & dab1lh(mgs,lhl,lr)*xdia(mgs,lhl,3)*xdia(mgs,lr,3) + & + & da1lr(mgs)*xdia(mgs,lr,3)**2 ) +! & da1(lr)*xdia(mgs,lr,3)**2 ) +! IF ( qhacr(mgs) .gt. 0. .or. tmp .gt. 0.0 ) write(0,*) 'qhacr= ',qhacr(mgs),tmp +!! qhacr(mgs) = Min( qhacr(mgs), qrmxd(mgs) ) +!! chacr(mgs) = qhacr(mgs)*cx(mgs,lr)/qx(mgs,lr) +!! chacr(mgs) = min(chacr(mgs),crmxd(mgs)) + + qhlacr(mgs) = Min( qhlacr(mgs), qxmxd(mgs,lr) ) + + + IF ( iqhlacrmlr >= 1 ) qhlacrmlr(mgs) = qhlacr(mgs) + + IF ( temg(mgs) > tfr .and. iehlr0c == 0) THEN + qhlacr(mgs) = 0.0 + IF ( iqhlacrmlr == 0 ) THEN + qhlacrmlr(mgs) = -qhlacw(mgs) + ENDIF + ELSE + chlacr(mgs) = 0.25*pi*ehlr(mgs)*cx(mgs,lhl)*cx(mgs,lr)*vt* & + & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & dab0lh(mgs,lhl,lr)*xdia(mgs,lhl,3)*xdia(mgs,lr,3) + & + & da0lr(mgs)*xdia(mgs,lr,3)**2 ) + + chlacr(mgs) = min(chlacr(mgs),crmxd(mgs)) + + IF ( lvol(lhl) .gt. 1 ) THEN + vhlacr(mgs) = rho0(mgs)*qhlacr(mgs)/raindn(mgs,lhl) + ENDIF + ENDIF + ENDIF + ENDIF + end do + + + +! +! +! +! +! if (ndebug .gt. 0 ) write(0,*) 'Collection: Cloud collects xxxxx' + + if (ndebug .gt. 0 ) write(0,*) 'Collection: cloud ice collects xxxx2' +! + do mgs = 1,ngscnt + qiacw(mgs) = 0.0 + IF ( eiw(mgs) .gt. 0.0 ) THEN + + vt = Sqrt((vtxbar(mgs,li,1)-vtxbar(mgs,lc,1))**2 + & + & 0.04*vtxbar(mgs,li,1)*vtxbar(mgs,lc,1) ) + + qiacw(mgs) = 0.25*pi*eiw(mgs)*cx(mgs,li)*qx(mgs,lc)*vt* & + & ( da0(li)*xdia(mgs,li,3)**2 + & + & dab1(li,lc)*xdia(mgs,li,3)*xdia(mgs,lc,3) + & + & da1lc(mgs)*xdia(mgs,lc,3)**2 ) + + qiacw(mgs) = Min( qiacw(mgs), qxmxd(mgs,lc) ) + ENDIF + end do + + +! +! + if (ndebug .gt. 0 ) write(0,*) 'Collection: cloud ice collects xxxx8' +! + do mgs = 1,ngscnt + qiacr(mgs) = 0.0 + qiacrf(mgs) = 0.0 + qiacrs(mgs) = 0.0 + ciacrs(mgs) = 0.0 + ciacr(mgs) = 0.0 + ciacrf(mgs) = 0.0 + viacrf(mgs) = 0.0 + csplinter(mgs) = 0.0 + qsplinter(mgs) = 0.0 + csplinter2(mgs) = 0.0 + qsplinter2(mgs) = 0.0 + IF ( iacr .ge. 1 .and. eri(mgs) .gt. 0.0 & + & .and. temg(mgs) .le. 270.15 ) THEN + IF ( ipconc .ge. 3 ) THEN + ni = 0.0 + IF ( xdia(mgs,li,1) .ge. 10.e-6 ) THEN + ni = ni + cx(mgs,li)*Exp(- (40.e-6/xdia(mgs,li,1))**3 ) + ENDIF + IF ( imurain == 1 ) THEN ! gamma of diameter + IF ( iacrsize /= 4 ) THEN + IF ( iacrsize .eq. 1 ) THEN + ratio = 500.e-6/xdia(mgs,lr,1) + ELSEIF ( iacrsize .eq. 2 ) THEN + ratio = 300.e-6/xdia(mgs,lr,1) + ELSEIF ( iacrsize .eq. 3 ) THEN + ratio = 40.e-6/xdia(mgs,lr,1) + ELSEIF ( iacrsize .eq. 5 ) THEN + ratio = 150.e-6/xdia(mgs,lr,1) + ENDIF + i = Min(nqiacrratio,Int(ratio*dqiacrratioinv)) + j = Int(Max(0.0,Min(15.,alpha(mgs,lr)))*dqiacralphainv) +! j = Int(Max(minalphalu,Min(maxalphalu,alpha(mgs,lr)))*dqiacralphainv) + delx = ratio - float(i)*dqiacrratio + dely = alpha(mgs,lr) - float(j)*dqiacralpha + ip1 = Min( i+1, nqiacrratio ) + jp1 = Min( j+1, nqiacralpha ) + + ! interpolate along x, i.e., ratio + tmp1 = ciacrratio(i,j) + delx*dqiacrratioinv*(ciacrratio(ip1,j) - ciacrratio(i,j)) + tmp2 = ciacrratio(i,jp1) + delx*dqiacrratioinv*(ciacrratio(ip1,jp1) - ciacrratio(i,jp1)) + + ! interpolate along alpha + + nr = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*cx(mgs,lr) + + ! interpolate along x, i.e., ratio; + tmp1 = qiacrratio(i,j) + delx*dqiacrratioinv*(qiacrratio(ip1,j) - qiacrratio(i,j)) + tmp2 = qiacrratio(i,jp1) + delx*dqiacrratioinv*(qiacrratio(ip1,jp1) - qiacrratio(i,jp1)) + + ! interpolate along alpha; + + qr = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*qx(mgs,lr) + + ELSE ! iacrsize == 4 : use all + nr = cx(mgs,lr) + qr = qx(mgs,lr) + ENDIF + + vt = Sqrt((vtxbar(mgs,lr,1)-vtxbar(mgs,li,1))**2 + & + & 0.04*vtxbar(mgs,lr,1)*vtxbar(mgs,li,1) ) + + qiacr(mgs) = 0.25*pi*eri(mgs)*ni*qr*vt* & + & ( da0(li)*xdia(mgs,li,3)**2 + & + & dab1lh(mgs,li,lr)*xdia(mgs,lh,3)*xdia(mgs,li,3) + & + & da1(lr)*xdia(mgs,lr,3)**2 ) + + qiacr(mgs) = Min( qrmxd(mgs), qiacr(mgs) ) + + + ciacr(mgs) = 0.25*pi*eri(mgs)*ni*nr*vt* & + & ( da0(li)*xdia(mgs,li,3)**2 + & + & dab0lh(mgs,li,lr)*xdia(mgs,lr,3)*xdia(mgs,li,3) + & + & da0(lr)*xdia(mgs,lr,3)**2 ) + + ciacr(mgs) = Min( crmxd(mgs), ciacr(mgs) ) + +! write(iunit,*) 'qiacr: ',cx(mgs,lr),nr,qx(mgs,lr),qr,qiacr(mgs),ciacr(mgs) +! write(iunit,*) 'xdia r li = ',xdia(mgs,lr,3),xdia(mgs,li,3),xdia(mgs,lr,1),xdia(mgs,li,1) +! write(iunit,*) 'i,j,ratio = ',i,j,ciacrratio(i,j),qiacrratio(i,j) +! write(iunit,*) 'ni,ci = ',ni,cx(mgs,li),qx(mgs,li) + + ELSEIF ( imurain == 3 ) THEN ! gamma of volume +! Set nr to the number of drops greater than 40 microns. + arg = 1000.*xdia(mgs,lr,3) +! nr = cx(mgs,lr)*gaml02( arg ) +! IF ( iacr .eq. 1 ) THEN + IF ( ipconc .ge. 3 ) THEN + IF ( iacrsize .eq. 1 ) THEN + nr = cx(mgs,lr)*gaml02d500( arg ) ! number greater than 500 microns in diameter + ELSEIF ( iacrsize .eq. 2 .or. iacrsize .eq. 5 ) THEN + nr = cx(mgs,lr)*gaml02d300( arg ) ! number greater than 300 microns in diameter + ELSEIF ( iacrsize .eq. 3 ) THEN + nr = cx(mgs,lr)*gaml02( arg ) ! number greater than 40 microns in diameter + ELSEIF ( iacrsize .eq. 4 ) THEN + nr = cx(mgs,lr) ! all raindrops + ENDIF + ELSE + nr = cx(mgs,lr)*gaml02( arg ) + ENDIF +! ELSEIF ( iacr .eq. 2 ) THEN +! nr = cx(mgs,lr)*gaml02d300( arg ) ! number greater than 300 microns in diameter +! ENDIF + IF ( ni .gt. 0.0 .and. nr .gt. 0.0 ) THEN + d0 = xdia(mgs,lr,3) + qiacr(mgs) = xdn(mgs,lr)*rhoinv(mgs)* & + & (0.217239*(0.522295*(d0**5) + & + & 49711.81*(d0**6) - & + & 1.673016e7*(d0**7)+ & + & 2.404471e9*(d0**8) - & + & 1.22872e11*(d0**9))*ni*nr) + qiacr(mgs) = Min( qrmxd(mgs), qiacr(mgs) ) + ciacr(mgs) = & + & (0.217239*(0.2301947*(d0**2) + & + & 15823.76*(d0**3) - & + & 4.167685e6*(d0**4) + & + & 4.920215e8*(d0**5) - & + & 2.133344e10*(d0**6))*ni*nr) + ciacr(mgs) = Min( crmxd(mgs), ciacr(mgs) ) +! ciacr(mgs) = qiacr(mgs)*cx(mgs,lr)/qx(mgs,lr) + ENDIF + ENDIF + IF ( iacr .eq. 1 .or. iacr .eq. 3 ) THEN + ciacrf(mgs) = Min(ciacr(mgs), qiacr(mgs)/(1.0*vr1mm*1000.0)*rho0(mgs) ) ! *rzxh(mgs) + ELSEIF ( iacr .eq. 2 ) THEN + ciacrf(mgs) = ciacr(mgs) ! *rzxh(mgs) + ELSEIF ( iacr .eq. 4 ) THEN + ciacrf(mgs) = Min(ciacr(mgs), qiacr(mgs)/(1.0*vfrz*1000.0)*rho0(mgs) ) ! *rzxh(mgs) + ELSEIF ( iacr .eq. 5 ) THEN + ciacrf(mgs) = ciacr(mgs)*rzxh(mgs) + ENDIF +! crfrzf(mgs) = Min(crfrz(mgs), qrfrz(mgs)/(bfnu*27.0*vr1mm*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs) + ENDIF + + + ELSE ! single-moment rain + qiacr(mgs) = & + & min( & + & ((0.25/gf4)*pi)*eri(mgs)*cx(mgs,li)*qx(mgs,lr) & + & *abs(vtxbar(mgs,lr,1)-vtxbar(mgs,li,1)) & + & *( gf6*gf1*xdia(mgs,lr,2) & + & + 2.0*gf5*gf2*xdia(mgs,lr,1)*xdia(mgs,li,1) & + & + gf4*gf3*xdia(mgs,li,2) ) & + & , qrmxd(mgs)) + ENDIF +! if ( temg(mgs) .gt. 268.15 ) then +! qiacr(mgs) = 0.0 +! ciacr(mgs) = 0.0 +! end if + + IF ( ipconc .ge. 1 ) THEN + IF ( nsplinter .ge. 1000 ) THEN + ! Lawson et al. 2015 JAS + ! ave. diam of freezing drops in microns + IF ( qiacr(mgs)*dtp > qxmin(lh) .and. ciacr(mgs) > 1.e-3 ) THEN + tmpdiam = 1.e6*( 6.*qiacr(mgs)/(1000.*pi*ciacr(mgs) ) )**(1./3.) ! avg. diameter of newly frozen drops in microns + csplinter(mgs) = lawson_splinter_fac*tmpdiam**4*ciacr(mgs) + ENDIF + ELSEIF ( nsplinter .ge. 0 ) THEN + csplinter(mgs) = nsplinter*ciacr(mgs) + ELSE + csplinter(mgs) = -nsplinter*ciacrf(mgs) + ENDIF + qsplinter(mgs) = Min(0.1*qiacr(mgs), csplinter(mgs)*splintermass/rho0(mgs) ) ! makes splinters smaller if too much mass is taken from graupel + ENDIF + + frach = 1.0 + IF ( ibiggsnow == 2 .or. ibiggsnow == 3 ) THEN + IF ( ciacr(mgs) > qxmin(lh) ) THEN + xvfrz = rho0(mgs)*qiacr(mgs)/(ciacr(mgs)*900.) ! mean volume of frozen drops; 900. for frozen drop density + frach = 0.5 *(1. + Tanh(0.2e12 *( xvfrz - 1.15*xvbiggsnow))) + + qiacrs(mgs) = (1.-frach)*qiacr(mgs) + ciacrs(mgs) = (1.-frach)*ciacr(mgs) ! *rzxh(mgs) + + ENDIF + ENDIF + + qiacrf(mgs) = frach*qiacr(mgs) + ciacrf(mgs) = frach*ciacrf(mgs) + + IF ( lvol(lh) > 1 ) THEN + viacrf(mgs) = rho0(mgs)*qiacrf(mgs)/rhofrz + ENDIF + + end do +! +! +! +! + +! snow aggregation here + if ( ipconc .ge. 4 ) then ! + do mgs = 1,ngscnt + csacs(mgs) = 0.0 + IF ( qx(mgs,ls) > qxmin(ls) .and. ess(mgs) .gt. 0.0 ) THEN ! .and. xv(mgs,ls) < 0.25*xvmx(ls)*Max(1.,100./Min(100.,xdn(mgs,ls))) ) THEN + + IF ( iessec0flag == 0 ) THEN + ec0(mgs) = 1.0 + ELSE + tmp = xv(mgs,ls)/(xvmx(ls)*Max(1.,100./Min(100.,xdn(mgs,ls)))) ! fraction of max snow mass + IF ( tmp .lt. essfrac1 ) THEN + ec0(mgs) = 1.0 + ELSEIF ( tmp .gt. essfrac2 ) THEN + ec0(mgs) = 0.0 + ELSE + ec0(mgs) = (essfrac2 - tmp)/(essfrac2 - essfrac1) + ENDIF + ENDIF + + csacs(mgs) = ec0(mgs)*rvt*aa2*ess(mgs)*cx(mgs,ls)**2*Min( xv(mgs,ls), 4.*pii/3.*essrmax**3 ) ! *Min(1.,xdn(mgs,ls)/100. ) ! Min func tries to recalibrate for low diagnosed density +! csacs(mgs) = rvt*aa2*ess(mgs)*cx(mgs,ls)**2*Min( xv(mgs,ls), 4.*pii/3.*0.02**3 ) ! *Min(1.,xdn(mgs,ls)/100. ) ! Min func tries to recalibrate for low diagnosed density + csacs(mgs) = Min(csacs(mgs),csmxd(mgs)) + ENDIF + end do + end if +! +! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 11' + if ( ipconc .ge. 2 .or. ipelec .ge. 9 ) then + do mgs = 1,ngscnt + ciacw(mgs) = 0.0 + IF ( eiw(mgs) .gt. 0.0 ) THEN + ciacw(mgs) = qiacw(mgs)*rho0(mgs)/xmas(mgs,lc) + ciacw(mgs) = min(ciacw(mgs),ccmxd(mgs)) + ENDIF + end do + + end if + + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 18' + if ( ipconc .ge. 2 .or. ipelec .ge. 1 ) then + do mgs = 1,ngscnt + cracw(mgs) = 0.0 + cracr(mgs) = 0.0 + ec0(mgs) = 1.e9 + IF ( qx(mgs,lc) .gt. qxmin(lc) .and. qx(mgs,lr) .gt. qxmin(lr) & + & .and. qracw(mgs) .gt. 0.0 ) THEN + + IF ( ipconc .lt. 3 ) THEN + IF ( erw(mgs) .gt. 0.0 ) THEN + cracw(mgs) = & + & ((0.25)*pi)*erw(mgs)*(cx(mgs,lc) - ccwresv(mgs))*cx(mgs,lr) & + & *abs(vtxbar(mgs,lr,1)-vtxbar(mgs,lc,1)) & + & *( gf1*xdia(mgs,lc,2) & + & + 2.0*gf2*xdia(mgs,lc,1)*xdia(mgs,lr,1) & + & + gf3*xdia(mgs,lr,2) ) + ENDIF + ELSE ! IF ( ipconc .ge. 3 .and. + IF ( dmrauto <= 0 .or. rho0(mgs)*qx(mgs,lr) > 1.2*xl2p(mgs) ) THEN !{ + IF ( 0.5*xdia(mgs,lr,3) .gt. rh(mgs) ) THEN ! { .or. cx(mgs,lr) .gt. nh(mgs) +! IF ( qx(mgs,lc) .gt. qxmin(lc) .and. qx(mgs,lr) .gt. qxmin(lr) ) THEN + IF ( 0.5*xdia(mgs,lr,3) .gt. rwradmn ) THEN ! r > 50.e-6 +! DM0CCC=A2*XNC*XNR*(XVC+XVR) ! (A11) +! NOTE: murain drops out, so same result for imurain = 1 and 3 + cracw(mgs) = aa2*cx(mgs,lr)*(cx(mgs,lc) - ccwresv(mgs))*(xv(mgs,lc) + xv(mgs,lr)) + ELSE + IF ( imurain == 3 ) THEN +! DM0CCC=A1*XNC*XNR*(((CNU+2.)/(CNU+1.))*XVC**2+((RNU+2.)/(RNU+1.))*XVR**2) ! (A13) + cracw(mgs) = aa1*cx(mgs,lr)*(cx(mgs,lc) - ccwresv(mgs))* & + & ((alpha(mgs,lc) + 2.)*xv(mgs,lc)**2/(alpha(mgs,lc) + 1.) + & + & (alpha(mgs,lr) + 2.)*xv(mgs,lr)**2/(alpha(mgs,lr) + 1.)) + ELSE ! imurain == 1 USE CP00 for rain DSD in diameter + cracw(mgs) = aa1*cx(mgs,lr)*(cx(mgs,lc) - ccwresv(mgs))* & + & ((alpha(mgs,lc) + 2.)*xv(mgs,lc)**2/(alpha(mgs,lc) + 1.) + & + & (alpha(mgs,lr) + 6.)*(alpha(mgs,lr) + 5.)*(alpha(mgs,lr) + 4.)*xv(mgs,lr)**2/ & + & ((alpha(mgs,lr) + 3.)*(alpha(mgs,lr) + 2.)*(alpha(mgs,lr) + 1.)) ) + ENDIF ! imurain + ENDIF + ENDIF ! } rh + ENDIF ! } dmrauto + ENDIF ! ipconc + ENDIF ! qc > qcmin & qr > qrmin + +! Rain self collection (cracr) and break-up (factor of ec0) +! +! + ec0(mgs) = 2.e9 + IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN + rwrad = 0.5*xdia(mgs,lr,3) + IF ( xdia(mgs,lr,3) .gt. 2.0e-3 .or. icracr <= 0 ) THEN + ec0(mgs) = 0.0 + cracr(mgs) = 0.0 + ELSE + IF ( dmrauto <= 0 .or. rho0(mgs)*qx(mgs,lr) > 1.2*xl2p(mgs) ) THEN + IF ( xdia(mgs,lr,3) .lt. 6.1e-4 ) THEN + ec0(mgs) = 1.0 + ELSE + ec0(mgs) = Exp(-50.0*(50.0*(xdia(mgs,lr,3) - 6.0e-4))) + ENDIF + + + IF ( rwrad .ge. 50.e-6 ) THEN + cracr(mgs) = ec0(mgs)*aa2*cx(mgs,lr)**2*xv(mgs,lr) + ELSE + IF ( imurain == 3 ) THEN + cracr(mgs) = ec0(mgs)*aa1*(cx(mgs,lr)*xv(mgs,lr))**2* & + & (alpha(mgs,lr) + 2.)/(alpha(mgs,lr) + 1.) + ELSE ! imurain == 1 + cracr(mgs) = ec0(mgs)*aa1*(cx(mgs,lr)*xv(mgs,lr))**2* & + & (alpha(mgs,lr) + 6.)*(alpha(mgs,lr) + 5.)*(alpha(mgs,lr) + 4.)/ & + & ((alpha(mgs,lr) + 3.)*(alpha(mgs,lr) + 2.)*(alpha(mgs,lr) + 1.)) + + ENDIF + ENDIF +! cracr(mgs) = Min(cracr(mgs),crmxd(mgs)) + ENDIF + ENDIF + ENDIF + +! cracw(mgs) = min(cracw(mgs),cxmxd(mgs,lc)) + end do + end if + +! +! +! +! Graupel +! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22ii' + chacw(:) = 0.0 + if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then + do mgs = 1,ngscnt + + IF ( ipconc .ge. 5 ) THEN + IF ( qhacw(mgs) .gt. 0.0 .and. xmas(mgs,lc) .gt. 0.0 ) THEN + +! This is the explict version of chacw, which turns out to be very close to the +! approximation that the droplet size does not change, to within a few percent. +! This may _not_ be the case for cnu other than zero! +! chacw(mgs) = (ehw(mgs)*cx(mgs,lc)*cx(mgs,lh)*(pi/4.)* +! : abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1))* +! : (2.0*xdia(mgs,lh,1)*(xdia(mgs,lh,1) + +! : xdia(mgs,lc,1)*gf43rds) + +! : xdia(mgs,lc,2)*gf53rds)) + +! chacw(mgs) = Min( chacw(mgs), 0.6*cx(mgs,lc)*dtpinv ) + +! chacw(mgs) = qhacw(mgs)*rho0(mgs)/xmas(mgs,lc) + chacw(mgs) = qhacw(mgs)*rho0(mgs)/xmascw(mgs) +! chacw(mgs) = min(chacw(mgs),cxmxd(mgs,lc)) + chacw(mgs) = Min( chacw(mgs), 0.5*(cx(mgs,lc) - ccwresv(mgs))*dtpinv ) + ELSE + qhacw(mgs) = 0.0 + ENDIF + ELSE + ! single-moment + chacw(mgs) = & + & ((0.25)*pi)*ehw(mgs)*cx(mgs,lc)*cx(mgs,lh) & + & *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1)) & + & *( gf1*xdia(mgs,lc,2) & + & + 2.0*gf2*xdia(mgs,lc,1)*xdia(mgs,lh,1) & + & + gf3*xdia(mgs,lh,2) ) + chacw(mgs) = min(chacw(mgs),0.5*cx(mgs,lc)*dtpinv) +! chacw(mgs) = min(chacw(mgs),cxmxd(mgs,lc)) +! chacw(mgs) = min(chacw(mgs),ccmxd(mgs)) + ENDIF + end do + end if +! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22kk' + chaci(:) = 0.0 + if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then + do mgs = 1,ngscnt + IF ( ehi(mgs) .gt. 0.0 .or. ( ehiclsn(mgs) > 0.0 .and. ipelec > 0 )) THEN + IF ( ipconc .ge. 5 ) THEN + + vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,li,1))**2 + & + & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,li,1) ) + + chaci0(mgs) = 0.25*pi*ehiclsn(mgs)*cx(mgs,lh)*cx(mgs,li)*vt* & + & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & dab0lh(mgs,lh,li)*xdia(mgs,lh,3)*xdia(mgs,li,3) + & + & da0(li)*xdia(mgs,li,3)**2 ) + + ELSE + chaci0(mgs) = & + & ((0.25)*pi)*ehiclsn(mgs)*cx(mgs,li)*cx(mgs,lh) & + & *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,li,1)) & + & *( gf1*xdia(mgs,li,2) & + & + 2.0*gf2*xdia(mgs,li,1)*xdia(mgs,lh,1) & + & + gf3*xdia(mgs,lh,2) ) + ENDIF + + chaci(mgs) = min(ehi(mgs)*chaci0(mgs),cimxd(mgs)) + ENDIF + end do + end if + + + chacis(:) = 0.0 + if ( lis > 1 .and. ipconc .ge. 5 .or. ipelec .ge. 1 ) then + do mgs = 1,ngscnt + IF ( ehis(mgs) .gt. 0.0 .or. ( ehisclsn(mgs) > 0.0 .and. ipelec > 0 )) THEN + + vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,lis,1))**2 + & + & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,lis,1) ) + + chacis0(mgs) = 0.25*pi*ehisclsn(mgs)*cx(mgs,lh)*cx(mgs,lis)*vt* & + & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & dab0lh(mgs,lh,lis)*xdia(mgs,lh,3)*xdia(mgs,lis,3) + & + & da0(lis)*xdia(mgs,lis,3)**2 ) + + + chacis(mgs) = min(ehis(mgs)*chacis0(mgs),cxmxd(mgs,lis)) + ENDIF + end do + end if +! +! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22nn' + chacs(:) = 0.0 + if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then + do mgs = 1,ngscnt + IF ( ehs(mgs) .gt. 0 ) THEN + IF ( ipconc .ge. 5 .or. ( ehsclsn(mgs) > 0.0 .and. ipelec > 0 ) ) THEN + + vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,ls,1))**2 + & + & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,ls,1) ) + + chacs0(mgs) = 0.25*pi*ehsclsn(mgs)*cx(mgs,lh)*cx(mgs,ls)*vt* & + & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & dab0lh(mgs,lh,ls)*xdia(mgs,lh,3)*xdia(mgs,ls,3) + & + & da0(ls)*xdia(mgs,ls,3)**2 ) + + ELSE + chacs0(mgs) = & + & ((0.25)*pi)*ehsclsn(mgs)*cx(mgs,ls)*cx(mgs,lh) & + & *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,ls,1)) & + & *( gf3*gf1*xdia(mgs,ls,2) & + & + 2.0*gf2*gf2*xdia(mgs,ls,1)*xdia(mgs,lh,1) & + & + gf1*gf3*xdia(mgs,lh,2) ) + ENDIF + chacs(mgs) = min(ehs(mgs)*chacs0(mgs),csmxd(mgs)) + ENDIF + end do + end if + + +! +! +! Hail +! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22ii' + chlacw(:) = 0.0 + if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then + do mgs = 1,ngscnt + + IF ( lhl .gt. 1 .and. ipconc .ge. 5 ) THEN + IF ( qhlacw(mgs) .gt. 0.0 .and. xmas(mgs,lc) .gt. 0.0 ) THEN + +! This is the explict version of chacw, which turns out to be very close to the +! approximation that the droplet size does not change, to within a few percent. +! This may _not_ be the case for cnu other than zero! +! chlacw(mgs) = (ehlw(mgs)*cx(mgs,lc)*cx(mgs,lhl)*(pi/4.)* +! : abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,lc,1))* +! : (2.0*xdia(mgs,lhl,1)*(xdia(mgs,lhl,1) + +! : xdia(mgs,lc,1)*gf43rds) + +! : xdia(mgs,lc,2)*gf53rds)) + +! chlacw(mgs) = Min( chlacw(mgs), 0.6*cx(mgs,lc)*dtpinv ) + +! chlacw(mgs) = qhlacw(mgs)*rho0(mgs)/xmas(mgs,lc) + chlacw(mgs) = qhlacw(mgs)*rho0(mgs)/xmascw(mgs) +! chlacw(mgs) = min(chlacw(mgs),cxmxd(mgs,lc)) + chlacw(mgs) = Min( chlacw(mgs), 0.5*cx(mgs,lc)*dtpinv ) + ELSE + qhlacw(mgs) = 0.0 + ENDIF +! ELSE +! chlacw(mgs) = +! > ((0.25)*pi)*ehlw(mgs)*cx(mgs,lc)*cx(mgs,lhl) +! > *abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,lc,1)) +! > *( gf1*xdia(mgs,lc,2) +! > + 2.0*gf2*xdia(mgs,lc,1)*xdia(mgs,lhl,1) +! > + gf3*xdia(mgs,lhl,2) ) +! chlacw(mgs) = min(chlacw(mgs),0.5*cx(mgs,lc)*dtpinv) +! chlacw(mgs) = min(chlacw(mgs),cxmxd(mgs,lc)) +! chlacw(mgs) = min(chlacw(mgs),ccmxd(mgs)) + ENDIF + end do + end if +! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22kk' + chlaci(:) = 0.0 + chlaci0(:) = 0.0 + if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then + do mgs = 1,ngscnt + IF ( lhl .gt. 1 .and. ( ehli(mgs) .gt. 0.0 .or. (ipelec > 0 .and. ehliclsn(mgs) > 0.0) ) ) THEN + IF ( ipconc .ge. 5 ) THEN + + vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,li,1))**2 + & + & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,li,1) ) + + chlaci0(mgs) = 0.25*pi*ehliclsn(mgs)*cx(mgs,lhl)*cx(mgs,li)*vt* & + & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & dab0(lhl,li)*xdia(mgs,lhl,3)*xdia(mgs,li,3) + & + & da0(li)*xdia(mgs,li,3)**2 ) + +! ELSE +! chlaci(mgs) = +! > ((0.25)*pi)*ehli(mgs)*cx(mgs,li)*cx(mgs,lhl) +! > *abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,li,1)) +! > *( gf1*xdia(mgs,li,2) +! > + 2.0*gf2*xdia(mgs,li,1)*xdia(mgs,lhl,1) +! > + gf3*xdia(mgs,lhl,2) ) + ENDIF + + chlaci(mgs) = min(ehli(mgs)*chlaci0(mgs),cimxd(mgs)) + ENDIF + end do + end if + + + IF ( lis > 1 .and. ipconc .ge. 5) THEN + + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22kk' + chlacis(:) = 0.0 + chlacis0(:) = 0.0 + do mgs = 1,ngscnt + IF ( lhl .gt. 1 .and. ( ehlis(mgs) .gt. 0.0 .or. (ipelec > 0 .and. ehlisclsn(mgs) > 0.0) ) ) THEN + + vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,lis,1))**2 + & + & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,lis,1) ) + + chlacis0(mgs) = 0.25*pi*ehlisclsn(mgs)*cx(mgs,lhl)*cx(mgs,lis)*vt* & + & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & dab0(lhl,lis)*xdia(mgs,lhl,3)*xdia(mgs,lis,3) + & + & da0(lis)*xdia(mgs,lis,3)**2 ) + + + chlacis(mgs) = min(ehlis(mgs)*chlacis0(mgs),cxmxd(mgs,lis)) + ENDIF + end do + ENDIF + +! +! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22jj' + chlacs(:) = 0.0 + chlacs0(:) = 0.0 + if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then + do mgs = 1,ngscnt + IF ( lhl .gt. 1 .and. ( ehls(mgs) .gt. 0.0 .or. (ipelec > 0 .and. ehlsclsn(mgs) > 0.0) ) ) THEN + IF ( ipconc .ge. 5 ) THEN + + vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,ls,1))**2 + & + & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,ls,1) ) + + chlacs0(mgs) = 0.25*pi*ehlsclsn(mgs)*cx(mgs,lhl)*cx(mgs,ls)*vt* & + & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & dab0(lhl,ls)*xdia(mgs,lhl,3)*xdia(mgs,ls,3) + & + & da0(ls)*xdia(mgs,ls,3)**2 ) + +! ELSE +! chlacs(mgs) = +! > ((0.25)*pi)*ehls(mgs)*cx(mgs,ls)*cx(mgs,lhl) +! > *abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,ls,1)) +! > *( gf3*gf1*xdia(mgs,ls,2) +! > + 2.0*gf2*gf2*xdia(mgs,ls,1)*xdia(mgs,lhl,1) +! > + gf1*gf3*xdia(mgs,lhl,2) ) + ENDIF + chlacs(mgs) = min(ehls(mgs)*chlacs0(mgs),csmxd(mgs)) + ENDIF + end do + end if + +! +! Ziegler (1985) autoconversion +! +! + IF ( ipconc .ge. 2 .and. ircnw /= -1) THEN ! DTD: added flag for autoconversion. If -1, turns off autoconversion + if (ndebug .gt. 0 ) write(0,*) 'conc 26a' + + DO mgs = 1,ngscnt + zrcnw(mgs) = 0.0 + qrcnw(mgs) = 0.0 + crcnw(mgs) = 0.0 + cautn(mgs) = 0.0 + ENDDO + + IF ( dmrauto >= -1 ) THEN !{ + DO mgs = 1,ngscnt +! qracw(mgs) = 0.0 +! cracw(mgs) = 0.0 + IF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. 1000. .and. temg(mgs) .gt. tfrh+4.) THEN + !( .and. w(igs(mgs),jgs,kgs(mgs)) > 5.0) THEN ! DTD: added w threshold for testing + volb = xv(mgs,lc)*(1./(1.+alpha(mgs,lc)))**(1./2.) + cautn(mgs) = Min(ccmxd(mgs), & + & ((alpha(mgs,lc)+2.)/(alpha(mgs,lc)+1.))*aa1*cx(mgs,lc)**2*xv(mgs,lc)**2) + cautn(mgs) = Max( 0.0d0, cautn(mgs) ) + IF ( rb(mgs) .le. 7.51d-6 .or. dmrauto == -1) THEN + t2s = 1.d30 +! cautn(mgs) = 0.0 + ELSE +! XL2P=2.7E-2*XNC*XVC*((1.E12*RB**3*RC)-0.4) + +! T2S=3.72E-3/(((1.E4*RB)-7.5)*XNC*XVC) +! t2s = 3.72E-3/(((1.e6*rb)-7.5)*cx(mgs,lc)*xv(mgs,lc)) +! t2s = 3.72/(((1.e6*rb(mgs))-7.5)*rho0(mgs)*qx(mgs,lc)) + t2s = 3.72/(1.e6*(rb(mgs)-7.500d-6)*rho0(mgs)*qx(mgs,lc)) + + qrcnw(mgs) = Max( 0.0d0, xl2p(mgs)/(t2s*rho0(mgs)) ) + crcnw(mgs) = Max( 0.0d0, Min(3.5e9*xl2p(mgs)/t2s,0.5*cautn(mgs)) ) + + IF ( dmrauto == 0 ) THEN + IF ( qx(mgs,lr)*rho0(mgs) > 1.2*xl2p(mgs) .and. cx(mgs,lr) > cxmin ) THEN ! Cohard and Pinty (2000a) switch over from (18) to (19) + crcnw(mgs) = cx(mgs,lr)/qx(mgs,lr)*qrcnw(mgs) + ELSEIF ( ( dmropt == 1 .or. dmropt == 3 ) .and. qx(mgs,lr) > qxmin(lr) ) THEN + tmp = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) + crcnw(mgs) = Min(tmp,crcnw(mgs) ) + ELSEIF ( ( dmropt == 4 ) .and. qx(mgs,lr) > qxmin(lr) ) THEN + tmp = crcnw(mgs) + tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) + ! try mass-weighted average of old and new Dmr using converted qc mass + crcnw(mgs) = (tmp*qrcnw(mgs)+tmp2*qx(mgs,lr))/(qrcnw(mgs)+qx(mgs,lr)) + ELSEIF ( ( dmropt == 5 ) .and. qx(mgs,lr) > qxmin(lr) ) THEN + tmp = crcnw(mgs) + tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) + ! try mass-weighted average of old and new Dmr using full qc mass + crcnw(mgs) = (tmp*qx(mgs,lc)+tmp2*qx(mgs,lr))/(qx(mgs,lc)+qx(mgs,lr)) + ELSEIF ( ( dmropt == 6 ) .and. qx(mgs,lr) > qxmin(lr) ) THEN + tmp = crcnw(mgs) + tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) + ! try mass*diameter-weighted average of old and new Dmr (using full qc mass) + crcnw(mgs) = (tmp*xdia(mgs,lc,3)*qx(mgs,lc)+tmp2*xdia(mgs,lr,3)*qx(mgs,lr))/(xdia(mgs,lc,3)*qx(mgs,lc)+xdia(mgs,lr,3)*qx(mgs,lr)) + ELSEIF ( ( dmropt == 7 ) .and. qx(mgs,lr) > qxmin(lr) ) THEN + tmp = crcnw(mgs) + tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) + ! try diameter-weighted average of old and new Dmr + crcnw(mgs) = (tmp*xdia(mgs,lc,3)+tmp2*xdia(mgs,lr,3))/(xdia(mgs,lc,3)+xdia(mgs,lr,3)) + ELSEIF ( ( dmropt == 8 ) .and. qx(mgs,lr) > qxmin(lr) ) THEN + tmp = crcnw(mgs) + tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) + ! try sqrt(diameter)-weighted average of old and new Dmr + crcnw(mgs) = (tmp*sqrt(xdia(mgs,lc,3))+tmp2*sqrt(xdia(mgs,lr,3)))/(sqrt(xdia(mgs,lc,3))+sqrt(xdia(mgs,lr,3))) + ENDIF + ELSEIF ( dmrauto == 1 .and. cx(mgs,lr) > cxmin) THEN + IF ( qx(mgs,lr) > qxmin(lr) ) THEN + tmp = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) + crcnw(mgs) = Min(tmp,crcnw(mgs) ) + ENDIF + ELSEIF ( dmrauto == 2 .and. cx(mgs,lr) > cxmin) THEN + tmp = crcnw(mgs) + tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) + ! try mass-weighted average of old and new Dmr + crcnw(mgs) = (tmp*qrcnw(mgs)+tmp2*qx(mgs,lr))/(qrcnw(mgs)+qx(mgs,lr)) + ELSEIF ( dmrauto == 3 .and. cx(mgs,lr) > cxmin) THEN ! adapted from MY/CP code + tmp = Max( 2.d0*rh(mgs), dble( xdia(mgs,lr,3) ) ) + crcnw(mgs) = rho0(mgs)*qrcnw(mgs)/(pi/6.*1000.*tmp**3) + ENDIF + + IF ( crcnw(mgs) < 1.e-30 ) qrcnw(mgs) = 0.0 + +! IF ( crcnw(mgs) .gt. cautn(mgs) .and. crcnw(mgs) .gt. 1.0 ) +! : THEN +! write(0,*) 'crcnw,cautn ',crcnw(mgs)/cautn(mgs), +! : crcnw(mgs),cautn(mgs),igs(mgs),kgs(mgs),t2s,qx(mgs,lr) +! write(0,*) ' ',qx(mgs,lc),cx(mgs,lc),0.5e6*xdia(mgs,lc,1) +! write(0,*) ' ',rho0(mgs)*qrcnw(mgs)/crcnw(mgs), +! : 1.e6*(( 3/(4.*pi))*rho0(mgs)*qrcnw(mgs)/ +! : (crcnw(mgs)*xdn(mgs,lr)))**(1./3.),rh(mgs)*1.e6,rwrad(mgs) +! ELSEIF ( crcnw(mgs) .gt. 1.0 .and. cautn(mgs) .gt. 0.) THEN +! write(0,*) 'crcnw,cautn ',crcnw(mgs)/cautn(mgs), +! : crcnw(mgs),cautn(mgs),igs(mgs),kgs(mgs),t2s +! write(0,*) ' ',rho0(mgs)*qrcnw(mgs)/crcnw(mgs), +! : 1.e6*(( 3*pi/4.)*rho0(mgs)*qrcnw(mgs)/ +! : (crcnw(mgs)*xdn(mgs,lr)))**(1./3.) +! ENDIF +! crcnw(mgs) = Min(cautn(mgs),3.5e9*xl2p(mgs)/t2s) + +! IF ( qrcnw(mgs) .gt. 0.3e-2 ) THEN +! write(0,*) 'QRCNW' +! write(0,*) qrcnw(mgs),crcnw(mgs),cautn(mgs) +! write(0,*) xl2p,t2s,rho0(mgs),xv(mgs,lc),cx(mgs,lc),qx(mgs,lc) +! write(0,*) rb,0.5*xdia(mgs,lc,1),mgs,igs(mgs),kgs(mgs) +! ENDIF +! qrcnw(mgs) = Min(qrcnw(mgs),qcmxd(mgs)) + ENDIF + + + ENDIF + ENDDO + + ENDIF !} dmrauto >= 0 + + + + ELSE + +! +! Berry 1968 auto conversion for rain (Orville & Kopp 1977) +! +! + if ( ircnw .eq. 4 ) then + do mgs = 1,ngscnt +! sconvmix(lcw,mgs) = 0.0 + qrcnw(mgs) = 0.0 + qdiff = max((qx(mgs,lc)-qminrncw),0.0) + if ( qdiff .gt. 0.0 .and. xdia(mgs,lc,1) .gt. 20.0e-6 ) then + argrcnw = & + & ((1.2e-4)+(1.596e-12)*(cx(mgs,lc)*1.0e-6) & + & /(cwdisp*qdiff*1.0e-3*rho0(mgs))) + qrcnw(mgs) = (rho0(mgs)*1e-3)*(qdiff**2)/argrcnw +! sconvmix(lcw,mgs) = max(sconvmix(lcw,mgs),0.0) + qrcnw(mgs) = (max(qrcnw(mgs),0.0)) + end if + end do + + ENDIF +! +! +! +! Berry 1968 auto conversion for rain (Ferrier 1994) +! +! + if ( ircnw .eq. 5 ) then + do mgs = 1,ngscnt + qrcnw(mgs) = 0.0 + qrcnw(mgs) = 0.0 + qccrit = (pi/6.)*(cx(mgs,lc)*cwdiap**3)*xdn(mgs,lc)/rho0(mgs) + qdiff = max((qx(mgs,lc)-qccrit),0.) + if ( qdiff .gt. 0.0 .and. cx(mgs,lc) .gt. 1.0 ) then + argrcnw = & +! > ((1.2e-4)+(1.596e-12)*cx(mgs,lc)/(cwdisp*rho0(mgs)*qdiff)) & + & ((1.2e-4)+(1.596e-12)*cx(mgs,lc)*1.0e-3/(cwdisp*rho0(mgs)*qdiff)) + qrcnw(mgs) = & +! > timflg(mgs)*rho0(mgs)*(qdiff**2)/argrcnw & + & 1.0e-3*rho0(mgs)*(qdiff**2)/argrcnw + qrcnw(mgs) = Min(qxmxd(mgs,lc), (max(qrcnw(mgs),0.0)) ) + +! write(iunit,*) 'qrcnw,cx =',qrcnw(mgs),cx(mgs,lc),mgs,1.e3*qx(mgs,lc),cno(lr) + end if + end do + end if + +! +! +! kessler auto conversion for rain. +! + if ( ircnw .eq. 2 ) then + do mgs = 1,ngscnt + qrcnw(mgs) = 0.0 + qrcnw(mgs) = (0.001)*max((qx(mgs,lc)-qminrncw),0.0) + end do + end if +! +! c4 = pi/6 +! c1 = 0.12-0.32 for colorado storms...typically 0.3-0.4 +! berry reinhart type conversion (proctor 1988) +! + if ( ircnw .eq. 1 ) then + do mgs = 1,ngscnt + qrcnw(mgs) = 0.0 + c1 = 0.2 + c4 = pi/(6.0) + bradp = & + & (1.e+06) * ((c1/(0.38))**(1./3.)) * (xdia(mgs,lc,1)*(0.5)) + bl2 = & + & (0.027) * ((100.0)*(bradp**3)*(xdia(mgs,lc,1)*(0.5)) - (0.4)) + bt2 = (bradp -7.5) / (3.72) + qrcnw(mgs) = 0.0 + if ( bl2 .gt. 0.0 .and. bt2 .gt. 0.0 ) then + qrcnw(mgs) = bl2 * bt2 * rho0(mgs) & + & * qx(mgs,lc) * qx(mgs,lc) + end if + end do + end if + + + + ENDIF ! ( ipconc .ge. 2 ) + +! +! +! +! Bigg Freezing of Rain +! + if (ndebug .gt. 0 ) write(0,*) 'conc 27a' + qrfrz(:) = 0.0 + qrfrzs(:) = 0.0 + qrfrzf(:) = 0.0 + vrfrzf(:) = 0.0 + crfrz(:) = 0.0 + crfrzs(:) = 0.0 + crfrzf(:) = 0.0 + zrfrz(:) = 0.0 + zrfrzs(:) = 0.0 + zrfrzf(:) = 0.0 + qwcnr(:) = 0.0 + + IF ( .not. ( ipconc == 0 .and. lwsm6 ) ) THEN + + do mgs = 1,ngscnt + if ( qx(mgs,lr) .gt. qxmin(lr) .and. temcg(mgs) .lt. -5. .and. ibiggopt > 0 ) then +! brz = 100.0 +! arz = 0.66 + IF ( ipconc .lt. 3 ) THEN + qrfrz(mgs) = & + & min( & + & (20.0)*(pi**2)*brz*(xdn(mgs,lr)/rho0(mgs)) & + & *cx(mgs,lr)*(xdia(mgs,lr,1)**6) & + & *(exp(max(-arz*temcg(mgs), 0.0))-1.0) & + & , qrmxd(mgs)) + qrfrzf(mgs) = qrfrz(mgs) + +! ELSEIF ( ipconc .ge. 3 .and. xv(mgs,lr) .gt. 1.1*xvmn(lr) ) THEN + ELSEIF ( ipconc .ge. 3 ) THEN +! tmp = brz*cx(mgs,lr)*(Exp(Max( -arz*temcg(mgs), 0.0 )) - 1.0) +! crfrz(mgs) = xv(mgs,lr)*tmp + + frach = 1.0d0 + +! IF ( ibiggopt == 2 .and. imurain == 1 .and. lzr < 1 ) THEN ! lzr check because results are weird for 3-moment + IF ( ibiggopt == 2 .and. imurain == 1 ) THEN ! + ! integrate from Bigg diameter (for given supercooling Ts) to infinity + + volt = exp( 16.2 + 1.0*temcg(mgs) )* 1.0e-6 ! Ts == -temcg ; volt comes from the fit in Fig. 1 in Bigg 1953 (Proc. Phys. Soc. London) + ! for mean temperature for freezing: -ln (V) = a*Ts - b, where a = 6.9/6.8, or approx a = 1.0, and b = 16.2 + ! volt is given in cm**3, so convert to m**3 + dbigg = (6./pi* volt )**(1./3.) + + ! perhaps should also test that W > V_t_dbigg, i.e., that drops the size of dbigg are being lifted and cooled. + IF ( dbigg < 8.e-3 ) THEN !{ only bother if freezing diameter is reasonable + + ratio = Min(maxratiolu, dbigg/xdia(mgs,lr,1) ) + + i = Min(nqiacrratio,Int(ratio*dqiacrratioinv)) + IF ( alp0flag ) THEN + j = Int(Max(0.0,Min(15.,alpha(mgs,lr)))*dqiacralphainv) + ELSE + j = Int(Max(minalphalu,Min(maxalphalu,alpha(mgs,lr)))*dqiacralphainv) + ENDIF + delx = ratio - float(i)*dqiacrratio + dely = alpha(mgs,lr) - float(j)*dqiacralpha + ip1 = Min( i+1, nqiacrratio ) + jp1 = Min( j+1, nqiacralpha ) + + ! interpolate along x, i.e., ratio; + tmp1 = ciacrratio(i,j) + delx*dqiacrratioinv*(ciacrratio(ip1,j) - ciacrratio(i,j)) + tmp2 = ciacrratio(i,jp1) + delx*dqiacrratioinv*(ciacrratio(ip1,jp1) - ciacrratio(i,jp1)) + + ! interpolate along alpha; + + crfrz(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*cx(mgs,lr)*dtpinv + crfrzf(mgs) = crfrz(mgs) + ! interpolate along x, i.e., ratio; + tmp1 = qiacrratio(i,j) + delx*dqiacrratioinv*(qiacrratio(ip1,j) - qiacrratio(i,j)) + tmp2 = qiacrratio(i,jp1) + delx*dqiacrratioinv*(qiacrratio(ip1,jp1) - qiacrratio(i,jp1)) + + ! interpolate along alpha; + + qrfrz(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*qx(mgs,lr)*dtpinv + qrfrzf(mgs) = qrfrz(mgs) + + IF ( qrfrz(mgs)*dtp < qxmin(lh) .or. crfrz(mgs)*dtp < cxmin ) THEN + + crfrz(mgs) = 0.0 + qrfrz(mgs) = 0.0 + qrfrzf(mgs) = 0.0 + + ELSE !{ + + + + IF ( ibiggsmallrain > 0 .and. xv(mgs,lr) < 2.*xvmn(lr) .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN +! IF ( ibiggsmallrain > 0 .and. xv(mgs,lr) < xvbiggsnow .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN + ! rain drops are so small that they cannot be pushed smaller, so put into snow (or cloud ice, depending on ifrzs) + crfrzf(mgs) = 0.0 + qrfrzf(mgs) = 0.0 + crfrzs(mgs) = crfrz(mgs) + qrfrzs(mgs) = qrfrz(mgs) + + ELSEIF ( dbigg < Max( biggsnowdiam, Max(dfrz,dhmn)) .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN ! { convert some to snow or ice crystals + ! temporarily store qrfrz and crfrz in snow terms and caclulate new crfrzf, qrfrzf, and zrfrzf. Leave crfrz etc. alone! + + crfrzs(mgs) = crfrz(mgs) + qrfrzs(mgs) = qrfrz(mgs) + + IF ( ibiggsmallrain > 0 .and. xv(mgs,lr) < 1.2*xvmn(lr) ) THEN + ! rain drops are so small that they cannot be pushed smaller, so put into snow (or cloud ice, depending on ifrzs) + crfrzf(mgs) = 0.0 + qrfrzf(mgs) = 0.0 + + ELSE !{ + + ! recalculate using dhmn for ratio + ratio = Min( maxratiolu, Max(dfrz,dhmn)/xdia(mgs,lr,1) ) + + i = Min(nqiacrratio,Int(ratio*dqiacrratioinv)) +! j = Int(Max(0.0,Min(15.,alpha(mgs,lr)))*dqiacralphainv) +! j = Int(Max(alphamin,Min(alphamax,alpha(mgs,lr)))*dqiacralphainv) + IF ( alp0flag ) THEN + j = Int(Max(0.0,Min(15.,alpha(mgs,lr)))*dqiacralphainv) + ELSE + j = Int(Max(minalphalu,Min(maxalphalu,alpha(mgs,lr)))*dqiacralphainv) + ENDIF + delx = ratio - float(i)*dqiacrratio + dely = alpha(mgs,lr) - float(j)*dqiacralpha + ip1 = Min( i+1, nqiacrratio ) + jp1 = Min( j+1, nqiacralpha ) + + ! interpolate along x, i.e., ratio; + tmp1 = ciacrratio(i,j) + delx*dqiacrratioinv*(ciacrratio(ip1,j) - ciacrratio(i,j)) + tmp2 = ciacrratio(i,jp1) + delx*dqiacrratioinv*(ciacrratio(ip1,jp1) - ciacrratio(i,jp1)) + + + ! interpolate along alpha; + + crfrzf(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*cx(mgs,lr)*dtpinv + + ! interpolate along x, i.e., ratio; + tmp1 = qiacrratio(i,j) + delx*dqiacrratioinv*(qiacrratio(ip1,j) - qiacrratio(i,j)) + tmp2 = qiacrratio(i,jp1) + delx*dqiacrratioinv*(qiacrratio(ip1,jp1) - qiacrratio(i,jp1)) + + ! interpolate along alpha; + + qrfrzf(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*qx(mgs,lr)*dtpinv + + ! now subtract off the difference + crfrzs(mgs) = crfrzs(mgs) - crfrzf(mgs) + qrfrzs(mgs) = qrfrzs(mgs) - qrfrzf(mgs) + + ENDIF ! } + ELSE + crfrzs(mgs) = 0.0 + qrfrzs(mgs) = 0.0 + ENDIF ! } + + ENDIF !} + + IF ( (qrfrz(mgs))*dtp > qx(mgs,lr) ) THEN + fac = ( qrfrz(mgs) )*dtp/qx(mgs,lr) + qrfrz(mgs) = fac*qrfrz(mgs) + qrfrzs(mgs) = fac*qrfrzs(mgs) + qrfrzf(mgs) = fac*qrfrzf(mgs) + crfrz(mgs) = fac*crfrz(mgs) + crfrzs(mgs) = fac*crfrzs(mgs) + crfrzf(mgs) = fac*crfrzf(mgs) + ENDIF + + ENDIF !} + +! IF ( (crfrzs(mgs) + crfrz(mgs))*dtp > cx(mgs,lr) ) THEN +! fac = ( crfrzs(mgs) + crfrz(mgs) )*dtp/cx(mgs,lr) +! crfrz(mgs) = fac*crfrz(mgs) +! crfrzs(mgs) = fac*crfrzs(mgs) +! ENDIF + +! qrfrzf(mgs) = qrfrz(mgs) +! crfrzf(mgs) = crfrz(mgs) + + ! qrfrz(mgs) = qrfrzf(mgs) + qrfrzs(mgs) + ! crfrz(mgs) = crfrzf(mgs) + crfrzs(mgs) + + + ELSEIF ( ibiggopt == 1 ) THEN + ! Z85, eq. A34 + tmp = xv(mgs,lr)*brz*cx(mgs,lr)*(Exp(Max( -arz*temcg(mgs), 0.0 )) - 1.0) + IF ( .false. .and. tmp .gt. cxmxd(mgs,lr) ) THEN ! { +! write(iunit,*) 'Bigg Freezing problem!',mgs,igs(mgs),kgs(mgs) +! write(iunit,*) 'tmp, cx(lr), xv = ',tmp, cx(mgs,lr), xv(mgs,lr), (Exp(Max( -arz*temcg(mgs), 0.0 )) - 1.0) +! write(iunit,*) 'qr,temcg = ',qx(mgs,lr)*1000.,temcg(mgs) + crfrz(mgs) = cxmxd(mgs,lr) ! cx(mgs,lr)*dtpinv + qrfrz(mgs) = qxmxd(mgs,lr) ! qx(mgs,lr)*dtpinv +! STOP + ELSE ! } { + crfrz(mgs) = tmp + ! crfrzfmx = cx(mgs,lr)*Exp(-4./3.*pi*(40.e-6)**3/xv(mgs,lr)) + ! IF ( crfrz(mgs) .gt. crfrzmx ) THEN + ! crfrz(mgs) = crfrzmx + ! qrfrz(mgs) = bfnu*xmas(mgs,lr)*rhoinv(mgs)*crfrzmx + ! qwcnr(mgs) = cx(mgs,lr) - crfrzmx + ! ELSE + IF ( lzr < 1 ) THEN + IF ( imurain == 3 ) THEN + bfnu = bfnu0 + ELSE !imurain == 1 + bfnu = bfnu1 + ENDIF + ELSE + ! bfnu = 1.0 ! (alpha(mgs,lr)+2.0)/(alpha(mgs,lr)+1.) + IF ( imurain == 3 ) THEN + bfnu = (alpha(mgs,lr)+2.0)/(alpha(mgs,lr)+1.) + ELSE !imurain == 1 +! bfnu = bfnu1 + bfnu = (4. + alpha(mgs,lr))*(5. + alpha(mgs,lr))*(6. + alpha(mgs,lr))/ & + & ((1. + alpha(mgs,lr))*(2. + alpha(mgs,lr))*(3. + alpha(mgs,lr))) +! bfnu = 1. + ENDIF + ENDIF + qrfrz(mgs) = bfnu*xmas(mgs,lr)*rhoinv(mgs)*crfrz(mgs) + + qrfrz(mgs) = Min( qrfrz(mgs), 1.*qx(mgs,lr)*dtpinv ) ! qxmxd(mgs,lr) + crfrz(mgs) = Min( crfrz(mgs), 1.*cx(mgs,lr)*dtpinv ) !cxmxd(mgs,lr) + qrfrz(mgs) = Min( qrfrz(mgs), qx(mgs,lr) ) + qrfrzf(mgs) = qrfrz(mgs) + ENDIF !} + + + + + IF ( crfrz(mgs) .gt. qxmin(lh) ) THEN !{ Yes, it compares cx and qxmin, but this is just to be sure that + ! crfrz is greater than zero in the division +! IF ( xdia(mgs,lr,1) .lt. 200.e-6 ) THEN +! IF ( xv(mgs,lr) .lt. xvmn(lh) ) THEN + + IF ( (ibiggsnow == 1 .or. ibiggsnow == 3 ) .and. ibiggopt /= 2 ) THEN + xvfrz = rho0(mgs)*qrfrz(mgs)/(crfrz(mgs)*900.) ! mean volume of frozen drops; 900. for frozen drop density + frach = 0.5 *(1. + Tanh(0.2e12 *( xvfrz - 1.15*xvmn(lh)))) + + qrfrzs(mgs) = (1.-frach)*qrfrz(mgs) + crfrzs(mgs) = (1.-frach)*crfrz(mgs) ! *rzxh(mgs) +! qrfrzf(mgs) = frach*qrfrz(mgs) + + ENDIF + + IF ( ipconc .ge. 14 .and. 1.e-3*rho0(mgs)*qrfrz(mgs)/crfrz(mgs) .lt. xvmn(lh) ) THEN + qrfrzs(mgs) = qrfrz(mgs) + crfrzs(mgs) = crfrz(mgs) ! *rzxh(mgs) + ELSE +! crfrz(mgs) = Min( crfrz(mgs), 0.1*cx(mgs,lr)*dtpinv ) ! cxmxd(mgs,lr) +! qrfrz(mgs) = Min( qrfrz(mgs), 0.1*qx(mgs,lr)*dtpinv ) ! qxmxd(mgs,lr) + qrfrzf(mgs) = frach*qrfrz(mgs) +! crfrzf(mgs) = Min( qrfrz(mgs)*rho0(mgs)/(xdn(mgs,lh)*vgra), crfrz(mgs) ) + IF ( ibfr .le. 1 ) THEN + crfrzf(mgs) = frach*Min(crfrz(mgs), qrfrz(mgs)/(bfnu*1.0*vr1mm*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs) + ELSEIF ( ibfr .eq. 5 ) THEN + crfrzf(mgs) = frach*Min(crfrz(mgs), qrfrz(mgs)/(bfnu*vfrz*1000.0)*rho0(mgs) )*rzxh(mgs) !*crfrz(mgs) + ELSEIF ( ibfr .eq. 2 ) THEN + crfrzf(mgs) = frach*Min(crfrz(mgs), qrfrz(mgs)/(bfnu*vfrz*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs) + ELSEIF ( ibfr .eq. 6 ) THEN + crfrzf(mgs) = frach*Max(crfrz(mgs), qrfrz(mgs)/(bfnu*9.*xv(mgs,lr)*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs) + ELSE + crfrzf(mgs) = frach*crfrz(mgs) + ENDIF +! crfrzf(mgs) = Min(crfrz(mgs), qrfrz(mgs)/(bfnu*xvmn(lh)*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs) +! IF ( lz(lr) > 1 .and. lz(lh) > 1 ) THEN +! crfrzf(mgs) = crfrz(mgs) +! ENDIF + + ENDIF +! crfrz(mgs) = Min( cxmxd(mgs,lr), rho0(mgs)*qrfrz(mgs)/xmas(mgs,lr) ) + ELSE + crfrz(mgs) = 0.0 + qrfrz(mgs) = 0.0 + ENDIF !} + + ENDIF ! ibiggopt + + IF ( lvol(lh) .gt. 1 ) THEN + vrfrzf(mgs) = rho0(mgs)*qrfrzf(mgs)/rhofrz + ENDIF + + + IF ( nsplinter .ne. 0 ) THEN + IF ( nsplinter .ge. 1000 ) THEN + ! Lawson et al. 2015 JAS + ! ave. diam of freezing drops in microns + tmp = 0 + IF ( qrfrz(mgs)*dtp > qxmin(lh) .and. crfrz(mgs) > 1.e-3 ) THEN + tmpdiam = 1.e6*( 6.*qrfrz(mgs)/(1000.*pi*crfrz(mgs) ))**(1./3.) ! avg. diameter of newly frozen drops in microns + tmp = lawson_splinter_fac*tmpdiam**4*crfrz(mgs) + ENDIF + ELSEIF ( nsplinter .gt. 0 ) THEN + tmp = nsplinter*crfrz(mgs) + ELSE + tmp = -nsplinter*crfrzf(mgs) + ENDIF + csplinter2(mgs) = tmp + qsplinter2(mgs) = Min(0.1*qrfrz(mgs), tmp*splintermass/rho0(mgs) ) ! makes splinters smaller if too much mass is taken from graupel + +! csplinter(mgs) = csplinter(mgs) + tmp +! qsplinter(mgs) = qsplinter(mgs) + Min(0.1*qrfrz(mgs), tmp*splintermass/rho0(mgs) ) ! makes splinters smaller if too much mass is taken from graupel + ENDIF +! IF ( temcg(mgs) .lt. -31.0 ) THEN +! qrfrz(mgs) = qx(mgs,lr)*dtpinv + qrcnw(mgs) +! qrfrzf(mgs) = qrfrz(mgs) +! crfrz(mgs) = cx(mgs,lr)*dtpinv + crcnw(mgs) +! crfrzf(mgs) = Min(crfrz(mgs), qrfrz(mgs)/(bfnu*1.0*vr1mm*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs) +! ENDIF +! qrfrz(mgs) = 6.0*xdn(mgs,lr)*xv(mgs,lr)**2*tmp*rhoinv(mgs) +! qrfrz(mgs) = Min( qrfrz(mgs), ffrz*qrmxd(mgs) ) +! crfrz(mgs) = Min( crmxd(mgs), ffrz*crfrz(mgs)) +! crfrz(mgs) = Min(crmxd(mgs),qrfrz(mgs)*rho0(mgs)/xmas(mgs,lr)) + ENDIF +! if ( temg(mgs) .gt. 268.15 ) then + else +! end if + end if + end do + + ENDIF +! +! Homogeneous freezing of cloud drops to ice crystals +! following Bigg (1953) and Ferrier (1994). +! + if (ndebug .gt. 0 ) write(0,*) 'conc 25b' + do mgs = 1,ngscnt + qwfrz(mgs) = 0.0 + cwfrz(mgs) = 0.0 + qwfrzc(mgs) = 0.0 + cwfrzc(mgs) = 0.0 + qwfrzp(mgs) = 0.0 + cwfrzp(mgs) = 0.0 + IF ( ibfc .ge. 1 .and. ibfc /= 3 .and. temg(mgs) < 268.15 ) THEN +! if ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. 1. .and. & +! & .not. (ipconc .ge. 2 .and. xdia(mgs,lc,1) .lt. 10.e-6) ) then + if ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. cxmin ) THEN + IF ( ipconc < 2 ) THEN + qwfrz(mgs) = ((2.0)*(brz)/(xdn(mgs,lc)*cx(mgs,lc))) & + & *(exp(max(-arz*temcg(mgs), 0.0))-1.0) & + & *rho0(mgs)*(qx(mgs,lc)**2) + qwfrz(mgs) = max(qwfrz(mgs), 0.0) + qwfrz(mgs) = min(qwfrz(mgs),qcmxd(mgs)) + cwfrz(mgs) = qwfrz(mgs)*rho0(mgs)/xmas(mgs,li) + ELSEIF ( ipconc .ge. 2 ) THEN + IF ( xdia(mgs,lc,3) > 0.e-6 ) THEN + volt = exp( 16.2 + 1.0*temcg(mgs) )* 1.0e-6 ! Ts == -temcg ; volt comes from the fit in Fig. 1 in Bigg 1953 + ! for mean temperature for freezing: -ln (V) = a*Ts - b + ! volt is given in cm**3, so factor of 1.e-6 to convert to m**3 +! dbigg = (6./pi* volt )**(1./3.) + + IF ( alpha(mgs,lc) == 0.0 ) THEN + cwfrz(mgs) = cx(mgs,lc)*Exp(-volt/xv(mgs,lc))*dtpinv ! number of droplets with volume greater than volt +!turn off limit so that all can freeze at low temp +!!! cwfrz(mgs) = Min(cwfrz(mgs),ccmxd(mgs)) + + qwfrz(mgs) = cwfrz(mgs)*xdn0(lc)*rhoinv(mgs)*(volt + xv(mgs,lc)) + ELSE + ratio = (1. + alpha(mgs,lc))*volt/xv(mgs,lc) + + IF ( .false. .and. usegamxinfcnu ) THEN + i = Nint(dgami*(1. + alpha(mgs,lc))) + gcnup1 = gmoi(i) + i = Nint(dgami*(2. + alpha(mgs,lc))) + gcnup2 = gmoi(i) + + cwfrz(mgs) = cx(mgs,lc)*Gamxinf(1.+alpha(mgs,lc), ratio)/(dtp*gcnup1) ! gamxinflu(i,j,1,1) + + qwfrz(mgs) = cx(mgs,lc)*xdn0(lc)*xv(mgs,lc)*rhoinv(mgs)*Gamxinf(2.+alpha(mgs,lc), ratio)/(dtp*gcnup2) ! gamxinflu(i,j,12,1) + + ELSE + + ratio = Min( maxratiolu, ratio ) +! write(0,*) 'cwfrz: temp,ratio = ',temcg(mgs),ratio +! write(0,*) 'cwfrz: xv,volt,qx = ',xv(mgs,lc),volt,qx(mgs,lc) +! write(0,*) 'cwfrz: i,j,k = ',igs(mgs),jgs,kgs(mgs) + tmp = gaminterp(ratio,alpha(mgs,lc),1,1) +! write(0,*) 'cwfrz: tmp1 = ',tmp + cwfrz(mgs) = cx(mgs,lc)*tmp*dtpinv ! Gamxinf(1.+alpha(mgs,lc), ratio)/(dtp*gcnup1) ! gamxinflu(i,j,1,1) + + tmp = gaminterp(ratio,alpha(mgs,lc),12,1) +! write(0,*) 'cwfrz: tmp2 = ',tmp + qwfrz(mgs) = cx(mgs,lc)*xdn0(lc)*xv(mgs,lc)*rhoinv(mgs)*dtpinv*tmp ! Gamxinf(2.+alpha(mgs,lc), ratio)/(dtp*gcnup2) ! gamxinflu(i,j,12,1) + + ENDIF + + ENDIF + + ENDIF + ENDIF + if ( temg(mgs) .gt. 268.15 ) then + qwfrz(mgs) = 0.0 + cwfrz(mgs) = 0.0 + end if + end if + ENDIF +! + if ( xplate(mgs) .eq. 1 ) then + qwfrzp(mgs) = qwfrz(mgs) + cwfrzp(mgs) = cwfrz(mgs) + end if +! + if ( xcolmn(mgs) .eq. 1 ) then + qwfrzc(mgs) = qwfrz(mgs) + cwfrzc(mgs) = cwfrz(mgs) + end if + +! +! qwfrzp(mgs) = 0.0 +! qwfrzc(mgs) = qwfrz(mgs) +! + end do +! +! +! Contact freezing nucleation: factor is to convert from L-1 +! T < -2C: via Meyers et al. JAM July, 1992 (31, 708-721) +! + if (ndebug .gt. 0 ) write(0,*) 'conc 25a' + do mgs = 1,ngscnt + + ccia(mgs) = 0.0 + + cwctfz(mgs) = 0.0 + qwctfz(mgs) = 0.0 + ctfzbd(mgs) = 0.0 + ctfzth(mgs) = 0.0 + ctfzdi(mgs) = 0.0 + + cwctfzc(mgs) = 0.0 + qwctfzc(mgs) = 0.0 + cwctfzp(mgs) = 0.0 + qwctfzp(mgs) = 0.0 + IF ( icfn .ge. 1 ) THEN + + IF ( temg(mgs) .lt. 271.15 .and. qx(mgs,lc) .gt. qxmin(lc)) THEN + +! find available # of ice nuclei & limit value to max depletion of cloud water + + IF ( icfn .ge. 2 ) THEN + ccia(mgs) = exp( 4.11 - (0.262)*temcg(mgs) ) ! in m-3, see Walko et al. 1995; 1000*exp(-2.8 -b*t) = exp(6.91)*exp(-2.8 - b*t) = exp(4.11 -b*t) + !ccia(mgs) = Min(cwctfz(mgs), ccmxd(mgs) ) + +! now find how many of these collect cloud water to form IN +! Cotton et al 1986 + + knud(mgs) = 2.28e-5 * temg(mgs) / ( pres(mgs)*raero ) !Walko et al. 1995 + knuda(mgs) = 1.257 + 0.4*exp(-1.1/knud(mgs)) !Pruppacher & Klett 1997 eqn 11-16 + gtp(mgs) = 1. / ( fai(mgs) + fbi(mgs) ) !Byers 65 / Cotton 72b + dfar(mgs) = kb*temg(mgs)*(1.+knuda(mgs)*knud(mgs))/(6.*pi*fadvisc(mgs)*raero) !P&K 1997 eqn 11-15 + fn1(mgs) = 2.*pi*xdia(mgs,lc,1)*cx(mgs,lc)*ccia(mgs) + fn2(mgs) = -gtp(mgs)*(ssw(mgs)-1.)*felv(mgs)/pres(mgs) + fnft(mgs) = 0.4*(1.+1.45*knud(mgs)+0.4*knud(mgs)*exp(-1./knud(mgs)))*(ftka(mgs)+2.5*knud(mgs)*kaero) & + & / ( (1.+3.*knud(mgs))*(2*ftka(mgs)+5.*knud(mgs)*kaero+kaero) ) + + +! Brownian diffusion + ctfzbd(mgs) = fn1(mgs)*dfar(mgs) + +! Thermophoretic contact nucleation + ctfzth(mgs) = fn1(mgs)*fn2(mgs)*fnft(mgs)/rho0(mgs) + +! Diffusiophoretic contact nucleation + ctfzdi(mgs) = fn1(mgs)*fn2(mgs)*rw*temg(mgs)/(felv(mgs)*rho0(mgs)) + + cwctfz(mgs) = max( ctfzbd(mgs) + ctfzth(mgs) + ctfzdi(mgs) , 0.) + +! Sum of the contact nucleation processes +! IF ( cx(mgs,lc) .gt. 1.e6) write(0,*) 'ctfzbd,etc = ',cwctfz(mgs),ctfzbd(mgs),ctfzth(mgs),ctfzdi(mgs) +! IF ( wvel(mgs) .lt. -0.05 ) write(6,*) 'ctfzbd,etc = ',ctfzbd(mgs),ctfzth(mgs),ctfzdi(mgs),cx(mgs,lc)*1e-6,wvel(mgs) +! IF ( ssw(mgs) .lt. 1.0 .and. cx(mgs,lc) .gt. 1.e6 .and. cwctfz(mgs) .gt. 1. ) THEN +! write(6,*) 'ctfzbd,etc = ',ctfzbd(mgs),ctfzth(mgs),ctfzdi(mgs),cx(mgs,lc)*1e-6,wvel(mgs),fn1(mgs),fn2(mgs) +! write(6,*) 'more = ',nstep,ssw(mgs),dfar(mgs),gtp(mgs),felv(mgs),pres(mgs) +! ENDIF + + ELSEIF ( icfn .eq. 1 ) THEN + IF ( wvel(mgs) .lt. -0.05 ) THEN ! older kludgy version + cwctfz(mgs) = cfnfac*exp( (-2.80) - (0.262)*temcg(mgs) ) + cwctfz(mgs) = Min((1.0e3)*cwctfz(mgs), ccmxd(mgs) ) !convert to m-3 + ENDIF + ENDIF ! icfn + + IF ( ipconc .ge. 2 ) THEN + cwctfz(mgs) = Min( cwctfz(mgs)*dtpinv, ccmxd(mgs) ) + qwctfz(mgs) = xmas(mgs,lc)*cwctfz(mgs)/rho0(mgs) + ELSE + qwctfz(mgs) = (cimasn)*cwctfz(mgs)/(dtp*rho0(mgs)) + qwctfz(mgs) = max(qwctfz(mgs), 0.0) + qwctfz(mgs) = min(qwctfz(mgs),qcmxd(mgs)) + ENDIF + +! + if ( xplate(mgs) .eq. 1 ) then + qwctfzp(mgs) = qwctfz(mgs) + cwctfzp(mgs) = cwctfz(mgs) + end if +! + if ( xcolmn(mgs) .eq. 1 ) then + qwctfzc(mgs) = qwctfz(mgs) + cwctfzc(mgs) = cwctfz(mgs) + end if + +! IF ( cwctfz(mgs)*dtp > 0.5 .and. dtp*qwctfz(mgs) > qxmin(li) ) THEN +! write(91,*) 'cwctfz: ',cwctfz(mgs),qwctfz(mgs) ! ,cwctfzc(mgs),qwctfzc(mgs) +! ENDIF + +! +! qwctfzc(mgs) = qwctfz(mgs) +! qwctfzp(mgs) = 0.0 +! + end if + + ENDIF ! icfn + + end do +! +! +! +! Hobbs-Rangno ice enhancement (Ferrier, 1994) +! + if (ndebug .gt. 0 ) write(0,*) 'conc 23a' + dthr = 300.0 + hrifac = (1.e-3)*((0.044)*(0.01**3)) + do mgs = 1,ngscnt + ciihr(mgs) = 0.0 + qiihr(mgs) = 0.0 + cicichr(mgs) = 0.0 + qicichr(mgs) = 0.0 + cipiphr(mgs) = 0.0 + qipiphr(mgs) = 0.0 + IF ( ihrn .ge. 1 ) THEN + if ( qx(mgs,lc) .gt. qxmin(lc) ) then + if ( temg(mgs) .lt. 273.15 ) then +! write(iunit,'(3(1x,i3),3(1x,1pe12.5))') +! : igs(mgs),jgs,kgs(mgs),cx(mgs,lc),rho0(mgs),qx(mgs,lc) +! write(iunit,'(1pe15.6)') +! : log(cx(mgs,lc)*(1.e-6)/(3.0)), +! : ((1.e-3)*rho0(mgs)*qx(mgs,lc)), +! : (cx(mgs,lc)*(1.e-6)), +! : ((1.e-3)*rho0(mgs)*qx(mgs,lc))/(cx(mgs,lc)*(1.e-6)), +! : (alog(cx(mgs,lc)*(1.e-6)/(3.0)) * +! > ((1.e-3)*rho0(mgs)*qx(mgs,lc))/(cx(mgs,lc)*(1.e-6))) + + IF ( Log(cx(mgs,lc)*(1.e-6)/(3.0)) .gt. 0.0 ) THEN + ciihr(mgs) = ((1.69e17)/dthr) & + & *(log(cx(mgs,lc)*(1.e-6)/(3.0)) * & + & ((1.e-3)*rho0(mgs)*qx(mgs,lc))/(cx(mgs,lc)*(1.e-6)))**(7./3.) + ciihr(mgs) = ciihr(mgs)*(1.0e6) + qiihr(mgs) = hrifac*ciihr(mgs)/rho0(mgs) + qiihr(mgs) = max(qiihr(mgs), 0.0) + qiihr(mgs) = min(qiihr(mgs),qcmxd(mgs)) + ENDIF +! + if ( xplate(mgs) .eq. 1 ) then + qipiphr(mgs) = qiihr(mgs) + cipiphr(mgs) = ciihr(mgs) + end if +! + if ( xcolmn(mgs) .eq. 1 ) then + qicichr(mgs) = qiihr(mgs) + cicichr(mgs) = ciihr(mgs) + end if +! +! qipiphr(mgs) = 0.0 +! qicichr(mgs) = qiihr(mgs) +! + end if + end if + ENDIF ! ihrn + end do +! +! +! +! simple frozen rain to hail conversion. All of the +! frozen rain larger than 5.0e-3 m in diameter are converted +! to hail. This is done by considering the equation for +! frozen rain mixing ratio: +! +! +! qfw = [ cno(lf) * pi * fwdn / (6 rhoair) ] +! +! /inf +! * | fwdia*3 exp(-dia/fwdia) d(dia) +! /Do +! +! The amount to be reclassified as hail is the integral above from +! Do to inf where Do is 5.0e-3 m. +! +! +! qfauh = [ cno(lf) * pi * fwdn / (6 rhoair) ] +! +! + + + hdia0 = 300.0e-6 + do mgs = 1,ngscnt + qscnvi(mgs) = 0.0 + cscnvi(mgs) = 0.0 + cscnvis(mgs) = 0.0 +! IF ( .false. ) THEN +! IF ( temg(mgs) .lt. tfr .and. ssi(mgs) .gt. 1.01 .and. qx(mgs,li) .gt. qxmin(li) ) THEN + IF ( temg(mgs) .lt. tfr .and. qx(mgs,li) .gt. qxmin(li) ) THEN + IF ( ipconc .ge. 4 .and. .false. ) THEN + if ( cx(mgs,li) .gt. 10. .and. xdia(mgs,li,1) .gt. 50.e-6 ) then !{ + cirdiatmp = & + & (qx(mgs,li)*rho0(mgs) & + & /(pi*xdn(mgs,li)*cx(mgs,li)))**(1./3.) + IF ( cirdiatmp .gt. 100.e-6 ) THEN !{ + qscnvi(mgs) = & + & ((pi*xdn(mgs,li)*cx(mgs,li)) / (6.0*rho0(mgs)*dtp)) & + & *exp(-hdia0/cirdiatmp) & + & *( (hdia0**3) + 3.0*(hdia0**2)*cirdiatmp & + & + 6.0*(hdia0)*(cirdiatmp**2) + 6.0*(cirdiatmp**3) ) + qscnvi(mgs) = & + & min(qscnvi(mgs),qimxd(mgs)) + IF ( ipconc .ge. 4 ) THEN + cscnvi(mgs) = Min( cimxd(mgs), cx(mgs,li)*Exp(-hdia0/cirdiatmp)) + ENDIF + ENDIF ! } + end if ! } + + ELSEIF ( ipconc .lt. 4 ) THEN + + qscnvi(mgs) = 0.001*eii(mgs)*max((qx(mgs,li)-1.e-3),0.0) + qscnvi(mgs) = min(qscnvi(mgs),qxmxd(mgs,li)) + cscnvi(mgs) = qscnvi(mgs)*rho0(mgs)/xmas(mgs,li) + cscnvis(mgs) = 0.5*cscnvi(mgs) + + ENDIF + ENDIF +! ENDIF + end do + + + +! +! Ventilation coeficients +! + do mgs = 1,ngscnt + fvent(mgs) = (fschm(mgs)**(1./3.)) * (fakvisc(mgs)**(-0.5)) + end do +! +! + if ( ndebug .gt. 0 ) write(0,*) 'civent' +! + civenta = 1.258e4 + civentb = 2.331 + civentc = 5.662e4 + civentd = 2.373 + civente = 0.8241 + civentf = -0.042 + civentg = 1.70 + + do mgs = 1,ngscnt + IF ( icond .eq. 1 .or. temg(mgs) .le. tfrh & + & .or. (qx(mgs,lr) .le. qxmin(lr) .and. qx(mgs,lc) .le. qxmin(lc)) ) THEN + IF ( qx(mgs,li) .gt. qxmin(li) ) THEN + cireyn = & + & (civenta*xdia(mgs,li,1)**civentb & + & +civentc*xdia(mgs,li,1)**civentd) & + & / & + & (civente*xdia(mgs,li,1)**civentf+civentg) + xcivent = (fschm(mgs)**(1./3.))*((cireyn/fakvisc(mgs))**0.5) + if ( xcivent .lt. 1.0 ) then + civent(mgs) = 1.0 + 0.14*xcivent**2 + end if + if ( xcivent .ge. 1.0 ) then + civent(mgs) = 0.86 + 0.28*xcivent + end if + ELSE + civent(mgs) = 0.0 + ENDIF + + + ENDIF ! icond .eq. 1 + end do + +! +! + igmrwa = 100.0*2.0 + igmrwb = 100.*((5.0+br)/2.0) + rwventa = (0.78)*gmoi(igmrwa) ! 0.78 + rwventb = (0.308)*gmoi(igmrwb) ! 0.562825 + do mgs = 1,ngscnt + IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN + IF ( ipconc .ge. 3 ) THEN + IF ( imurain == 3 ) THEN + IF ( izwisventr == 1 ) THEN + rwvent(mgs) = ventrx(mgs)*(1.6 + 124.9*(1.e-3*rho0(mgs)*qx(mgs,lr))**.2046) + ELSE ! izwisventr = 2 +! Following Wisner et al. (1972) but using gamma of volume. Note that Ferrier rain fall speed does not integrate with gamma of volume, so using Vr = ar*d^br + rwvent(mgs) = & + & (0.78*ventrx(mgs) + 0.308*ventrxn(mgs)*fvent(mgs) & + & *Sqrt((ar*rhovt(mgs))) & + & *(xdia(mgs,lr,1)**((1.0+br)/2.0)) ) + ENDIF + + ELSE ! imurain == 1 + ! linear interpolation of complete gamma function +! tmp = 2. + alpha(mgs,lr) +! i = Int(dgami*(tmp)) +! del = tmp - dgam*i +! x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + IF ( iferwisventr == 1 ) THEN + + ! Ferrier fall speed in the ventillation term [uses fx(lr) ] + + alpr = Min(alpharmax,alpha(mgs,lr) ) + + x = 1. + alpha(mgs,lr) + + IF ( lzr > 1 ) THEN ! 3 moment +! + ELSE + y = ventrxn(mgs) + ENDIF + +! vent1 = dble(xdia(mgs,lr,1))**(-2. - alpr) ! Actually OK +! vent2 = dble(1./xdia(mgs,lr,1) + 0.5*fx(lr))**dble(2.5+alpr+0.5*bx(lr)) ! Actually OK + vent1 = dble(xdia(mgs,lr,1))**(0.5 + 0.5*bx(lr)) ! 2016.2.26 Changed for consistency with derivation (recast formula -- should be equivalent) + vent2 = dble(1. + 0.5*fx(lr)*xdia(mgs,lr,1))**dble(2.5+alpr+0.5*bx(lr)) + + + rwvent(mgs) = & + & 0.78*x + & + & 0.308*fvent(mgs)*y* & + & Sqrt(ax(lr)*rhovt(mgs))*(vent1/vent2) + + + ELSEIF ( iferwisventr == 2 ) THEN + +! Following Wisner et al. (1972) but using gamma of volume. Note that Ferrier rain fall speed does not integrate with gamma of volume, so using Vr = ar*d^br + x = 1. + alpha(mgs,lr) + + rwvent(mgs) = & + & (0.78*x + 0.308*ventrxn(mgs)*fvent(mgs) & + & *Sqrt((ar*rhovt(mgs))) & + & *(xdia(mgs,lr,1)**((1.0+br)/2.0)) ) + + + + ENDIF ! iferwisventr + + ENDIF ! imurain + ELSE + rwvent(mgs) = & + & (rwventa + rwventb*fvent(mgs) & + & *Sqrt((ar*rhovt(mgs))) & + & *(xdia(mgs,lr,1)**((1.0+br)/2.0)) ) + ENDIF + ELSE + rwvent(mgs) = 0.0 + ENDIF + end do +! + igmswa = 100.0*2.0 + igmswb = 100.*((5.0+ds)/2.0) + swventa = (0.78)*gmoi(igmswa) + swventb = (0.308)*gmoi(igmswb) + do mgs = 1,ngscnt + IF ( qx(mgs,ls) .gt. qxmin(ls) ) THEN + IF ( ipconc .ge. 4 ) THEN + swvent(mgs) = 0.65 + 0.44*fvent(mgs)*Sqrt(vtxbar(mgs,ls,1)*xdia(mgs,ls,1)) + ELSE +! 10-ice version: + swvent(mgs) = & + & (swventa + swventb*fvent(mgs) & + & *Sqrt((cs*rhovt(mgs))) & + & *(xdia(mgs,ls,1)**((1.0+ds)/2.0)) ) + ENDIF + ELSE + swvent(mgs) = 0.0 + ENDIF + end do +! +! + + igmhwa = 100.0*2.0 + igmhwb = 100.0*2.75 + hwventa = (0.78)*gmoi(igmhwa) + hwventb = (0.308)*gmoi(igmhwb) +! hwventc = (4.0*gr/(3.0*cdx(lh)))**(0.25) + do mgs = 1,ngscnt + IF ( qx(mgs,lh) .gt. qxmin(lh) ) THEN + hwventc = (4.0*gr/(3.0*cdxgs(mgs,lh)))**(0.25) + IF ( .false. .or. alpha(mgs,lh) .eq. 0.0 ) THEN + hwvent(mgs) = & + & ( hwventa + hwventb*hwventc*fvent(mgs) & + & *((xdn(mgs,lh)/rho0(mgs))**(0.25)) & + & *(xdia(mgs,lh,1)**(0.75))) + ELSE ! Ferrier 1994, eq. B.36 + ! linear interpolation of complete gamma function +! tmp = 2. + alpha(mgs,lh) +! i = Int(dgami*(tmp)) +! del = tmp - dgam*i +! x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + +! note that hwvent includes a division by Gamma(1+alpha), so Gamma(2+alpha)/Gamma(1+alpha) = 1 + alpha +! and g1palp = Gamma(1+alpha) divides into y + x = 1. + alpha(mgs,lh) + + tmp = 1 + alpha(mgs,lh) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = 2.5 + alpha(mgs,lh) + 0.5*bxx(mgs,lh) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = (gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami)/g1palp + + + hwventy(mgs) = 0.308*fvent(mgs)*(xdia(mgs,lh,1)**(0.5 + 0.5*bxx(mgs,lh)))*Sqrt(axx(mgs,lh)*rhovt(mgs)) + hwvent(mgs) = & + & ( 0.78*x + y*hwventy(mgs) ) ! & +! & 0.308*fvent(mgs)*y*(xdia(mgs,lh,1)**(0.5 + 0.5*bxx(mgs,lh)))* & +! & Sqrt(axx(mgs,lh)*rhovt(mgs)) ) + + ENDIF + ELSE + hwvent(mgs) = 0.0 + hwventy(mgs) = 0.0 + ENDIF + end do + + + hlvent(:) = 0.0 + hlventy(:) = 0.0 + + IF ( lhl .gt. 1 ) THEN + igmhwa = 100.0*2.0 + igmhwb = 100.0*2.75 + hwventa = (0.78)*gmoi(igmhwa) + hwventb = (0.308)*gmoi(igmhwb) +! hwventc = (4.0*gr/(3.0*cdx(lhl)))**(0.25) + do mgs = 1,ngscnt + IF ( qx(mgs,lhl) .gt. qxmin(lhl) ) THEN + hwventc = (4.0*gr/(3.0*cdxgs(mgs,lhl)))**(0.25) + + IF ( .false. .or. alpha(mgs,lhl) .eq. 0.0 ) THEN + hlvent(mgs) = & + & ( hwventa + hwventb*hwventc*fvent(mgs) & + & *((xdn(mgs,lhl)/rho0(mgs))**(0.25)) & + & *(xdia(mgs,lhl,1)**(0.75))) + ELSE ! Ferrier 1994, eq. B.36 + ! linear interpolation of complete gamma function +! tmp = 2. + alpha(mgs,lhl) +! i = Int(dgami*(tmp)) +! del = tmp - dgam*i +! x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + +! note that hlvent includes a division by Gamma(1+alpha), so x = Gamma(2+alpha)/Gamma(1+alpha) = 1 + alpha +! and g1palp = Gamma(1+alpha) divides into y + + x = 1. + alpha(mgs,lhl) + + tmp = 1 + alpha(mgs,lhl) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = 2.5 + alpha(mgs,lhl) + 0.5*bxx(mgs,lhl) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = (gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami)/g1palp ! ratio of gamma functions + + hlventy(mgs) = 0.308*fvent(mgs)*(xdia(mgs,lhl,1)**(0.5 + 0.5*bxx(mgs,lhl)))*Sqrt(axx(mgs,lhl)*rhovt(mgs)) + + hlvent(mgs) = 0.78*x + y*hlventy(mgs) ! & +! & 0.308*fvent(mgs)*y*(xdia(mgs,lhl,1)**(0.5 + 0.5*bxx(mgs,lhl)))* & +! & Sqrt(axx(mgs,lhl)*rhovt(mgs))) +! : Sqrt(xdn(mgs,lhl)*ax(lhl)*rhovt(mgs)/rg0))/tmp + + ENDIF + ENDIF + end do + ENDIF + +! +! +! +! Wet growth constants +! + do mgs = 1,ngscnt + fwet1(mgs) = & + & (2.0*pi)* & + & ( felv(mgs)*fwvdf(mgs)*rho0(mgs)*(qss0(mgs)-qx(mgs,lv)) & + & -ftka(mgs)*temcg(mgs) ) & + & / ( rho0(mgs)*(felf(mgs)+fcw(mgs)*temcg(mgs)) ) + fwet2(mgs) = & + & (1.0)-fci(mgs)*temcg(mgs) & + & / ( felf(mgs)+fcw(mgs)*temcg(mgs) ) + end do +! +! Melting constants +! + do mgs = 1,ngscnt + fmlt1(mgs) = (2.0*pi)* & + & ( felv(mgs)*fwvdf(mgs)*(qss0(mgs)-qx(mgs,lv)) & + & -ftka(mgs)*temcg(mgs)/rho0(mgs) ) & + & / (felf(mgs)) + fmlt2(mgs) = -fcw(mgs)*temcg(mgs)/felf(mgs) + end do +! +! Vapor Deposition constants +! + do mgs = 1,ngscnt + fvds(mgs) = & + & (4.0*pi/rho0(mgs))*(ssi(mgs)-1.0)* & + & (1.0/(fai(mgs)+fbi(mgs))) + end do + do mgs = 1,ngscnt + fvce(mgs) = & + & (4.0*pi/rho0(mgs))*(ssw(mgs)-1.0)* & + & (1.0/(fav(mgs)+fbv(mgs))) + end do + +! +! deposition, sublimation, and melting of snow, graupel and hail +! + qsmlr(:) = 0.0 + qimlr(:) = 0.0 ! this is not used. qi melts to qc way down in the code. + qhmlr(:) = 0.0 + qhlmlr(:) = 0.0 + IF ( lhwlg > 1 ) THEN + qhmlrlg(:) = 0.0 + qhlmlrlg(:) = 0.0 + ENDIF + qhfzh(:) = 0.0 + qhlfzhl(:) = 0.0 + qhfzhlg(:) = 0.0 + qhlfzhllg(:) = 0.0 + vhfzh(:) = 0.0 + vffzf(:) = 0.0 + vhlfzhl(:) = 0.0 + qsfzs(:) = 0.0 + zsmlr(:) = 0.0 + zhmlr(:) = 0.0 + zhmlrr(:) = 0.0 + zhshr(:) = 0.0 + zhlmlr(:) = 0.0 + zhlshr(:) = 0.0 + + zhshrr(:) = 0.0 + zhlmlrr(:) = 0.0 + zhlshrr(:) = 0.0 + + csmlr(:) = 0.0 + csmlrr(:) = 0.0 + chmlr(:) = 0.0 + chmlrr(:) = 0.0 + chlmlr(:) = 0.0 + chlfmlr(:) = 0.0 +! chlmlrsave(:) = 0.0 +! qhlmlrsave(:) = 0.0 +! chlsave(:) = 0.0 +! qhlsave(:) = 0.0 + chlmlrr(:) = 0.0 + + + if ( .not. mixedphase ) then !{ + do mgs = 1,ngscnt +! + IF ( temg(mgs) .gt. tfr ) THEN + + IF ( qx(mgs,ls) .gt. qxmin(ls) ) THEN + qsmlr(mgs) = & + & min( & + & (c1sw*fmlt1(mgs)*cx(mgs,ls)*swvent(mgs)*xdia(mgs,ls,1) ) & ! /rhosm & + & , 0.0 ) + ENDIF + + +! IF ( qx(mgs,ls) .gt. 0.1e-4 ) write(0,*) 'qsmlr: ',qsmlr(mgs),qx(mgs,ls),cx(mgs,ls),fmlt1(mgs), +! : temcg(mgs),swvent(mgs),xdia(mgs,ls,1),qss0(mgs)-qx(mgs,lv) +! ELSE +! qsmlr(mgs) = 0.0 +! ENDIF +! 10ice version: +! > min( +! > (fmlt1(mgs)*cx(mgs,ls)*swvent(mgs)*xdia(mgs,ls,1) + +! > fmlt2(mgs)*(qsacr(mgs)+qsacw(mgs)) ) +! < , 0.0 ) + + IF ( qx(mgs,lh) .gt. qxmin(lh) ) THEN + + IF ( ibinhmlr == 0 .or. lzh < 1 ) THEN + qhmlr(mgs) = & + & meltfac*min( & + & fmlt1(mgs)*cx(mgs,lh)*hwvent(mgs)*xdia(mgs,lh,1) & + & + fmlt2(mgs)*(qhacrmlr(mgs)+qhacw(mgs)) & + & , 0.0 ) + ELSEIF ( ibinhmlr == 1 ) THEN ! use incomplete gamma functions to approximate the bin results + + errmsg = 'ibinhmlr = 1 not available for 2-moment' + errflg = 1 + RETURN + + ELSEIF ( ibinhmlr == 2 .or. ibinhmlr == 3 ) THEN + + ENDIF + + + IF ( ivhmltsoak > 0 .and. qhmlr(mgs) < 0.0 .and. lvol(lh) > 1 .and. xdn(mgs,lh) .lt. xdnmx(lh) ) THEN + ! act as if 100% of the meltwater were soaked into the graupel + v1 = (1. - xdn(mgs,lh)/xdnmx(lh))*(vx(mgs,lh) + rho0(mgs)*qhmlr(mgs)/xdn(mgs,lh) )/(dtp) ! volume available for filling + v2 = -1.0*rho0(mgs)*qhmlr(mgs)/xdnmx(lh) ! volume of melted ice if it were refrozen in the matrix + + vhsoak(mgs) = Min(v1,v2) + + ENDIF + + ENDIF ! qx(mgs,lh) .gt. qxmin(lh) + + + IF ( lhl .gt. 1 .and. lhlw < 1 ) THEN + + IF ( qx(mgs,lhl) .gt. qxmin(lhl) ) THEN + IF ( ibinhlmlr == 0 .or. lzhl < 1) THEN + qhlmlr(mgs) = & + & meltfac*min( & + & fmlt1(mgs)*cx(mgs,lhl)*hlvent(mgs)*xdia(mgs,lhl,1) & + & + fmlt2(mgs)*(qhlacrmlr(mgs)+qhlacw(mgs)) & + & , 0.0 ) + + ELSEIF ( ibinhlmlr == 1 ) THEN ! use incomplete gamma functions to approximate the bin results + +! #ifdef Z3MOM +! #if (defined Z3MOM) && defined( COMMAS ) || defined( COMMASTMP ) + + ELSEIF ( ibinhlmlr == -1 ) THEN ! OLD VERSION use incomplete gamma functions to approximate the bin results + + ENDIF ! ibinhlmlr + + + IF ( ivhmltsoak > 0 .and. qhlmlr(mgs) < 0.0 .and. lvol(lhl) > 1 .and. xdn(mgs,lhl) .lt. xdnmx(lhl) ) THEN + ! act as if 50% of the meltwater were soaked into the graupel + v1 = (1. - xdn(mgs,lhl)/xdnmx(lhl))*(vx(mgs,lhl) + rho0(mgs)*qhlmlr(mgs)/xdn(mgs,lhl) )/(dtp) ! volume available for filling + v2 = -1.0*rho0(mgs)*qhlmlr(mgs)/xdnmx(lhl) ! volume of melted ice if it were refrozen in the matrix + + vhlsoak(mgs) = Min(v1,v2) + + ENDIF + + ENDIF + ENDIF + + ENDIF + +! +! qimlr(mgs) = max( qimlr(mgs), -qimxd(mgs) ) +! qsmlr(mgs) = max( qsmlr(mgs), -qsmxd(mgs) ) +! erm 5/10/2007 changed to next line: + if ( .not. mixedphase ) qsmlr(mgs) = max( qsmlr(mgs), Min( -qsmxd(mgs), -0.7*qx(mgs,ls)*dtpinv ) ) + IF ( .not. mixedphase ) THEN + qhmlr(mgs) = max( qhmlr(mgs), Min( -qhmxd(mgs), -0.95*qx(mgs,lh)*dtpinv ) ) + chmlr(mgs) = max( chmlr(mgs), Min( -chmxd(mgs), -0.95*cx(mgs,lh)*dtpinv ) ) + ENDIF +! qhmlr(mgs) = max( max( qhmlr(mgs), -qhmxd(mgs) ) , -0.5*qx(mgs,lh)*dtpinv ) !limits to 1/2 qh or max depletion + qhmlh(mgs) = 0. + + + ! Rasmussen and Heymsfield say melt water remains on graupel up to 9 mm before shedding + + + IF ( lhl .gt. 1 .and. lhlw < 1 ) THEN + qhlmlr(mgs) = max( qhlmlr(mgs), Min( -qxmxd(mgs,lhl), -0.95*qx(mgs,lhl)*dtpinv ) ) + chlmlr(mgs) = max( chlmlr(mgs), Min( -cxmxd(mgs,lhl), -0.95*cx(mgs,lhl)*dtpinv ) ) + ENDIF + +! + end do + + endif ! } not mixedphase +! + if ( ipconc .ge. 1 ) then + do mgs = 1,ngscnt + cimlr(mgs) = (cx(mgs,li)/(qx(mgs,li)+1.e-20))*qimlr(mgs) + IF ( .not. mixedphase ) THEN !{ + IF ( xdia(mgs,ls,1) .gt. 1.e-6 .and. -qsmlr(mgs) .ge. 0.5*qxmin(ls) .and. ipconc .ge. 4 ) THEN +! csmlr(mgs) = rho0(mgs)*qsmlr(mgs)/(xv(mgs,ls)*rhosm) + csmlr(mgs) = (cx(mgs,ls)/(qx(mgs,ls)))*qsmlr(mgs) + ELSEIF ( qx(mgs,ls) > qxmin(ls) ) THEN + csmlr(mgs) = (cx(mgs,ls)/(qx(mgs,ls)))*qsmlr(mgs) + ENDIF + + csmlrr(mgs) = csmlr(mgs)/rzxs(mgs) + IF ( -csmlrr(mgs)*dtp > cxmin .and. -qsmlr(mgs)*dtp > qxmin(lr) .and. snowmeltdia > 0.0 ) THEN + rmas = rho0(mgs)*qsmlr(mgs)/csmlrr(mgs) + IF ( rmas > snowmeltmass ) THEN + csmlrr(mgs) = rho0(mgs)*qsmlr(mgs)/snowmeltmass + ENDIF + ENDIF + + + +! IF ( xdia(mgs,lh,1) .gt. 1.e-6 .and. Abs(qhmlr(mgs)) .ge. qxmin(lh) ) THEN +! chmlr(mgs) = rho0(mgs)*qhmlr(mgs)/(pi*xdn(mgs,lh)*xdia(mgs,lh,1)**3) ! out of hail +! chmlr(mgs) = Max( chmlr(mgs), -chmxd(mgs) ) +! ELSE + IF ( ibinhmlr == 0 .or. lzh < 1 ) THEN + chmlr(mgs) = (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhmlr(mgs) + IF ( imltshddmr == 3 .and. qhmlr(mgs) < -qxmin(lh) ) THEN + ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) + ! + ! IF ( tmpdiam > sheddiam ) THEN ! let size get smaller until it reaches sheddiam + ! chmlr(mgs) = 0.0 + ! ENDIF + + ! test to remove the part of the melting associated with large ice particles so they get smaller + + tmp = 1. + alpha(mgs,lh) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + ratio = Min( maxratiolu, mltdiam1/xdia(mgs,lh,1) ) + + x = gamxinfdp(2. + alpha(mgs,lh), ratio)/g1palp + y = gamxinfdp(2.5 + alpha(mgs,lh) + 0.5*bxx(mgs,lh), ratio)/g1palp + + hwvent1 = 0.78*x + y*hwventy(mgs) + + qhlmlr1 = min( fmlt1(mgs)*cx(mgs,lh)*hwvent1*xdia(mgs,lh,1), 0.0 ) + + chmlr(mgs) = (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*(qhmlr(mgs) - qhlmlr1) + + + ENDIF +! IF ( igs(mgs) == 40 ) THEN +! write(0,*) 'is this running? chmlr = ',kgs(mgs), chmlr(mgs) +! ENDIF + ENDIF +! ENDIF + + + + IF ( chmlr(mgs) < 0.0 .and. (ibinhmlr < 1 .or. lzh < 1) ) THEN ! { already done if ibinhmlr > 0 + + IF ( ibinhmlr == 0 .or. lzh < 1 ) THEN + IF ( ihmlt .eq. 1 ) THEN + chmlrr(mgs) = Min( chmlr(mgs), rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lr)*vmlt) ) ! into rain + ELSEIF ( ihmlt .eq. 2 ) THEN + IF ( xv(mgs,lh) .gt. 0.0 .and. chmlr(mgs) .lt. 0.0 ) THEN +! chmlrr(mgs) = Min( chmlr(mgs), rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lh)*xv(mgs,lh)) ) ! into rain +! guess what, this is the same as chmlr: rho0*qhmlr/xmas(lh) --> cx/qx = rho0/xmas + IF(imltshddmr == 1) THEN + ! DTD: If Dmg < sheddiam, then assume complete melting into + ! maximal raindrop. Between sheddiam and sheddiam0 mm, linearly ramp down to a 3 mm shed drop + tmp = -rho0(mgs)*qhmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lh)*xv(mgs,lh))) ! Min of Maximum raindrop size/mean hail size + tmp2 = -rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lr)*vr3mm) ! conc. change for a 3 mm mean drop diameter + + chmlrr(mgs) = tmp*(sheddiam0-xdia(mgs,lh,3))/(sheddiam0-sheddiam)+tmp2*(xdia(mgs,lh,3)-sheddiam)/(sheddiam0-sheddiam) ! old version + chmlrr(mgs) = -Max(tmp,Min(tmp2,chmlrr(mgs))) + ELSEIF ( imltshddmr == 2 .or. imltshddmr == 3 ) THEN + ! 8/26/2015 ERM updated to use shedalp and tmpdiam + ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) + chmlrr(mgs) = rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lr)*vshdgs(mgs,lh)) ! into rain + ELSE ! Old method + chmlrr(mgs) = rho0(mgs)*qhmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lh)*xv(mgs,lh))) ! into rain + ENDIF + ELSE + chmlrr(mgs) = chmlr(mgs) + ENDIF + ELSEIF ( ihmlt .eq. 0 ) THEN + chmlrr(mgs) = chmlr(mgs) + ENDIF + + ELSE ! ibinhmlr < 0? Already have an outer IF test for ibinhmlr < 1 + chmlrr(mgs) = Min( chmlrr(mgs), rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lr)*xvmx(lr)) ) ! into rain + ENDIF + + ENDIF ! } ( chmlr(mgs) < 0.0 .and. ibinhmlr < 1) + + IF ( lhl .gt. 1 .and. lhlw < 1 .and. .not. mixedphase .and. qhlmlr(mgs) < 0.0 ) THEN ! { + + IF ( ibinhlmlr == 0 .or. lzhl < 1 ) THEN +! IF ( xdia(mgs,lhl,1) .gt. 1.e-6 .and. Abs(qhlmlr(mgs)) .ge. qxmin(lhl) ) THEN +! chlmlr(mgs) = rho0(mgs)*qhlmlr(mgs)/(pi*xdn(mgs,lhl)*xdia(mgs,lhl,1)**3) ! out of hail +! chlmlr(mgs) = Max( chlmlr(mgs), -cxmxd(mgs,lhl) ) +! ELSE + chlmlr(mgs) = (cx(mgs,lhl)/(qx(mgs,lhl)+1.e-20))*qhlmlr(mgs) + IF ( imltshddmr == 3 .and. qhlmlr(mgs) < -qxmin(lhl) ) THEN +! IF ( .false. .and. imltshddmr == 3 ) THEN +! tmpdiam = (shedalp+alpha(mgs,lhl))*xdia(mgs,lhl,1) +! +! IF ( tmpdiam > sheddiam ) THEN ! let size get smaller until it reaches sheddiam +! chlmlr(mgs) = 0.0 +! ENDIF + + ! test to remove the part of the melting associated with large ice particles so they get smaller +! + tmp = 1. + alpha(mgs,lhl) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + ratio = Min( maxratiolu, mltdiam1/xdia(mgs,lhl,1) ) + + x = gamxinfdp(2. + alpha(mgs,lhl), ratio)/g1palp + y = gamxinfdp(2.5 + alpha(mgs,lhl) + 0.5*bxx(mgs,lhl), ratio)/g1palp + + hwvent1 = 0.78*x + y*hlventy(mgs) + + qhlmlr1 = min( fmlt1(mgs)*cx(mgs,lhl)*hwvent1*xdia(mgs,lhl,1), 0.0 ) + + chlmlr(mgs) = (cx(mgs,lhl)/(qx(mgs,lhl)+1.e-20))*Min(0.0, qhlmlr(mgs) - qhlmlr1) + + ENDIF +! ENDIF + ENDIF + + IF ( ibinhlmlr == 0 .or. lzhl < 1 ) THEN !{ + IF ( ihmlt .eq. 1 ) THEN + chlmlrr(mgs) = Min( chlmlr(mgs), rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lr)*vmlt) ) ! into rain + ELSEIF ( ihmlt .eq. 2 ) THEN + IF ( xv(mgs,lhl) .gt. 0.0 .and. chlmlr(mgs) .lt. 0.0 ) THEN +! chlmlrr(mgs) = rho0(mgs)*qhlmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl))) ! into rain +! chlmlrr(mgs) = Min( chlmlr(mgs), rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lhl)*xv(mgs,lhl)) ) ! into rain + IF(imltshddmr == 1 ) THEN + tmp = -rho0(mgs)*qhlmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl))) ! Min of Maximum raindrop size/mean hail size + tmp2 = -rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lr)*vr3mm) ! conc. change for a 3 mm mean drop diameter + chlmlrr(mgs) = tmp*(20.e-3-xdia(mgs,lhl,3))/(20.e-3-sheddiam)+tmp2*(xdia(mgs,lhl,3)-sheddiam)/(20.e-3-sheddiam) + chlmlrr(mgs) = -Max(tmp,Min(tmp2,chlmlrr(mgs))) + ELSEIF ( imltshddmr == 2 .or. imltshddmr == 3 ) THEN + ! 8/26/2015 ERM updated to use shedalp and tmpdiam + ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) + chlmlrr(mgs) = rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lr)*vshdgs(mgs,lhl)) ! into rain + ELSE ! old method + chlmlrr(mgs) = rho0(mgs)*qhlmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl))) ! into rain + ENDIF + ELSE + chlmlrr(mgs) = chlmlr(mgs) + ENDIF + ELSEIF ( ihmlt .eq. 0 ) THEN + chlmlrr(mgs) = chlmlr(mgs) + ENDIF + + ELSE ! } { ibinhlmlr > 0 + chlmlrr(mgs) = Min( chlmlrr(mgs), rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lr)*xvmx(lr)) ) ! into rain + ENDIF !} + + + ENDIF ! } + + ENDIF ! }.not. mixedphase + +! 10ice versions: +! chmlr(mgs) = (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhmlr(mgs) +! chmlrr(mgs) = chmlr(mgs) + end do + end if + +! +! deposition/sublimation of ice +! + DO mgs = 1,ngscnt + + rwcap(mgs) = (0.5)*xdia(mgs,lr,1) + swcap(mgs) = (0.5)*xdia(mgs,ls,1) + hwcap(mgs) = (0.5)*xdia(mgs,lh,1) + IF ( lhl .gt. 1 ) hlcap(mgs) = (0.5)*xdia(mgs,lhl,1) + + if ( qx(mgs,li).gt.qxmin(li) .and. xdia(mgs,li,1) .gt. 0.0 ) then +! +! from Cotton, 1972 (Part II) +! + cilen(mgs) = 0.4764*(xdia(mgs,li,1))**(0.958) + cval = xdia(mgs,li,1) + aval = cilen(mgs) + eval = Sqrt(1.0-(aval**2)/(cval**2)) + fval = min(0.99,eval) + gval = alog( abs( (1.+fval)/(1.-fval) ) ) + cicap(mgs) = cval*fval / gval + ELSE + cicap(mgs) = 0.0 + end if + ENDDO +! +! + qhldsv(:) = 0.0 + + do mgs = 1,ngscnt + IF ( icond .eq. 1 .or. temg(mgs) .le. tfrh & + & .or. (qx(mgs,lr) .le. qxmin(lr) .and. qx(mgs,lc) .le. qxmin(lc)) ) THEN + qidsv(mgs) = & + & fvds(mgs)*cx(mgs,li)*civent(mgs)*cicap(mgs)*depfac + qsdsv(mgs) = & + & fvds(mgs)*cx(mgs,ls)*swvent(mgs)*swcap(mgs)*depfac +! IF ( ny .eq. 2 .and. igs(mgs) .eq. 302 .and. temg(mgs) .le. tfrh+10 .and. qx(mgs,lv) .gt. qis(mgs) +! : .and. qx(mgs,li) .gt. qxmin(li) ) THEN +! write(0,*) 'qidsv = ',nstep,kgs(mgs),qidsv(mgs),temg(mgs)-tfrh,100.*(qx(mgs,lv)/qis(mgs) - 1.),1.e6*xdia(mgs,li,1), +! : fvds(mgs),civent(mgs),cicap(mgs) +! ENDIF + ELSE + qidsv(mgs) = 0.0 + qsdsv(mgs) = 0.0 + ENDIF + qhdsv(mgs) = & + & fvds(mgs)*cx(mgs,lh)*hwvent(mgs)*hwcap(mgs)*depfac + + IF ( lhl .gt. 1 ) qhldsv(mgs) = fvds(mgs)*cx(mgs,lhl)*hlvent(mgs)*hlcap(mgs)*depfac +! +! + end do +! + + +! #include "nssl.qlimit.F" + +! +! Use a test saturation adjustment to set limits on ice deposition/sublimation +! and rain evaporation +! +! + IF ( DoSublimationFix ) THEN + + do mgs = 1,ngscnt + + qitmp(mgs) = qx(mgs,li) + qx(mgs,ls) + qx(mgs,lh) + IF ( lis > 1 ) qitmp(mgs) = qitmp(mgs) + qx(mgs,lis) + IF ( lhl > 1 ) qitmp(mgs) = qitmp(mgs) + qx(mgs,lhl) + qrtmp(mgs) = qx(mgs,lr) + qctmp(mgs) = qx(mgs,lc) + qsimxdep(mgs) = 0.0 + qsimxsub(mgs) = 0.0 + dqcitmp(mgs) = 0.0 + + +! IF ( ( qitmp(mgs) > qxmin(li) .or. qrtmp(mgs) > qxmin(lr) ) ) THEN + IF ( qitmp(mgs) > qxmin(li) ) THEN + + qitmp1 = qitmp(mgs) + qctmp1 = qctmp(mgs) + felvcptmp = felvcp(mgs) + felscptmp = felscp(mgs) + qvtmp(mgs) = qx(mgs,lv) + qss(mgs) = qvs(mgs) + qsstmp = qvs(mgs) + qvstmp = qvs(mgs) + qisstmp = qis(mgs) + thetatmp = theta(mgs) + thetaptmp = thetap(mgs) + temgtmp = temg(mgs) + temcgtmp = temcg(mgs) + qvaptmp = qx(mgs,lv) ! qwvp(mgs) + qv0(mgs) + qvptmp = 0.0 ! qwvp(mgs) ! qv pertubation + + qsstmp = qisstmp + + + dqwvtmp(mgs) = ( qvtmp(mgs) - qsstmp ) + + do itertd = 1,2 + +! +! calculate super-saturation +! + IF ( itertd == 1 ) THEN + + ELSE + dqcitmp(mgs) = dqci(mgs) + ! dqwvtmp(mgs) = dqwv(mgs) + ENDIF + + dqcw(mgs) = 0.0 + dqci(mgs) = 0.0 + dqwv(mgs) = ( qvtmp(mgs) - qsstmp ) +! +! evaporation and sublimation adjustment +! + if( dqwv(mgs) .lt. 0. ) then ! { subsaturated + if( qitmp(mgs) .gt. -dqwv(mgs) ) then ! check if qi can make up all the deficit + dqci(mgs) = dqwv(mgs) + dqwv(mgs) = 0. + else ! otherwise make all ice available for sublimation + dqci(mgs) = -qitmp(mgs) + dqwv(mgs) = dqwv(mgs) + qitmp(mgs) + end if +! + qvptmp = qvptmp - ( dqcw(mgs) + dqci(mgs) ) ! add to perturbation vapor + + IF ( itertd == 2 .and. eqtset > 1 ) THEN + ! if eqtset == 2, then need to update the latent heats for change in hydrometeor content + tmp = qitmp(mgs) !+ qx(mgs,lh) +! IF ( lhl > 1 ) tmp = tmp + qx(mgs,lhl) + cvm = cv+cvv*qvtmp(mgs)+cpl*(qx(mgs,lc)+qrtmp(mgs)) & + +cpigb*(tmp) + + felvcptmp = (felv(mgs)-rw*temg(mgs))/cvm + felscptmp = (fels(mgs)-rw*temg(mgs))/cvm + ENDIF + + +! qitmp(mgs) = qx(mgs,li) + qctmp(mgs) = qctmp(mgs) + dqcw(mgs) ! dqcw is zero + qitmp(mgs) = qitmp(mgs) + dqci(mgs) + thetaptmp = thetaptmp + & + & 1./pi0(mgs)* & + & (felvcp(mgs)*dqcw(mgs) +felscp(mgs)*dqci(mgs)) + + + end if ! } dqwv(mgs) .lt. 0. (end of evap/sublim) +! +! condensation/deposition +! + IF ( dqwv(mgs) .ge. 0. ) THEN ! { + +! write(iunit,*) 'satadj: mgs,iter = ',mgs,itertd,dqwv(mgs),qss(mgs),qx(mgs,lv),qx(mgs,lc) +! +! qitmp(mgs) = qx(mgs,li) + fracl(mgs) = 0.0 + fraci(mgs) = 1.0 + if ( temg(mgs) .lt. tfr .and. temg(mgs) .gt. thnuc ) then +! fracl(mgs) = max(min(1.,(temg(mgs)-233.15)/(20.)),0.0) +! fraci(mgs) = 1.0-fracl(mgs) + end if + if ( temg(mgs) .le. thnuc ) then + fraci(mgs) = 1.0 + fracl(mgs) = 0.0 + end if +! fraci(mgs) = 1.0-fracl(mgs) + + gamss = (felvcp(mgs)*fracl(mgs) + felscp(mgs)*fraci(mgs)) & + & / (pi0(mgs)) + + dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv2(mgs)*qsstmp/ & + & ((temg(mgs)-cbi)**2)) + + if ( temg(mgs) .ge. tfr ) then + dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv1(mgs)*qsstmp/ & + & ((temg(mgs)-cbw)**2)) + end if + + delqci1=qx(mgs,li) + + + dqcw(mgs) = dqvcnd(mgs)*fracl(mgs) ! is zero + dqci(mgs) = dqvcnd(mgs)*fraci(mgs) + + thetaptmp = thetaptmp + & + & (felvcp(mgs)*dqcw(mgs) + felscp(mgs)*dqci(mgs)) & + & / (pi0(mgs)) + + qvptmp = qvptmp - ( dqvcnd(mgs) ) + qctmp(mgs) = qctmp(mgs) + dqcw(mgs) + qitmp(mgs) = qitmp(mgs) + dqci(mgs) + + IF ( itertd == 2 .and. eqtset > 1 ) THEN + ! if eqtset == 2, then need to update the latent heats for change in hydrometeor content + tmp = qitmp(mgs) ! + qx(mgs,lh) +! IF ( lhl > 1 ) tmp = tmp + qx(mgs,lhl) + cvm = cv+cvv*qvtmp(mgs)+cpl*(qctmp(mgs) +qrtmp(mgs)) & + +cpigb*(tmp) + + felvcptmp = (felv(mgs)-rw*temg(mgs))/cvm + felscptmp = (fels(mgs)-rw*temg(mgs))/cvm + ENDIF + + IF ( eqtset > 2 ) THEN + pipert(mgs) = pipert(mgs) + (0 & + & +felspi(mgs)*dqci(mgs) & + & +felvpi(mgs)*dqcw(mgs))*dtp + ENDIF + +! +! + END IF ! } dqwv(mgs) .ge. 0. + + +! + IF ( itertd == 1 ) THEN + ! update temporary saturation values + + thetatmp = thetaptmp + theta0(mgs) + temgtmp = thetatmp*pk(mgs) ! ( pres(mgs) / poo ) ** cap + qvaptmp = Max((qvptmp + qv0(mgs)), 0.0) + temcgtmp = temgtmp - tfr + tqvcon = temgtmp-cbw + ltemq = (temgtmp-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + qvstmp = pqs(mgs)*tabqvs(ltemq) + qisstmp = pqs(mgs)*tabqis(ltemq) + qctmp(mgs) = max( 0.0, qctmp(mgs) ) + qitmp(mgs) = max( 0.0, qitmp(mgs) ) + qvtmp(mgs) = max( 0.0, qvaptmp ) + +! qsstmp = qvstmp + qsstmp = qisstmp + + ELSE + ! set max depletion + qctmp(mgs) = max( 0.0, qctmp(mgs) ) + qitmp(mgs) = max( 0.0, qitmp(mgs) ) + + IF ( qitmp(mgs) < qitmp1 ) THEN + qsimxsub(mgs) = (qitmp1 - qitmp(mgs))*dtpinv + ELSEIF ( qitmp(mgs) > qitmp1 ) THEN + qsimxdep(mgs) = (qitmp(mgs) - qitmp1)*dtpinv + ENDIF + + + ENDIF +! pceds(mgs) = (thetap(mgs) - thsave(mgs))*dtpinv +! write(iunit,*) 'satadj2: mgs,iter = ',mgs,itertd,dqwv(mgs),qss(mgs),qxtmp,qctmp(mgs) +! +! end the saturation adjustment iteration loop +! + end do ! itertd + + ENDIF + + end do ! mgs + + ELSE + + DO mgs = 1,ngscnt + qsimxdep(mgs) = qvimxd(mgs) + qsimxsub(mgs) = 1.e20 + ENDDO + + ENDIF + +! end of qlimit + + do mgs = 1,ngscnt + qisbv(mgs) = 0.0 + qssbv(mgs) = 0.0 + qidpv(mgs) = 0.0 + qsdpv(mgs) = 0.0 + IF ( icond .eq. 1 .or. temg(mgs) .le. tfrh & + & .or. (qx(mgs,lr) .le. qxmin(lr) .and. qx(mgs,lc) .le. qxmin(lc)) ) THEN +! qisbv(mgs) = max( min(qidsv(mgs), 0.0), -qimxd(mgs) ) +! qssbv(mgs) = max( min(qsdsv(mgs), 0.0), -qsmxd(mgs) ) +! erm 5/10/2007: + qisbv(mgs) = max( min(qidsv(mgs), 0.0), Min( -qimxd(mgs), -0.5*qx(mgs,li)*dtpinv ) ) + qssbv(mgs) = max( min(qsdsv(mgs), 0.0), Min( -qsmxd(mgs), -0.5*qx(mgs,ls)*dtpinv ) ) + qidpv(mgs) = Max(qidsv(mgs), 0.0) + qsdpv(mgs) = Max(qsdsv(mgs), 0.0) + + + ELSE + qisbv(mgs) = 0.0 + qssbv(mgs) = 0.0 + qidpv(mgs) = 0.0 + qsdpv(mgs) = 0.0 + ENDIF + + qhsbv(mgs) = max( min(qhdsv(mgs), 0.0), -qhmxd(mgs) ) + + qhdpv(mgs) = Max(qhdsv(mgs), 0.0) + + + qhlsbv(mgs) = 0.0 + qhldpv(mgs) = 0.0 + IF ( lhl .gt. 1 ) THEN + qhlsbv(mgs) = max( min(qhldsv(mgs), 0.0), -qxmxd(mgs,lhl) ) + qhldpv(mgs) = Max(qhldsv(mgs), 0.0) + ENDIF + + temp1 = qidpv(mgs) + qsdpv(mgs) + qhdpv(mgs) + qhldpv(mgs) + +! IF ( temp1 .gt. qvimxd(mgs) ) THEN + +! frac = qvimxd(mgs)/temp1 + + IF ( temp1 .gt. qsimxdep(mgs) ) THEN + frac = qsimxdep(mgs)/temp1 + + qidpv(mgs) = frac*qidpv(mgs) + qsdpv(mgs) = frac*qsdpv(mgs) + qhdpv(mgs) = frac*qhdpv(mgs) + qhldpv(mgs) = frac*qhldpv(mgs) + +! IF ( ny .eq. 2 .and. igs(mgs) .eq. 302 .and. temg(mgs) .le. tfrh+10 .and. qx(mgs,lv) .gt. qis(mgs) +! : .and. qx(mgs,li) .gt. qxmin(li) ) THEN +! write(0,*) 'qidpv,frac = ',kgs(mgs),qidpv(mgs),frac +! ENDIF + + ENDIF + + temp1 = qisbv(mgs) + qssbv(mgs) + qhsbv(mgs) + qhlsbv(mgs) + + + IF ( temp1 < -qsimxsub(mgs) ) THEN + frac = -qsimxsub(mgs)/temp1 + + qisbv(mgs) = frac*qisbv(mgs) + qssbv(mgs) = frac*qssbv(mgs) + qhsbv(mgs) = frac*qhsbv(mgs) + qhlsbv(mgs) = frac*qhlsbv(mgs) + +! IF ( ny .eq. 2 .and. igs(mgs) .eq. 302 .and. temg(mgs) .le. tfrh+10 .and. qx(mgs,lv) .gt. qis(mgs) +! : .and. qx(mgs,li) .gt. qxmin(li) ) THEN +! write(0,*) 'qidpv,frac = ',kgs(mgs),qidpv(mgs),frac +! ENDIF + + ENDIF + + + end do +! +! + if ( ipconc .ge. 1 ) then + do mgs = 1,ngscnt + cssbv(mgs) = (cx(mgs,ls)/(qx(mgs,ls)+1.e-20))*qssbv(mgs) + cisbv(mgs) = (cx(mgs,li)/(qx(mgs,li)+1.e-20))*qisbv(mgs) + chsbv(mgs) = (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhsbv(mgs) + IF ( lhl .gt. 1 ) chlsbv(mgs) = (cx(mgs,lhl)/(qx(mgs,lhl)+1.e-20))*qhlsbv(mgs) + csdpv(mgs) = 0.0 ! (cx(mgs,ls)/(qx(mgs,ls)+1.e-20))*qsdpv(mgs) + cidpv(mgs) = 0.0 ! (cx(mgs,li)/(qx(mgs,li)+1.e-20))*qidpv(mgs) + cisdpv(mgs) = 0.0 + chdpv(mgs) = 0.0 ! (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhdpv(mgs) + chldpv(mgs) = 0.0 + end do + end if + +! +! Aggregation or size conversion of small crystals to snow +! + if (ndebug .gt. 0 ) write(0,*) 'conc 29a' + do mgs = 1,ngscnt + qscni(mgs) = 0.0 + cscni(mgs) = 0.0 + cscnis(mgs) = 0.0 + if ( ipconc .ge. 4 .and. iscni .ge. 1 .and. qx(mgs,li) .gt. qxmin(li) ) then + IF ( iscni .eq. 1 ) THEN + qscni(mgs) = & + & pi*rho0(mgs)*((0.25)/(6.0)) & + & *eii(mgs)*(qx(mgs,li)**2)*(xdia(mgs,li,2)) & + & *vtxbar(mgs,li,1)/xmas(mgs,li) + cscni(mgs) = Min(cimxd(mgs),qscni(mgs)*rho0(mgs)/xmas(mgs,li)) + cscnis(mgs) = 0.5*cscni(mgs) + ELSEIF ( iscni .eq. 2 .or. iscni .eq. 4 .or. iscni .eq. 5 ) THEN ! Zeigler 1985/Zrnic 1993, sort of + IF ( iscni .ne. 5 .and. qidpv(mgs) .gt. 0.0 .and. xdia(mgs,li,3) .ge. 100.e-6 ) THEN + ! convert larger crystals to snow +! IF ( xdia(mgs,ls,3) .gt. xdia(mgs,li,3) ) THEN +! qscni(mgs) = Max(0.1,xdia(mgs,li,3)/xdia(mgs,ls,3))*qidpv(mgs) +! erm 9/5/08 changed max to min + qscni(mgs) = Min(0.5, xdia(mgs,li,3)/200.e-6)*qidpv(mgs) +! ELSE +! qscni(mgs) = 0.1*qidpv(mgs) +! ENDIF + cscni(mgs) = fscni*qscni(mgs)*rho0(mgs)/Max(rho_qs*xvmn(ls),xmas(mgs,li)) +! cscni(mgs) = fscni*Min(cimxd(mgs),qscni(mgs)*rho0(mgs)/Max(xdn(mgs,ls)*xvmn(ls),xmas(mgs,li))) +! cscni(mgs) = Min(cimxd(mgs),qscni(mgs)*rho0(mgs)/xmas(mgs,li) ) +! IF ( xdia(mgs,ls,3) .le. 200.e-6 ) THEN + cscnis(mgs) = cscni(mgs) +! ELSE +! cscnis(mgs) = 0.0 +! ENDIF + ENDIF + + IF ( iscni .ne. 4 ) THEN + ! crystal aggregation to become snow +! erm 9/5/08 commented second line and added xv to 1st line (zrnic et al 1993) + tmp = ess(mgs)*rvt*aa2*cx(mgs,li)*cx(mgs,li)*xv(mgs,li) +! : ((cinu + 2.)*xv(mgs,li)/(cinu + 1.) + xv(mgs,li)) + +! csacs(mgs) = rvt*aa2*ess(mgs)*cx(mgs,ls)**2*xv(mgs,ls) + + qscni(mgs) = qscni(mgs) + Min( qxmxd(mgs,li), 2.0*tmp*xmas(mgs,li)*rhoinv(mgs) ) + cscni(mgs) = cscni(mgs) + Min( cxmxd(mgs,li), 2.0*tmp ) + cscnis(mgs) = cscnis(mgs) + Min( cxmxd(mgs,li), tmp ) + ENDIF + ELSEIF ( iscni .eq. 3 ) THEN ! LFO + qscni(mgs) = 0.001*eii(mgs)*max((qx(mgs,li)-1.e-3),0.0) + qscni(mgs) = min(qscni(mgs),qxmxd(mgs,li)) + cscni(mgs) = qscni(mgs)*rho0(mgs)/xmas(mgs,li) + cscnis(mgs) = 0.5*cscni(mgs) +! write(iunit,*) 'qscni, qi = ',qscni(mgs),qx(mgs,li),igs(mgs),kgs(mgs) + ENDIF + + ELSEIF ( ipconc < 4 ) THEN ! LFO + IF ( lwsm6 ) THEN + qimax = rhoinv(mgs)*roqimax + qscni(mgs) = Min(0.90*qx(mgs,li), Max( 0.0, (qx(mgs,li) - qimax)*dtpinv ) ) + ELSE + qscni(mgs) = 0.001*eii(mgs)*max((qx(mgs,li)-1.e-3),0.0) + qscni(mgs) = min(qscni(mgs),qxmxd(mgs,li)) + ENDIF + else ! 10-ice version + if ( iscni > 0 .and. qx(mgs,li) .gt. qxmin(li) ) then + qscni(mgs) = & + & pi*rho0(mgs)*((0.25)/(6.0)) & + & *eii(mgs)*(qx(mgs,li)**2)*(xdia(mgs,li,2)) & + & *vtxbar(mgs,li,1)/xmas(mgs,li) + cscni(mgs) = Min(cimxd(mgs),qscni(mgs)*rho0(mgs)/xmas(mgs,li)) + end if + + end if + end do + +! +! +! compute dry growth rate of snow, graupel, and hail +! + do mgs = 1,ngscnt +! + qsdry(mgs) = qsacr(mgs) + qsacw(mgs) & + & + qsaci(mgs) +! + qhdry(mgs) = qhaci(mgs) + qhacs(mgs) & + & + qhacr(mgs) & + & + qhacw(mgs) +! + + qhldry(mgs) = 0.0 + IF ( lhl .gt. 1 ) THEN + qhldry(mgs) = qhlaci(mgs) + qhlacs(mgs) & + & + qhlacr(mgs) & + & + qhlacw(mgs) + ENDIF + end do +! +! set wet growth and shedding +! + do mgs = 1,ngscnt + + IF ( temg(mgs) < tfr ) THEN +! +! qswet(mgs) = +! > ( xdia(mgs,ls,1)*swvent(mgs)*cx(mgs,ls)*fwet1(mgs) +! > + fwet2(mgs)*(qsaci(mgs)+qsacir(mgs) +! > +qsacip(mgs)) ) +! qswet(mgs) = max( 0.0, qswet(mgs)) +! +! IF ( dnu(lh) .ne. 0. ) THEN +! qhwet(mgs) = qhdry(mgs) +! ELSE + qhwet(mgs) = & + & ( xdia(mgs,lh,1)*hwvent(mgs)*cx(mgs,lh)*fwet1(mgs) & + & + fwet2(mgs)*(qhaci(mgs) + qhacs(mgs)) ) + qhwet(mgs) = max( 0.0, qhwet(mgs)) +! ENDIF + + + qhlwet(mgs) = 0.0 + IF ( lhl .gt. 1 ) THEN + qhlwet(mgs) = & + & ( xdia(mgs,lhl,1)*hlvent(mgs)*cx(mgs,lhl)*fwet1(mgs) & + & + fwet2(mgs)*(qhlaci(mgs) + qhlacs(mgs)) ) + qhlwet(mgs) = max( 0.0, qhlwet(mgs)) + ENDIF + + ELSE + + qhwet(mgs) = qhdry(mgs) + qhlwet(mgs) = qhldry(mgs) + + ENDIF +! +! qhlwet(mgs) = qhldry(mgs) + + end do +! +! shedding rate +! + qsshr(:) = 0.0 + qhshr(:) = 0.0 + qhlshr(:) = 0.0 + qhshh(:) = 0.0 + csshr(:) = 0.0 + csshrr(:) = 0.0 + chshr(:) = 0.0 + chlshr(:) = 0.0 + chshrr(:) = 0.0 + chlshrr(:) = 0.0 + vhshdr(:) = 0.0 + vhlshdr(:) = 0.0 + wetsfc(:) = .false. + wetgrowth(:) = .false. + wetsfchl(:) = .false. + wetgrowthhl(:) = .false. + + do mgs = 1,ngscnt +! +! +! + qhshr(mgs) = Min( 0.0, qhwet(mgs) - qhdry(mgs) ) ! water that freezes should never be more than what sheds + + + + qhlshr(mgs) = Min( 0.0, qhlwet(mgs) - qhldry(mgs) ) + +! +! limit wet growth to only higher density particles +! + qsshr(mgs) = 0.0 +! +! +! no shedding for temperatures < 243.15 +! + if ( temg(mgs) .lt. 243.15 ) then + qsshr(mgs) = 0.0 + qhshr(mgs) = 0.0 + qhlshr(mgs) = 0.0 + vhshdr(mgs) = 0.0 + vhlshdr(mgs) = 0.0 + wetsfc(mgs) = .false. + wetgrowth(mgs) = .false. + wetsfchl(mgs) = .false. + wetgrowthhl(mgs) = .false. + end if +! +! shed all at temperatures > 273.15 +! + if ( temg(mgs) .gt. tfr ) then + + IF ( .false. ) THEN ! old and incorrect -- Thanks to Shaofeng Hua for noticing this error (9/17/2017) + qsshr(mgs) = -qsdry(mgs) + qhshr(mgs) = -qhdry(mgs) + qhlshr(mgs) = -qhldry(mgs) + ELSE ! new and correct + + qsshr(mgs) = - qsacr(mgs) - qsacw(mgs) ! -qsdry(mgs) + qhlshr(mgs) = - qhlacw(mgs) - qhlacr(mgs) ! -qhldry(mgs) + qhshr(mgs) = - qhacw(mgs) - qhacr(mgs) ! -qhdry(mgs) + + ENDIF + + vhshdr(mgs) = -vhacw(mgs) - vhacr(mgs) + vhlshdr(mgs) = -vhlacw(mgs) - vhlacr(mgs) + qhwet(mgs) = 0.0 + qhlwet(mgs) = 0.0 + end if +! +! if (qhshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) THEN + wetsfc(mgs) = (qhshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) .or. ( qhmlr(mgs) < -qxmin(lh) .and. temg(mgs) > tfr ) + wetgrowth(mgs) = (qhshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) +! ENDIF + if (qhlshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) THEN + wetsfchl(mgs) = (qhlshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) .or. ( qhlmlr(mgs) < -qxmin(lhl) .and. temg(mgs) > tfr ) + wetgrowthhl(mgs) = (qhlshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) + ENDIF + + end do +! + if ( ipconc .ge. 1 ) then + do mgs = 1,ngscnt + csshr(mgs) = 0.0 ! (cx(mgs,ls)/(qx(mgs,ls)+1.e-20))*Min(0.0,qsshr(mgs)) + + chshr(mgs) = 0.0 ! no change to graupel number concentration for wet-growth shedding + + ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) + ! Base the drop size on the shedding regime + ! 8/26/2015 ERM updated to use shedalp and tmpdiam + ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) + chshrr(mgs) = rho0(mgs)*qhshr(mgs)/(xdn(mgs,lr)*vshdgs(mgs,lh)) ! into rain + + + + chlshr(mgs) = 0.0 + chlshrr(mgs) = 0.0 + IF ( lhl .gt. 1 ) THEN +! chlshr(mgs) = (cx(mgs,lhl)/(qx(mgs,lhl)+1.e-20))*qhlshr(mgs) + + + chlshr(mgs) = 0.0 ! no change to hail number concentration for wet-growth shedding + + ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) + ! Base the drop size on the shedding regime + ! 8/26/2015 ERM updated to use shedalp and tmpdiam + ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) + chlshrr(mgs) = rho0(mgs)*qhlshr(mgs)/(xdn(mgs,lr)*vshdgs(mgs,lhl)) ! into rain + + ENDIF ! ( lhl > 1 ) + + + end do + end if + + + +! +! final decisions +! + do mgs = 1,ngscnt +! +! Snow +! + if ( qsshr(mgs) .lt. 0.0 ) then + qsdpv(mgs) = 0.0 + qssbv(mgs) = 0.0 + else + qsshr(mgs) = 0.0 + end if +! +! if ( qsdry(mgs) .lt. qswet(mgs) ) then +! qswet(mgs) = 0.0 +! else +! qsdry(mgs) = 0.0 +! end if +! + +! graupel +! +! + if ( wetgrowth(mgs) .or. (mixedphase .and. fhw(mgs) .gt. 0.05 .and. temg(mgs) .gt. 243.15) ) then + + +! soaking (when not advected liquid water film with graupel) + + IF ( lvol(lh) .gt. 1 .and. .not. mixedphase) THEN + ! rescale volumes to maximum density + IF ( iwetsoak ) THEN + + rimdn(mgs,lh) = xdnmx(lh) + raindn(mgs,lh) = xdnmx(lh) + vhacw(mgs) = qhacw(mgs)*rho0(mgs)/rimdn(mgs,lh) + vhacr(mgs) = qhacr(mgs)*rho0(mgs)/raindn(mgs,lh) +! IF ( lvol(lh) .gt. 1 .and. wetgrowth(mgs) ) THEN + IF ( xdn(mgs,lh) .lt. xdnmx(lh) ) THEN + ! soak some liquid into the graupel +! v1 = xdnmx(lh)*vx(mgs,lh)/(xdn(mgs,lh)*dtp) ! volume available for filling + v1 = (1. - xdn(mgs,lh)/xdnmx(lh))*vx(mgs,lh)/(dtp) ! volume available for filling +! tmp = (vx(mgs,lh)/rho0(mgs))*(xdnmx(lh) - xdn(mgs,lh)) ! max mixing ratio of liquid water that can be added + v2 = rho0(mgs)*qhwet(mgs)/xdnmx(lh) ! volume of frozen accretion + + vhsoak(mgs) = Min(v1,v2) + + + ENDIF + + ENDIF + + vhshdr(mgs) = Min(0.0, rho0(mgs)*qhwet(mgs)/xdnmx(lh) - vhacw(mgs) - vhacr(mgs) ) + + ELSEIF ( lvol(lh) .gt. 1 .and. mixedphase ) THEN +! vhacw(mgs) = rho0(mgs)*qhacw(mgs)/xdn0(lr) +! vhacr(mgs) = rho0(mgs)*qhacr(mgs)/xdn0(lr) + ENDIF + + + qhdpv(mgs) = 0.0 +! qhsbv(mgs) = 0.0 + chdpv(mgs) = 0.0 +! chsbv(mgs) = 0.0 + +! collection efficiency modification + + IF ( ehi(mgs) .gt. 0.0 ) THEN + qhaci(mgs) = Min(qimxd(mgs),qhaci0(mgs)) ! effectively sets collection eff to 1 + chaci(mgs) = Min(cimxd(mgs),chaci0(mgs)) ! effectively sets collection eff to 1 + ENDIF + IF ( ehs(mgs) .gt. 0.0 ) THEN +! qhacs(mgs) = Min(qsmxd(mgs),qhacs(mgs)/ehs(mgs)) ! effectively sets collection eff to 1 + qhacs(mgs) = Min(qsmxd(mgs),qhacs0(mgs)) !/ehs(mgs) ! divide out the collection efficiency + chacs(mgs) = Min(csmxd(mgs),chacs0(mgs)) !/ehs(mgs) ! divide out the collection efficiency + ehs(mgs) = ehsmax ! 1.0 ! min(ehsfrac*ehs(mgs),ehsmax) ! modify it + qhacs(mgs) = Min(qsmxd(mgs),qhacs(mgs)) ! plug it back in + ENDIF + +! be sure to catch particles with wet surfaces but not in wet growth to turn off Hallett-Mossop + wetsfc(mgs) = .true. + + else +! qhshr(mgs) = 0.0 + end if +! +! +! hail +! +! if ( lhl .gt. 1 .and. qhlshr(mgs) .lt. 0.0 ) then + if ( lhl > 1 .and. ( wetgrowthhl(mgs) .or. (mixedphase .and. fhlw(mgs) .gt. 0.05 .and. temg(mgs) .gt. 243.15) ) ) then +! if ( wetgrowthhl(mgs) ) then + + + qhldpv(mgs) = 0.0 +! qhlsbv(mgs) = 0.0 + chldpv(mgs) = 0.0 +! chlsbv(mgs) = 0.0 + + + + + IF ( lvol(lhl) .gt. 1 .and. .not. mixedphase ) THEN +! IF ( lvol(lhl) .gt. 1 .and. wetgrowthhl(mgs) ) THEN + + IF ( iwetsoak ) THEN + + rimdn(mgs,lhl) = xdnmx(lhl) + raindn(mgs,lhl) = xdnmx(lhl) + vhlacw(mgs) = qhlacw(mgs)*rho0(mgs)/rimdn(mgs,lhl) + vhlacr(mgs) = qhlacr(mgs)*rho0(mgs)/raindn(mgs,lhl) + + IF ( xdn(mgs,lhl) .lt. xdnmx(lhl) ) THEN + ! soak some liquid into the hail +! v1 = xdnmx(lhl)*vx(mgs,lhl)/(xdn(mgs,lhl)*dtp) ! volume available for filling + v1 = (1. - xdn(mgs,lhl)/xdnmx(lhl))*vx(mgs,lhl)/(dtp) ! volume available for filling +! tmp = (vx(mgs,lhl)/rho0(mgs))*(xdnmx(lhl) - xdn(mgs,lhl)) ! max mixing ratio of liquid water that can be added + v2 = rho0(mgs)*qhlwet(mgs)/xdnmx(lhl) ! volume of frozen accretion + IF ( v1 > v2 ) THEN ! all the frozen stuff fits in + vhlsoak(mgs) = v2 + ELSE ! fill up the available space + vhlsoak(mgs) = v1 + ENDIF +! vhlacw(mgs) = 0.0 +! vhlacr(mgs) = Max( 0.0, v2 - v1 ) + ELSE + vhlsoak(mgs) = 0.0 +! vhlacw(mgs) = 0.0 +! vhlacr(mgs) = rho0(mgs)*qhlwet(mgs)/raindn(mgs,lhl) + + ENDIF + + ENDIF + + vhlshdr(mgs) = Min(0.0, rho0(mgs)*qhlwet(mgs)/xdnmx(lhl) - vhlacw(mgs) - vhlacr(mgs) ) + + + ELSEIF ( lvol(lhl) .gt. 1 .and. mixedphase ) THEN +! vhlacw(mgs) = rho0(mgs)*qhlacw(mgs)/xdn0(lr) +! vhlacr(mgs) = rho0(mgs)*qhlacr(mgs)/xdn0(lr) + ENDIF + + IF ( ehli(mgs) .gt. 0.0 ) THEN + qhlaci(mgs) = Min(qimxd(mgs),qhlaci0(mgs)) ! effectively sets collection eff to 1 + chlaci(mgs) = Min(cimxd(mgs),chlaci0(mgs)) ! effectively sets collection eff to 1 + ENDIF + +! IF ( ehls(mgs) .gt. 0.0 ) THEN +! qhlacs(mgs) = Min(qsmxd(mgs),qhlacs(mgs)/ehls(mgs)) +! ENDIF + IF ( ehls(mgs) .gt. 0.0 ) THEN + qhlacs(mgs) = Min(qsmxd(mgs),qhlacs0(mgs)) !/ehls(mgs) ! divide out the collection efficiency + chlacs(mgs) = Min(csmxd(mgs),chlacs0(mgs)) !/ehls(mgs) ! divide out the collection efficiency + ehls(mgs) = ehsmax ! 1.0 ! min(ehsfrac*ehs(mgs),ehsmax) ! modify it +! qhlacs(mgs) = Min(qsmxd(mgs),qhlacs(mgs)) ! plug it back in + ENDIF + + +! qhlwet(mgs) = 1.0 + +! be sure to catch particles with wet surfaces but not in wet growth to turn off Hallett-Mossop + wetsfchl(mgs) = .true. + + + else +! qhlshr(mgs) = 0.0 +! qhlwet(mgs) = 0.0 + end if + + end do +! +! Ice -> graupel conversion +! + DO mgs = 1,ngscnt + + qhcni(mgs) = 0.0 + chcni(mgs) = 0.0 + chcnih(mgs) = 0.0 + vhcni(mgs) = 0.0 + + IF ( iglcnvi .ge. 1 ) THEN + IF ( temg(mgs) .lt. 273.0 .and. qiacw(mgs) - qidpv(mgs) .gt. 0.0 ) THEN + + + tmp = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & + & *((0.60)*vtxbar(mgs,li,1)) & + & /(temg(mgs)-273.15))**(rimc2) + tmp = Min( Max( rimc3, tmp ), 900.0 ) + + ! Assume that half the volume of the embryo is rime with density 'tmp' + ! m = rhoi*(V/2) + rhorime*(V/2) = (rhoi + rhorime)*V/2 + ! V = 2*m/(rhoi + rhorime) + +! write(0,*) 'rime dens = ',tmp + + IF ( tmp .ge. 200.0 .or. iglcnvi >= 2 ) THEN + r = Max( 0.5*(xdn(mgs,li) + tmp), xdnmn(lh) ) +! r = Max( r, 400. ) + qhcni(mgs) = (qiacw(mgs) - qidpv(mgs)) ! *float(iglcnvi) + chcni(mgs) = cx(mgs,li)*qhcni(mgs)/qx(mgs,li) +! chcnih(mgs) = rho0(mgs)*qhcni(mgs)/(1.6e-10) + chcnih(mgs) = Min(chcni(mgs), rho0(mgs)*qhcni(mgs)/(r*xvmn(lh)) ) +! vhcni(mgs) = rho0(mgs)*2.0*qhcni(mgs)/(xdn(mgs,li) + tmp) + vhcni(mgs) = rho0(mgs)*qhcni(mgs)/r + ENDIF + + ELSEIF ( iglcnvi == 3 ) THEN + + IF ( temg(mgs) .lt. 273.0 .and. qiacw(mgs)*dtp > 2.*qxmin(lh) .and. gamice73fac*xmas(mgs,li) > xdnmn(lh)*xvmn(lh) ) THEN + + + tmp = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & + & *((0.60)*vtxbar(mgs,li,1)) & + & /(temg(mgs)-273.15))**(rimc2) + tmp = Min( Max( rimc3, tmp ), 900.0 ) + + ! Assume that half the volume of the embryo is rime with density 'tmp' + ! m = rhoi*(V/2) + rhorime*(V/2) = (rhoi + rhorime)*V/2 + ! V = 2*m/(rhoi + rhorime) + +! write(0,*) 'rime dens = ',tmp + ! convert to particles with the mass of the mass-weighted diameter + ! massofmwr = gamice73fac*xmas(mgs,li) + + IF ( tmp .ge. xdnmn(lh) ) THEN + r = Max( 0.5*(xdn(mgs,li) + tmp), xdnmn(lh) ) +! r = Max( r, 400. ) + qhcni(mgs) = 0.5*qiacw(mgs) + chcni(mgs) = qhcni(mgs)/(gamice73fac*xmas(mgs,li)) + chcnih(mgs) = Min(chcni(mgs), rho0(mgs)*qhcni(mgs)/(r*xvmn(lh)) ) +! vhcni(mgs) = rho0(mgs)*2.0*qhcni(mgs)/(xdn(mgs,li) + tmp) + vhcni(mgs) = rho0(mgs)*qhcni(mgs)/r + ENDIF + + ENDIF + + + ENDIF + ENDIF + + + ENDDO + + + qhlcnh(:) = 0.0 + chlcnh(:) = 0.0 + chlcnhhl(:) = 0.0 + vhlcnh(:) = 0.0 + vhlcnhl(:) = 0.0 + zhlcnh(:) = 0.0 + + qhcnhl(:) = 0.0 + chcnhl(:) = 0.0 + vhcnhl(:) = 0.0 + zhcnhl(:) = 0.0 + + + IF ( lhl .gt. 1 ) THEN + + IF ( ihlcnh == 1 .or. ihlcnh == 3 ) THEN + +! +! Graupel (h) conversion to hail (hl) based on Milbrandt and Yau 2005b +! + DO mgs = 1,ngscnt + +! IF ( lhl .gt. 1 .and. ipconc .ge. 5 .and. qx(mgs,lh) .gt. 1.0e-3 .and. +! : xdn(mgs,lh) .gt. 750. .and. qhshr(mgs) .lt. 0.0 .and. +! : xdia(mgs,lh,3) .gt. 1.e-3 ) THEN + IF ( hlcnhdia > 0 ) THEN + ltest = xdia(mgs,lh,3) .gt. hlcnhdia ! test on mean volume diameter + ELSE +! ltest = xdia(mgs,lh,1)*(3. + alpha(mgs,lh)) > Abs( hlcnhdia ) ! test on maximum mass diameter + ltest = xdia(mgs,lh,1)*(4. + alpha(mgs,lh)) > Abs( hlcnhdia ) ! test on mass-weighted diameter + ENDIF + + dg0(mgs) = -1. + + wtest = (dg0(mgs) > 0.0 .and. dg0(mgs) < dg0thresh ) + + IF ( ihlcnh == 1 ) THEN ! .or. iusedw == 0 THEN + + IF ( ( wetgrowth(mgs) .and. (xdn(mgs,lh) .gt. hldnmn .or. lvh < 1 ) .and. & ! correct this when hail gets turned on + & rimdn(mgs,lh) .gt. 800. .and. & + & ltest .and. qx(mgs,lh) .gt. hlcnhqmin ) .or. wtest ) THEN ! { +! : xdia(mgs,lh,3) .gt. 2.e-3 .and. qx(mgs,lh) .gt. 1.0e-3 THEN ! 0823.2008 erm test +! IF ( xdia(mgs,lh,3) .gt. 1.e-3 ) THEN + IF ( qhacw(mgs) .gt. 0.0 .and. qhacw(mgs) .gt. qhaci(mgs) .and. temg(mgs) .le. tfr-2.0 ) THEN ! { + ! dh0 is the diameter dividing wet growth from dry growth (Ziegler 1985), modified by MY05 +! dh0 = 0.01*(exp(temcg(mgs)/(1.1e4*(qx(mgs,lc)+qx(mgs,lr)) - +! : 1.3e3*qx(mgs,li) + 1.0e-3 ) ) - 1.0) + IF ( wtest ) THEN + dh0 = dg0(mgs) + ELSE + x = (1.1e4*(rho0(mgs)*qx(mgs,lc)) - 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0e-3 ) + IF ( x > 1.e-20 ) THEN + arg = Min(70.0, (-temcg(mgs)/x )) ! prevent overflow of the exp function in 32 bit + dh0 = 0.01*(exp(arg) - 1.0) + ELSE + dh0 = 1.e30 + ENDIF + ENDIF ! wtest +! dh0 = Max( dh0, 5.e-3 ) + +! IF ( dh0 .gt. 0.0 ) write(0,*) 'dh0 = ',dh0 +! IF ( dh0 .gt. 1.0e-4 ) THEN + IF ( xdia(mgs,lh,3)/dh0 .gt. 0.1 ) THEN !{ +! IF ( xdia(mgs,lh,3) .lt. 20.*dh0 .and. dh0 .lt. 2.0*xdia(mgs,lh,3) ) THEN + tmp = qhacw(mgs) + qhacr(mgs) + qhaci(mgs) + qhacs(mgs) +! qtmp = Min( 1.0, xdia(mgs,lh,3)/(2.0*dh0) )*(tmp) + qtmp = Min( 100.0, xdia(mgs,lh,3)/(2.0*dh0) )*(tmp) +! IF ( .false. .and. qx(mgs,lhl) + qtmp*dtp .lt. 0.5e-3 ) THEN +! hdia1 = Max(dh0, xdia(mgs,lh,3) ) +! qtmp = qtmp + Min(qxmxd(mgs,lh), Max( 0.0, & +! & ((pi*xdn(mgs,lh)*cx(mgs,lh)) / (6.0*rho0(mgs)*dtp)) & +! & *exp(-hdia1/xdia(mgs,lh,1)) & +! & *( (hdia1**3) + 3.0*(hdia1**2)*xdia(mgs,lh,1) & +! & + 6.0*(hdia1)*(xdia(mgs,lh,1)**2) + 6.0*(xdia(mgs,lh,1)**3) ) ) ) + +! ENDIF + +! qhlcnh(mgs) = Min( 0.5*(qx(mgs,lh))+tmp, xdia(mgs,lh,3)/(2.0*dh0)*(tmp) ) +! qhlcnh(mgs) = Min( qxmxd(mgs,lh), xdia(mgs,lh,3)/(2.0*dh0)*(tmp) ) + qhlcnh(mgs) = Min( qxmxd(mgs,lh), qtmp ) + + IF ( ipconc .ge. 5 ) THEN !{ +! dh0 = Max( xdia(mgs,lh,3), Min( dh0, 5.e-3 ) ) ! do not create hail greater than 5mm diam. unless the graupel is larger + IF ( .not. wtest ) dh0 = Min( dh0, 10.e-3 ) ! do not create hail greater than 10mm diam., which is the max graupel size + IF ( qx(mgs,lhl) > 0.1e-3 ) dh0 = Max( dh0, xdia(mgs,lhl,3) ) ! when enough hail is established, do not dilute the size + chlcnhhl(mgs) = Min( cxmxd(mgs,lh), rho0(mgs)*qhlcnh(mgs)/(pi*xdn(mgs,lh)*dh0**3/6.0) ) + + r = rho0(mgs)*qhlcnh(mgs)/(xdn(mgs,lh)*xv(mgs,lh)) ! number of graupel particles at mean volume diameter +! chlcnh(mgs) = Min( Max( 1./8.*r , chlcnh(mgs)), r ) +! chlcnh(mgs) = Min( chlcnh(mgs), r ) + chlcnh(mgs) = Max( chlcnhhl(mgs), r ) + ENDIF !} + + vhlcnh(mgs) = rho0(mgs)*qhlcnh(mgs)/xdn(mgs,lh) + vhlcnhl(mgs) = rho0(mgs)*qhlcnh(mgs)/Max(xdnmn(lhl), xdn(mgs,lh)) + + ENDIF !} + + ENDIF ! } + ENDIF ! } + + ELSEIF ( ihlcnh == 3 ) THEN !{ + + + ENDIF !} + + ENDDO + + ELSEIF ( ihlcnh == 2 ) THEN ! 10-ice type conversion + + ELSEIF ( ihlcnh == 0 ) THEN + + do mgs = 1,ngscnt +! qhlcnh(mgs) = 0.0 +! chlcnh(mgs) = 0.0 + if ( wetgrowth(mgs) .and. temg(mgs) .lt. tfr-5. .and. qx(mgs,lh) > qxmin(lh) ) then + if ( qhacw(mgs).gt.1.e-6 .and. xdn(mgs,lh) > 700. ) then + qhlcnh(mgs) = & + ((pi*xdn(mgs,lh)*cx(mgs,lh)) / (6.0*rho0(mgs)*dtp)) & + *exp(-hldia1/xdia(mgs,lh,1)) & + *( (hldia1**3) + 3.0*(hldia1**2)*xdia(mgs,lh,1) & + + 6.0*(hldia1)*(xdia(mgs,lh,1)**2) + 6.0*(xdia(mgs,lh,1)**3) ) + qhlcnh(mgs) = min(qhlcnh(mgs),qhmxd(mgs)) + IF ( ipconc .ge. 5 ) THEN + chlcnh(mgs) = Min( cxmxd(mgs,lh), cx(mgs,lh)*Exp(-hldia1/xdia(mgs,lh,1))) + chlcnhhl(mgs) = chlcnh(mgs) +! chlcnh(mgs) = Min( cxmxd(mgs,lh), rho0(mgs)*qhlcnh(mgs)/(2.0*xmas(mgs,lh) )) + ENDIF + vhlcnh(mgs) = rho0(mgs)*qhlcnh(mgs)/xdn(mgs,lh) + vhlcnhl(mgs) = rho0(mgs)*qhlcnh(mgs)/Max(xdnmn(lhl), xdn(mgs,lh)) + end if + end if + end do + +! ENDIF ! true + + ENDIF ! ihlcnh options + + ! convert low-density hail to graupel + IF ( icvhl2h >= 1 ) THEN + DO mgs = 1,ngscnt + IF ( qx(mgs,lhl) > qxmin(lhl) .and. xdn(mgs,lhl) < 0.5*(xdnmn(lhl) + xdnmx(lhl)) ) THEN + tmp = Min(0.95, 1. - 0.5*(1. + tanh(0.125*(xdn(mgs,lhl) - 1.01*xdnmn(lhl) )) )) + qhcnhl(mgs) = tmp*qx(mgs,lhl)*dtpinv + chcnhl(mgs) = cx(mgs,lhl)*qhcnhl(mgs)/qx(mgs,lhl) + vhcnhl(mgs) = vx(mgs,lhl)*qhcnhl(mgs)/qx(mgs,lhl) + + ENDIF + ENDDO + + ENDIF + + ENDIF ! lhl > 1 + + + + +! +! Ziegler snow conversion to graupel +! + DO mgs = 1,ngscnt + + qhcns(mgs) = 0.0 + chcns(mgs) = 0.0 + chcnsh(mgs) = 0.0 + vhcns(mgs) = 0.0 + + qscnh(mgs) = 0.0 + cscnh(mgs) = 0.0 + vscnh(mgs) = 0.0 + + IF ( ipconc .ge. 5 ) THEN + + ! test attempt at converting graupel to snow when not riming but growing by deposition + IF ( temg(mgs) < tfr .and. qx(mgs,lh) .gt. qxmin(lh) .and. qhdpv(mgs) > qxmin(lh)*dtpinv & + & .and. qhacw(mgs) < qxmin(lh)*dtpinv ) THEN + IF ( xdn(mgs,lh) < 290. ) THEN +! qscnh(mgs) = 2.*qhdpv(mgs) +! cscnh(mgs) = cx(mgs,lh)*qscnh(mgs)/qx(mgs,lh) +! vscnh(mgs) = rho0(mgs)*qscnh(mgs)/xdn(mgs,lh) + ENDIF + ENDIF + + + IF ( qx(mgs,ls) .gt. qxmin(ls) .and. qsacw(mgs) .gt. 0.0 ) THEN + +! DATA VGRA/1.413E-2/ ! this is the volume (cm**3) of a 3mm diam. sphere +! vgra = 1.4137e-8 m**3 + +! DNNET=DNCNV-DNAGG +! DQNET=QXCON+QSACC+SDEP +! +! DNSCNV=EXP(-(ROS*XNS*VGRA/(RO*QI)))*((1.-(XNS*VGRA*ROS/ +! / (RO*QI)))*DNNET + (XNS**2*VGRA*ROS/(RO*QI**2))*DQNET) +! IF(DNSCNV.LT.0.) DNSCNV=0. +! +! QIHC=(ROS*VGRA/RO)*DNSCNV +! +! QH=QH+DT*QIHC +! QI=QI-DT*QIHC +! XNH=XNH+DT*DNSCNV +! XNS=XNS-DT*DNSCNV + + IF ( iglcnvs .eq. 1 ) THEN ! Zrnic, Ziegler et al (1993) + + dnnet = cscnvis(mgs) + cscnis(mgs) - csacs(mgs) + dqnet = qscnvi(mgs) + qscni(mgs) + qsacw(mgs) + qsdpv(mgs) + qssbv(mgs) + + a3 = 1./(rho0(mgs)*qx(mgs,ls)) + a1 = Exp( - xdn(mgs,ls)*cx(mgs,ls)*vgra*a3 ) !! EXP(-(ROS*XNS*VGRA/(RO*QI))) +! (1.-(XNS*VGRA*ROS/(RO*QI)))*DNNET + a2 = (1.-(cx(mgs,ls)*vgra*xdn(mgs,ls)*a3))*dnnet +! (XNS**2*VGRA*ROS/(RO*QI**2))*DQNET + a4 = cx(mgs,ls)**2*vgra*xdn(mgs,ls)*a3/qx(mgs,ls)*dqnet + + chcns(mgs) = Max( 0.0, a1*(a2 + a4) ) + chcns(mgs) = Min( chcns(mgs), cxmxd(mgs,ls) ) + chcnsh(mgs) = chcns(mgs) + + qhcns(mgs) = Min( xdn(mgs,ls)*vgra*rhoinv(mgs)*chcns(mgs), qxmxd(mgs,ls) ) + vhcns(mgs) = rho0(mgs)*qhcns(mgs)/Max(xdn(mgs,ls),xdnmn(lh)) +! vhcns(mgs) = rho0(mgs)*qhcns(mgs)/Max(xdn(mgs,ls),400.) + + ELSEIF ( iglcnvs .ge. 2 ) THEN ! treat like ice crystals, i.e., check for rime density (ERM) + + IF ( temg(mgs) .lt. 273.0 .and. ( qsacw(mgs) - qsdpv(mgs) .gt. 0.0 .or. & + ( iglcnvs >= 3 .and. qsacw(mgs)*dtp > 2.*qxmin(lh) .and. gamsnow73fac*xmas(mgs,ls) > xdnmn(lh)*xvmn(lh) ) ) ) THEN !{ + + + tmp = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & + & *((0.60)*vtxbar(mgs,ls,1)) & + & /(temg(mgs)-273.15))**(rimc2) +! tmp = Min( Max( rimc3, tmp ), 900.0 ) + tmp = Min( tmp , 900.0 ) + + ! Assume that half the volume of the embryo is rime with density 'tmp' + ! m = rhoi*(V/2) + rhorime*(V/2) = (rhoi + rhorime)*V/2 + ! V = 2*m/(rhoi + rhorime) + +! write(0,*) 'rime dens = ',tmp + + IF ( iglcnvs == 2 ) THEN !{ + IF ( tmp .ge. 200.0 ) THEN + r = Max( 0.5*(xdn(mgs,ls) + tmp), xdnmn(lh) ) +! r = Max( r, 400. ) + qhcns(mgs) = (qsacw(mgs) - qsdpv(mgs)) + chcns(mgs) = cx(mgs,ls)*qhcns(mgs)/qx(mgs,ls) +! chcnih(mgs) = rho0(mgs)*qhcni(mgs)/(1.6e-10) + chcnsh(mgs) = Min(chcns(mgs), rho0(mgs)*qhcns(mgs)/(r*xvmn(lh)) ) +! vhcni(mgs) = rho0(mgs)*2.0*qhcni(mgs)/(xdn(mgs,li) + tmp) + vhcns(mgs) = rho0(mgs)*qhcns(mgs)/r + ENDIF + + ELSEIF ( iglcnvs == 3 ) THEN + + ! convert to particles with the mass of the mass-weighted diameter + ! massofmwr = gamice73fac*xmas(mgs,li) + + IF ( tmp > xdnmn(lh) ) THEN + r = Max( 0.5*(xdn(mgs,ls) + tmp), xdnmn(lh) ) +! r = Max( r, 400. ) + qhcns(mgs) = 0.5*qsacw(mgs) + chcns(mgs) = qhcns(mgs)/(gamsnow73fac*xmas(mgs,ls)) + chcns(mgs) = Min( chcns(mgs), cx(mgs,ls)*qhcns(mgs)/qx(mgs,ls)) + chcnsh(mgs) = Min(chcns(mgs), rho0(mgs)*qhcns(mgs)/(r*xvmn(lh)) ) + vhcns(mgs) = rho0(mgs)*qhcns(mgs)/r + ENDIF + + ENDIF !} + + ENDIF !} + + ENDIF + + + ENDIF + + ELSE ! single moment lfo + + qhcns(mgs) = 0.001*ehscnv(mgs)*max((qx(mgs,ls)-6.e-4),0.0) + qhcns(mgs) = min(qhcns(mgs),qxmxd(mgs,ls)) + IF ( lvol(lh) .ge. 1 ) vhcns(mgs) = rho0(mgs)*qhcns(mgs)/Max(xdn(mgs,ls),400.) + + ENDIF + ENDDO +! +! +! heat budget for rain---not all rain that collects ice can freeze +! +! +! + if ( irwfrz .gt. 0 .and. .not. mixedphase) then +! + do mgs = 1,ngscnt +! +! compute total rain that freeze when it interacts with cloud ice +! + qrztot(mgs) = qrfrz(mgs) + qiacr(mgs) + qsacr(mgs) +! +! compute the maximum amount of rain that can freeze +! Used to limit freezing to 4*qrmxd, but now allow all rain to freeze if possible +! + qrzmax(mgs) = & + & ( xdia(mgs,lr,1)*rwvent(mgs)*cx(mgs,lr)*fwet1(mgs) ) + qrzmax(mgs) = max(qrzmax(mgs), 0.0) + qrzmax(mgs) = min(qrztot(mgs), qrzmax(mgs)) + qrzmax(mgs) = min(qx(mgs,lr)*dtpinv, qrzmax(mgs)) + + IF ( temcg(mgs) < -30. ) THEN ! allow all to freeze if T < -30 because fwet becomes invalid (negative) + qrzmax(mgs) = qx(mgs,lr)*dtpinv + ENDIF +! qrzmax(mgs) = min(4.*qrmxd(mgs), qrzmax(mgs)) +! +! compute the correction factor +! +! IF ( qrztot(mgs) .gt. qxmin(lr) ) THEN + IF ( qrztot(mgs) .gt. qrzmax(mgs) .and. qrztot(mgs) .gt. qxmin(lr) ) THEN + qrzfac(mgs) = qrzmax(mgs)/(qrztot(mgs)) + ELSE + qrzfac(mgs) = 1.0 + ENDIF + qrzfac(mgs) = min(1.0, qrzfac(mgs)) +! + end do +! +! +! now correct the above sources +! +! + do mgs = 1,ngscnt + if ( temg(mgs) .le. 273.15 .and. qrzfac(mgs) .lt. 1.0 ) then + qrfrz(mgs) = qrzfac(mgs)*qrfrz(mgs) + qrfrzs(mgs) = qrzfac(mgs)*qrfrzs(mgs) + qrfrzf(mgs) = qrzfac(mgs)*qrfrzf(mgs) + qiacr(mgs) = qrzfac(mgs)*qiacr(mgs) + qsacr(mgs) = qrzfac(mgs)*qsacr(mgs) + qiacrf(mgs) = qrzfac(mgs)*qiacrf(mgs) + qiacrs(mgs) = qrzfac(mgs)*qiacrs(mgs) + crfrz(mgs) = qrzfac(mgs)*crfrz(mgs) + crfrzf(mgs) = qrzfac(mgs)*crfrzf(mgs) + crfrzs(mgs) = qrzfac(mgs)*crfrzs(mgs) + ciacr(mgs) = qrzfac(mgs)*ciacr(mgs) + ciacrf(mgs) = qrzfac(mgs)*ciacrf(mgs) + ciacrs(mgs) = qrzfac(mgs)*ciacrs(mgs) + + + vrfrzf(mgs) = qrzfac(mgs)*vrfrzf(mgs) + viacrf(mgs) = qrzfac(mgs)*viacrf(mgs) + end if + end do +! +! +! + end if +! +! +! +! evaporation of rain +! +! +! + qrcev(:) = 0.0 + crcev(:) = 0.0 + + + do mgs = 1,ngscnt +! + IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN + + qrcev(mgs) = & + & fvce(mgs)*cx(mgs,lr)*rwvent(mgs)*rwcap(mgs)*evapfac +! this line to allow condensation on rain: + IF ( rcond .eq. 1 ) THEN + qrcev(mgs) = min(qrcev(mgs), qxmxd(mgs,lv)) +! this line to have evaporation only: + ELSE + qrcev(mgs) = min(qrcev(mgs), 0.0) + ENDIF + + qrcev(mgs) = max(qrcev(mgs), -qrmxd(mgs)) +! if ( temg(mgs) .lt. 273.15 ) qrcev(mgs) = 0.0 + IF ( qrcev(mgs) .lt. 0. .and. lnr > 1 ) THEN +! qrcev(mgs) = -qrmxd(mgs) +! crcev(mgs) = (rho0(mgs)/(xmas(mgs,lr)+1.e-20))*qrcev(mgs) + crcev(mgs) = (cx(mgs,lr)/(qx(mgs,lr)))*qrcev(mgs) + ELSE + crcev(mgs) = 0.0 + ENDIF +! if ( temg(mgs) .lt. 273.15 ) crcev(mgs) = 0.0 +! + ENDIF + + end do +! +! evaporation/condensation of wet graupel and snow +! + qscev(:) = 0.0 + cscev(:) = 0.0 + qhcev(:) = 0.0 + chcev(:) = 0.0 + qhlcev(:) = 0.0 + chlcev(:) = 0.0 + IF ( lhwlg > 1 ) THEN + qhcevlg(:) = 0.0 + chcevlg(:) = 0.0 + ENDIF + IF ( lhlwlg > 1 ) THEN + qhlcevlg(:) = 0.0 + chlcevlg(:) = 0.0 + ENDIF + +! +! +! +! ICE MULTIPLICATION: Two modes (rimpa, and rimpb) +! (following Cotton et al. 1986) +! + + chmul1(:) = 0.0 + chlmul1(:) = 0.0 + csmul1(:) = 0.0 +! + qhmul1(:) = 0.0 + qhlmul1(:) = 0.0 + qsmul1(:) = 0.0 + do mgs = 1,ngscnt + + ltest = qx(mgs,lh) .gt. qxmin(lh) + IF ( lhl > 1 ) ltest = ltest .or. qx(mgs,lhl) .gt. qxmin(lhl) + + IF ( (itype1 .ge. 1 .or. itype2 .ge. 1 ) & + & .and. qx(mgs,lc) .gt. qxmin(lc)) THEN + if ( temg(mgs) .ge. 265.15 .and. temg(mgs) .le. 271.15 ) then + IF ( ipconc .ge. 2 ) THEN + IF ( xv(mgs,lc) .gt. 0.0 & + & .and. ltest & +! .and. itype2 .ge. 2 & + & ) THEN +! +! Ziegler et al. 1986 Hallett-Mossop process. VSTAR = 7.23e-15 (vol of 12micron radius) +! + IF ( alpha(mgs,lc) == 0.0 ) THEN + ex1 = (1./250.)*Exp(-7.23e-15/xv(mgs,lc)) + ELSE + + ratio = (1. + alpha(mgs,lc))*(7.23e-15)/xv(mgs,lc) + + IF ( usegamxinfcnu ) THEN + i = Nint(dgami*(1. + alpha(mgs,lc))) + gcnup1 = gmoi(i) + ex1 = (1./250.)*Gamxinf(1.+alpha(mgs,lc), ratio)/(gcnup1) + ELSE + ratio = Min( maxratiolu, ratio ) + tmp = gaminterp(ratio,alpha(mgs,lc),1,1) + ex1 = (1./250.)*tmp + ENDIF + ENDIF + IF ( itype2 .le. 2 ) THEN + ft = Max(0.0,Min(1.0,-0.11*temcg(mgs)**2 - 1.1*temcg(mgs)-1.7)) + ELSE + IF ( temg(mgs) .ge. 265.15 .and. temg(mgs) .le. 267.15 ) THEN + ft = 0.5 + ELSEIF (temg(mgs) .ge. 267.15 .and. temg(mgs) .le. 269.15 ) THEN + ft = 1.0 + ELSEIF (temg(mgs) .ge. 269.15 .and. temg(mgs) .le. 271.15 ) THEN + ft = 0.5 + ELSE + ft = 0.0 + ENDIF + ENDIF +! rhoinv = 1./rho0(mgs) +! DNSTAR = ex1*cglacw(mgs) + + IF ( ft > 0.0 ) THEN + + IF ( itype2 > 0 ) THEN + IF ( qx(mgs,lh) .gt. qxmin(lh) .and. (.not. wetsfc(mgs)) ) THEN + chmul1(mgs) = ft*ex1*chacw(mgs) +! chmul1(mgs) = Min( ft*ex1*chacw(mgs), ft*(30.*1.e+06)*rho0(mgs)*qhacw(mgs) ) ! 1.e+6 converts kg to mg; Saunders & Hosseini (2001) average of about 30 crystals per mg + qhmul1(mgs) = cimas0*chmul1(mgs)*rhoinv(mgs) + ENDIF + IF ( lhl .gt. 1 ) THEN + IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. (.not. wetsfchl(mgs)) ) THEN + chlmul1(mgs) = (ft*ex1*chlacw(mgs)) + qhlmul1(mgs) = cimas0*chlmul1(mgs)*rhoinv(mgs) + ENDIF + ENDIF + ENDIF ! itype2 + + IF ( itype1 > 0 ) THEN + IF ( qx(mgs,lh) .gt. qxmin(lh) .and. (.not. wetsfc(mgs)) ) THEN + tmp = ft*(3.5e+08)*rho0(mgs)*qhacw(mgs) + chmul1(mgs) = chmul1(mgs) + tmp + qhmul1(mgs) = qhmul1(mgs) + cimas0*tmp*rhoinv(mgs) + ENDIF + IF ( lhl .gt. 1 ) THEN + IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. (.not. wetsfchl(mgs)) ) THEN + tmp = ft*(3.5e+08)*rho0(mgs)*qhlacw(mgs) + chlmul1(mgs) = chlmul1(mgs) + tmp + qhlmul1(mgs) = qhlmul1(mgs) + cimas0*tmp*rhoinv(mgs) + ENDIF + ENDIF + ENDIF ! itype1 + + + ENDIF ! ft + + ENDIF ! xv(mgs,lc) .gt. 0.0 .and. + + ELSE ! ipconc .lt. 2 +! +! define the temperature function +! + fimt1(mgs) = 0.0 +! +! Cotton et al. (1986) version +! + if ( temg(mgs) .ge. 268.15 .and. temg(mgs) .le. 270.15 ) then + fimt1(mgs) = 1.0 -(temg(mgs)-268.15)/2.0 + elseif (temg(mgs) .le. 268.15 .and. temg(mgs) .ge. 265.15 ) then + fimt1(mgs) = 1.0 +(temg(mgs)-268.15)/3.0 + ELSE + fimt1(mgs) = 0.0 + end if +! +! Ferrier (1994) version +! + if ( temg(mgs) .ge. 265.15 .and. temg(mgs) .le. 267.15 ) then + fimt1(mgs) = 0.5 + elseif (temg(mgs) .ge. 267.15 .and. temg(mgs) .le. 269.15 ) then + fimt1(mgs) = 1.0 + elseif (temg(mgs) .ge. 269.15 .and. temg(mgs) .le. 271.15 ) then + fimt1(mgs) = 0.5 + ELSE + fimt1(mgs) = 0.0 + end if +! +! +! type I: 350 splinters are formed for every 1e-3 grams of cloud +! water accreted by graupel/hail (note converted to MKS units) +! 3.5e+8 has units of 1/kg +! + IF ( itype1 .ge. 1 ) THEN + fimta(mgs) = (3.5e+08)*rho0(mgs) + ELSE + fimta(mgs) = 0.0 + ENDIF + +! +! +! type II: 1 splinter formed for every 250 cloud droplets larger than +! 24 micons in diameter (12 microns in radius) accreted by +! graupel/hail +! +! + fimt2(mgs) = 0.0 + xcwmas = xmas(mgs,lc) * 1000. +! + IF ( itype2 .ge. 1 ) THEN + if ( xcwmas.lt.1.26e-9 ) then + fimt2(mgs) = 0.0 + end if + if ( xcwmas .le. 3.55e-9 .and. xcwmas .ge. 1.26e-9 ) then + fimt2(mgs) = (2.27)*alog(xcwmas) + 13.39 + end if + if ( xcwmas .gt. 3.55e-9 ) then + fimt2(mgs) = 1.0 + end if + + fimt2(mgs) = min(fimt2(mgs),1.0) + fimt2(mgs) = max(fimt2(mgs),0.0) + + ENDIF +! +! qhmul2 = 0.0 +! qsmul2 = 0.0 +! +! qhmul2 = +! > (4.0e-03)*fimt1(mgs)*fimt2(mgs)*qhacw(mgs) +! qsmul2 = +! > (4.0e-03)*fimt1(mgs)*fimt2(mgs)*qsacw(mgs) +! +! cimas0 = (1.0e-12) +! cimas0 = 2.5e-10 + IF ( .not. wetsfc(mgs) ) THEN + chmul1(mgs) = fimt1(mgs)*(fimta(mgs) + & + & (4.0e-03)*fimt2(mgs))*qhacw(mgs) + ENDIF +! + qhmul1(mgs) = chmul1(mgs)*(cimas0/rho0(mgs)) + + IF ( lhl .gt. 1 ) THEN + IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. (.not. wetsfchl(mgs)) ) THEN + tmp = fimt1(mgs)*(fimta(mgs) + & + & (4.0e-03)*fimt2(mgs))*qhlacw(mgs) + chlmul1(mgs) = tmp + qhlmul1(mgs) = cimas0*tmp*rhoinv(mgs) + ENDIF + ENDIF + +! qsmul1(mgs) = csmul1(mgs)*(cimas0/rho0(mgs)) +! + ENDIF ! ( ipconc .ge. 2 ) + + end if ! (in temperature range) + + ENDIF ! ( itype1 .eq. 1 .or. itype2 .eq. 1) +! + end do +! +! +! +! end if +! +! end do +! +! +! ICE MULTIPLICATION FROM SNOW +! Lo and Passarelli 82 / Willis and Heymsfield 89 / Schuur and Rutledge 00b +! using kfrag as fragmentation rate (s-1) / 500 microns as char mean diam for max snow mix ratio +! + csmul(:) = 0.0 + qsmul(:) = 0.0 + + IF ( isnwfrac /= 0 ) THEN + do mgs = 1,ngscnt + IF (temg(mgs) .gt. 265.0) THEN !{ + if (xdia(mgs,ls,1) .gt. 100.e-6 .and. xdia(mgs,ls,1) .lt. 2.0e-3) then ! equiv diameter 100microns to 2mm + + tmp = rhoinv(mgs)*pi*xdn(mgs,ls)*cx(mgs,ls)*(500.e-6)**3 + qsmul(mgs) = Max( kfrag*( qx(mgs,ls) - tmp ) , 0.0 ) + + qsmul(mgs) = Min( qxmxd(mgs,li), qsmul(mgs) ) + csmul(mgs) = Min( cxmxd(mgs,li), rho0(mgs)*qsmul(mgs)/mfrag ) + + endif + ENDIF !} + enddo + ENDIF + +! +! frozen rain-rain interaction.... +! +! +! +! +! rain-ice interaction +! +! + do mgs = 1,ngscnt + qracif(mgs) = qraci(mgs) + cracif(mgs) = craci(mgs) +! ciacrf(mgs) = ciacr(mgs) + end do +! +! +! vapor to pristine ice crystals UP +! +! +! +! compute the nucleation rate +! +! do mgs = 1,ngscnt +! idqis = 0 +! if ( ssi(mgs) .gt. 1.0 ) idqis = 1 +! fiinit(mgs) = (felv(mgs)**2)/(cp*rw) +! dqisdt(mgs) = (qx(mgs,lv)-qis(mgs))/ +! > (1.0 + fiinit(mgs)*qis(mgs)/tsqr(mgs)) +! qidsvp(mgs) = dqisdt(mgs) +! cnnt = min(cnit*exp(-temcg(mgs)*bta1),1.0e+09) +! qiint(mgs) = +! > il5(mgs)*idqis*(1.0*dtpinv) +! < *min((6.88e-13)*cnnt/rho0(mgs), 0.25*dqisdt(mgs)) +! end do +! +! Meyers et al. (1992; JAS) and Ferrier (1994) primary ice nucleation +! + cmassin = cimasn ! 6.88e-13 + do mgs = 1,ngscnt + qiint(mgs) = 0.0 + ciint(mgs) = 0.0 + qicicnt(mgs) = 0.0 + cicint(mgs) = 0.0 + qipipnt(mgs) = 0.0 + cipint(mgs) = 0.0 + ccitmp = 0.0 + IF ( icenucopt == 1 .or. icenucopt == -10 .or. icenucopt == -11 ) THEN + if ( ( temg(mgs) .lt. 268.15 .or. & +! : ( imeyers5 .and. temg(mgs) .lt. 273.0) ) .and. & + & ( imeyers5 .and. temg(mgs) .lt. 272.0 .and. temgkm2(mgs) .lt. tfr) ) .and. & + & ciintmx .gt. (cx(mgs,li)+ccitmp) & +! : .and. cninm(mgs) .gt. 0. & + & ) then + fiinit(mgs) = (felv(mgs)**2)/(cp*rw) + dqisdt(mgs) = (qx(mgs,lv)-qis(mgs))/ & + & (1.0 + fiinit(mgs)*qis(mgs)/tsqr(mgs)) +! qidsvp(mgs) = dqisdt(mgs) + idqis = 0 + if ( ssi(mgs) .gt. 1.0 ) THEN + idqis = 1 + dzfacp = max( float(kgsp(mgs)-kgs(mgs)), 0.0 ) + dzfacm = max( float(kgs(mgs)-kgsm(mgs)), 0.0 ) + qiint(mgs) = & + & idqis*il5(mgs) & + & *(cmassin/rho0(mgs)) & + & *max(0.0,wvel(mgs)) & + & *max((cninp(mgs)-cninm(mgs)),0.0)/gz(igs(mgs),jgs,kgs(mgs)) & + & /((dzfacp+dzfacm)) + + qiint(mgs) = min(qiint(mgs), max(0.25*dqisdt(mgs),0.0)) + ciint(mgs) = qiint(mgs)*rho0(mgs)/cmassin + +! +! limit new crystals so it does not increase the current concentration +! above ciintmx 20,000 per liter (2.e7 per m**3) +! +! ciintmx = 1.e9 +! ciintmx = 1.e9 + IF ( icenucopt /= -10 ) THEN + + IF ( lcin > 1 ) THEN + ciint(mgs) = Min(ciint(mgs), ccin(mgs)*dtpinv) ! because ciint is a *rate* + ccin(mgs) = ccin(mgs) - ciint(mgs)*dtp + qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs) + ELSEIF ( lcina > 1 ) THEN + ciint(mgs) = Max(0.0, Min( ciint(mgs), Min( cnina(mgs), ciintmx ) - cina(mgs) )) + qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs) + + ELSEIF ( icenucopt == 1 .and. ciint(mgs) .gt. Max(0.0, ciintmx - cx(mgs,li) - ccitmp )*dtpinv ) THEN + ciint(mgs) = Max(0.0, ciintmx - (cx(mgs,li)) )*dtpinv + qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs) + + ELSEIF ( icenucopt == -11 .and. dtp*ciint(mgs) .gt. ( cnina(mgs) - (cx(mgs,li) - ccitmp))) THEN + ciint(mgs) = Max(0.0, cnina(mgs) - (cx(mgs,li)+ccitmp)*dtpinv ) + qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs) + + ENDIF + ENDIF + + end if + endif + + ELSEIF ( icenucopt == 2 .or. icenucopt == -1 .or. icenucopt == -2 ) THEN + + IF ( ( temg(mgs) .lt. 268.15 .and. ssw(mgs) > 1.0 ) .or. ssi(mgs) > 1.25 ) THEN + IF ( lcin > 1 ) THEN + ciint(mgs) = Min(cnina(mgs), ccin(mgs)) + ciint(mgs) = Min( ciint(mgs), Max(0.0, ciintmx - (cx(mgs,li) - ccitmp) ) ) ! do not initiate ice beyond concentration of ciintmx + ccin(mgs) = ccin(mgs) - ciint(mgs) + ciint(mgs) = ciint(mgs)*dtpinv ! convert total initiation to a rate + ELSE + ciint(mgs) = Max( 0.0, cnina(mgs) - cina(mgs) )*dtpinv + ENDIF + qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs) + + fiinit(mgs) = (felv(mgs)**2)/(cp*rw) + dqisdt(mgs) = (qx(mgs,lv)-qis(mgs))/(1.0 + fiinit(mgs)*qis(mgs)/tsqr(mgs)) + qiint(mgs) = min(qiint(mgs), max(0.25*dqisdt(mgs),0.0)) + ciint(mgs) = qiint(mgs)*rho0(mgs)/cmassin + ENDIF + + + + ELSEIF ( icenucopt == 3 .or. icenucopt == 4 .or. icenucopt == 10 ) THEN + IF ( temg(mgs) .lt. 268.15 ) THEN + IF ( lcin > 1 ) THEN + ciint(mgs) = Min(cnina(mgs), ccin(mgs)) + ciint(mgs) = Min( ciint(mgs), Max(0.0, ciintmx - (cx(mgs,li) + ccitmp) ) ) ! do not initiate ice beyond concentration of ciintmx + ccin(mgs) = ccin(mgs) - ciint(mgs) + ciint(mgs) = ciint(mgs)*dtpinv ! convert total initiation to a rate + ELSE + ciint(mgs) = Max( 0.0, cnina(mgs) - cina(mgs) )*dtpinv + ENDIF + qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs) + ENDIF + + ENDIF +! + if ( xplate(mgs) .eq. 1 ) then + qipipnt(mgs) = qiint(mgs) + cipint(mgs) = ciint(mgs) + end if +! + if ( xcolmn(mgs) .eq. 1 ) then + qicicnt(mgs) = qiint(mgs) + cicint(mgs) = ciint(mgs) + end if +! +! qipipnt(mgs) = 0.0 +! qicicnt(mgs) = qiint(mgs) +! + end do +! +! + +! +! vapor to cloud droplets UP +! + if (ndebug .gt. 0 ) write(0,*) 'dbg = 8' +! +! + if (ndebug .gt. 0 ) write(0,*) 'Collection: set 3-component' +! +! time for riming.... +! +! rimtim = 240.0 +! dtrim = rimtim +! xacrtim = 120.0 +! tranfr = 0.50 +! tranfw = 0.50 +! +! coefficients for riming +! +! rimc1 = 300.00 +! rimc2 = 0.44 +! +! +! zero some arrays +! +! + do mgs = 1,ngscnt + qrshr(mgs) = 0.0 + qwshw(mgs) = 0.0 + cwshw(mgs) = 0.0 + qsshrp(mgs) = 0.0 + qhshrp(mgs) = 0.0 + end do +! +! +! first sum all of the shed rain +! +! + do mgs = 1,ngscnt + qrshr(mgs) = qsshr(mgs) + qhshr(mgs) + qhlshr(mgs) + crshr(mgs) = chshrr(mgs)/rzxh(mgs) + chlshrr(mgs)/rzxhl(mgs) + + + IF ( ipconc .ge. 3 ) THEN +! crshr(mgs) = Max(crshr(mgs), rho0(mgs)*qrshr(mgs)/(xdn(mgs,lr)*vr1mm) ) + ENDIF + end do +! +! +! + +! +! +! +! + IF ( ipconc .ge. 1 ) THEN +! +! +! concentration production terms +! +! YYY +! +! +! DO mgs = 1,ngscnt + pccwi(:) = 0.0 + pccwd(:) = 0.0 + pccwdacc(:) = 0.0 + pccii(:) = 0.0 + pccin(:) = 0.0 + pccid(:) = 0.0 + pcisi(:) = 0.0 + pcisd(:) = 0.0 + pcrwi(:) = 0.0 + pcrwd(:) = 0.0 + pcswi(:) = 0.0 + pcswd(:) = 0.0 + pchwi(:) = 0.0 + pchwd(:) = 0.0 + pchli(:) = 0.0 + pchld(:) = 0.0 +! ENDDO +! +! Cloud ice +! +! IF ( ipconc .ge. 1 ) THEN + + IF ( warmonly < 0.5 ) THEN + IF ( ffrzs < 1.0 ) THEN + do mgs = 1,ngscnt + pccii(mgs) = & + & il5(mgs)*cicint(mgs) & + & +il5(mgs)*((1.0-cwfrz2snowfrac)*cwfrzc(mgs)+cwctfzc(mgs) & + & +cicichr(mgs)) & + & +chmul1(mgs) & + & +chlmul1(mgs) & + & + csplinter(mgs) + csplinter2(mgs) & + & +csmul(mgs) + + pccii(mgs) = pccii(mgs)*(1.0 - ffrzs) + +! > + nsplinter*(crfrzf(mgs) + crfrz(mgs)) + pccid(mgs) = & + & il5(mgs)*(-cscni(mgs) - cscnvi(mgs) & ! - cwaci(mgs) & + & -craci(mgs) & + & -csaci(mgs) & + & -chaci(mgs) - chlaci(mgs) & + & -chcni(mgs)) & + & +il5(mgs)*cisbv(mgs) & + & -(1.-il5(mgs))*cimlr(mgs) + + pccin(mgs) = ciint(mgs) + + + end do + ENDIF ! ffrzs + ELSEIF ( warmonly < 0.8 ) THEN + do mgs = 1,ngscnt + +! qiint(mgs) = 0.0 +! cicint(mgs) = 0.0 +! qicicnt(mgs) = 0.0 + + pccii(mgs) = & + & il5(mgs)*cicint(mgs) & + & +il5(mgs)*((1.0-cwfrz2snowfrac)*cwfrzc(mgs)+cwctfzc(mgs) & + & +cicichr(mgs)) & + & +chmul1(mgs) & + & +chlmul1(mgs) & + & + csplinter(mgs) + csplinter2(mgs) & + & +csmul(mgs) + + pccii(mgs) = pccii(mgs)*(1. - ffrzs) + pccid(mgs) = & +! & il5(mgs)*(-cscni(mgs) - cscnvi(mgs) & ! - cwaci(mgs) & +! & -craci(mgs) & +! & -csaci(mgs) & +! & -chaci(mgs) - chlaci(mgs) & +! & -chcni(mgs)) & + & +il5(mgs)*cisbv(mgs) & + & -(1.-il5(mgs))*cimlr(mgs) + + pccin(mgs) = ciint(mgs) + + end do + ENDIF ! warmonly + + +! ENDIF ! ( ipconc .ge. 1 ) +! +! Cloud water +! + IF ( ipconc .ge. 2 ) THEN + + do mgs = 1,ngscnt + pccwi(mgs) = (0.0) - cwshw(mgs) ! + (1-il5(mgs))*(-cirmlw(mgs)) + + IF ( warmonly < 0.5 ) THEN + pccwd(mgs) = & + & - cautn(mgs) + & + & il5(mgs)*(-ciacw(mgs)-cwfrz(mgs)-cwctfzp(mgs) & + & -cwctfzc(mgs) & + & ) & + & -cracw(mgs) -csacw(mgs) -chacw(mgs) - chlacw(mgs) + + + ELSEIF ( warmonly < 0.8 ) THEN + pccwd(mgs) = & + & - cautn(mgs) + & + & il5(mgs)*( & + & -ciacw(mgs)-cwfrz(mgs)-cwctfzp(mgs) & + & -cwctfzc(mgs) & + & ) & + & -cracw(mgs) -chacw(mgs) -chlacw(mgs) + ELSE + +! tmp3d(igs(mgs),jy,kgs(mgs)) = crcnw(mgs) + +! cracw(mgs) = 0.0 ! turn off accretion +! qracw(mgs) = 0.0 +! crcev(mgs) = 0.0 ! turn off evap +! qrcev(mgs) = 0.0 ! turn off evap +! cracr(mgs) = 0.0 ! turn off self collection + + +! cautn(mgs) = 0.0 +! crcnw(mgs) = 0.0 +! qrcnw(mgs) = 0.0 + + pccwd(mgs) = & + & - cautn(mgs) -cracw(mgs) + ENDIF + + + IF ( .false. .and. exwmindiam > 0.0 .and. ccwresv(mgs) > 0.0 ) THEN + pccwdacc(mgs) = & + & il5(mgs)*(-ciacw(mgs) & + & ) & + & -cracw(mgs) -csacw(mgs) -chacw(mgs) - chlacw(mgs) + + IF ( -pccwdacc(mgs)*dtp .gt. cx(mgs,lc) - ccwresv(mgs) ) THEN + + frac = -(cx(mgs,lc) - ccwresv(mgs) )/(pccwdacc(mgs)*dtp) + pccwdacc(mgs) = -(cx(mgs,lc) - ccwresv(mgs) )*dtpinv + + ciacw(mgs) = frac*ciacw(mgs) + cracw(mgs) = frac*cracw(mgs) + csacw(mgs) = frac*csacw(mgs) + chacw(mgs) = frac*chacw(mgs) + cautn(mgs) = frac*cautn(mgs) + + IF ( lhl .gt. 1 ) chlacw(mgs) = frac*chlacw(mgs) + +! resum + pccwd(mgs) = & + & - cautn(mgs) + & + & il5(mgs)*(-ciacw(mgs)-cwfrzp(mgs)-cwctfzp(mgs) & + & -cwfrzc(mgs)-cwctfzc(mgs) & + & -il5(mgs)*(ciihr(mgs)) & + & ) & + & -cracw(mgs) -csacw(mgs) -chacw(mgs) - chlacw(mgs) + + ENDIF + + ENDIF + + + IF ( -pccwd(mgs)*dtp .gt. cx(mgs,lc) ) THEN +! write(0,*) 'OUCH! pccwd(mgs)*dtp .gt. ccw(mgs) ',pccwd(mgs),cx(mgs,lc) +! write(0,*) 'qc = ',qx(mgs,lc) +! write(0,*) -ciacw(mgs)-cwfrzp(mgs)-cwctfzp(mgs)-cwfrzc(mgs)-cwctfzc(mgs) +! write(0,*) -cracw(mgs) -csacw(mgs) -chacw(mgs) +! write(0,*) - cautn(mgs) + + frac = -cx(mgs,lc)/(pccwd(mgs)*dtp) + pccwd(mgs) = -cx(mgs,lc)*dtpinv + + ciacw(mgs) = frac*ciacw(mgs) + cwfrz(mgs) = frac*cwfrz(mgs) + cwfrzp(mgs) = frac*cwfrzp(mgs) + cwctfzp(mgs) = frac*cwctfzp(mgs) + cwfrzc(mgs) = frac*cwfrzc(mgs) + cwctfzc(mgs) = frac*cwctfzc(mgs) + cwctfz(mgs) = frac*cwctfz(mgs) + cracw(mgs) = frac*cracw(mgs) + csacw(mgs) = frac*csacw(mgs) + chacw(mgs) = frac*chacw(mgs) + cautn(mgs) = frac*cautn(mgs) + + pccii(mgs) = pccii(mgs) - (1.-frac)*il5(mgs)*(cwfrzc(mgs)+cwctfzc(mgs))*(1. - ffrzs) + IF ( lhl .gt. 1 ) chlacw(mgs) = frac*chlacw(mgs) + +! STOP + ENDIF + + end do + + ENDIF ! ipconc + +! +! Rain +! + IF ( ipconc .ge. 3 ) THEN + + do mgs = 1,ngscnt + + IF ( warmonly < 0.5 ) THEN + pcrwi(mgs) = & +! > cracw(mgs) + & + & crcnw(mgs) & + & +(1-il5(mgs))*( & + & -chmlrr(mgs)/rzxh(mgs) & + & -chlmlrr(mgs)/rzxhl(mgs) & +! & -csmlr(mgs)/rzxs(mgs) & + & -csmlrr(mgs) & + & - cimlr(mgs) ) & + & -crshr(mgs) !null at this point when wet snow/graupel included + pcrwd(mgs) = & + & il5(mgs)*(-ciacr(mgs) - crfrz(mgs) ) & ! - cipacr(mgs)) +! > -csacr(mgs) & + & - chacr(mgs) - chlacr(mgs) & + & +crcev(mgs) & + & - cracr(mgs) +! > -il5(mgs)*ciracr(mgs) + + + ELSEIF ( warmonly < 0.8 ) THEN + pcrwi(mgs) = & + & crcnw(mgs) & + & +(1-il5(mgs))*( & + & -chmlrr(mgs)/rzxh(mgs) & + & -chlmlrr(mgs)/rzxhl(mgs) & +! & -csmlr(mgs) & + & -csmlrr(mgs) & + & - cimlr(mgs) ) & + & -crshr(mgs) !null at this point when wet snow/graupel included + pcrwd(mgs) = & + & il5(mgs)*( - crfrz(mgs) ) & ! - cipacr(mgs)) + & - chacr(mgs) & + & - chlacr(mgs) & + & +crcev(mgs) & + & - cracr(mgs) + ELSE + pcrwi(mgs) = & + & crcnw(mgs) + pcrwd(mgs) = & + & +crcev(mgs) & + & - cracr(mgs) + +! tmp3d(igs(mgs),jy,kgs(mgs)) = vtxbar(mgs,lr,1) ! crcnw(mgs) ! (pcrwi(mgs) + pcrwd(mgs)) +! pcrwi(mgs) = 0.0 +! pcrwd(mgs) = 0.0 +! qrcnw(mgs) = 0.0 + + ENDIF + + + frac = 0.0 + IF ( -pcrwd(mgs)*dtp .gt. cx(mgs,lr) ) THEN +! write(0,*) 'OUCH! pcrwd(mgs)*dtp .gt. crw(mgs) ',pcrwd(mgs)*dtp,cx(mgs,lr),mgs,igs(mgs),kgs(mgs) +! write(0,*) -ciacr(mgs) +! write(0,*) -crfrz(mgs) +! write(0,*) -chacr(mgs) +! write(0,*) crcev(mgs) +! write(0,*) -cracr(mgs) + + frac = -cx(mgs,lr)/(pcrwd(mgs)*dtp) + pcrwd(mgs) = -cx(mgs,lr)*dtpinv + + ciacr(mgs) = frac*ciacr(mgs) + ciacrf(mgs) = frac*ciacrf(mgs) + ciacrs(mgs) = frac*ciacrs(mgs) + crfrz(mgs) = frac*crfrz(mgs) + crfrzf(mgs) = frac*crfrzf(mgs) + crfrzs(mgs) = frac*crfrzs(mgs) + chacr(mgs) = frac*chacr(mgs) + chlacr(mgs) = frac*chlacr(mgs) + crcev(mgs) = frac*crcev(mgs) + cracr(mgs) = frac*cracr(mgs) + +! STOP + ENDIF + + end do + + ENDIF + + + IF ( warmonly < 0.5 ) THEN + +! +! Snow +! + IF ( ipconc .ge. 4 ) THEN ! + + do mgs = 1,ngscnt + pcswi(mgs) = & + & il5(mgs)*(cscnis(mgs) + cscnvis(mgs) ) & + & + cwfrz2snowfrac*cwfrz(mgs)/cwfrz2snowratio & + & + cscnh(mgs) + + IF ( ffrzs > 0.0 ) THEN + pcswi(mgs) = pcswi(mgs) + ffrzs* ( & + & il5(mgs)*cicint(mgs) & + & +il5(mgs)*(cwfrzc(mgs)+cwctfzc(mgs) & + & +cicichr(mgs)) & + & +chmul1(mgs) & + & +chlmul1(mgs) & + & + csplinter(mgs) + csplinter2(mgs) & + & +csmul(mgs) ) + ENDIF + + + IF ( ess0 < 0.0 ) THEN + csacs(mgs) = Max(0.0, csacs(mgs) - (ifrzs)*(crfrzs(mgs) + ciacrs(mgs))) + ENDIF + + pcswd(mgs) = & +! : cracs(mgs) & + & -chacs(mgs) - chlacs(mgs) & + & -chcns(mgs) & + & +(1-il5(mgs))*csmlr(mgs) + csshr(mgs) & ! + csshrp(mgs) +! > +il5(mgs)*(cssbv(mgs)) & + & + cssbv(mgs) & + & - csacs(mgs) + + frac = 0.0 + IF ( imixedphase == 0 ) THEN + IF ( cx(mgs,ls) + dtp*(pcswi(mgs) + pcswd(mgs)) < 0.0 ) THEN + frac = (-cx(mgs,ls) + pcswi(mgs)*dtp)/(pcswd(mgs)*dtp) + + pcswd(mgs) = frac*pcswd(mgs) + + chacs(mgs) = frac*chacs(mgs) + chlacs(mgs) = frac*chlacs(mgs) + chcns(mgs) = frac*chcns(mgs) + csmlr(mgs) = frac*csmlr(mgs) + csshr(mgs) = frac*csshr(mgs) + cssbv(mgs) = frac*cssbv(mgs) + csacs(mgs) = frac*csacs(mgs) + + ENDIF + ENDIF + + + + pccii(mgs) = pccii(mgs) & + & + (1. - ifrzs)*crfrzs(mgs) & + & + (1. - ifrzs)*ciacrs(mgs) + + pcswi(mgs) = pcswi(mgs) & + & + (ifrzs)*crfrzs(mgs) & + & + (ifrzs)*ciacrs(mgs) + + end do + + ENDIF + +! +! Graupel +! + IF ( ipconc .ge. 5 ) THEN ! + do mgs = 1,ngscnt + pchwi(mgs) = & + & +(ffrzh*ifrzg*crfrzf(mgs) & + & +il5(mgs)*ffrzh*ifiacrg*(ciacrf(mgs) )) & + & + f2h*chcnsh(mgs) + f2h*chcnih(mgs) + chcnhl(mgs) + + pchwd(mgs) = & + & (1-il5(mgs))*chmlr(mgs) & +! > + il5(mgs)*chsbv(mgs) & + & + chsbv(mgs) & + & - il5(mgs)*chlcnh(mgs) & + & - cscnh(mgs) + + end do + + + +! + +! +! Hail +! + IF ( lhl .gt. 1 .and. lnhl > 1 ) THEN ! + do mgs = 1,ngscnt + pchli(mgs) = (ffrzh*(1.0-ifrzg)*crfrzf(mgs) +il5(mgs)*ffrzh*(1.0-ifiacrg)*(ciacrf(mgs) )) & + & + chlcnhhl(mgs) *rzxhlh(mgs) + + pchld(mgs) = & + & (1-il5(mgs))*chlmlr(mgs) & +! > + il5(mgs)*chlsbv(mgs) & + & + chlsbv(mgs) - chcnhl(mgs) + + IF ( imixedphase == 0 ) THEN + frac = 0.0 + IF ( cx(mgs,lhl) + dtp*(pchli(mgs) + pchld(mgs)) < 0.0 ) THEN + ! rescale depletion + + frac = (-cx(mgs,lhl) + pchli(mgs)*dtp)/(pchld(mgs)*dtp) + + chlmlr(mgs) = frac*chlmlr(mgs) + chlsbv(mgs) = frac*chlsbv(mgs) + chcnhl(mgs) = frac*chcnhl(mgs) + + pchld(mgs) = frac*pchld(mgs) + + ENDIF + ENDIF + + end do + + ENDIF +! + + ENDIF ! (ipconc .ge. 5 ) + + ELSEIF ( warmonly < 0.8 ) THEN + +! +! Graupel +! + IF ( ipconc .ge. 5 ) THEN ! + do mgs = 1,ngscnt + pchwi(mgs) = & + & +ifrzg*(crfrzf(mgs) ) ! +il5(mgs)*(ciacrf(mgs) )) + + pchwd(mgs) = & + & (1-il5(mgs))*chmlr(mgs) & + & - il5(mgs)*chlcnh(mgs) + end do +! +! Hail +! + IF ( lhl .gt. 1 ) THEN ! + do mgs = 1,ngscnt + pchli(mgs) = (1.0-ifrzg)*(crfrzf(mgs)) & ! +il5(mgs)*(ciacrf(mgs) )) & + & + chlcnhhl(mgs) *rzxhl(mgs)/rzxh(mgs) + + pchld(mgs) = & + & (1-il5(mgs))*chlmlr(mgs) ! & +! > + il5(mgs)*chlsbv(mgs) & +! & + chlsbv(mgs) + +! IF ( pchli(mgs) .ne. 0. .or. pchld(mgs) .ne. 0 ) THEN +! write(0,*) 'dr: pchli,pchld = ', pchli(mgs),pchld(mgs), igs(mgs),kgs(mgs) +! ENDIF + end do + + ENDIF + + ENDIF ! ipconc >= 5 + + ENDIF ! warmonly + +! + +! +! Balance and checks for continuity.....within machine precision... +! + do mgs = 1,ngscnt + pctot(mgs) = pccwi(mgs) +pccwd(mgs) + & + & pccii(mgs) +pccid(mgs) + & + & pcrwi(mgs) +pcrwd(mgs) + & + & pcswi(mgs) +pcswd(mgs) + & + & pchwi(mgs) +pchwd(mgs) + & + & pchli(mgs) +pchld(mgs) + end do +! +! + ENDIF ! ( ipconc .ge. 1 ) +! +! +! +! +! +! GOGO +! production terms for mass +! +! + pqwvi(:) = 0.0 + pqwvd(:) = 0.0 + pqcwi(:) = 0.0 + pqcwd(:) = 0.0 + pqcwdacc(:) = 0.0 + pqcii(:) = 0.0 + pqcid(:) = 0.0 + pqrwi(:) = 0.0 + pqrwd(:) = 0.0 + pqswi(:) = 0.0 + pqswd(:) = 0.0 + pqhwi(:) = 0.0 + pqhwd(:) = 0.0 + pqhli(:) = 0.0 + pqhld(:) = 0.0 + pqlwsi(:) = 0.0 + pqlwsd(:) = 0.0 + pqlwhi(:) = 0.0 + pqlwhd(:) = 0.0 + pqlwlghi(:) = 0.0 + pqlwlghd(:) = 0.0 + pqlwlghli(:) = 0.0 + pqlwlghld(:) = 0.0 + pqlwhli(:) = 0.0 + pqlwhld(:) = 0.0 + + +! +! Vapor +! + IF ( warmonly < 0.5 ) THEN + do mgs = 1,ngscnt + +! NOTE: ANY CHANGES HERE ALSO NEED TO GO INTO THE RESUM FARTHER DOWN! + pqwvi(mgs) = & + & -Min(0.0, qrcev(mgs)) & + & -Min(0.0, qhcev(mgs)) & + & -Min(0.0, qhlcev(mgs)) & + & -Min(0.0, qscev(mgs)) & +! > +il5(mgs)*(-qhsbv(mgs) - qhlsbv(mgs) ) & + & -qhsbv(mgs) - qhlsbv(mgs) & + & -qssbv(mgs) & + & -il5(mgs)*qisbv(mgs) + + pqwvd(mgs) = & + & -Max(0.0, qrcev(mgs)) & + & -Max(0.0, qhcev(mgs)) & + & -Max(0.0, qhlcev(mgs)) & + & -Max(0.0, qscev(mgs)) & + & +il5(mgs)*(-qiint(mgs) & + & -qhdpv(mgs) -qsdpv(mgs) - qhldpv(mgs)) & + & -il5(mgs)*qidpv(mgs) + + end do + + ELSEIF ( warmonly < 0.8 ) THEN + do mgs = 1,ngscnt + pqwvi(mgs) = & + & -Min(0.0, qrcev(mgs)) & + & -il5(mgs)*qisbv(mgs) + pqwvd(mgs) = & + & +il5(mgs)*(-qiint(mgs) & +! & -qhdpv(mgs) ) & !- qhldpv(mgs)) & + & -qhdpv(mgs) - qhldpv(mgs)) & +! & -qhdpv(mgs) -qsdpv(mgs) - qhldpv(mgs)) & + & -Max(0.0, qrcev(mgs)) & + & -il5(mgs)*qidpv(mgs) + end do + + ELSE + do mgs = 1,ngscnt + pqwvi(mgs) = & + & -Min(0.0, qrcev(mgs)) + pqwvd(mgs) = & + & -Max(0.0, qrcev(mgs)) + end do + + ENDIF ! warmonly +! +! Cloud water +! + do mgs = 1,ngscnt + + pqcwi(mgs) = (0.0) + qwcnr(mgs) - qwshw(mgs) + + IF ( warmonly < 0.5 ) THEN + pqcwd(mgs) = & + & il5(mgs)*(-qiacw(mgs)-qwfrz(mgs)-qwctfz(mgs)) & + & -il5(mgs)*(qiihr(mgs)) & + & -qracw(mgs) -qsacw(mgs) -qrcnw(mgs) -qhacw(mgs) - qhlacw(mgs) !& +! & -il5(mgs)*(qwfrzp(mgs)) + ELSEIF ( warmonly < 0.8 ) THEN + pqcwd(mgs) = & + & il5(mgs)*(-qiacw(mgs)-qwfrz(mgs)-qwctfz(mgs)) & + & -il5(mgs)*(qiihr(mgs)) & + & -qracw(mgs) -qrcnw(mgs) -qhacw(mgs) -qhlacw(mgs) + ELSE + pqcwd(mgs) = & + & -qracw(mgs) - qrcnw(mgs) + ENDIF + + + IF ( pqcwd(mgs) .lt. 0.0 .and. -pqcwd(mgs)*dtp .gt. qx(mgs,lc) ) THEN + + frac = -Max(0.0,qx(mgs,lc))/(pqcwd(mgs)*dtp) + pqcwd(mgs) = -qx(mgs,lc)*dtpinv + + qiacw(mgs) = frac*qiacw(mgs) +! qwfrzp(mgs) = frac*qwfrzp(mgs) +! qwctfzp(mgs) = frac*qwctfzp(mgs) + qwfrzc(mgs) = frac*qwfrzc(mgs) + qwfrz(mgs) = frac*qwfrz(mgs) + qwctfzc(mgs) = frac*qwctfzc(mgs) + qwctfz(mgs) = frac*qwctfz(mgs) + qracw(mgs) = frac*qracw(mgs) + qsacw(mgs) = frac*qsacw(mgs) + qhacw(mgs) = frac*qhacw(mgs) + vhacw(mgs) = frac*vhacw(mgs) + qrcnw(mgs) = frac*qrcnw(mgs) + qwfrzp(mgs) = frac*qwfrzp(mgs) + IF ( lhl .gt. 1 ) THEN + qhlacw(mgs) = frac*qhlacw(mgs) + vhlacw(mgs) = frac*vhlacw(mgs) + ENDIF +! IF ( lzh .gt. 1 ) zhacw(mgs) = frac*zhacw(mgs) + +! STOP + ENDIF + + + end do +! +! Cloud ice +! + IF ( warmonly < 0.5 ) THEN + + do mgs = 1,ngscnt + IF ( ffrzs < 1.0 ) THEN + pqcii(mgs) = & + & il5(mgs)*qicicnt(mgs) & + & +il5(mgs)*((1.0-cwfrz2snowfrac)*qwfrzc(mgs)+qwctfzc(mgs)) & + & +il5(mgs)*(qicichr(mgs)) & + & +qsmul(mgs) & + & +qhmul1(mgs) + qhlmul1(mgs) & + & + qsplinter(mgs) + qsplinter2(mgs) +! > + cimas0*nsplinter*(crfrzf(mgs) + crfrz(mgs))/rho0(mgs) + ENDIF + + pqcii(mgs) = pqcii(mgs)*(1.0 - ffrzs) & + & +il5(mgs)*qidpv(mgs) & + & +il5(mgs)*qiacw(mgs) + + pqcid(mgs) = & + & il5(mgs)*(-qscni(mgs) - qscnvi(mgs) & ! -qwaci(mgs) & + & -qraci(mgs) & + & -qsaci(mgs) ) & + & -qhaci(mgs) & + & -qhlaci(mgs) & + & +il5(mgs)*qisbv(mgs) & + & +(1.-il5(mgs))*qimlr(mgs) & + & - qhcni(mgs) + end do + + + ELSEIF ( warmonly < 0.8 ) THEN + + do mgs = 1,ngscnt + pqcii(mgs) = & + & il5(mgs)*qicicnt(mgs)*(1. - ffrzs) & + & +il5(mgs)*((1.0-cwfrz2snowfrac)*qwfrzc(mgs)+qwctfzc(mgs))*(1. - ffrzs) & + & +il5(mgs)*(qicichr(mgs))*(1. - ffrzs) & +! & +il5(mgs)*(qicichr(mgs)) & +! & +qsmul(mgs) & + & +qhmul1(mgs) + qhlmul1(mgs) & + & + qsplinter(mgs) + qsplinter2(mgs) & + & +il5(mgs)*qidpv(mgs) & + & +il5(mgs)*qiacw(mgs) ! & ! (qiacwi(mgs)+qwacii(mgs)) & +! & +il5(mgs)*(qwfrzc(mgs)+qwctfzc(mgs)) & +! & +il5(mgs)*(qicichr(mgs)) & +! & +qsmul(mgs) & +! & +qhmul1(mgs) + qhlmul1(mgs) & +! & + qsplinter(mgs) + qsplinter2(mgs) + + pqcid(mgs) = & +! & il5(mgs)*(-qscni(mgs) - qscnvi(mgs) & ! -qwaci(mgs) & +! & -qraci(mgs) & +! & -qsaci(mgs) ) & +! & -qhaci(mgs) & +! & -qhlaci(mgs) & + & +il5(mgs)*qisbv(mgs) & + & +(1.-il5(mgs))*qimlr(mgs) ! & +! & - qhcni(mgs) + end do + + ENDIF +! +! Rain +! + + do mgs = 1,ngscnt + IF ( warmonly < 0.5 ) THEN + pqrwi(mgs) = & + & qracw(mgs) + qrcnw(mgs) + Max(0.0, qrcev(mgs)) & + & +(1-il5(mgs))*( & + & -qhmlr(mgs) & !null at this point when wet snow/graupel included + & -qsmlr(mgs) - qhlmlr(mgs) & + & -qimlr(mgs)) & +! & -qsshr(mgs) & !null at this point when wet snow/graupel included +! & -qhshr(mgs) & !null at this point when wet snow/graupel included +! & -qhlshr(mgs) & + & - qrshr(mgs) + + pqrwd(mgs) = & + & il5(mgs)*(-qiacr(mgs)-qrfrz(mgs)) & + & - qsacr(mgs) - qhacr(mgs) - qhlacr(mgs) - qwcnr(mgs) & + & + Min(0.0,qrcev(mgs)) + ELSEIF ( warmonly < 0.8 ) THEN + pqrwi(mgs) = & + & qracw(mgs) + qrcnw(mgs) + Max(0.0, qrcev(mgs)) & + & +(1-il5(mgs))*( & + & -qhlmlr(mgs) & !null at this point when wet snow/graupel included + & -qhmlr(mgs) ) & !null at this point when wet snow/graupel included + & -qhshr(mgs) & !null at this point when wet snow/graupel included + & -qhlshr(mgs) !null at this point when wet snow/graupel included + pqrwd(mgs) = & + & il5(mgs)*(-qrfrz(mgs)) & + & - qhacr(mgs) & + & - qhlacr(mgs) & + & + Min(0.0,qrcev(mgs)) + ELSE + pqrwi(mgs) = & + & qracw(mgs) + qrcnw(mgs) + Max(0.0, qrcev(mgs)) + pqrwd(mgs) = Min(0.0,qrcev(mgs)) + ENDIF ! warmonly + + + ! IF ( pqrwd(mgs) .lt. 0.0 .and. -(pqrwd(mgs) + pqrwi(mgs))*dtp .gt. qx(mgs,lr) ) THEN + IF ( pqrwd(mgs) .lt. 0.0 .and. -(pqrwd(mgs) + pqrwi(mgs))*dtp .gt. qx(mgs,lr) ) THEN + + frac = (-qx(mgs,lr) + pqrwi(mgs)*dtp)/(pqrwd(mgs)*dtp) +! pqrwd(mgs) = -qx(mgs,lr)*dtpinv + pqrwi(mgs) + + pqwvi(mgs) = pqwvi(mgs) & + & + Min(0.0, qrcev(mgs)) & + & - frac*Min(0.0, qrcev(mgs)) + pqwvd(mgs) = pqwvd(mgs) & + & + Max(0.0, qrcev(mgs)) & + & - frac*Max(0.0, qrcev(mgs)) + + qiacr(mgs) = frac*qiacr(mgs) + qiacrf(mgs) = frac*qiacrf(mgs) + qiacrs(mgs) = frac*qiacrs(mgs) + viacrf(mgs) = frac*viacrf(mgs) + qrfrz(mgs) = frac*qrfrz(mgs) + qrfrzs(mgs) = frac*qrfrzs(mgs) + qrfrzf(mgs) = frac*qrfrzf(mgs) + vrfrzf(mgs) = frac*vrfrzf(mgs) + qsacr(mgs) = frac*qsacr(mgs) + qhacr(mgs) = frac*qhacr(mgs) + vhacr(mgs) = frac*vhacr(mgs) + qrcev(mgs) = frac*qrcev(mgs) + qhlacr(mgs) = frac*qhlacr(mgs) + vhlacr(mgs) = frac*vhlacr(mgs) +! qhcev(mgs) = frac*qhcev(mgs) + + + IF ( warmonly < 0.5 ) THEN + pqrwd(mgs) = & + & il5(mgs)*(-qiacr(mgs)-qrfrz(mgs) - qsacr(mgs)) & + & - qhacr(mgs) - qhlacr(mgs) - qwcnr(mgs) & + & + Min(0.0,qrcev(mgs)) + ELSEIF ( warmonly < 0.8 ) THEN + pqrwd(mgs) = & + & il5(mgs)*(-qrfrz(mgs)) & + & - qhacr(mgs) & + & - qhlacr(mgs) & + & + Min(0.0,qrcev(mgs)) + ELSE + pqrwd(mgs) = Min(0.0,qrcev(mgs)) + ENDIF ! warmonly + +! +! Resum for vapor since qrcev has changed +! + IF ( qrcev(mgs) .ne. 0.0 ) THEN + pqwvi(mgs) = & + & -Min(0.0, qrcev(mgs)) & + & -Min(0.0, qhcev(mgs)) & + & -Min(0.0, qhlcev(mgs)) & + & -Min(0.0, qscev(mgs)) & +! > +il5(mgs)*(-qhsbv(mgs) - qhlsbv(mgs) ) & + & -qhsbv(mgs) - qhlsbv(mgs) & + & -qssbv(mgs) & + & -il5(mgs)*qisbv(mgs) + + pqwvd(mgs) = & + & -Max(0.0, qrcev(mgs)) & + & -Max(0.0, qhcev(mgs)) & + & -Max(0.0, qhlcev(mgs)) & + & -Max(0.0, qscev(mgs)) & + & +il5(mgs)*(-qiint(mgs) & + & -qhdpv(mgs) -qsdpv(mgs) - qhldpv(mgs)) & + & -il5(mgs)*qidpv(mgs) + + ENDIF + + +! STOP + ENDIF + end do + + IF ( warmonly < 0.5 ) THEN + +! +! Snow +! + do mgs = 1,ngscnt + pqswi(mgs) = & + & il5(mgs)*(qscni(mgs)+qsaci(mgs)+qsdpv(mgs) & + & + qscnvi(mgs) & + & + ifrzs*(qiacrs(mgs) + qrfrzs(mgs)) & + & + il5(mgs)*(( qwfrzc(mgs) + qwctfzc(mgs) + qicichr(mgs) )*ffrzs & + & + (1.0 - ffrzs)*cwfrz2snowfrac*qwfrz(mgs) ) & + & + il2(mgs)*qsacr(mgs)) & + & + il5(mgs)*qicicnt(mgs)*ffrzs & + & + il3(mgs)*(qiacrf(mgs)+qracif(mgs)) & ! only applies for ipconc <= 3 + & + Max(0.0, qscev(mgs)) & + & + qsacw(mgs) + qscnh(mgs) & + & + ffrzs*(qsmul(mgs) & + & +qhmul1(mgs) + qhlmul1(mgs) & + & + qsplinter(mgs) + qsplinter2(mgs)) + pqswd(mgs) = & +! > -qfacs(mgs) ! -qwacs(mgs) & + & -qracs(mgs)*(1-il2(mgs)) -qhacs(mgs) - qhlacs(mgs) & + & -qhcns(mgs) & + & +(1-il5(mgs))*qsmlr(mgs) + qsshr(mgs) & !null at this point when wet snow included +! > +il5(mgs)*(qssbv(mgs)) & + & + (qssbv(mgs)) & + & + Min(0.0, qscev(mgs)) & + & -qsmul(mgs) + + + IF ( imixedphase == 0 .and. pqswd(mgs) .lt. 0.0 ) THEN + IF ( qx(mgs,ls) + dtp*(pqswi(mgs) + pqswd(mgs)) < 0.0 ) THEN + frac = (-qx(mgs,ls) + pqswi(mgs)*dtp)/(pqswd(mgs)*dtp) + + pqswd(mgs) = frac*pqswd(mgs) + + qracs(mgs) = frac*qracs(mgs) ! only used for single moment at this time + qhacs(mgs) = frac*qhacs(mgs) + qhlacs(mgs) = frac*qhlacs(mgs) + qhcns(mgs) = frac*qhcns(mgs) + qsmlr(mgs) = frac*qsmlr(mgs) + qsshr(mgs) = frac*qsshr(mgs) + qssbv(mgs) = frac*qssbv(mgs) + qsmul(mgs) = frac*qsmul(mgs) + IF ( qscev(mgs) < 0.0 ) qscev(mgs) = frac*qscev(mgs) + + ENDIF + ENDIF + + pqcii(mgs) = pqcii(mgs) & + & + (1. - ifrzs)*qrfrzs(mgs) & + & + (1. - ifrzs)*qiacrs(mgs) + + end do + +! +! Graupel +! + do mgs = 1,ngscnt + pqhwi(mgs) = & + & +il5(mgs)*(ffrzh*ifrzg*qrfrzf(mgs) + (1-il3(mgs))*ffrzh*ifiacrg*(qiacrf(mgs)+qracif(mgs))) & + & + (1-il2(mgs))*(qracs(mgs) + qsacr(mgs)) & ! only used for ipconc < 3 + & +il5(mgs)*(qhdpv(mgs)) & + & +Max(0.0, qhcev(mgs)) & + & +qhacr(mgs)+qhacw(mgs) & + & +qhacs(mgs)+qhaci(mgs) & + & + f2h*qhcns(mgs) + f2h*qhcni(mgs) + qhcnhl(mgs) + pqhwd(mgs) = & + & qhshr(mgs) & !null at this point when wet graupel included + & +(1-il5(mgs))*qhmlr(mgs) & !null at this point when wet graupel included +! > +il5(mgs)*qhsbv(mgs) & + & + qhsbv(mgs) & + & + Min(0.0, qhcev(mgs)) & + & -qhmul1(mgs) - qhlcnh(mgs) - qscnh(mgs) & + & - ffrzh*(qsplinter(mgs) + qsplinter2(mgs)) +! > - cimas0*nsplinter*(crfrzf(mgs) + crfrz(mgs))/rho0(mgs) + + end do + + +! +! Hail +! + IF ( lhl .gt. 1 ) THEN + + do mgs = 1,ngscnt + pqhli(mgs) = & + & +il5(mgs)*(qhldpv(mgs) + ((1.0-ifrzg)*qrfrzf(mgs) + (1.0-ifiacrg)*(qiacrf(mgs)+ qracif(mgs)))) & + & +Max(0.0, qhlcev(mgs)) & + & +qhlacr(mgs)+qhlacw(mgs) & + & +qhlacs(mgs)+qhlaci(mgs) & + & + qhlcnh(mgs) + pqhld(mgs) = & + & qhlshr(mgs) & + & +(1-il5(mgs))*qhlmlr(mgs) & +! > +il5(mgs)*qhlsbv(mgs) & + & + qhlsbv(mgs) & + & + Min(0.0, qhlcev(mgs)) & + & -qhlmul1(mgs) - qhcnhl(mgs) + + IF ( imixedphase == 0 ) THEN + frac = 0.0 + IF ( qx(mgs,lhl) + dtp*(pqhli(mgs) + pqhld(mgs)) < 0.0 ) THEN + ! rescale depletion + + frac = (-qx(mgs,lhl) + pqhli(mgs)*dtp)/(pqhld(mgs)*dtp) + + qhlmlr(mgs) = frac*qhlmlr(mgs) + qhlsbv(mgs) = frac*qhlsbv(mgs) + qhcnhl(mgs) = frac*qhcnhl(mgs) + qhlmul1(mgs) = frac*qhlmul1(mgs) + IF ( qhlcev(mgs) < 0.0 ) qhlcev(mgs) = frac*qhlcev(mgs) + + pqhld(mgs) = frac*pqhld(mgs) + + ENDIF + ENDIF + + + end do + + ENDIF ! lhl + + ELSEIF ( warmonly < 0.8 ) THEN +! +! Graupel +! + do mgs = 1,ngscnt + pqhwi(mgs) = & + & +il5(mgs)*ifrzg*(qrfrzf(mgs) ) & + & +il5(mgs)*(qhdpv(mgs)) & + & +qhacr(mgs)+qhacw(mgs) + pqhwd(mgs) = & + & qhshr(mgs) & !null at this point when wet graupel included + & - qhlcnh(mgs) & + & - qhmul1(mgs) & + & - qsplinter(mgs) - qsplinter2(mgs) & + & +(1-il5(mgs))*qhmlr(mgs) !null at this point when wet graupel included + end do + +! +! Hail +! + IF ( lhl .gt. 1 ) THEN + + do mgs = 1,ngscnt + pqhli(mgs) = & + & +il5(mgs)*(qhldpv(mgs) ) & ! + (1.0-ifrzg)*(qiacrf(mgs)+qrfrzf(mgs) + qracif(mgs))) & + & +il5(mgs)*(1.0-ifrzg)*(qrfrzf(mgs) ) & + & +qhlacr(mgs)+qhlacw(mgs) & +! & +qhlacs(mgs)+qhlaci(mgs) & + & + qhlcnh(mgs) + pqhld(mgs) = & + & qhlshr(mgs) & + & +(1-il5(mgs))*qhlmlr(mgs) & +! > +il5(mgs)*qhlsbv(mgs) & + & + qhlsbv(mgs) & + & -qhlmul1(mgs) - qhcnhl(mgs) + + end do + + ENDIF ! lhl + + ENDIF ! warmonly + +! +! Liquid water on snow and graupel +! + + vhmlr(:) = 0.0 + vhlmlr(:) = 0.0 + vhfzh(:) = 0.0 + vhlfzhl(:) = 0.0 + + IF ( mixedphase ) THEN + ELSE ! set arrays for non-mixedphase graupel + +! vhshdr(:) = 0.0 + vhmlr(:) = qhmlr(:) ! not actually volume, but treated as q in rate equation +! vhsoak(:) = 0.0 + +! vhlshdr(:) = 0.0 + vhlmlr(:) = qhlmlr(:) ! not actually volume, but treated as q in rate equation +! vhlmlr(:) = rho0(:)*qhlmlr(:)/xdn(:,lhl) +! vhlsoak(:) = 0.0 + + ENDIF ! mixedphase + + + +! +! Snow volume +! + IF ( lvol(ls) .gt. 1 ) THEN + do mgs = 1,ngscnt +! pvswi(mgs) = rho0(mgs)*( pqswi(mgs) )/xdn0(ls) + + pvswi(mgs) = rho0(mgs)*( & +!aps > il5*qsfzs(mgs)/xdn(mgs,ls) & +!aps > -il5*qsfzs(mgs)/xdn(mgs,lr) & + & +il5(mgs)*(qscni(mgs)+qsaci(mgs)+qsdpv(mgs) & + & + qscnvi(mgs) + (1. - ifrzs)*qiacrs(mgs) & + & + (1. - ifrzs)*qrfrzs(mgs) & + & )/xdn0(ls) & + & + (qsacr(mgs))/rimdn(mgs,ls) ) + vsacw(mgs) +! > + (qsacw(mgs) + qsacr(mgs))/rimdn(mgs,ls) ) + pvswd(mgs) = rho0(mgs)*( pqswd(mgs) )/xdn0(ls) & +! > -qhacs(mgs) +! > -qhcns(mgs) +! > +(1-il5(mgs))*qsmlr(mgs) + qsshr(mgs) +! > +il5(mgs)*(qssbv(mgs)) + & -rho0(mgs)*qsmul(mgs)/xdn0(ls) +!aps > +rho0(mgs)*(1-il5(mgs))*( +!aps > qsmlr(mgs)/xdn(mgs,ls) +!aps > +(qscev-qsmlr(mgs))/xdn(mgs,lr) ) + end do + +!aps IF (mixedphase) THEN +!aps pvswd(mgs) = pvswd(mgs) +!aps > + rho0(mgs)*qsshr(mgs)/xdn(mgs,lr) +!aps ENDIF + + ENDIF +! +! Graupel volume +! + IF ( lvol(lh) .gt. 1 ) THEN + DO mgs = 1,ngscnt +! pvhwi(mgs) = rho0(mgs)*( (pqhwi(mgs) )/xdn0(lh) ) + +! pvhwi(mgs) = rho0(mgs)*( (pqhwi(mgs) - il5(mgs)*qrfrzf(mgs) )/xdn0(lh) ! +! : + il5(mgs)*qrfrzf(mgs)/rhofrz ) + + pvhwi(mgs) = rho0(mgs)*( & + & +il5(mgs)*( ifiacrg*ffrzh*qracif(mgs))/rhofrz & +!erm > + il5(mgs)*qhfzh(mgs)/rhofrz !aps: or use xdnmx(lh)? & + & + ( il5(mgs)*qhdpv(mgs)/qhdpvdn & + & + (qhacs(mgs) + qhaci(mgs))/qhacidn ) ) & + & + rho0(mgs)*Max(0.0, qhcev(mgs))/1000. & ! only used in mixed phase: evaporation/condensation of liquid water coating +! > + qhacs(mgs) + qhaci(mgs) )/xdn0(ls) ) & + & + f2h*vhcns(mgs) & + & + vhacr(mgs) + vhacw(mgs) + vhfzh(mgs) & ! qhacw(mgs)/rimdn(mgs,lh) +! > + vhfrh(mgs) & + & + f2h*vhcni(mgs) + (ifiacrg*viacrf(mgs) + ifrzg*vrfrzf(mgs))*ffrzh +! > +qhacr(mgs)/raindn(mgs,lh) + qhacw(mgs)/rimdn(mgs,lh) + +! pvhwd(mgs) = rho0(mgs)*(pqhwd(mgs) )/xdn0(lh) + + pvhwd(mgs) = rho0(mgs)*( & +! > qhshr(mgs)/xdn0(lr) & +! > - il5(mgs)*qhfzh(mgs)/xdn(mgs,lr) & + & +( (1-il5(mgs))*vhmlr(mgs) & +! > +il5(mgs)*qhsbv(mgs) & + & + qhsbv(mgs) & + & + Min(0.0, qhcev(mgs)) & + & -qhmul1(mgs) )/xdn(mgs,lh) ) & + & - vhlcnh(mgs) + vhshdr(mgs) - vhsoak(mgs) - vscnh(mgs) + +! IF (mixedphase) THEN +! pvhwd(mgs) = pvhwd(mgs) +! > + rho0(mgs)*qhshr(mgs)/xdn(mgs,lh) !xdn(mgs,lr) +! ENDIF + + IF ( .false. .and. ny .eq. 2 .and. kgs(mgs) .eq. 9 .and. igs(mgs) .eq. 19 ) THEN + + write(iunit,*) + write(iunit,*) 'Graupel at ',igs(mgs),kgs(mgs) +! + write(iunit,*) il5(mgs)*qrfrzf(mgs), qrfrzf(mgs) - qrfrz(mgs) + write(iunit,*) il5(mgs)*qiacrf(mgs) + write(iunit,*) il5(mgs)*qracif(mgs) + write(iunit,*) 'qhcns',qhcns(mgs) + write(iunit,*) 'qhcni',qhcni(mgs) + write(iunit,*) il5(mgs)*(qhdpv(mgs)) + write(iunit,*) 'qhacr ',qhacr(mgs) + write(iunit,*) 'qhacw', qhacw(mgs) + write(iunit,*) 'qhacs', qhacs(mgs) + write(iunit,*) 'qhaci', qhaci(mgs) + write(iunit,*) 'pqhwi = ',pqhwi(mgs) + write(iunit,*) + write(iunit,*) 'qhcev',qhcev(mgs) + write(iunit,*) + write(iunit,*) 'qhshr',qhshr(mgs) + write(iunit,*) 'qhmlr', (1-il5(mgs))*qhmlr(mgs) + write(iunit,*) 'qhsbv', qhsbv(mgs) + write(iunit,*) 'qhlcnh',-qhlcnh(mgs) + write(iunit,*) 'qhmul1',-qhmul1(mgs) + write(iunit,*) 'pqhwd = ', pqhwd(mgs) + write(iunit,*) + write(iunit,*) 'Volume' + write(iunit,*) + write(iunit,*) 'pvhwi',pvhwi(mgs) + write(iunit,*) 'vhcns', vhcns(mgs) + write(iunit,*) 'vhacr,vhacw',vhacr(mgs), vhacw(mgs) ! qhacw(mgs)/rimdn(mgs,lh) + write(iunit,*) 'vhcni',vhcni(mgs) + write(iunit,*) + write(iunit,*) 'pvhwd',pvhwd(mgs) + write(iunit,*) 'vhlcnh,vhshdr,vhsoak ', vhlcnh(mgs), vhshdr(mgs), vhsoak(mgs) + write(iunit,*) 'vhmlr', vhmlr(mgs) + write(iunit,*) +! write(iunit,*) +! write(iunit,*) +! write(iunit,*) + write(iunit,*) 'Concentration' + write(iunit,*) pchwi(mgs),pchwd(mgs) + write(iunit,*) crfrzf(mgs) + write(iunit,*) chcns(mgs) + write(iunit,*) ciacrf(mgs) + + + ENDIF + + + ENDDO + + ENDIF +! +! +! + +! +! Hail volume +! + IF ( lhl .gt. 1 ) THEN + IF ( lvol(lhl) .gt. 1 ) THEN + DO mgs = 1,ngscnt + + pvhli(mgs) = rho0(mgs)*( & + & + ( il5(mgs)*(((1.0-ifiacrg)*ffrzh*qracif(mgs))/rhofrz + qhldpv(mgs) ) & +! & + Max(0.0, qhlcev(mgs)) & +! & + qhlacs(mgs) + qhlaci(mgs) )/xdnmn(lhl) ) & ! xdn0(ls) ) & +! & + qhlacs(mgs) + qhlaci(mgs) )/xdnmn(lh) ) & ! yes, this is 'lh' on purpose + & + qhlacs(mgs) + qhlaci(mgs) )/500. ) & ! changed to 500 instead of min graupel density to keep hail density from dropping too much + & + rho0(mgs)*Max(0.0, qhlcev(mgs))/1000. & + & + vhlcnhl(mgs) + ((1.0-ifiacrg)*ffrzh*viacrf(mgs) + (1.0-ifrzg)*ffrzh*vrfrzf(mgs)) & + & + vhlacr(mgs) + vhlacw(mgs) + vhlfzhl(mgs) ! qhlacw(mgs)/rimdn(mgs,lhl) + + pvhld(mgs) = rho0(mgs)*( & + & +( qhlsbv(mgs) & + & + Min(0.0, qhlcev(mgs)) & + & -qhlmul1(mgs) )/xdn(mgs,lhl) ) & +! & + vhlmlr(mgs) & + & + rho0(mgs)*(1-il5(mgs))*vhlmlr(mgs)/xdn(mgs,lhl) & + & + vhlshdr(mgs) - vhlsoak(mgs) + + + ENDDO + + ENDIF + ENDIF + + + if ( ndebug .ge. 1 ) then + do mgs = 1,ngscnt +! + ptotal(mgs) = 0. + ptotal(mgs) = ptotal(mgs) & + & + pqwvi(mgs) + pqwvd(mgs) & + & + pqcwi(mgs) + pqcwd(mgs) & + & + pqcii(mgs) + pqcid(mgs) & + & + pqrwi(mgs) + pqrwd(mgs) & + & + pqswi(mgs) + pqswd(mgs) & + & + pqhwi(mgs) + pqhwd(mgs) & + & + pqhli(mgs) + pqhld(mgs) +! + + + + ENDDO + + do mgs = 1,ngscnt + + if ( ( (ndebug .ge. 0 ) .and. abs(ptotal(mgs)) .gt. eqtot ) & +! if ( ( abs(ptotal(mgs)) .gt. eqtot ) +! : .or. pqswi(mgs)*dtp .gt. 1.e-3 +! : .or. pqhwi(mgs)*dtp .gt. 1.e-3 +! : .or. dtp*(pqrwi(mgs)+pqrwd(mgs)) .gt. 10.0e-3 +! : .or. dtp*(pccii(mgs)+pccid(mgs)) .gt. 1.e7 +! : .or. dtp*(pcipi(mgs)+pcipd(mgs)) .gt. 1.e7 & + & .or. .not. (ptotal(mgs) .lt. 1.0 .and. ptotal(mgs) .gt. -1.0) & ! this line is basically checking for NaNs + & ) then + write(iunit,*) 'YIKES! ','ptotal1',mgs,igs(mgs),jgs, & + & kgs(mgs),ptotal(mgs) + + write(iunit,*) 't7: ', t7(igs(mgs),jgs,kgs(mgs)) + write(iunit,*) 'cci,ccw,crw,rdia: ',cx(mgs,li),cx(mgs,lc),cx(mgs,lr),0.5*xdia(mgs,lr,1) + write(iunit,*) 'qc,qi,qr : ',qx(mgs,lc),qx(mgs,li),qx(mgs,lr) + write(iunit,*) 'rmas, qrcalc : ',xmas(mgs,lr),xmas(mgs,lr)*cx(mgs,lr)/rho0(mgs) + write(iunit,*) 'vti,vtc,eiw,vtr: ',vtxbar(mgs,li,1),vtxbar(mgs,lc,1),eiw(mgs),vtxbar(mgs,lr,1) + write(iunit,*) 'cidia,cwdia,qcmxd: ', xdia(mgs,li,1),xdia(mgs,lc,1),qcmxd(mgs) + write(iunit,*) 'snow: ',qx(mgs,ls),cx(mgs,ls),swvent(mgs),vtxbar(mgs,ls,1),xdia(mgs,ls,1) + write(iunit,*) 'graupel: ',qx(mgs,lh),cx(mgs,lh),hwvent(mgs),vtxbar(mgs,lh,1),xdia(mgs,lh,1) + IF ( lhl .gt. 1 ) write(iunit,*) 'hail: ',qx(mgs,lhl),cx(mgs,lhl),hlvent(mgs),vtxbar(mgs,lhl,1),xdia(mgs,lhl,1) + + + write(iunit,*) 'li: ',xdia(mgs,li,1),xdia(mgs,li,2),xmas(mgs,li),qx(mgs,li), & + & vtxbar(mgs,li,1) + + + write(iunit,*) 'rain cx,xv : ',cx(mgs,lr),xv(mgs,lr) + write(iunit,*) 'temcg = ', temcg(mgs) + + write(iunit,*) 'v ', pqwvi(mgs) ,pqwvd(mgs) + write(iunit,*) 'c ', pqcwi(mgs) ,pqcwd(mgs) + write(iunit,*) 'ci', pqcii(mgs) ,pqcid(mgs) + write(iunit,*) 'r ', pqrwi(mgs) ,pqrwd(mgs) + write(iunit,*) 's ', pqswi(mgs) ,pqswd(mgs) + write(iunit,*) 'h ', pqhwi(mgs) ,pqhwd(mgs) + write(iunit,*) 'hl', pqhli(mgs) ,pqhld(mgs) + tmp = pqwvi(mgs) + pqwvd(mgs) & + & + pqcwi(mgs) + pqcwd(mgs) & + & + pqcii(mgs) + pqcid(mgs) & + & + pqrwi(mgs) + pqrwd(mgs) & + & + pqswi(mgs) + pqswd(mgs) & + & + pqhwi(mgs) + pqhwd(mgs) & + & + pqhli(mgs) + pqhld(mgs) + + write(iunit,*) 'total = ',tmp + write(iunit,*) 'END OF OUTPUT OF SOURCE AND SINK' + +! +! print production terms +! + write(iunit,*) + write(iunit,*) 'Vapor' +! + write(iunit,*) -Min(0.0,qrcev(mgs)) + write(iunit,*) -il5(mgs)*qhsbv(mgs) + write(iunit,*) -il5(mgs)*qhlsbv(mgs) + write(iunit,*) -il5(mgs)*qssbv(mgs) + write(iunit,*) -il5(mgs)*qisbv(mgs) + write(iunit,*) 'pqwvi= ', pqwvi(mgs) + write(iunit,*) -Max(0.0,qrcev(mgs)) + write(iunit,*) -Max(0.0,qhcev(mgs)) + write(iunit,*) -Max(0.0,qhlcev(mgs)) + write(iunit,*) -Max(0.0,qscev(mgs)) + write(iunit,*) -il5(mgs)*qiint(mgs) + write(iunit,*) -il5(mgs)*qhdpv(mgs) + write(iunit,*) -il5(mgs)*qhldpv(mgs) + write(iunit,*) -il5(mgs)*qsdpv(mgs) + write(iunit,*) -il5(mgs)*qidpv(mgs) + write(iunit,*) 'pqwvd = ', pqwvd(mgs) +! + write(iunit,*) + write(iunit,*) 'Cloud ice' +! + write(iunit,*) il5(mgs)*qicicnt(mgs) + write(iunit,*) il5(mgs)*qidpv(mgs) + write(iunit,*) il5(mgs)*qiacw(mgs) + write(iunit,*) il5(mgs)*qwfrzc(mgs) + write(iunit,*) il5(mgs)*qwctfzc(mgs) + write(iunit,*) il5(mgs)*qicichr(mgs) + write(iunit,*) qhmul1(mgs) + write(iunit,*) qhlmul1(mgs) + write(iunit,*) 'pqcii = ', pqcii(mgs) + write(iunit,*) -il5(mgs)*qscni(mgs) + write(iunit,*) -il5(mgs)*qscnvi(mgs) + write(iunit,*) -il5(mgs)*qraci(mgs) + write(iunit,*) -il5(mgs)*qsaci(mgs) + write(iunit,*) -il5(mgs)*qhaci(mgs) + write(iunit,*) -il5(mgs)*qhlaci(mgs) + write(iunit,*) il5(mgs)*qisbv(mgs) + write(iunit,*) (1.-il5(mgs))*qimlr(mgs) + write(iunit,*) -il5(mgs)*qhcni(mgs) + write(iunit,*) 'pqcid = ', pqcid(mgs) + write(iunit,*) ' Conc:' + write(iunit,*) pccii(mgs),pccid(mgs) + write(iunit,*) il5(mgs),cicint(mgs) + write(iunit,*) cwfrzc(mgs),cwctfzc(mgs) + write(iunit,*) cicichr(mgs) + write(iunit,*) chmul1(mgs) + write(iunit,*) chlmul1(mgs) + write(iunit,*) csmul(mgs) +! +! +! +! + write(iunit,*) + write(iunit,*) 'Cloud water' +! + write(iunit,*) 'pqcwi =', pqcwi(mgs) + write(iunit,*) -il5(mgs)*qiacw(mgs) + write(iunit,*) -il5(mgs)*qwfrzc(mgs) + write(iunit,*) -il5(mgs)*qwctfzc(mgs) +! write(iunit,*) -il5(mgs)*qwfrzp(mgs) +! write(iunit,*) -il5(mgs)*qwctfzp(mgs) + write(iunit,*) -il5(mgs)*qiihr(mgs) + write(iunit,*) -il5(mgs)*qicichr(mgs) + write(iunit,*) -il5(mgs)*qipiphr(mgs) + write(iunit,*) -qracw(mgs) + write(iunit,*) -qsacw(mgs) + write(iunit,*) -qrcnw(mgs) + write(iunit,*) -qhacw(mgs) + write(iunit,*) -qhlacw(mgs) + write(iunit,*) 'pqcwd = ', pqcwd(mgs) + + + write(iunit,*) + write(iunit,*) 'Concentration:' + write(iunit,*) -cautn(mgs) + write(iunit,*) -cracw(mgs) + write(iunit,*) -csacw(mgs) + write(iunit,*) -chacw(mgs) + write(iunit,*) -ciacw(mgs) + write(iunit,*) -cwfrzp(mgs) + write(iunit,*) -cwctfzp(mgs) + write(iunit,*) -cwfrzc(mgs) + write(iunit,*) -cwctfzc(mgs) + write(iunit,*) pccwd(mgs) +! + write(iunit,*) + write(iunit,*) 'Rain ' +! + write(iunit,*) qracw(mgs) + write(iunit,*) qrcnw(mgs) + write(iunit,*) Max(0.0, qrcev(mgs)) + write(iunit,*) -(1-il5(mgs))*qhmlr(mgs) + write(iunit,*) -(1-il5(mgs))*qhlmlr(mgs) + write(iunit,*) -(1-il5(mgs))*qsmlr(mgs) + write(iunit,*) -(1-il5(mgs))*qimlr(mgs) + write(iunit,*) -qrshr(mgs) + write(iunit,*) 'pqrwi = ', pqrwi(mgs) + write(iunit,*) -qsshr(mgs) + write(iunit,*) -qhshr(mgs) + write(iunit,*) -qhlshr(mgs) + write(iunit,*) -il5(mgs)*qiacr(mgs),qiacr(mgs), qiacrf(mgs) + write(iunit,*) -il5(mgs)*qrfrz(mgs) + write(iunit,*) -qsacr(mgs) + write(iunit,*) -qhacr(mgs) + write(iunit,*) -qhlacr(mgs) + write(iunit,*) qrcev(mgs) + write(iunit,*) 'pqrwd = ', pqrwd(mgs) + write(iunit,*) 'qrzfac = ', qrzfac(mgs) +! + + write(iunit,*) + write(iunit,*) 'Rain concentration' + write(iunit,*) pcrwi(mgs) + write(iunit,*) crcnw(mgs) + write(iunit,*) 1-il5(mgs) + write(iunit,*) -chmlr(mgs),-csmlr(mgs) + write(iunit,*) -crshr(mgs) + write(iunit,*) pcrwd(mgs) + write(iunit,*) il5(mgs) + write(iunit,*) -ciacr(mgs),-crfrz(mgs) + write(iunit,*) -csacr(mgs),-chacr(mgs) + write(iunit,*) +crcev(mgs) + write(iunit,*) cracr(mgs) +! write(iunit,*) -il5(mgs)*ciracr(mgs) + + + write(iunit,*) + write(iunit,*) 'Snow' +! + write(iunit,*) il5(mgs)*qscni(mgs), qscnvi(mgs) + write(iunit,*) il5(mgs)*qsaci(mgs) + write(iunit,*) il5(mgs)*qrfrzs(mgs) + write(iunit,*) il5(mgs)*qiacrs(mgs),il3(mgs)*(qiacrf(mgs)+qracif(mgs)),il3(mgs),qiacrf(mgs),qracif(mgs) + write(iunit,*) il5(mgs)*qsdpv(mgs), qscev(mgs) + write(iunit,*) qsacw(mgs) + write(iunit,*) qsacr(mgs), qscnh(mgs) + write(iunit,*) 'pqswi = ',pqswi(mgs) + write(iunit,*) -qhcns(mgs) + write(iunit,*) -qracs(mgs) + write(iunit,*) -qhacs(mgs) + write(iunit,*) -qhlacs(mgs) + write(iunit,*) (1-il5(mgs))*qsmlr(mgs) + write(iunit,*) qsshr(mgs) +! write(iunit,*) qsshrp(mgs) + write(iunit,*) il5(mgs)*(qssbv(mgs)) + write(iunit,*) 'pqswd = ', pqswd(mgs) + write(iunit,*) -qracs(mgs)*(1-il2(mgs)) , qhacs(mgs) , qhlacs(mgs) + write(iunit,*) -qhcns(mgs) + write(iunit,*) +(1-il5(mgs))*qsmlr(mgs) , qsshr(mgs) + write(iunit,*) (qssbv(mgs)) + write(iunit,*) Min(0.0, qscev(mgs)) + write(iunit,*) -qsmul(mgs) +! +! + write(iunit,*) + write(iunit,*) 'Graupel' +! + write(iunit,*) il5(mgs)*qrfrzf(mgs), qrfrzf(mgs) - qrfrz(mgs) + write(iunit,*) il5(mgs)*qiacrf(mgs) + write(iunit,*) il5(mgs)*qracif(mgs) + write(iunit,*) qhcns(mgs) + write(iunit,*) qhcni(mgs) + write(iunit,*) il5(mgs)*(qhdpv(mgs)) + write(iunit,*) qhacr(mgs) + write(iunit,*) qhacw(mgs) + write(iunit,*) qhacs(mgs) + write(iunit,*) qhaci(mgs) + write(iunit,*) 'pqhwi = ',pqhwi(mgs) + write(iunit,*) + write(iunit,*) qhshr(mgs) + write(iunit,*) (1-il5(mgs))*qhmlr(mgs) + write(iunit,*) il5(mgs),qhsbv(mgs) + write(iunit,*) -qhlcnh(mgs) + write(iunit,*) -qhmul1(mgs) + write(iunit,*) 'pqhwd = ', pqhwd(mgs) + write(iunit,*) 'Concentration' + write(iunit,*) pchwi(mgs),pchwd(mgs) + write(iunit,*) crfrzf(mgs) + write(iunit,*) chcns(mgs) + write(iunit,*) ciacrf(mgs) + +! + write(iunit,*) + write(iunit,*) 'Hail' +! + write(iunit,*) qhlcnh(mgs) + write(iunit,*) il5(mgs)*(qhldpv(mgs)) + write(iunit,*) qhlacr(mgs) + write(iunit,*) qhlacw(mgs) + write(iunit,*) qhlacs(mgs) + write(iunit,*) qhlaci(mgs) + write(iunit,*) pqhli(mgs) + write(iunit,*) + write(iunit,*) qhlshr(mgs) + write(iunit,*) (1-il5(mgs))*qhlmlr(mgs) + write(iunit,*) il5(mgs)*qhlsbv(mgs) + write(iunit,*) pqhld(mgs) + write(iunit,*) 'Concentration' + write(iunit,*) pchli(mgs),pchld(mgs) + write(iunit,*) chlcnh(mgs) +! +! Balance and checks for continuity.....within machine precision... +! +! + write(iunit,*) 'END OF OUTPUT OF SOURCE AND SINK' + write(iunit,*) 'PTOTAL',ptotal(mgs) +! + end if ! ptotal out of bounds or NaN +! + end do +! + + end if ! ( nstep/12*12 .eq. nstep ) + +! +! latent heating from phase changes (except qcw, qci cond, and evap) +! + do mgs = 1,ngscnt + IF ( warmonly < 0.5 ) THEN + pfrz(mgs) = & + & (1-il5(mgs))* & + & (qhmlr(mgs)+qsmlr(mgs)+qhlmlr(mgs)) & !+qhmlh(mgs)) & + & +il5(mgs)*(qhfzh(mgs)+qsfzs(mgs)+qhlfzhl(mgs)) & + & +il5(mgs)*(1-imixedphase)*( & + & qsacw(mgs)+qhacw(mgs) + qhlacw(mgs) & + & +qsacr(mgs)+qhacr(mgs) + qhlacr(mgs) & + & +qsshr(mgs) & + & +qhshr(mgs) & + & +qhlshr(mgs) +qrfrz(mgs)+qiacr(mgs) & + & ) & + & +il5(mgs)*(qwfrz(mgs) & + & +qwctfz(mgs)+qiihr(mgs) & + & +qiacw(mgs)) + pmlt(mgs) = & + & (1-il5(mgs))* & + & (qhmlr(mgs)+qsmlr(mgs)+qhlmlr(mgs)) !+qhmlh(mgs)) + ! NOTE: psub is sum of sublimation and deposition + psub(mgs) = & + & il5(mgs)*( & + & + qsdpv(mgs) + qhdpv(mgs) & + & + qhldpv(mgs) & + & + qidpv(mgs) + qisbv(mgs) ) & + & + qssbv(mgs) + qhsbv(mgs) + qhlsbv(mgs) & + & +il5(mgs)*(qiint(mgs)) + pvap(mgs) = & + & qrcev(mgs) + qhcev(mgs) + qscev(mgs) + qhlcev(mgs) + pevap(mgs) = & + & Min(0.0,qrcev(mgs)) + Min(0.0,qhcev(mgs)) + Min(0.0,qscev(mgs)) + Min(0.0,qhlcev(mgs)) + ! NOTE: pdep is the deposition part only + pdep(mgs) = & + & il5(mgs)*( & + & + qsdpv(mgs) + qhdpv(mgs) & + & + qhldpv(mgs) & + & + qidpv(mgs) ) & + & +il5(mgs)*(qiint(mgs)) + ELSEIF ( warmonly < 0.8 ) THEN + pfrz(mgs) = & + & (1-il5(mgs))* & + & (qhmlr(mgs)+qhlmlr(mgs)) & !+qhmlh(mgs)) & + & +il5(mgs)*(qhfzh(mgs)+qhlfzhl(mgs)) & + & +il5(mgs)*( & + & +qhshr(mgs) & + & +qhlshr(mgs) & + & +qrfrz(mgs)+qwfrz(mgs) & + & +qwctfz(mgs)+qiihr(mgs) & + & +qiacw(mgs) & + & +qhacw(mgs) + qhlacw(mgs) & + & +qhacr(mgs) + qhlacr(mgs) ) + psub(mgs) = 0.0 + & + & il5(mgs)*( & + & + qhdpv(mgs) & + & + qhldpv(mgs) & + & + qidpv(mgs) + qisbv(mgs) ) & + & +il5(mgs)*(qiint(mgs)) + pvap(mgs) = & + & qrcev(mgs) + qhcev(mgs) + qhlcev(mgs) ! + qscev(mgs) + ELSE + pfrz(mgs) = 0.0 + psub(mgs) = 0.0 + pvap(mgs) = qrcev(mgs) + ENDIF ! warmonly + ptem(mgs) = & + & (1./pi0(mgs))* & + & (felfcp(mgs)*pfrz(mgs) & + & +felscp(mgs)*psub(mgs) & + & +felvcp(mgs)*pvap(mgs)) + thetap(mgs) = thetap(mgs) + dtp*ptem(mgs) + ptem2(mgs) = ptem(mgs) + IF ( eqtset > 2 ) THEN + pipert(mgs) = pipert(mgs) + (felfpi(mgs)*pfrz(mgs) & + & +felspi(mgs)*psub(mgs) & + & +felvpi(mgs)*pvap(mgs))*dtp + ENDIF + end do + + + + +! +! sum the sources and sinks for qwvp, qcw, qci, qrw, qsw +! +! + do mgs = 1,ngscnt + qwvp(mgs) = qwvp(mgs) + & + & dtp*(pqwvi(mgs)+pqwvd(mgs)) + qx(mgs,lc) = qx(mgs,lc) + & + & dtp*(pqcwi(mgs)+pqcwd(mgs)) + qx(mgs,lr) = qx(mgs,lr) + & + & dtp*(pqrwi(mgs)+pqrwd(mgs)) + qx(mgs,li) = qx(mgs,li) + & + & dtp*(pqcii(mgs)+pqcid(mgs)) + qx(mgs,ls) = qx(mgs,ls) + & + & dtp*(pqswi(mgs)+pqswd(mgs)) + qx(mgs,lh) = qx(mgs,lh) + & + & dtp*(pqhwi(mgs)+pqhwd(mgs)) + IF ( lhl .gt. 1 ) THEN + qx(mgs,lhl) = qx(mgs,lhl) + & + & dtp*(pqhli(mgs)+pqhld(mgs)) + ENDIF + + + end do + +! sum sources for particle volume + + IF ( ldovol ) THEN + + do mgs = 1,ngscnt + + IF ( lvol(ls) .gt. 1 ) THEN + vx(mgs,ls) = vx(mgs,ls) + & + & dtp*(pvswi(mgs)+pvswd(mgs)) + ENDIF + + IF ( lvol(lh) .gt. 1 ) THEN + vx(mgs,lh) = vx(mgs,lh) + & + & dtp*(pvhwi(mgs)+pvhwd(mgs)) +! > rho0(mgs)*dtp*(pqhwi(mgs)+pqhwd(mgs))/xdn0(lh) + ENDIF + + IF ( lhl .gt. 1 ) THEN + IF ( lvol(lhl) .gt. 1 ) THEN + vx(mgs,lhl) = vx(mgs,lhl) + & + & dtp*(pvhli(mgs)+pvhld(mgs)) +! > rho0(mgs)*dtp*(pqhwi(mgs)+pqhwd(mgs))/xdn0(lh) + ENDIF + ENDIF + + ENDDO + + ENDIF ! ldovol + +! +! +! +! concentrations +! + if ( ipconc .ge. 1 ) then + do mgs = 1,ngscnt + cx(mgs,li) = cx(mgs,li) + & + & dtp*(pccii(mgs)+pccid(mgs)) + cina(mgs) = cina(mgs) + pccin(mgs)*dtp + IF ( ipconc .ge. 2 ) THEN + cx(mgs,lc) = cx(mgs,lc) + & + & dtp*(pccwi(mgs)+pccwd(mgs)) + ENDIF + IF ( ipconc .ge. 3 ) THEN + cx(mgs,lr) = cx(mgs,lr) + & + & dtp*(pcrwi(mgs)+pcrwd(mgs)) + ENDIF + IF ( ipconc .ge. 4 ) THEN + cx(mgs,ls) = cx(mgs,ls) + & + & dtp*(pcswi(mgs)+pcswd(mgs)) + ENDIF + IF ( ipconc .ge. 5 ) THEN + cx(mgs,lh) = cx(mgs,lh) + & + & dtp*(pchwi(mgs)+pchwd(mgs)) + IF ( lhl .gt. 1 ) THEN + cx(mgs,lhl) = cx(mgs,lhl) + & + & dtp*(pchli(mgs)+pchld(mgs)) + + + + + ENDIF + ENDIF + end do + end if + + + IF ( has_wetscav ) THEN + DO mgs = 1,ngscnt + evapprod2d(igs(mgs),kgs(mgs)) = -(qrcev(mgs) + qssbv(mgs) + qhsbv(mgs) + qhlsbv(mgs)) + rainprod2d(igs(mgs),kgs(mgs)) = qrcnw(mgs) + qracw(mgs) + qsacw(mgs) + qhacw(mgs) + qhlacw(mgs) + & + qraci(mgs) + qsaci(mgs) + qhaci(mgs) + qhlaci(mgs) + qscni(mgs) + ENDDO + ENDIF +! +! +! +! start saturation adjustment +! + if (ndebug .gt. 0 ) write(0,*) 'conc 30a' +! include 'sam.jms.satadj.sgi' +! +! +! +! Modified Straka adjustment (nearly identical to Tao et al. 1989 MWR) +! +! +! +! set up temperature and vapor arrays +! + do mgs = 1,ngscnt + pqs(mgs) = (380.0)/(pres(mgs)) + theta(mgs) = thetap(mgs) + theta0(mgs) + qvap(mgs) = max( (qwvp(mgs) + qv0(mgs)), 0.0 ) + temg(mgs) = theta(mgs)*pk(mgs) ! ( pres(mgs) / poo ) ** cap + end do +! +! melting of cloud ice +! + do mgs = 1,ngscnt + qcwtmp(mgs) = qx(mgs,lc) + ptimlw(mgs) = 0.0 + end do +! + do mgs = 1,ngscnt + qitmp(mgs) = qx(mgs,li) + if( temg(mgs) .gt. tfr .and. & + & qitmp(mgs) .gt. 0.0 ) then + qx(mgs,lc) = qx(mgs,lc) + qitmp(mgs) +! pfrz(mgs) = pfrz(mgs) - qitmp(mgs)*dtpinv + ptem(mgs) = ptem(mgs) + & + & (1./pi0(mgs))* & + & felfcp(mgs)*(- qitmp(mgs)*dtpinv) + IF ( eqtset > 2 ) THEN + pipert(mgs) = pipert(mgs) - (felfpi(mgs)*qitmp(mgs)) + ENDIF + pmlt(mgs) = pmlt(mgs) - qitmp(mgs)*dtpinv + scx(mgs,lc) = scx(mgs,lc) + scx(mgs,li) + thetap(mgs) = thetap(mgs) - & + & fcc3(mgs)*qitmp(mgs) + ptimlw(mgs) = -fcc3(mgs)*qitmp(mgs)*dtpinv + cx(mgs,lc) = cx(mgs,lc) + cx(mgs,li) + qx(mgs,li) = 0.0 + cx(mgs,li) = 0.0 + scx(mgs,li) = 0.0 + vx(mgs,li) = 0.0 + qitmp(mgs) = 0.0 + end if + end do + +! +! + + +! do mgs = 1,ngscnt +! qimlw(mgs) = (qcwtmp(mgs)-qx(mgs,lc))*dtpinv +! end do +! +! homogeneous freezing of cloud water +! + IF ( warmonly < 0.8 ) THEN + + do mgs = 1,ngscnt + qcwtmp(mgs) = qx(mgs,lc) + ptwfzi(mgs) = 0.0 + end do +! + do mgs = 1,ngscnt + +! if( temg(mgs) .lt. tfrh ) THEN +! write(0,*) 'GS: mgs,temp,qc,qi = ',mgs,temg(mgs),temcg(mgs),qx(mgs,lc),qx(mgs,li) +! ENDIF + + ctmp = 0.0 + frac = 0.0 + qtmp = 0.0 + +! if( ( temg(mgs) .lt. thnuc + 2. .or. (ibfc == 2 .and. temg(mgs) < thnuc + 10. ) ) .and. & +! & qx(mgs,lc) .gt. qxmin(lc) .and. (ipconc < 2 .or. ibfc == 0 .or. ibfc == 2 )) then +! commented for test (12/01/2015): +! if( temg(mgs) .lt. thnuc + 0. .and. & +! & qx(mgs,lc) .gt. 0.0 .and. (ipconc < 2 .or. ibfc == 0 )) then + if( ( ( temg(mgs) .lt. thnuc + 0.) .or. (temg(mgs) .lt. thnuc + 2. .and. ibfc >= 3) ) .and. & + & qx(mgs,lc) .gt. 0.0 .and. (ipconc < 2 .or. ibfc == 0 .or. ibfc == 2)) then + + IF ( ibfc >= 3 ) THEN + frac = Max( 0.25, Min( 1., ((thnuc + 2.) - temg(mgs) )/4.0 ) ) + ELSEIF ( ibfc /= 2 .or. ipconc < 2 ) THEN + frac = Max( 0.25, Min( 1., ((thnuc + 1.) - temg(mgs) )/4.0 ) ) + ELSE + volt = exp( 16.2 + 1.0*temcg(mgs) )* 1.0e-6 ! Ts == -temcg ; volt comes from the fit in Fig. 1 in Bigg 1953 + ! for mean temperature for freezing: -ln (V) = a*Ts - b + ! volt is given in cm**3, so factor of 1.e-6 to convert to m**3 + + cwfrz(mgs) = cx(mgs,lc)*Exp(-volt/xv(mgs,lc)) ! number of droplets with volume greater than volt + + qtmp = cwfrz(mgs)*xdn0(lc)*rhoinv(mgs)*(volt + xv(mgs,lc)) + frac = qtmp/qx(mgs,lc) ! reset number frozen to same fraction as mass. This makes + ! sure that cwfrz and qwfrz are consistent and prevents + ! spurious creation of ice crystals. + + ENDIF + qtmp = frac*qx(mgs,lc) + + IF ( ibfc == 4 .and. lis >= 1 ) THEN + qx(mgs,lis) = qx(mgs,lis) + qtmp + ELSE + qx(mgs,li) = qx(mgs,li) + qtmp ! qx(mgs,lc) + ENDIF + pfrz(mgs) = pfrz(mgs) + qtmp*dtpinv + ptem(mgs) = ptem(mgs) + & + & (1./pi0(mgs))* & + & felfcp(mgs)*(qtmp*dtpinv) + + IF ( eqtset > 2 ) THEN + pipert(mgs) = pipert(mgs) + felfpi(mgs)*qtmp + ENDIF + +! IF ( lvol(li) .gt. 1 ) vx(mgs,li) = vx(mgs,li) + rho0(mgs)*qx(mgs,lc)/xdn0(li) + IF ( lvol(li) .gt. 1 ) vx(mgs,li) = vx(mgs,li) + rho0(mgs)*qtmp/xdn0(li) + + IF ( ipconc .ge. 2 ) THEN + ctmp = frac*cx(mgs,lc) +! cx(mgs,li) = cx(mgs,li) + cx(mgs,lc) + IF ( ibfc == 4 .and. lis >= 1 ) THEN + cx(mgs,lis) = cx(mgs,lis) + ctmp + ELSE + cx(mgs,li) = cx(mgs,li) + ctmp + ENDIF + ELSE ! (ipconc .lt. 2 ) + ctmp = 0.0 + IF ( t9(igs(mgs),jgs,kgs(mgs)-1) .gt. qx(mgs,lc) ) THEN + qtmp = frac*t9(igs(mgs),jgs,kgs(mgs)-1) + +! cx(mgs,lc) = cx(mgs,lc)*qx(mgs,lc)*rho0(mgs)/qtmp + ctmp = cx(mgs,lc)*qx(mgs,lc)*rho0(mgs)/qtmp + ELSE + cx(mgs,lc) = Max(0.0,wvel(mgs))*dtp*cwccn & + & /gz(igs(mgs),jgs,kgs(mgs)) + cx(mgs,lc) = cwccn + ENDIF + + IF ( ipconc .ge. 1 ) cx(mgs,li) = Min(ccimx, cx(mgs,li) + cx(mgs,lc)) + ENDIF + + sctmp = frac*scx(mgs,lc) +! scx(mgs,li) = scx(mgs,li) + scx(mgs,lc) + scx(mgs,li) = scx(mgs,li) + sctmp +! thetap(mgs) = thetap(mgs) + fcc3(mgs)*qx(mgs,lc) +! ptwfzi(mgs) = fcc3(mgs)*qx(mgs,lc)*dtpinv +! qx(mgs,lc) = 0.0 +! cx(mgs,lc) = 0.0 +! scx(mgs,lc) = 0.0 + thetap(mgs) = thetap(mgs) + fcc3(mgs)*qtmp + ptwfzi(mgs) = fcc3(mgs)*qtmp*dtpinv + qx(mgs,lc) = qx(mgs,lc) - qtmp + cx(mgs,lc) = cx(mgs,lc) - ctmp + scx(mgs,lc) = scx(mgs,lc) - sctmp + end if + end do + + ENDIF ! warmonly +! +! do mgs = 1,ngscnt +! qwfzi(mgs) = (qcwtmp(mgs)-qx(mgs,lc))*dtpinv ! Not used?? (ERM) +! end do +! +! reset temporaries for cloud particles and vapor +! + qcond(:) = 0.0 + + IF ( ipconc .le. 1 .and. lwsm6 ) THEN ! Explicit cloud condensation/evaporation (Rutledge and Hobbs 1983) + DO mgs = 1,ngscnt + + qcwtmp(mgs) = qx(mgs,lc) + theta(mgs) = thetap(mgs) + theta0(mgs) + temgtmp = temg(mgs) +! temg(mgs) = theta(mgs)*(p2(igs(mgs),jgs,kgs(mgs)) ) ! *pk(mgs) ! ( pres(mgs) / poo ) ** cap +! temsav = temg(mgs) +! thsave(mgs) = thetap(mgs) + temg(mgs) = theta(mgs)*pk(mgs) ! ( pres(mgs) / poo ) ** cap + temcg(mgs) = temg(mgs) - tfr + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + + IF ( ( qvap(mgs) > qvs(mgs) .or. qx(mgs,lc) > qxmin(lc) ) .and. temg(mgs) > tfrh ) THEN + tmp = (qvap(mgs) - qvs(mgs))/(1. + qvs(mgs)*felv(mgs)**2/(cp*rw*temg(mgs)**2) ) + qcond(mgs) = Min( Max( 0.0, tmp ), (qvap(mgs)-qvs(mgs)) ) + IF ( qx(mgs,lc) > qxmin(lc) .and. tmp < 0.0 ) THEN ! evaporation + qcond(mgs) = Max( tmp, -qx(mgs,lc) ) + ENDIF + qwvp(mgs) = qwvp(mgs) - qcond(mgs) + qvap(mgs) = qvap(mgs) - qcond(mgs) + qx(mgs,lc) = Max( 0.0, qx(mgs,lc) + qcond(mgs) ) + thetap(mgs) = thetap(mgs) + felvcp(mgs)*qcond(mgs)/(pi0(mgs)) + + ENDIF + + ENDDO + + ENDIF + + + IF ( ipconc .le. 1 .and. .not. lwsm6 ) THEN +! IF ( ipconc .le. 1 ) THEN + + do mgs = 1,ngscnt + qx(mgs,lv) = max( 0.0, qvap(mgs) ) + qx(mgs,lc) = max( 0.0, qx(mgs,lc) ) + qx(mgs,li) = max( 0.0, qx(mgs,li) ) + qitmp(mgs) = qx(mgs,li) + end do +! +! + do mgs = 1,ngscnt + qcwtmp(mgs) = qx(mgs,lc) + qitmp(mgs) = qx(mgs,li) + theta(mgs) = thetap(mgs) + theta0(mgs) + temgtmp = temg(mgs) + temg(mgs) = theta(mgs)*(pinit(kgs(mgs)) + p2(igs(mgs),jgs,kgs(mgs)) ) ! *pk(mgs) ! ( pres(mgs) / poo ) ** cap + temsav = temg(mgs) + thsave(mgs) = thetap(mgs) + temcg(mgs) = temg(mgs) - tfr + tqvcon = temg(mgs)-cbw + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) +! IF ( ltemq .lt. 1 .or. ltemq .gt. nqsat ) THEN +! C$PAR CRITICAL SECTION +! write(iunit,*) 'out of range ltemq!',temgtmp,temg(mgs), +! : thetap(mgs),theta0(mgs),pres(mgs),theta(mgs), +! : ltemq,igs(mgs),jy,kgs(mgs) +! write(iunit,*) an(igs(mgs),jy,kgs(mgs),lt), +! : ab(igs(mgs),jy,kgs(mgs),lt), +! : t0(igs(mgs),jy,kgs(mgs)) +! write(iunit,*) fcc3(mgs),qx(mgs,lc),qitmp(mgs),dtp,ptem(mgs) +! STOP +! C$PAR END CRITICAL SECTION +! END IF + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + qis(mgs) = pqs(mgs)*tabqis(ltemq) +! qss(kz) = qvs(kz) +! if ( temg(kz) .lt. tfr ) then +! if( qcw(kz) .le. qxmin(lc) .and. qci(kz) .gt. qxmin(li)) +! > qss(kz) = qis(kz) +! if( qcw(kz) .gt. qxmin(lc) .and. qci(kz) .gt. qxmin(li)) +! > qss(kz) = (qcw(kz)*qvs(kz) + qci(kz)*qis(kz)) / +! > (qcw(kz) + qci(kz)) +! qss(kz) = qis(kz) +! end if +! dont get enough condensation with qcw .le./.gt. qxmin(lc) +! if ( temg(mgs) .lt. tfr ) then +! if( qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) ) +! > qss(mgs) = qvs(mgs) +! if( qx(mgs,lc) .eq. 0.0 .and. qitmp(mgs) .gt. qxmin(li)) +! > qss(mgs) = qis(mgs) +! if( qx(mgs,lc) .gt. 0.0 .and. qitmp(mgs) .gt. qxmin(li)) +! > qss(mgs) = (qx(mgs,lc)*qvs(mgs) + qitmp(mgs)*qis(mgs)) / +! > (qx(mgs,lc) + qitmp(mgs)) +! else +! qss(mgs) = qvs(mgs) +! end if + qss(mgs) = qvs(mgs) + if ( temg(mgs) .lt. tfr ) then + if( qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) ) & + & qss(mgs) = qvs(mgs) + if( qx(mgs,lc) .le. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li)) & + & qss(mgs) = qis(mgs) + if( qx(mgs,lc) .gt. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li)) & + & qss(mgs) = (qx(mgs,lc)*qvs(mgs) + qitmp(mgs)*qis(mgs)) / & + & (qx(mgs,lc) + qitmp(mgs)) + end if + end do +! +! iterate adjustment +! + do itertd = 1,2 +! + do mgs = 1,ngscnt +! +! calculate super-saturation +! + qitmp(mgs) = qx(mgs,li) + fcci(mgs) = 0.0 + fcip(mgs) = 0.0 + dqcw(mgs) = 0.0 + dqci(mgs) = 0.0 + dqwv(mgs) = ( qx(mgs,lv) - qss(mgs) ) +! +! evaporation and sublimation adjustment +! + if( dqwv(mgs) .lt. 0. ) then ! subsaturated + if( qx(mgs,lc) .gt. -dqwv(mgs) ) then ! check if qc can make up all of the deficit + dqcw(mgs) = dqwv(mgs) + dqwv(mgs) = 0. + else ! otherwise make all qc available for evap + dqcw(mgs) = -qx(mgs,lc) + dqwv(mgs) = dqwv(mgs) + qx(mgs,lc) + end if +! + if( qitmp(mgs) .gt. -dqwv(mgs) ) then ! check if qi can make up all the deficit + dqci(mgs) = dqwv(mgs) + dqwv(mgs) = 0. + else ! otherwise make all ice available for sublimation + dqci(mgs) = -qitmp(mgs) + dqwv(mgs) = dqwv(mgs) + qitmp(mgs) + end if +! + qwvp(mgs) = qwvp(mgs) - ( dqcw(mgs) + dqci(mgs) ) ! add to perturbation vapor +! +! This next line removed 3/19/2003 thanks to Adam Houston, +! who found the bug in the 3-ICE code +! qwvp(mgs) = max(qwvp(mgs), 0.0) + qitmp(mgs) = qx(mgs,li) + IF ( qitmp(mgs) .ge. qxmin(li) ) THEN + fcci(mgs) = qx(mgs,li)/(qitmp(mgs)) + ELSE + fcci(mgs) = 1.0 + ENDIF + qx(mgs,lc) = qx(mgs,lc) + dqcw(mgs) + qx(mgs,li) = qx(mgs,li) + dqci(mgs) * fcci(mgs) + thetap(mgs) = thetap(mgs) + & + & 1./pi0(mgs)* & + & (felvcp(mgs)*dqcw(mgs) +felscp(mgs)*dqci(mgs)) + + IF ( eqtset > 2 ) THEN + pipert(mgs) = pipert(mgs) & + & +(felspi(mgs)*dqci(mgs) & + & +felvpi(mgs)*dqcw(mgs))*dtp + ENDIF + + end if ! dqwv(mgs) .lt. 0. (end of evap/sublim) +! +! condensation/deposition +! + IF ( dqwv(mgs) .ge. 0. ) THEN + +! write(iunit,*) 'satadj: mgs,iter = ',mgs,itertd,dqwv(mgs),qss(mgs),qx(mgs,lv),qx(mgs,lc) +! + qitmp(mgs) = qx(mgs,li) + fracl(mgs) = 1.0 + fraci(mgs) = 0.0 + if ( temg(mgs) .lt. tfr .and. temg(mgs) .gt. thnuc ) then + fracl(mgs) = max(min(1.,(temg(mgs)-233.15)/(20.)),0.0) + fraci(mgs) = 1.0-fracl(mgs) + end if + if ( temg(mgs) .le. thnuc ) then + fraci(mgs) = 1.0 + fracl(mgs) = 0.0 + end if + fraci(mgs) = 1.0-fracl(mgs) +! + gamss = (felvcp(mgs)*fracl(mgs) + felscp(mgs)*fraci(mgs)) & + & / (pi0(mgs)) +! + IF ( temg(mgs) .lt. tfr ) then + IF (qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) ) then + dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv1(mgs)*qss(mgs)/ & + & ((temg(mgs)-cbw)**2)) + END IF + IF ( qx(mgs,lc) .eq. 0.0 .and. qitmp(mgs) .gt. qxmin(li) ) then + dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv2(mgs)*qss(mgs)/ & + & ((temg(mgs)-cbi)**2)) + END IF + IF ( qx(mgs,lc) .gt. 0.0 .and. qitmp(mgs) .gt. qxmin(li) ) then + cdw = caw*pi0(mgs)*tfrcbw/((temg(mgs)-cbw)**2) + cdi = cai*pi0(mgs)*tfrcbi/((temg(mgs)-cbi)**2) + denom1 = qx(mgs,lc) + qitmp(mgs) + denom2 = 1.0 + gamss* & + & (qx(mgs,lc)*qvs(mgs)*cdw + qitmp(mgs)*qis(mgs)*cdi) / denom1 + dqvcnd(mgs) = dqwv(mgs) / denom2 + END IF + + ENDIF ! temg(mgs) .lt. tfr +! + if ( temg(mgs) .ge. tfr ) then + dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv1(mgs)*qss(mgs)/ & + & ((temg(mgs)-cbw)**2)) + end if +! + delqci1=qx(mgs,li) +! + IF ( qitmp(mgs) .gt. qxmin(li) ) THEN + fcci(mgs) = qx(mgs,li)/(qitmp(mgs)) + ELSE + fcci(mgs) = 1.0 + ENDIF +! + dqcw(mgs) = dqvcnd(mgs)*fracl(mgs) + dqci(mgs) = dqvcnd(mgs)*fraci(mgs) +! + thetap(mgs) = thetap(mgs) + & + & (felvcp(mgs)*dqcw(mgs) + felscp(mgs)*dqci(mgs)) & + & / (pi0(mgs)) + + IF ( eqtset > 2 ) THEN + pipert(mgs) = pipert(mgs) + (0 & + & +felspi(mgs)*dqci(mgs) & + & +felvpi(mgs)*dqcw(mgs))*dtp + ENDIF + + qwvp(mgs) = qwvp(mgs) - ( dqvcnd(mgs) ) + qx(mgs,lc) = qx(mgs,lc) + dqcw(mgs) +! IF ( qitmp(mgs) .gt. qxmin(li) ) THEN + qx(mgs,li) = qx(mgs,li) + dqci(mgs)*fcci(mgs) + qitmp(mgs) = qx(mgs,li) +! ENDIF +! +! delqci(mgs) = dqci(mgs)*fcci(mgs) +! + END IF ! dqwv(mgs) .ge. 0. + end do +! + do mgs = 1,ngscnt + qitmp(mgs) = qx(mgs,li) + theta(mgs) = thetap(mgs) + theta0(mgs) + temg(mgs) = theta(mgs)*pk(mgs) ! ( pres(mgs) / poo ) ** cap + qvap(mgs) = Max((qwvp(mgs) + qv0(mgs)), 0.0) + temcg(mgs) = temg(mgs) - tfr + tqvcon = temg(mgs)-cbw + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + qis(mgs) = pqs(mgs)*tabqis(ltemq) + qx(mgs,lc) = max( 0.0, qx(mgs,lc) ) + qitmp(mgs) = max( 0.0, qitmp(mgs) ) + qx(mgs,lv) = max( 0.0, qvap(mgs)) +! if ( temg(mgs) .lt. tfr ) then +! if( qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) ) +! > qss(mgs) = qvs(mgs) +!c if( qx(mgs,lc) .le. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li)) +! if( qx(mgs,lc) .eq. 0.0 .and. qitmp(mgs) .gt. qxmin(li)) +! > qss(mgs) = qis(mgs) +!c if( qx(mgs,lc) .gt. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li)) +! if( qx(mgs,lc) .gt. 0.0 .and. qitmp(mgs) .gt. qxmin(li)) +! > qss(mgs) = (qx(mgs,lc)*qvs(mgs) + qitmp(mgs)*qis(mgs)) / +! > (qx(mgs,lc) + qitmp(mgs)) +! else +! qss(mgs) = qvs(mgs) +! end if + qss(mgs) = qvs(mgs) + if ( temg(mgs) .lt. tfr ) then + if( qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) ) & + & qss(mgs) = qvs(mgs) + if( qx(mgs,lc) .le. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li)) & + & qss(mgs) = qis(mgs) + if( qx(mgs,lc) .gt. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li)) & + & qss(mgs) = (qx(mgs,lc)*qvs(mgs) + qitmp(mgs)*qis(mgs)) / & + & (qx(mgs,lc) + qitmp(mgs)) + end if +! pceds(mgs) = (thetap(mgs) - thsave(mgs))*dtpinv +! write(iunit,*) 'satadj2: mgs,iter = ',mgs,itertd,dqwv(mgs),qss(mgs),qx(mgs,lv),qx(mgs,lc) + end do +! +! end the saturation adjustment iteration loop +! + end do + + ENDIF ! ( ipconc .le. 1 ) + +! +! spread the growth owing to vapor diffusion onto the +! ice crystal categories using the +! +! END OF SATURATION ADJUSTMENT +! + + if (ndebug .gt. 0 ) write(0,*) 'conc 30b' +! +! +! end of saturation adjustment + +! +! +! !DIR$ IVDEP + do mgs = 1,ngscnt + t0(igs(mgs),jy,kgs(mgs)) = temg(mgs) + end do +! +! Load the save arrays +! + + +! Sample code for using the axtra array to load microphysical rates or quantities for output +! +! Note that indices 1 and 2 are used in the nucond subroutine for condensation/evap of droplets (1) and +! condensation of rain (2) +! +! IF ( io_flag .and. nxtra > 1 ) THEN +! DO mgs = 1,ngscnt +! axtra(igs(mgs),jy,kgs(mgs),3) = pfrz(mgs) ! +! axtra(igs(mgs),jy,kgs(mgs),4) = qrcev(mgs) ! pre2 +! axtra(igs(mgs),jy,kgs(mgs),5) = psub(mgs) ! depsubr +! axtra(igs(mgs),jy,kgs(mgs),6) = qrfrz(mgs) ! rain freezing (Bigg) +! axtra(igs(mgs),jy,kgs(mgs),7) = pmlt(mgs) ! melr2 +! ENDDO +! ENDIF + + + + + if (ndebug .gt. 0 ) write(0,*) 'gs 11' + + do mgs = 1,ngscnt +! + an(igs(mgs),jy,kgs(mgs),lt) = & + & theta0(mgs) + thetap(mgs) + an(igs(mgs),jy,kgs(mgs),lv) = qwvp(mgs) + qv0(mgs) ! + + IF ( eqtset > 2 ) THEN + p2(igs(mgs),jy,kgs(mgs)) = pipert(mgs) + ENDIF +! + + DO il = lc,lhab + IF ( ido(il) .eq. 1 ) THEN + IF ( lf > 1 .and. il == lf ) THEN + lfsave(mgs,1) = an(igs(mgs),jy,kgs(mgs),il) + lfsave(mgs,2) = qx(mgs,il) + ENDIF + an(igs(mgs),jy,kgs(mgs),il) = qx(mgs,il) + & + & min( an(igs(mgs),jy,kgs(mgs),il), 0.0 ) + qx(mgs,il) = an(igs(mgs),jy,kgs(mgs),il) + ENDIF + ENDDO + + IF ( lcina > 1 ) THEN + an(igs(mgs),jy,kgs(mgs),lcina) = cina(mgs) + ENDIF + + +! + end do +! + + if ( ipconc .ge. 1 ) then + DO il = lc,lhab !{ + +! write(0,*) 'limiter loop: il,ipc,lz: ',il,ipc(il),lz(il),ipconc + + IF ( ipconc .ge. ipc(il) .and. ido(il) > 0 ) THEN ! { + + IF ( ipconc .ge. 4 .and. ipc(il) .ge. 1 ) THEN ! { + +! write(0,*) 'MY limiter: il,ipc,lz: ',il,ipc(il),lz(il),lr,lzr +! STOP + + IF ( lz(il) <= 1 .or. ioldlimiter == 1 ) THEN ! { { is a two-moment category so dont worry about reflectivity + + + DO mgs = 1,ngscnt + IF ( qx(mgs,il) .le. 0.0 ) THEN + cx(mgs,il) = 0.0 + ELSE !{ + IF ( cx(mgs,il) .gt. cxmin ) THEN !{ +! xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*Max(1.0e-9,cx(mgs,il))) +! xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*Max(cxmin,cx(mgs,il))) + xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*cx(mgs,il)) + +! IF ( lhl .gt. 1 .and. il .eq. lhl ) THEN +! write(0,*) 'dr: xv,cx,qx,xdn,ln = ',xv(mgs,il),cx(mgs,il),qx(mgs,il),xdn(mgs,il),ln(il) +! ENDIF + + ! 8/26/2015 erm: apply imaxdiaopt for 2-moment also + IF ( imaxdiaopt == 1 .or. il == lc .or. il == li .or. (il == lr .and. imurain == 3) .or. & + & (il == ls .and. imusnow == 3 ) ) THEN + xvbarmax = xvmx(il) + ELSEIF ( imaxdiaopt == 2 ) THEN ! test against maximum mass diameter + xvbarmax = xvmx(il) /((3. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il)))) + ELSEIF ( imaxdiaopt == 3 ) THEN ! test against mass-weighted diameter + xvbarmax = xvmx(il) /((4. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il)))) + ELSE + xvbarmax = xvmx(il) + ENDIF + + tmp = 1.0 + IF ( il == ls ) THEN + xvbarmax = xvbarmax*Max(1.,100./Min(100.,xdn(mgs,ls))) + ENDIF + + IF ( xv(mgs,il) .lt. xvmn(il) .or. xv(mgs,il) .gt. xvbarmax ) THEN + xv(mgs,il) = Min( xvbarmax, xv(mgs,il) ) + xv(mgs,il) = Max( xvmn(il), xv(mgs,il) ) + cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xv(mgs,il)*xdn(mgs,il)) + ENDIF + + ENDIF !} + +! IF ( lhl .gt. 1 .and. il .eq. lhl ) THEN +! write(0,*) 'dr: xv,cx,= ',xv(mgs,il),cx(mgs,il) +! ENDIF + + ENDIF !} + ENDDO ! mgs + + + ENDIF ! }} + ENDIF ! } + + DO mgs = 1,ngscnt + + IF ( il == lh ) THEN + IF ( lnhf > 1 ) THEN ! number of graupel from frozen drops + an(igs(mgs),jy,kgs(mgs),lnhf) = Max( chxf(mgs,lh), 0.0) + ENDIF + ENDIF + + IF ( il == lhl ) THEN + + IF ( lnhlf > 1 ) THEN ! number of hail from frozen drops +! an(igs(mgs),jy,kgs(mgs),lnhlf) = Min( cx(mgs,lhl), Max( chxf(mgs,lhl), 0.0) ) + an(igs(mgs),jy,kgs(mgs),lnhlf) = Max( chxf(mgs,lhl), 0.0) + ENDIF + ENDIF + an(igs(mgs),jy,kgs(mgs),ln(il)) = Max(cx(mgs,il), 0.0) + ENDDO + ENDIF ! } + ENDDO ! il } + + IF ( lcin > 1 ) THEN + do mgs = 1,ngscnt + an(igs(mgs),jy,kgs(mgs),lcin) = Max(0.0, ccin(mgs)) + end do + ENDIF + + IF ( ipconc .ge. 2 ) THEN + do mgs = 1,ngscnt + IF ( lss > 1 ) THEN + an(igs(mgs),jy,kgs(mgs),lss) = Max(0.0, ssmax(mgs) ) + ENDIF + + IF ( lccn > 1 ) THEN + an(igs(mgs),jy,kgs(mgs),lccn) = Max(0.0, ccnc(mgs) ) + ENDIF + end do + ENDIF + + ELSEIF ( ipconc .eq. 0 .and. lni .gt. 1 ) THEN + + DO mgs = 1,ngscnt + an(igs(mgs),jy,kgs(mgs),lni) = Max(cx(mgs,li), 0.0) + ENDDO + + + end if + + IF ( ldovol ) THEN + + DO il = li,lhab + + IF ( lvol(il) .ge. 1 ) THEN + + DO mgs = 1,ngscnt + + an(igs(mgs),jy,kgs(mgs),lvol(il)) = Max( 0.0, vx(mgs,il) ) + ENDDO + + ENDIF + + ENDDO + + ENDIF +! +! +! +! +! + if (ndebug .gt. 0 ) write(0,*) 'gs 12' + + + + if (ndebug .gt. 0 ) write(0,*) 'gs 13' + + 9998 continue + + if ( kz .gt. nz-1 .and. ix .ge. itile) then + if ( ix .ge. itile ) then + go to 1200 ! exit gather scatter + else + nzmpb = kz + endif + else + nzmpb = kz + end if + + if ( ix .ge. itile ) then + nxmpb = 1 + nzmpb = kz+1 + else + nxmpb = ix+1 + end if + + 1000 continue + 1200 continue +! +! end of gather scatter (for this jy slice) +! +! + + return + end subroutine nssl_2mom_gs +! +!-------------------------------------------------------------------------- +! + + + +! +!-------------------------------------------------------------------------- +! + + +END MODULE module_mp_nssl_2mom diff --git a/physics/mp_nssl.F90 b/physics/mp_nssl.F90 new file mode 100644 index 000000000..7101d50b0 --- /dev/null +++ b/physics/mp_nssl.F90 @@ -0,0 +1,826 @@ +!>\file mp_nssl.F90 +!! This file contains NSSL 2-moment MP scheme. + + +!>\defgroup nsslmp NSSL MP Module +!! This module contains the front end to NSSL microphysics scheme. +module mp_nssl + + use machine, only : kind_phys, kind_real + use module_mp_nssl_2mom, only : nssl_2mom_init, nssl_2mom_driver + + implicit none + + public :: mp_nssl_init, mp_nssl_run, mp_nssl_finalize + + private + logical :: is_initialized = .False. + real :: nssl_qccn + + contains + +!>\ingroup nsslmp +!> This subroutine is a wrapper around the nssl_2mom_init(). +!! \section arg_table_mp_nssl_init Argument Table +!>@{ +!> \section arg_table_mp_nssl_init Argument Table +!! \htmlinclude mp_nssl_init.html +!! + subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & + mpirank, mpiroot, & + con_g, con_rd, con_cp, con_rv, & + con_t0c, con_cliq, con_csol, con_eps, & + imp_physics, imp_physics_nssl, & + nssl_cccn, nssl_alphah, nssl_alphahl, & + nssl_ccn_on, nssl_hail_on, nssl_invertccn ) + + + use module_mp_nssl_2mom, only: nssl_2mom_init, nssl_2mom_init_const + + implicit none + + integer, intent(in) :: ncol + integer, intent(in) :: nlev + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg + integer, intent(in) :: threads + logical, intent(in) :: restart + real(kind_phys), intent(in) :: con_g, con_rd, con_cp, con_rv, & + con_t0c, con_cliq, con_csol, con_eps + + integer, intent(in) :: mpirank + integer, intent(in) :: mpiroot + integer, intent(in) :: imp_physics + integer, intent(in) :: imp_physics_nssl + real(kind_phys), intent(in) :: nssl_cccn, nssl_alphah, nssl_alphahl + logical, intent(in) :: nssl_ccn_on, nssl_hail_on, nssl_invertccn + + ! Local variables: dimensions used in nssl_init + integer :: ims,ime, jms,jme, kms,kme, nx, nz, i,k + real :: nssl_params(20) + integer :: ihailv + + + ! Initialize the CCPP error handling variables + errflg = 0 + errmsg = '' + +! write(0,*) 'nssl_init: nlev,ncol,rank = ',nlev,ncol,mpirank + + if ( is_initialized ) return + + IF ( .not. is_initialized ) THEN ! only do this on first call + if (mpirank==mpiroot) then + write(0,*) ' ----------------------------------------------------------------------------------------------------------------' + write(0,*) ' --- CCPP NSSL MP scheme init ---' + write(0,*) ' ----------------------------------------------------------------------------------------------------------------' + write(6,*) ' ----------------------------------------------------------------------------------------------------------------' + write(6,*) ' --- CCPP NSSL MP scheme init ---' + write(6,*) ' ----------------------------------------------------------------------------------------------------------------' + end if + +! update this when ccn_flag is active? + if ( imp_physics /= imp_physics_nssl ) then + write(errmsg,'(*(a))') "Logic error: namelist choice of microphysics is different from NSSL" + errflg = 1 + return + end if + + ! set some physical constants in NSSL microphysics to be consistent with parent model + call nssl_2mom_init_const( & + con_g, con_rd, con_cp, con_rv, con_t0c, con_cliq, con_csol, con_eps ) + + + ! Set internal dimensions + ims = 1 + ime = ncol + nx = ncol + jms = 1 + jme = 1 + kms = 1 + kme = nlev + nz = nlev + + + nssl_params(:) = 0.0 + nssl_params(1) = nssl_cccn + nssl_params(2) = nssl_alphah + nssl_params(3) = nssl_alphahl + nssl_params(4) = 4.e5 ! nssl_cnoh -- not used for 2-moment + nssl_params(5) = 4.e4 ! nssl_cnohl-- not used for 2-moment + nssl_params(6) = 4.e5 ! nssl_cnor-- not used for 2-moment + nssl_params(7) = 4.e6 ! nssl_cnos-- not used for 2-moment + nssl_params(8) = 500. ! nssl_rho_qh + nssl_params(9) = 800. ! nssl_rho_qhl + nssl_params(10) = 100. ! nssl_rho_qs + nssl_params(11) = 0 ! nssl_ipelec_tmp + nssl_params(12) = 11 ! nssl_isaund + nssl_params(13) = 0 ! 1= turn on cccna; 0 = turn off + + nssl_qccn = nssl_cccn/1.225 + ! if (mpirank==mpiroot) then + ! write(*,*) 'nssl_init: nssl_qccn = ',nssl_qccn + ! endif + + IF ( nssl_hail_on ) THEN + ihailv = 1 + ELSE + ihailv = -1 + ENDIF + +! write(0,*) 'call nssl_2mom_init' + CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=5,mixphase=0, & + ihvol=ihailv,errmsg=errmsg,errflg=errflg,myrank=mpirank,mpiroot=mpiroot) + + + + is_initialized = .true. + + ENDIF ! .not. is_initialized + + return + + end subroutine mp_nssl_init +!>@} + +!>\ingroup nsslmp +!>\section gen_nssl NSSL MP General Algorithm: interface to driver +!>@{ +!> \section arg_table_mp_nssl_run Argument Table +!! \htmlinclude mp_nssl_run.html +!! + subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & +! spechum, cccn, qc, qr, qi, qs, qh, qhl, & + spechum, cccn, cccna, qc, qr, qi, qs, qh, qhl, & + ccw, crw, cci, csw, chw, chl, vh, vhl, & + tgrs, prslk, prsl, phii, omega, dtp, & + prcp, rain, graupel, ice, snow, sr, & + refl_10cm, do_radar_ref, first_time_step, & + re_cloud, re_ice, re_snow, re_rain, & + nleffr, nieffr, nseffr, nreffr, & + imp_physics, convert_dry_rho, & + imp_physics_nssl, nssl_ccn_on, & + nssl_hail_on, nssl_invertccn, ntccn, ntccna, & + errflg, errmsg) + + use module_mp_nssl_2mom, only: calcnfromq, na + + implicit none + integer, intent(in) :: ncol, nlev + real(kind_phys), intent(in ) :: con_g + real(kind_phys), intent(in ) :: con_rd + integer, intent(in) :: mpirank + ! Hydrometeors + logical, intent(in ) :: convert_dry_rho + real(kind_phys), intent(inout) :: spechum(:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: cccn(:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: cccna(:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: qc (:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: qr (:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: qi (:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: qs (:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: qh (:,:) !(1:ncol,1:nlev) graupel + real(kind_phys), intent(inout) :: qhl(:,:) !(1:ncol,1:nlev) hail + real(kind_phys), intent(inout) :: ccw(:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: crw(:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: cci(:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: csw(:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: chw(:,:) !(1:ncol,1:nlev) graupel number + real(kind_phys), intent(inout) :: chl(:,:) !(1:ncol,1:nlev) hail number + real(kind_phys), intent(inout) :: vh (:,:) !(1:ncol,1:nlev) graupel volume + real(kind_phys), intent(inout) :: vhl(:,:) !(1:ncol,1:nlev) hail volume + ! State variables and timestep information + real(kind_phys), intent(inout) :: tgrs (:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(in ) :: prsl (:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(in ) :: prslk(:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(in ) :: phii (:,:) !(1:ncol,1:nlev+1) + real(kind_phys), intent(in ) :: omega(:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(in ) :: dtp + ! Precip/rain/snow/graupel fall amounts and fraction of frozen precip + real(kind_phys), intent( out) :: prcp (:) !(1:ncol) + real(kind_phys), intent( out) :: rain (:) !(1:ncol) + real(kind_phys), intent( out) :: graupel(:) !(1:ncol) + real(kind_phys), intent( out) :: ice (:) !(1:ncol) + real(kind_phys), intent( out) :: snow (:) !(1:ncol) + real(kind_phys), intent( out) :: sr (:) !(1:ncol) + ! Radar reflectivity + real(kind_phys), intent(inout) :: refl_10cm(:,:) !(1:ncol,1:nlev) + logical, intent(in ) :: do_radar_ref, first_time_step + ! Cloud effective radii + real(kind_phys), intent(inout) :: re_cloud(:,:) ! (1:ncol,1:nlev) + real(kind_phys), intent(inout) :: re_ice(:,:) ! (1:ncol,1:nlev) + real(kind_phys), intent(inout) :: re_snow(:,:) ! (1:ncol,1:nlev) + real(kind_phys), intent(inout) :: re_rain(:,:) ! (1:ncol,1:nlev) + integer, intent(in) :: nleffr, nieffr, nseffr, nreffr + integer, intent(in) :: imp_physics + integer, intent(in) :: imp_physics_nssl + logical, intent(in) :: nssl_ccn_on, nssl_hail_on, nssl_invertccn + integer, intent(in) :: ntccn, ntccna + + integer, intent(out) :: errflg + character(len=*), intent(out) :: errmsg + + + ! Local variables + + ! Air density + real(kind_phys) :: rho(1:ncol,1:nlev) !< kg m-3 + ! Hydrometeors + real(kind_phys) :: qv_mp(1:ncol,1:nlev) !< kg kg-1 (dry mixing ratio) + real(kind_phys) :: qc_mp(1:ncol,1:nlev) !< kg kg-1 (dry mixing ratio) + real(kind_phys) :: qr_mp(1:ncol,1:nlev) !< kg kg-1 (dry mixing ratio) + real(kind_phys) :: qi_mp(1:ncol,1:nlev) !< kg kg-1 (dry mixing ratio) + real(kind_phys) :: qs_mp(1:ncol,1:nlev) !< kg kg-1 (dry mixing ratio) + real(kind_phys) :: qh_mp(1:ncol,1:nlev) !< kg kg-1 (graupel dry mixing ratio) + real(kind_phys) :: qhl_mp(1:ncol,1:nlev) !< kg kg-1 (hail dry mixing ratio) + real(kind_phys) :: nc_mp(1:ncol,1:nlev) !< droplet num. conc. + real(kind_phys) :: nr_mp(1:ncol,1:nlev) !< rain num. conc. + real(kind_phys) :: ni_mp(1:ncol,1:nlev) !< ice crystal num. conc. + real(kind_phys) :: ns_mp(1:ncol,1:nlev) !< snow num. conc. + real(kind_phys) :: nh_mp(1:ncol,1:nlev) !< graupel num. conc. + real(kind_phys) :: nhl_mp(1:ncol,1:nlev) !< hail num. conc. + real(kind_phys) :: cn_mp(1:ncol,1:nlev) + real(kind_phys) :: cna_mp(1:ncol,1:nlev) + real(kind_phys) :: cccn_mp(1:ncol,1:nlev) + real(kind_phys) :: cccna_mp(1:ncol,1:nlev) + real(kind_phys) :: vh_mp(1:ncol,1:nlev) !< m3 kg-1 (volume mixing ratio) + ! create temporaries for hail in case it does not exist + !real(kind_phys) :: chl_mp(1:ncol,1:nlev) !< kg-1 (number mixing ratio) + real(kind_phys) :: vhl_mp(1:ncol,1:nlev) !< m3 kg-1 (volume mixing ratio) + ! Vertical velocity and level width + real(kind_phys) :: w(1:ncol,1:nlev) !< m s-1 + real(kind_phys) :: dz(1:ncol,1:nlev) !< m + + ! Rain/snow/graupel fall amounts + real(kind_phys) :: rain_mp(1:ncol) ! mm, dummy, not used + real(kind_phys) :: graupel_mp(1:ncol) ! mm, dummy, not used + real(kind_phys) :: ice_mp(1:ncol) ! mm, dummy, not used + real(kind_phys) :: snow_mp(1:ncol) ! mm, dummy, not used + real(kind_phys) :: delta_rain_mp(1:ncol) ! mm + real(kind_phys) :: delta_graupel_mp(1:ncol) ! mm + real(kind_phys) :: delta_ice_mp(1:ncol) ! mm + real(kind_phys) :: delta_snow_mp(1:ncol) ! mm + + real(kind_phys) :: xrain_mp(1:ncol) ! mm, dummy, not used + real(kind_phys) :: xgraupel_mp(1:ncol) ! mm, dummy, not used + real(kind_phys) :: xice_mp(1:ncol) ! mm, dummy, not used + real(kind_phys) :: xsnow_mp(1:ncol) ! mm, dummy, not used + real(kind_phys) :: xdelta_rain_mp(1:ncol) ! mm + real(kind_phys) :: xdelta_graupel_mp(1:ncol) ! mm + real(kind_phys) :: xdelta_ice_mp(1:ncol) ! mm + real(kind_phys) :: xdelta_snow_mp(1:ncol) ! mm + + ! Radar reflectivity + logical :: diagflag ! must be true if do_radar_ref is true, not used otherwise + integer :: do_radar_ref_mp ! integer instead of logical do_radar_ref + ! Effective cloud radii + logical :: do_effective_radii + real(kind_phys) :: re_cloud_mp(1:ncol,1:nlev) ! m + real(kind_phys) :: re_ice_mp(1:ncol,1:nlev) ! m + real(kind_phys) :: re_snow_mp(1:ncol,1:nlev) ! m + real(kind_phys) :: re_rain_mp(1:ncol,1:nlev) ! m + integer :: has_reqc + integer :: has_reqi + integer :: has_reqs + integer :: has_reqr + ! Dimensions used in driver + integer :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, i,j,k + integer :: itimestep ! timestep counter + integer :: ntmul, n + real, parameter :: dtpmax = 60. ! allow up to dt=75 (1.25*60) + real(kind_phys) :: dtptmp + integer, parameter :: ndebug = 0 + logical :: invertccn + real :: cwmas + + real(kind_phys), allocatable :: an(:,:,:,:) ! temporary scalar array + + + errflg = 0 + errmsg = '' + +! write(0,*) 'nssl_run: nlev,ncol,rank = ',nlev,ncol,mpirank + + IF ( ndebug >= 1 ) write(0,*) 'In physics nssl_run' + + + ! Check initialization state + if (.not.is_initialized) then + write(errmsg, fmt='((a))') 'mp_nssl_run called before mp_nssl_init' + errflg = 1 + return + end if + + invertccn = nssl_invertccn + + !> - Convert specific humidity/moist mixing ratios to dry mixing ratios + ! NOTE: Implied loops! + qv_mp = spechum/(1.0_kind_phys-spechum) + IF ( convert_dry_rho ) THEN + qc_mp = qc/(1.0_kind_phys-spechum) + qr_mp = qr/(1.0_kind_phys-spechum) + qi_mp = qi/(1.0_kind_phys-spechum) + qs_mp = qs/(1.0_kind_phys-spechum) + qh_mp = qh/(1.0_kind_phys-spechum) + + IF ( nssl_ccn_on ) cccn_mp = cccn/(1.0_kind_phys-spechum) +! cccna_mp = cccna/(1.0_kind_phys-spechum) + nc_mp = ccw/(1.0_kind_phys-spechum) + nr_mp = crw/(1.0_kind_phys-spechum) + ni_mp = cci/(1.0_kind_phys-spechum) + ns_mp = csw/(1.0_kind_phys-spechum) + nh_mp = chw/(1.0_kind_phys-spechum) + vh_mp = vh/(1.0_kind_phys-spechum) + IF ( nssl_hail_on ) THEN + qhl_mp = qhl/(1.0_kind_phys-spechum) + nhl_mp = chl/(1.0_kind_phys-spechum) + vhl_mp = vhl/(1.0_kind_phys-spechum) + ENDIF + ELSE +! qv_mp = spechum ! /(1.0_kind_phys-spechum) + qc_mp = qc ! /(1.0_kind_phys-spechum) + qr_mp = qr ! /(1.0_kind_phys-spechum) + qi_mp = qi ! /(1.0_kind_phys-spechum) + qs_mp = qs ! /(1.0_kind_phys-spechum) + qh_mp = qh ! /(1.0_kind_phys-spechum) + IF ( nssl_ccn_on ) cccn_mp = cccn +! cccna_mp = cccna + nc_mp = ccw + nr_mp = crw + ni_mp = cci + ns_mp = csw + nh_mp = chw + IF ( nssl_hail_on ) THEN + qhl_mp = qhl ! /(1.0_kind_phys-spechum) + nhl_mp = chl + vhl_mp = vhl + ENDIF + + ENDIF + + IF ( nssl_hail_on ) THEN +! nhl_mp = chl +! vhl_mp = vhl + ELSE + qhl_mp = 0 + nhl_mp = 0 + vhl_mp = 0 + ENDIF + + IF ( .false. ) THEN + write(6,*) 'nsslrun: qc,max ccw = ',mpirank,maxval(qc_mp),maxval(nc_mp),sum(nc_mp) + IF ( mpirank == 1 ) THEN + DO k=1,nlev + DO i=1,ncol + IF ( qc_mp(i,k) > 1.e-6 .and. nc_mp(i,k) <= 1.e-9 ) THEN + write(6,*) 'i,k,qc,nc,ccn = ',i,k,qc_mp(i,k),nc_mp(i,k),cccn_mp(i,k) + ENDIF + ENDDO + ENDDO + ENDIF + ENDIF + + ! IF ( first_time_step ) THEN + ! write(0,*) 'mp_nssl_run: qi,qs,qh maxval: ',maxval(qi),maxval(qs),maxval(qh) + ! write(0,*) 'mp_nssl_run: ni,ns,nh maxval: ',maxval(ni_mp),maxval(ns_mp),maxval(nh_mp) + ! ENDIF + + + !> - Density of air in kg m-3 + rho = prsl/(con_rd*tgrs) + + !> - Convert omega in Pa s-1 to vertical velocity w in m s-1 + w = -omega/(rho*con_g) + + !> - Layer thickness in m from geopotential in m2 s-2 + dz = (phii(:,2:nlev+1) - phii(:,1:nlev)) / con_g + + ! Accumulated values inside scheme, not used; + ! only use delta and add to inout variables (different units) + rain_mp = 0 + graupel_mp = 0 + ice_mp = 0 + snow_mp = 0 + delta_rain_mp = 0 + delta_graupel_mp = 0 + delta_ice_mp = 0 + delta_snow_mp = 0 + xrain_mp = 0 + xgraupel_mp = 0 + xice_mp = 0 + xsnow_mp = 0 + xdelta_rain_mp = 0 + xdelta_graupel_mp = 0 + xdelta_ice_mp = 0 + xdelta_snow_mp = 0 + IF ( ndebug > 1 ) THEN + write(*,*) 'Max q before micro' + write(*,*) 'qc = ',1000.*maxval(qc_mp) + write(*,*) 'qr = ',1000.*maxval(qr_mp) + write(*,*) 'qi = ',1000.*maxval(qi_mp) + write(*,*) 'qs = ',1000.*maxval(qs_mp) + write(*,*) 'qh = ',1000.*maxval(qh_mp) + IF ( nssl_hail_on ) write(*,*) 'qhl = ',1000.*maxval(qhl_mp) + write(*,*) 'ccw = ',1.e-6*maxval(ccw*rho) + ENDIF + + ! Flags for calculating radar reflectivity; diagflag is redundant + if (do_radar_ref) then + diagflag = .true. + do_radar_ref_mp = 1 + else + diagflag = .false. + do_radar_ref_mp = 0 + end if + + do_effective_radii = .false. + IF ( nleffr > 0 .and. nieffr > 0 .and. nseffr > 0 .and. nreffr > 0 ) THEN + ! if (present(re_cloud) .and. present(re_ice) .and. present(re_snow)) then + do_effective_radii = .true. + has_reqc = 1 + has_reqi = 1 + has_reqs = 1 + has_reqr = 1 + else if (nleffr < 1 .and. nieffr < 1 .and. nseffr < 1 .and. nreffr < 1 ) then + do_effective_radii = .false. + has_reqc = 0 + has_reqi = 0 + has_reqs = 0 + has_reqr = 0 + else + write(errmsg,fmt='(*(a))') 'Logic error in mp_nssl_run:', & + ' hydrometeor radius calculation logic problem' + errflg = 1 + return + end if + ! Initialize to zero, intent(out) variables + re_cloud_mp = 0 + re_ice_mp = 0 + re_snow_mp = 0 + re_rain_mp = 0 + + ! Set internal dimensions + ids = 1 + ims = 1 + its = 1 + ide = ncol + ime = ncol + ite = ncol + jds = 1 + jms = 1 + jts = 1 + jde = 1 + jme = 1 + jte = 1 + kds = 1 + kms = 1 + kts = 1 + kde = nlev + kme = nlev + kte = nlev + + + IF ( ndebug >= 1 ) write(0,*) 'call nssl_2mom_driver' + + IF ( dtp > 1.25001*dtpmax ) THEN + ntmul = Max(2, Nint( dtp/dtpmax ) ) + dtptmp = dtp/ntmul + ELSE + dtptmp = dtp + ntmul = 1 + ENDIF + + IF ( first_time_step ) THEN + itimestep = 0 ! gets incremented to 1 in call loop + IF ( nssl_ccn_on ) THEN + IF ( invertccn ) THEN + cccn_mp = 0 + !cccn = nssl_qccn + ELSE + cccn_mp = nssl_qccn + ENDIF + ENDIF + ELSE + itimestep = 2 + ENDIF + + IF ( .false. ) THEN ! disable for now, as logic in the NSSL driver does this, but may switch back to here + ! incoming droplet field may have some inconsistent number concentrations (e.g., from PBL) + ! so check for that, otherwise mass may be zapped into vapor + allocate( an(ncol,1,nlev,na) ) + an(:,:,:,:) = 0.0 ! needed for workspace in routine + + cwmas = 1000.*0.523599*(2.*9.e-6)**3 + + call calcnfromq(nx=ncol,ny=1,nz=nlev,an=an,na=na,nor=0,norz=0,dn=rho, & + & qcw=qc_mp,qci=qi_mp, & + & ccw=nc_mp,cci=ni_mp, & + & cccn=cccn_mp,qv=qv_mp, invertccn_flag=nssl_invertccn, cwmasin=cwmas ) + + IF ( .false. ) THEN + write(6,*) 'nsslrun2: qc,max ccw = ',mpirank,maxval(qc_mp),maxval(nc_mp),sum(nc_mp) + IF ( mpirank == 1 ) THEN + DO k=1,nlev + DO i=1,ncol + IF ( qc_mp(i,k) > 1.e-6 .and. nc_mp(i,k) <= 1.e-9 ) THEN + write(6,*) 'i2,k,qc,nc,ccn = ',i,k,qc_mp(i,k),nc_mp(i,k),cccn_mp(i,k) + ENDIF + ENDDO + ENDDO + ENDIF + ENDIF + + + deallocate( an ) + ENDIF + + IF ( nssl_ccn_on ) THEN + IF ( invertccn ) THEN +! cn_mp = Max(0.0, nssl_qccn - Max(0.0,cccn)) + DO k = 1,nlev + DO i = 1,ncol + cn_mp(i,k) = Max(0.0, nssl_qccn - Max(0.0, cccn_mp(i,k)) ) +! cn_mp(i,k) = Min(nssl_qccn, nssl_qccn - cccn(i,k) ) + ENDDO + ENDDO + ! DO k = 1,nlev + ! DO i = 1,ncol + ! cccn(i,k) = Max(0.0, nssl_qccn - cn_mp(i,k) ) + ! cn_mp(i,k) = cccn(i,k) + ! ENDDO + ! ENDDO + ELSE + cn_mp = cccn_mp + ENDIF + IF ( ntccna > 0 ) THEN +! cna_mp = cccna + ELSE + cna_mp = 0 + ENDIF + ENDIF + + IF ( .true. ) THEN + DO n = 1,ntmul + + itimestep = itimestep + 1 + + + + IF ( nssl_ccn_on ) THEN + + + CALL nssl_2mom_driver( & + ITIMESTEP=itimestep, & + ! TH=th, & + tt=tgrs, & + QV=qv_mp, & + QC=qc_mp, & + QR=qr_mp, & + QI=qi_mp, & + QS=qs_mp, & + QH=qh_mp, & + QHL=qhl_mp, & + CCW=nc_mp, & + CRW=nr_mp, & + CCI=ni_mp, & + CSW=ns_mp, & + CHW=nh_mp, & + CHL=nhl_mp, & + VHW=vh_mp, & + VHL=vhl_mp, & + cn=cn_mp, & +! cna=cna_mp, f_cna=( ntccna > 0 ), & ! for future use + cna=cna_mp, f_cna=.false. , & + PII=prslk, & + P=prsl, & + W=w, & + DZ=dz, & + DTP=dtptmp, & + DN=rho, & + rainnc=xrain_mp, rainncv=xdelta_rain_mp, & + snownc=xsnow_mp, snowncv=xdelta_snow_mp, & +! icenc=ice_mp, icencv=delta_ice_mp, & + GRPLNC=xgraupel_mp, GRPLNCV=xdelta_graupel_mp, sr=sr, & + dbz = refl_10cm, & +! nssl_progn=.false., & + diagflag = diagflag, & + errmsg=errmsg,errflg=errflg, & + re_cloud=re_cloud_mp, & + re_ice=re_ice_mp, & + re_snow=re_snow_mp, & + re_rain=re_rain_mp, & + has_reqc=has_reqc, & ! ala G. Thompson + has_reqi=has_reqi, & ! ala G. Thompson + has_reqs=has_reqs, & ! ala G. Thompson + has_reqr=has_reqr, & + IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde, & + IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme, & + ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & + ) + + + ELSE + + CALL nssl_2mom_driver( & + ITIMESTEP=itimestep, & + ! TH=th, & + tt=tgrs, & + QV=qv_mp, & + QC=qc_mp, & + QR=qr_mp, & + QI=qi_mp, & + QS=qs_mp, & + QH=qh_mp, & + QHL=qhl_mp, & +! CCW=qnc_mp, & + CCW=nc_mp, & + CRW=nr_mp, & + CCI=ni_mp, & + CSW=ns_mp, & + CHW=nh_mp, & + CHL=nhl_mp, & + VHW=vh_mp, & + VHL=vhl_mp, & + ! cn=cccn, & + PII=prslk, & + P=prsl, & + W=w, & + DZ=dz, & + DTP=dtptmp, & + DN=rho, & + rainnc=xrain_mp, rainncv=xdelta_rain_mp, & + snownc=xsnow_mp, snowncv=xdelta_snow_mp, & +! icenc=ice_mp, icencv=delta_ice_mp, & + GRPLNC=xgraupel_mp, GRPLNCV=xdelta_graupel_mp, sr=sr, & + dbz = refl_10cm, & +! nssl_progn=.false., & + diagflag = diagflag, & + errmsg=errmsg,errflg=errflg, & + re_cloud=re_cloud_mp, & + re_ice=re_ice_mp, & + re_snow=re_snow_mp, & + re_rain=re_rain_mp, & + has_reqc=has_reqc, & ! ala G. Thompson + has_reqi=has_reqi, & ! ala G. Thompson + has_reqs=has_reqs, & ! ala G. Thompson + has_reqr=has_reqr, & + IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde, & + IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme, & + ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & + ) + + ENDIF + + + DO i = 1,ncol + delta_rain_mp(i) = delta_rain_mp(i) + xdelta_rain_mp(i) ! this is liquid equivalent of all precip + delta_graupel_mp(i) = delta_graupel_mp(i) + xdelta_graupel_mp(i) ! this is liquid equivalent of graupel + delta_ice_mp(i) = delta_ice_mp(i) + xdelta_ice_mp(i) + delta_snow_mp(i) = delta_snow_mp(i) + xdelta_snow_mp(i) + ENDDO + + ENDDO + + ENDIF + + + IF ( nssl_ccn_on ) THEN + IF ( invertccn ) THEN + !cccn = Max(0.0, nssl_qccn - cn_mp ) + DO k = 1,nlev + DO i = 1,ncol +! cccn(i,k) = Max(0.0, nssl_qccn - cn_mp(i,k) ) + cccn_mp(i,k) = nssl_qccn - cn_mp(i,k) + ENDDO + ENDDO + ELSE + cccn_mp = cn_mp + ENDIF +! cccna = cna_mp + ENDIF + +! test code +! IF ( ntccna > 1 .and. do_effective_radii ) THEN +! cccna = re_ice_mp*1.0E6_kind_phys +! ENDIF + + IF ( ndebug > 1 ) write(0,*) 'done nssl_2mom_driver' + + if (errflg/=0) return + + IF ( ndebug > 1 ) THEN + write(*,*) 'Max q after micro' + write(*,*) 'qc = ',1000.*maxval(qc_mp) + write(*,*) 'qr = ',1000.*maxval(qr_mp) + write(*,*) 'qi = ',1000.*maxval(qi_mp) + write(*,*) 'qs = ',1000.*maxval(qs_mp) + write(*,*) 'qh = ',1000.*maxval(qh_mp) + IF ( nssl_hail_on ) THEN + write(*,*) 'qhl = ',1000.*maxval(qhl_mp) + ENDIF + write(*,*) 'ccw = ',1.e-6*maxval(ccw*rho) + IF ( 1000.*maxval(qc_mp) > 0.5 .or. 1000.*maxval(qi_mp) > 0.09 .or. 1000.*maxval(qs_mp) > 0.1 ) THEN + IF ( nssl_ccn_on ) THEN + write(*,*) 'qc, ccn, ccw, tt, qi+qs by height' + DO k = 1,nlev + write(*,*) qc_mp(1,k)*1000., cccn(1,k)*rho(1,k)*1.e-6, ccw(1,k)*rho(1,k)*1.e-6, tgrs(1,k), (qs_mp(1,k)+qi_mp(1,k))*1000. ! cccn(1,k)*1.e-6 + ENDDO + ELSE + write(*,*) 'qc, ccn, ccw, tt, qi+qs by height' + DO k = 1,nlev + write(*,*) qc_mp(1,k)*1000., cccn(1,k)*rho(1,k)*1.e-6, 0.0, tgrs(1,k), (qs_mp(1,k)+qi_mp(1,k))*1000. ! cccn(1,k)*1.e-6 + ENDDO + ENDIF + ENDIF + ENDIF + + + !> - Convert dry mixing ratios to specific humidity/moist mixing ratios + spechum = qv_mp/(1.0_kind_phys+qv_mp) + IF ( convert_dry_rho ) THEN + qc = qc_mp/(1.0_kind_phys+qv_mp) + qr = qr_mp/(1.0_kind_phys+qv_mp) + qi = qi_mp/(1.0_kind_phys+qv_mp) + qs = qs_mp/(1.0_kind_phys+qv_mp) + qh = qh_mp/(1.0_kind_phys+qv_mp) + IF ( nssl_ccn_on ) cccn = cccn_mp/(1.0_kind_phys+qv_mp) +! cccna = cccna_mp/(1.0_kind_phys+qv_mp) + ccw = nc_mp/(1.0_kind_phys+qv_mp) + crw = nr_mp/(1.0_kind_phys+qv_mp) + cci = ni_mp/(1.0_kind_phys+qv_mp) + csw = ns_mp/(1.0_kind_phys+qv_mp) + chw = nh_mp/(1.0_kind_phys+qv_mp) + vh = vh_mp/(1.0_kind_phys+qv_mp) + IF ( nssl_hail_on ) THEN + qhl = qhl_mp/(1.0_kind_phys+qv_mp) + chl = nhl_mp/(1.0_kind_phys+qv_mp) + vhl = vhl_mp/(1.0_kind_phys+qv_mp) + ENDIF + ELSE +! spechum = qv_mp ! /(1.0_kind_phys+qv_mp) + qc = qc_mp ! /(1.0_kind_phys+qv_mp) + qr = qr_mp ! /(1.0_kind_phys+qv_mp) + qi = qi_mp ! /(1.0_kind_phys+qv_mp) + qs = qs_mp ! /(1.0_kind_phys+qv_mp) + qh = qh_mp ! /(1.0_kind_phys+qv_mp) + IF ( nssl_ccn_on ) cccn = cccn_mp +! cccna = cccna_mp + ccw = nc_mp + crw = nr_mp + cci = ni_mp + csw = ns_mp + chw = nh_mp + vh = vh_mp + IF ( nssl_hail_on ) THEN + qhl = qhl_mp ! /(1.0_kind_phys+qv_mp) + chl = nhl_mp + vhl = vhl_mp + ENDIF + + ENDIF + +! write(0,*) 'mp_nssl: done q' + + !> - Convert rainfall deltas from mm to m (on physics timestep); add to inout variables + ! "rain" in NSSL MP refers to precipitation (total of liquid rainfall+snow+graupel+ice) + + prcp = max(0.0, delta_rain_mp/1000.0_kind_phys) + graupel = max(0.0, delta_graupel_mp/1000.0_kind_phys) + ice = max(0.0, delta_ice_mp/1000.0_kind_phys) + snow = max(0.0, delta_snow_mp/1000.0_kind_phys) + rain = max(0.0, (delta_rain_mp - (delta_graupel_mp + delta_ice_mp + delta_snow_mp))/1000.0_kind_phys) + +! write(0,*) 'mp_nssl: done precip' + + if (do_effective_radii) then + ! Convert m to micron + re_cloud = re_cloud_mp*1.0E6_kind_phys + re_ice = re_ice_mp*1.0E6_kind_phys + re_snow = re_snow_mp*1.0E6_kind_phys + re_rain = re_rain_mp*1.0E6_kind_phys + end if + + IF ( ndebug >= 1 ) write(0,*) 'mp_nssl: end' + + end subroutine mp_nssl_run +!>@} + +#if 0 +!! \section arg_table_mp_nssl_finalize Argument Table +!! \htmlinclude mp_nssl_finalize.html +!! +#endif + subroutine mp_nssl_finalize(errflg, errmsg) + implicit none + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg + + errflg = 0 + errmsg = '' + + + end subroutine mp_nssl_finalize + +end module mp_nssl diff --git a/physics/mp_nssl.meta b/physics/mp_nssl.meta new file mode 100644 index 000000000..43350fd10 --- /dev/null +++ b/physics/mp_nssl.meta @@ -0,0 +1,634 @@ +[ccpp-table-properties] + name = mp_nssl + type = scheme + dependencies = machine.F,module_mp_nssl_2mom.F90 + +[ccpp-arg-table] + name = mp_nssl_init + type = scheme +[ncol] + standard_name = horizontal_dimension + long_name = horizontal dimension + units = count + dimensions = () + type = integer + intent = in +[nlev] + standard_name = vertical_layer_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out +[threads] + standard_name = number_of_openmp_threads + long_name = number of OpenMP threads available to scheme + units = count + dimensions = () + type = integer + intent = in +[restart] + standard_name = flag_for_restart + long_name = flag for restart (warmstart) or coldstart + units = flag + dimensions = () + type = logical + intent = in +[mpirank] + standard_name = mpi_rank + long_name = current MPI-rank + units = index + dimensions = () + type = integer + intent = in +[mpiroot] + standard_name = mpi_root + long_name = master MPI-rank + units = index + dimensions = () + type = integer + intent = in +[con_g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_rd] + standard_name = gas_constant_of_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_cp] + standard_name = specific_heat_of_dry_air_at_constant_pressure + long_name = specific heat of dry air at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_rv] + standard_name = gas_constant_water_vapor + long_name = ideal gas constant for water vapor + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_t0c] + standard_name = temperature_at_zero_celsius + long_name = temperature at 0 degree Celsius + units = K + dimensions = () + type = real + kind = kind_phys + intent = in +[con_cliq] + standard_name = specific_heat_of_liquid_water_at_constant_pressure + long_name = specific heat of liquid water at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_csol] + standard_name = specific_heat_of_ice_at_constant_pressure + long_name = specific heat of ice at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_eps] + standard_name = ratio_of_dry_air_to_water_vapor_gas_constants + long_name = rd/rv + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[imp_physics] + standard_name = control_for_microphysics_scheme + long_name = choice of microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[imp_physics_nssl] + standard_name = identifier_for_nssl_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[nssl_cccn] + standard_name = nssl_ccn_concentration + long_name = CCN concentration + units = m-3 + dimensions = () + type = real + kind = kind_phys + intent = in +[nssl_alphah] + standard_name = nssl_alpha_graupel + long_name = graupel PSD shape parameter in NSSL micro + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[nssl_alphahl] + standard_name = nssl_alpha_hail + long_name = hail PSD shape parameter in NSSL micro + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[nssl_ccn_on] + standard_name = nssl_ccn_on + long_name = CCN activation flag in NSSL micro + units = flag + dimensions = () + type = logical + intent = in +[nssl_hail_on] + standard_name = nssl_hail_on + long_name = hail activation flag in NSSL micro + units = flag + dimensions = () + type = logical + intent = in +[nssl_invertccn] + standard_name = nssl_invertccn + long_name = flag to invert CCN in NSSL micro + units = flag + dimensions = () + type = logical + intent = in +######################################################################## +[ccpp-arg-table] + name = mp_nssl_run + type = scheme +[ncol] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[nlev] + standard_name = vertical_layer_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in +[con_g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_rd] + standard_name = gas_constant_of_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[mpirank] + standard_name = mpi_rank + long_name = current MPI-rank + units = index + dimensions = () + type = integer + intent = in +[spechum] + standard_name = specific_humidity_of_new_state + long_name = water vapor specific humidity + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[qc] + standard_name = cloud_liquid_water_mixing_ratio_of_new_state + long_name = cloud water mixing ratio wrt dry+vapor (no condensates) + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[qr] + standard_name = rain_mixing_ratio_of_new_state + long_name = rain water mixing ratio wrt dry+vapor (no condensates) + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[qi] + standard_name = cloud_ice_mixing_ratio_of_new_state + long_name = ice water mixing ratio wrt dry+vapor (no condensates) + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[qs] + standard_name = snow_mixing_ratio_of_new_state + long_name = snow water mixing ratio wrt dry+vapor (no condensates) + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[qh] + standard_name = graupel_mixing_ratio_of_new_state + long_name = graupel mixing ratio wrt dry+vapor (no condensates) + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[qhl] + standard_name = hail_mixing_ratio_of_new_state + long_name = moist (dry+vapor, no condensates) mixing ratio of hail updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[cccn] + standard_name = cloud_condensation_nuclei_number_concentration_of_new_state + long_name = number concentration of cloud condensation nuclei updated by physics + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[cccna] + standard_name = activated_cloud_condensation_nuclei_number_concentration_of_new_state + long_name = number concentration of activated cloud condensation nuclei updated by physics + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[ccw] + standard_name = mass_number_concentration_of_cloud_liquid_water_particles_in_air_of_new_state + long_name = cloud droplet number concentration + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[crw] + standard_name = mass_number_concentration_of_rain_of_new_state + long_name = rain number concentration + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[cci] + standard_name = mass_number_concentration_of_cloud_ice_water_crystals_in_air_of_new_state + long_name = ice number concentration + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[csw] + standard_name = mass_number_concentration_of_snow_of_new_state + long_name = snow number concentration + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[chw] + standard_name = mass_number_concentration_of_graupel_of_new_state + long_name = graupel number concentration + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[chl] + standard_name = mass_number_concentration_of_hail_of_new_state + long_name = hail number concentration + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[vh] + standard_name = graupel_volume_of_new_state + long_name = graupel particle volume + units = m3 kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[vhl] + standard_name = hail_volume_of_new_state + long_name = hail particle volume + units = m3 kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[tgrs] + standard_name = air_temperature_of_new_state + long_name = model layer mean temperature + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[prslk] + standard_name = dimensionless_exner_function + long_name = dimensionless Exner function at model layer centers + units = none + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[prsl] + standard_name = air_pressure + long_name = mean layer pressure + units = Pa + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[phii] + standard_name = geopotential_at_interface + long_name = geopotential at model layer interfaces + units = m2 s-2 + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = in +[omega] + standard_name = lagrangian_tendency_of_air_pressure + long_name = layer mean vertical velocity + units = Pa s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[dtp] + standard_name = timestep_for_physics + long_name = physics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in +[prcp] + standard_name = lwe_thickness_of_explicit_precipitation_amount + long_name = explicit precipitation (rain, ice, snow, graupel) on physics timestep + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[rain] + standard_name = lwe_thickness_of_explicit_rain_amount + long_name = explicit rain fall on physics timestep + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[graupel] + standard_name = lwe_thickness_of_graupel_amount + long_name = graupel fall on physics timestep + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[ice] + standard_name = lwe_thickness_of_ice_amount + long_name = ice fall on physics timestep + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[snow] + standard_name = lwe_thickness_of_snow_amount + long_name = snow fall on physics timestep + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[sr] + standard_name = ratio_of_snowfall_to_rainfall + long_name = ratio of snowfall to large-scale rainfall + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[refl_10cm] + standard_name = radar_reflectivity_10cm + long_name = instantaneous refl_10cm + units = dBZ + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[do_radar_ref] + standard_name = flag_for_radar_reflectivity + long_name = flag for radar reflectivity + units = flag + dimensions = () + type = logical + intent = in +[first_time_step] + standard_name = flag_for_first_timestep + long_name = flag for first time step for time integration loop (cold/warmstart) + units = flag + dimensions = () + type = logical + intent = in +[re_cloud] + standard_name = effective_radius_of_stratiform_cloud_liquid_water_particle + long_name = eff. radius of cloud liquid water particle in micrometer + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[re_ice] + standard_name = effective_radius_of_stratiform_cloud_ice_particle + long_name = eff. radius of cloud ice water particle in micrometer + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[re_snow] + standard_name = effective_radius_of_stratiform_cloud_snow_particle + long_name = effective radius of cloud snow particle in micrometer + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[re_rain] + standard_name = effective_radius_of_stratiform_cloud_rain_particle + long_name = effective radius of cloud rain particle in micrometers + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[nleffr] + standard_name = index_of_cloud_liquid_water_effective_radius_in_xyz_dimensioned_restart_array + long_name = the index of cloud liquid water effective radius in phy_f3d + units = index + dimensions = () + type = integer + intent = in +[nieffr] + standard_name = index_of_cloud_ice_effective_radius_in_xyz_dimensioned_restart_array + long_name = the index of ice effective radius in phy_f3d + units = index + dimensions = () + type = integer + intent = in +[nreffr] + standard_name = index_of_rain_effective_radius_in_xyz_dimensioned_restart_array + long_name = the index of rain effective radius in phy_f3d + units = index + dimensions = () + type = integer + intent = in +[nseffr] + standard_name = index_of_snow_effective_radius_in_xyz_dimensioned_restart_array + long_name = the index of snow effective radius in phy_f3d + units = index + dimensions = () + type = integer + intent = in +[imp_physics] + standard_name = control_for_microphysics_scheme + long_name = choice of microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[convert_dry_rho] + standard_name = flag_for_converting_hydrometeors_from_moist_to_dry_air + long_name = flag for converting hydrometeors from moist to dry air + units = flag + dimensions = () + type = logical + intent = in +[imp_physics_nssl] + standard_name = identifier_for_nssl_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[nssl_ccn_on] + standard_name = nssl_ccn_on + long_name = CCN activation flag in NSSL micro + units = flag + dimensions = () + type = logical + intent = in +[nssl_hail_on] + standard_name = nssl_hail_on + long_name = hail activation flag in NSSL micro + units = flag + dimensions = () + type = logical + intent = in +[nssl_invertccn] + standard_name = nssl_invertccn + long_name = flag to invert CCN in NSSL micro + units = flag + dimensions = () + type = logical + intent = in +[ntccn] + standard_name = index_of_cloud_condensation_nuclei_number_concentration_in_tracer_concentration_array + long_name = tracer index for cloud condensation nuclei number concentration + units = index + dimensions = () + type = integer + intent = in +[ntccna] + standard_name = index_of_activated_cloud_condensation_nuclei_number_concentration_in_tracer_concentration_array + long_name = tracer index for activated cloud condensation nuclei number concentration + units = index + dimensions = () + type = integer + intent = in +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + +######################################################################## +[ccpp-arg-table] + name = mp_nssl_finalize + type = scheme +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out diff --git a/physics/ozinterp.f90 b/physics/ozinterp.f90 index acb63efbf..6fe86c8e1 100644 --- a/physics/ozinterp.f90 +++ b/physics/ozinterp.f90 @@ -129,7 +129,7 @@ SUBROUTINE setindxoz(npts,dlat,jindx1,jindx2,ddy) ENDDO RETURN - END + END SUBROUTINE setindxoz ! !********************************************************************** ! @@ -206,6 +206,6 @@ SUBROUTINE ozinterpol(me,npts,IDATE,FHOUR,jindx1,jindx2,ozplout,ddy) enddo ! RETURN - END + END SUBROUTINE ozinterpol end module ozinterp diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index c3e0b1293..c9f417bf8 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -300,6 +300,7 @@ module module_radiation_clouds !!\n =6: WSM6 microphysics !!\n =10: MG microphysics !!\n =15: Ferrier-Aligo microphysics +!!\n =17/18: NSSL microphysics !!\param me print control flag !>\section gen_cld_init cld_init General Algorithm !! @{ @@ -390,6 +391,8 @@ subroutine cld_init & print *,' --- MG cloud microphysics' elseif (imp_physics == 15) then print *,' --- Ferrier-Aligo cloud microphysics' + elseif (imp_physics == 17) then + print *,' --- NSSL cloud microphysics' else print *,' !!! ERROR in cloud microphysc specification!!!', & & ' imp_physics (NP3D) =',imp_physics @@ -2896,7 +2899,7 @@ end subroutine progcld5 !mz: this is the original progcld5 for Thompson MP (and WSM6), -! to be replaced by the GSL version of progcld6 for Thompson MP +! to be replaced by the GSL version of progcld6 for Thompson MP and NSSL subroutine progcld6 & & ( plyr,plvl,tlyr,qlyr,qstl,rhly,clw, & ! --- inputs: & xlat,xlon,slmsk,dz,delp, & @@ -2912,7 +2915,7 @@ subroutine progcld6 & ! ================= subprogram documentation block ================ ! ! ! ! subprogram: progcld6 computes cloud related quantities using ! -! Thompson/WSM6 cloud microphysics scheme. ! +! Thompson/WSM6/NSSL cloud microphysics scheme. ! ! ! ! abstract: this program computes cloud fractions from cloud ! ! condensates, ! diff --git a/physics/radiation_surface.meta b/physics/radiation_surface.meta index beab83ce9..668a2bd21 100644 --- a/physics/radiation_surface.meta +++ b/physics/radiation_surface.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = module_radiation_surface type = module - dependencies = + dependencies = namelist_soilveg_ruc.F90,set_soilveg_ruc.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/sfc_drv_ruc.F90 b/physics/sfc_drv_ruc.F90 index 4c42f17fe..17b38268d 100644 --- a/physics/sfc_drv_ruc.F90 +++ b/physics/sfc_drv_ruc.F90 @@ -323,6 +323,7 @@ end subroutine lsm_ruc_finalize subroutine lsm_ruc_run & ! inputs & ( iter, me, master, delt, kdt, im, nlev, lsm_ruc, lsm, & & imp_physics, imp_physics_gfdl, imp_physics_thompson, & + & imp_physics_nssl, & & do_mynnsfclay, lsoil_ruc, lsoil, rdlai, xlat_d, xlon_d, zs,& & t1, q1, qc, stype, vtype, sigmaf, laixy, & & dlwflx, dswsfc, tg3, coszen, land, icy, use_lake, & @@ -371,7 +372,8 @@ subroutine lsm_ruc_run & ! inputs integer, intent(in) :: me, master integer, intent(in) :: im, nlev, iter, lsoil_ruc, lsoil, kdt, isot, ivegsrc integer, intent(in) :: lsm_ruc, lsm - integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson + integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, & + imp_physics_nssl real (kind=kind_phys), dimension(:), intent(in) :: xlat_d, xlon_d real (kind=kind_phys), dimension(:), intent(in) :: & @@ -776,7 +778,8 @@ subroutine lsm_ruc_run & ! inputs ! Set flag for mixed phase precipitation depending on microphysics scheme. ! For GFDL and Thompson, srflag is fraction of frozen precip for convective+explicit precip. - if (imp_physics==imp_physics_gfdl .or. imp_physics==imp_physics_thompson) then + if (imp_physics==imp_physics_gfdl .or. imp_physics==imp_physics_thompson .or. & + imp_physics == imp_physics_nssl) then frpcpn = .true. else frpcpn = .false. diff --git a/physics/sfc_drv_ruc.meta b/physics/sfc_drv_ruc.meta index b9709c4d3..587fda681 100644 --- a/physics/sfc_drv_ruc.meta +++ b/physics/sfc_drv_ruc.meta @@ -620,6 +620,13 @@ dimensions = () type = integer intent = in +[imp_physics_nssl] + standard_name = identifier_for_nssl_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme + units = flag + dimensions = () + type = integer + intent = in [do_mynnsfclay] standard_name = flag_for_mellor_yamada_nakanishi_niino_surface_layer_scheme long_name = flag to activate MYNN surface layer