diff --git a/CMakeLists.txt b/CMakeLists.txt index f16014cb7..242275411 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -6,7 +6,7 @@ project(ccpp_physics #------------------------------------------------------------------------------ set(PACKAGE "ccpp-physics") -set(AUTHORS "Grant Firl" "Dom Heinzeller" "Man Zhang" "Laurie Carson") +set(AUTHORS "Grant Firl" "Dom Heinzeller" "Man Zhang" "Mike Kavulich" "Chunxi Zhang") #------------------------------------------------------------------------------ # Set OpenMP flags for C/C++/Fortran @@ -20,7 +20,7 @@ if(NOT CMAKE_BUILD_TYPE AND NOT CMAKE_CONFIGURATION_TYPES) message(STATUS "Setting build type to 'Release' as none was specified.") set(CMAKE_BUILD_TYPE Release CACHE STRING "Choose the type of build." FORCE) # Set the possible values of build type for cmake-gui - set_property(CACHE CMAKE_BUILD_TYPE PROPERTY STRINGS "Debug" "Bitforbit" "Release" "Coverage") + set_property(CACHE CMAKE_BUILD_TYPE PROPERTY STRINGS "Debug" "Release" "Coverage") endif() #------------------------------------------------------------------------------ @@ -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 @@ -117,8 +120,8 @@ set(SCHEMES_OPENMP_OFF ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/mo_ # List of files that need to be compiled with different precision set(SCHEMES_DYNAMICS) -if(${LOCAL_CURRENT_SOURCE_DIR}/physics/gfdl_fv_sat_adj.F90 IN_LIST SCHEMES) - list(APPEND SCHEMES_DYNAMICS ${LOCAL_CURRENT_SOURCE_DIR}/physics/gfdl_fv_sat_adj.F90) +if(${LOCAL_CURRENT_SOURCE_DIR}/physics/fv_sat_adj.F90 IN_LIST SCHEMES) + list(APPEND SCHEMES_DYNAMICS ${LOCAL_CURRENT_SOURCE_DIR}/physics/fv_sat_adj.F90) endif() # Remove files that need to be compiled with different precision @@ -141,18 +144,36 @@ 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 - ${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") +# Lower optimization for certain schemes when compiling with Intel in Release mode +if(CMAKE_BUILD_TYPE STREQUAL "Release" 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" AND ${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") + # Define a list of schemes that can't be optimized with Intel in Release mode + set(SCHEME_NAMES_NO_OPTIMIZATION GFS_typedefs.F90) + foreach(SCHEME_NAME IN LISTS SCHEME_NAMES_NO_OPTIMIZATION) + set(SCHEMES_TMP ${SCHEMES}) + # Need to determine the name of the scheme with its path + list(FILTER SCHEMES_TMP INCLUDE REGEX ".*${SCHEME_NAME}$") + SET_SOURCE_FILES_PROPERTIES(${SCHEMES_TMP} + APPEND_STRING PROPERTY COMPILE_FLAGS " ${CMAKE_Fortran_FLAGS_PHYSICS} ${OpenMP_Fortran_FLAGS} -O0") + endforeach() endif() # Reduce optimization for mo_gas_optics_kernels.F90 (to avoid an apparent compiler bug with Intel 19+) if(${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/kernels/mo_gas_optics_kernels.F90 IN_LIST SCHEMES_OPENMP_OFF AND - (CMAKE_BUILD_TYPE STREQUAL "Release" OR CMAKE_BUILD_TYPE STREQUAL "Bitforbit") AND - ${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") + CMAKE_BUILD_TYPE STREQUAL "Release" AND ${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") SET_SOURCE_FILES_PROPERTIES(${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/kernels/mo_gas_optics_kernels.F90 APPEND_STRING PROPERTY COMPILE_FLAGS " ${CMAKE_Fortran_FLAGS_PHYSICS} -O1") endif() diff --git a/physics/GFS_DCNV_generic.F90 b/physics/GFS_DCNV_generic_post.F90 similarity index 58% rename from physics/GFS_DCNV_generic.F90 rename to physics/GFS_DCNV_generic_post.F90 index e7dec5ca1..96901a568 100644 --- a/physics/GFS_DCNV_generic.F90 +++ b/physics/GFS_DCNV_generic_post.F90 @@ -1,107 +1,10 @@ -!> \file GFS_DCNV_generic.F90 +!> \file GFS_DCNV_generic_post.F90 !! Contains code related to deep convective schemes to be used within the GFS physics suite. - module GFS_DCNV_generic_pre - - contains - - subroutine GFS_DCNV_generic_pre_init () - end subroutine GFS_DCNV_generic_pre_init - - subroutine GFS_DCNV_generic_pre_finalize() - end subroutine GFS_DCNV_generic_pre_finalize - -!> \brief Interstitial scheme called prior to any deep convective scheme to save state variables for calculating tendencies after the deep convective scheme is executed -!! \section arg_table_GFS_DCNV_generic_pre_run Argument Table -!! \htmlinclude GFS_DCNV_generic_pre_run.html -!! - subroutine GFS_DCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, do_cnvgwd, cplchm, & - gu0, gv0, gt0, gq0, nsamftrac, ntqv, & - save_u, save_v, save_t, save_q, clw, & - ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl, & - ntgnc, cscnv, satmedmf, trans_trac, ras, ntrac, & - dtidx, index_of_process_dcnv, errmsg, errflg) - - use machine, only: kind_phys - - implicit none - - integer, intent(in) :: im, levs, nsamftrac, ntqv, index_of_process_dcnv, dtidx(:,:), & - ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntrac,ntgnc - logical, intent(in) :: ldiag3d, qdiag3d, do_cnvgwd, cplchm - real(kind=kind_phys), dimension(:,:), intent(in) :: gu0 - real(kind=kind_phys), dimension(:,:), intent(in) :: gv0 - real(kind=kind_phys), dimension(:,:), intent(in) :: gt0 - real(kind=kind_phys), dimension(:,:,:), intent(inout) :: gq0 - real(kind=kind_phys), dimension(:,:), intent(inout) :: save_u - real(kind=kind_phys), dimension(:,:), intent(inout) :: save_v - real(kind=kind_phys), dimension(:,:), intent(inout) :: save_t - real(kind=kind_phys), dimension(:,:,:), intent(inout) :: save_q - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - logical, intent(in) :: cscnv, satmedmf, trans_trac, ras - real(kind=kind_phys), parameter :: zero = 0.0d0 - real(kind=kind_phys), dimension(:,:,:), intent(in) :: clw - - integer :: i, k, n, tracers - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (ldiag3d) then - do k=1,levs - do i=1,im - save_t(i,k) = gt0(i,k) - save_u(i,k) = gu0(i,k) - save_v(i,k) = gv0(i,k) - enddo - enddo - elseif (do_cnvgwd) then - do k=1,levs - do i=1,im - save_t(i,k) = gt0(i,k) - enddo - enddo - endif - - if ((ldiag3d.and.qdiag3d) .or. cplchm) then - if (cscnv .or. satmedmf .or. trans_trac .or. ras) then - tracers = 2 - do n=2,ntrac - if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt .and. & - n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & - n /= ntsnc .and. n /= ntgl .and. n /= ntgnc) then - tracers = tracers + 1 - if(dtidx(100+n,index_of_process_dcnv)>0) then - save_q(:,:,n) = clw(:,:,tracers) - endif - endif - enddo - else - do n=2,ntrac - if(dtidx(100+n,index_of_process_dcnv)>0) then - save_q(:,:,n) = gq0(:,:,n) - endif - enddo - endif ! end if_ras or cfscnv or samf - save_q(:,:,ntqv) = gq0(:,:,ntqv) - endif - - end subroutine GFS_DCNV_generic_pre_run - - end module GFS_DCNV_generic_pre - module GFS_DCNV_generic_post contains - subroutine GFS_DCNV_generic_post_init () - end subroutine GFS_DCNV_generic_post_init - - subroutine GFS_DCNV_generic_post_finalize () - end subroutine GFS_DCNV_generic_post_finalize - !> \section arg_table_GFS_DCNV_generic_post_run Argument Table !! \htmlinclude GFS_DCNV_generic_post_run.html !! @@ -111,7 +14,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 +44,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 +110,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_post.meta similarity index 65% rename from physics/GFS_DCNV_generic.meta rename to physics/GFS_DCNV_generic_post.meta index 47fb65d9a..9fbc96f74 100644 --- a/physics/GFS_DCNV_generic.meta +++ b/physics/GFS_DCNV_generic_post.meta @@ -1,268 +1,3 @@ -[ccpp-table-properties] - name = GFS_DCNV_generic_pre - type = scheme - dependencies = machine.F - -######################################################################## -[ccpp-arg-table] - name = GFS_DCNV_generic_pre_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in -[levs] - standard_name = vertical_layer_dimension - long_name = vertical layer dimension - units = count - dimensions = () - type = integer - intent = in -[ldiag3d] - standard_name = flag_for_diagnostics_3D - long_name = flag for 3d diagnostic fields - units = flag - dimensions = () - type = logical - intent = in -[qdiag3d] - standard_name = flag_for_tracer_diagnostics_3D - long_name = flag for 3d tracer diagnostic fields - units = flag - dimensions = () - type = logical - intent = in -[do_cnvgwd] - standard_name = flag_for_convective_gravity_wave_drag - long_name = flag for convective gravity wave drag (gwd) - units = flag - dimensions = () - type = logical - intent = in -[cplchm] - standard_name = flag_for_chemistry_coupling - long_name = flag controlling cplchm collection (default off) - units = flag - dimensions = () - type = logical - intent = in -[gu0] - standard_name = x_wind_of_new_state - long_name = zonal wind updated by physics - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[gv0] - standard_name = y_wind_of_new_state - long_name = meridional wind updated by physics - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[gt0] - standard_name = air_temperature_of_new_state - long_name = temperature updated by physics - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[gq0] - standard_name = tracer_concentration_of_new_state - long_name = tracer concentration updated by physics - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = inout -[nsamftrac] - standard_name = number_of_tracers_for_samf - long_name = number of tracers for scale-aware mass flux schemes - units = count - dimensions = () - type = integer - intent = in -[ntqv] - standard_name = index_of_specific_humidity_in_tracer_concentration_array - long_name = tracer index for water vapor (specific humidity) - units = index - dimensions = () - type = integer - intent = in -[save_u] - standard_name = x_wind_save - long_name = x-wind before entering a physics scheme - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[save_v] - standard_name = y_wind_save - long_name = y-wind before entering a physics scheme - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[save_t] - standard_name = air_temperature_save - long_name = air temperature before entering a physics scheme - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[save_q] - standard_name = tracer_concentration_save - long_name = tracer concentration before entering a physics scheme - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = in -[dtidx] - standard_name = cumulative_change_of_state_variables_outer_index - long_name = index of state-variable and process in last dimension of diagnostic tendencies array AKA cumulative_change_index - units = index - dimensions = (number_of_tracers_plus_one_hundred,number_of_cumulative_change_processes) - type = integer - intent = in -[index_of_process_dcnv] - standard_name = index_of_deep_convection_process_process_in_cumulative_change_index - long_name = index of deep convection process in second dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[cscnv] - standard_name = flag_for_Chikira_Sugiyama_deep_convection - long_name = flag for Chikira-Sugiyama convection - units = flag - dimensions = () - type = logical - intent = in -[satmedmf] - standard_name = flag_for_scale_aware_TKE_moist_EDMF_PBL - long_name = flag for scale-aware TKE moist EDMF PBL scheme - units = flag - dimensions = () - type = logical - intent = in -[trans_trac] - standard_name = flag_for_convective_transport_of_tracers - long_name = flag for convective transport of tracers - units = flag - dimensions = () - type = logical - intent = in -[ras] - standard_name = flag_for_relaxed_arakawa_schubert_deep_convection - long_name = flag for ras convection scheme - units = flag - dimensions = () - type = logical - intent = in -[ntcw] - standard_name = index_of_cloud_liquid_water_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for cloud condensate (or liquid water) - units = index - dimensions = () - type = integer - intent = in -[ntiw] - standard_name = index_of_cloud_ice_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for ice water - units = index - dimensions = () - type = integer - intent = in -[ntclamt] - standard_name = index_of_cloud_area_fraction_in_atmosphere_layer_in_tracer_concentration_array - long_name = tracer index for cloud amount integer - units = index - dimensions = () - type = integer - intent = in -[ntrw] - standard_name = index_of_rain_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for rain water - units = index - dimensions = () - type = integer - intent = in -[ntsw] - standard_name = index_of_snow_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for snow water - units = index - dimensions = () - type = integer - intent = in -[ntrnc] - standard_name = index_of_mass_number_concentration_of_rain_in_tracer_concentration_array - long_name = tracer index for rain number concentration - units = index - dimensions = () - type = integer - intent = in -[ntsnc] - standard_name = index_of_mass_number_concentration_of_snow_in_tracer_concentration_array - long_name = tracer index for snow number concentration - units = index - dimensions = () - type = integer - intent = in -[ntgl] - standard_name = index_of_graupel_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for graupel - units = index - dimensions = () - type = integer - intent = in -[ntgnc] - standard_name = index_of_mass_number_concentration_of_graupel_in_tracer_concentration_array - long_name = tracer index for graupel number concentration - units = index - dimensions = () - type = integer - intent = in -[clw] - standard_name = convective_transportable_tracers - long_name = array to contain cloud water and other convective trans. tracers - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers_for_convective_transport) - type = real - kind = kind_phys - intent = in -[ntrac] - standard_name = number_of_tracers - long_name = number of tracers - units = count - dimensions = () - type = integer - intent = in -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out - ######################################################################## [ccpp-table-properties] name = GFS_DCNV_generic_post @@ -684,6 +419,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_DCNV_generic_pre.F90 b/physics/GFS_DCNV_generic_pre.F90 new file mode 100644 index 000000000..e4eed29c9 --- /dev/null +++ b/physics/GFS_DCNV_generic_pre.F90 @@ -0,0 +1,90 @@ +!> \file GFS_DCNV_generic_pre.F90 +!! Contains code related to deep convective schemes to be used within the GFS physics suite. + + module GFS_DCNV_generic_pre + + contains + +!> \brief Interstitial scheme called prior to any deep convective scheme to save state variables for calculating tendencies after the deep convective scheme is executed +!! \section arg_table_GFS_DCNV_generic_pre_run Argument Table +!! \htmlinclude GFS_DCNV_generic_pre_run.html +!! + subroutine GFS_DCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, do_cnvgwd, cplchm, & + gu0, gv0, gt0, gq0, nsamftrac, ntqv, & + save_u, save_v, save_t, save_q, clw, & + ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl, & + ntgnc, nthl, nthnc, nthv, ntgv, & + cscnv, satmedmf, trans_trac, ras, ntrac, & + dtidx, index_of_process_dcnv, errmsg, errflg) + + use machine, only: kind_phys + + implicit none + + integer, intent(in) :: im, levs, nsamftrac, ntqv, index_of_process_dcnv, dtidx(:,:), & + ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntrac,ntgnc,nthl,nthnc,nthv,ntgv + logical, intent(in) :: ldiag3d, qdiag3d, do_cnvgwd, cplchm + real(kind=kind_phys), dimension(:,:), intent(in) :: gu0 + real(kind=kind_phys), dimension(:,:), intent(in) :: gv0 + real(kind=kind_phys), dimension(:,:), intent(in) :: gt0 + real(kind=kind_phys), dimension(:,:,:), intent(inout) :: gq0 + real(kind=kind_phys), dimension(:,:), intent(inout) :: save_u + real(kind=kind_phys), dimension(:,:), intent(inout) :: save_v + real(kind=kind_phys), dimension(:,:), intent(inout) :: save_t + real(kind=kind_phys), dimension(:,:,:), intent(inout) :: save_q + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + logical, intent(in) :: cscnv, satmedmf, trans_trac, ras + real(kind=kind_phys), parameter :: zero = 0.0d0 + real(kind=kind_phys), dimension(:,:,:), intent(in) :: clw + + integer :: i, k, n, tracers + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (ldiag3d) then + do k=1,levs + do i=1,im + save_t(i,k) = gt0(i,k) + save_u(i,k) = gu0(i,k) + save_v(i,k) = gv0(i,k) + enddo + enddo + elseif (do_cnvgwd) then + do k=1,levs + do i=1,im + save_t(i,k) = gt0(i,k) + enddo + enddo + endif + + if ((ldiag3d.and.qdiag3d) .or. cplchm) then + if (cscnv .or. satmedmf .or. trans_trac .or. ras) then + tracers = 2 + do n=2,ntrac + if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt .and. & + n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & + n /= ntsnc .and. n /= ntgl .and. n /= ntgnc .and. & + n /= nthl .and. n /= nthnc .and. n /= nthv .and. & + n /= ntgv ) then + tracers = tracers + 1 + if(dtidx(100+n,index_of_process_dcnv)>0) then + save_q(:,:,n) = clw(:,:,tracers) + endif + endif + enddo + else + do n=2,ntrac + if(dtidx(100+n,index_of_process_dcnv)>0) then + save_q(:,:,n) = gq0(:,:,n) + endif + enddo + endif ! end if_ras or cfscnv or samf + save_q(:,:,ntqv) = gq0(:,:,ntqv) + endif + + end subroutine GFS_DCNV_generic_pre_run + + end module GFS_DCNV_generic_pre \ No newline at end of file diff --git a/physics/GFS_DCNV_generic_pre.meta b/physics/GFS_DCNV_generic_pre.meta new file mode 100644 index 000000000..e1cf1b022 --- /dev/null +++ b/physics/GFS_DCNV_generic_pre.meta @@ -0,0 +1,292 @@ +[ccpp-table-properties] + name = GFS_DCNV_generic_pre + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = GFS_DCNV_generic_pre_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[levs] + standard_name = vertical_layer_dimension + long_name = vertical layer dimension + units = count + dimensions = () + type = integer + intent = in +[ldiag3d] + standard_name = flag_for_diagnostics_3D + long_name = flag for 3d diagnostic fields + units = flag + dimensions = () + type = logical + intent = in +[qdiag3d] + standard_name = flag_for_tracer_diagnostics_3D + long_name = flag for 3d tracer diagnostic fields + units = flag + dimensions = () + type = logical + intent = in +[do_cnvgwd] + standard_name = flag_for_convective_gravity_wave_drag + long_name = flag for convective gravity wave drag (gwd) + units = flag + dimensions = () + type = logical + intent = in +[cplchm] + standard_name = flag_for_chemistry_coupling + long_name = flag controlling cplchm collection (default off) + units = flag + dimensions = () + type = logical + intent = in +[gu0] + standard_name = x_wind_of_new_state + long_name = zonal wind updated by physics + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[gv0] + standard_name = y_wind_of_new_state + long_name = meridional wind updated by physics + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[gt0] + standard_name = air_temperature_of_new_state + long_name = temperature updated by physics + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[gq0] + standard_name = tracer_concentration_of_new_state + long_name = tracer concentration updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = inout +[nsamftrac] + standard_name = number_of_tracers_for_samf + long_name = number of tracers for scale-aware mass flux schemes + units = count + dimensions = () + type = integer + intent = in +[ntqv] + standard_name = index_of_specific_humidity_in_tracer_concentration_array + long_name = tracer index for water vapor (specific humidity) + units = index + dimensions = () + type = integer + intent = in +[save_u] + standard_name = x_wind_save + long_name = x-wind before entering a physics scheme + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[save_v] + standard_name = y_wind_save + long_name = y-wind before entering a physics scheme + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[save_t] + standard_name = air_temperature_save + long_name = air temperature before entering a physics scheme + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[save_q] + standard_name = tracer_concentration_save + long_name = tracer concentration before entering a physics scheme + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = in +[dtidx] + standard_name = cumulative_change_of_state_variables_outer_index + long_name = index of state-variable and process in last dimension of diagnostic tendencies array AKA cumulative_change_index + units = index + dimensions = (number_of_tracers_plus_one_hundred,number_of_cumulative_change_processes) + type = integer + intent = in +[index_of_process_dcnv] + standard_name = index_of_deep_convection_process_process_in_cumulative_change_index + long_name = index of deep convection process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[cscnv] + standard_name = flag_for_Chikira_Sugiyama_deep_convection + long_name = flag for Chikira-Sugiyama convection + units = flag + dimensions = () + type = logical + intent = in +[satmedmf] + standard_name = flag_for_scale_aware_TKE_moist_EDMF_PBL + long_name = flag for scale-aware TKE moist EDMF PBL scheme + units = flag + dimensions = () + type = logical + intent = in +[trans_trac] + standard_name = flag_for_convective_transport_of_tracers + long_name = flag for convective transport of tracers + units = flag + dimensions = () + type = logical + intent = in +[ras] + standard_name = flag_for_relaxed_arakawa_schubert_deep_convection + long_name = flag for ras convection scheme + units = flag + dimensions = () + type = logical + intent = in +[ntcw] + standard_name = index_of_cloud_liquid_water_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for cloud condensate (or liquid water) + units = index + dimensions = () + type = integer + intent = in +[ntiw] + standard_name = index_of_cloud_ice_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for ice water + units = index + dimensions = () + type = integer + intent = in +[ntclamt] + standard_name = index_of_cloud_area_fraction_in_atmosphere_layer_in_tracer_concentration_array + long_name = tracer index for cloud amount integer + units = index + dimensions = () + type = integer + intent = in +[ntrw] + standard_name = index_of_rain_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for rain water + units = index + dimensions = () + type = integer + intent = in +[ntsw] + standard_name = index_of_snow_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for snow water + units = index + dimensions = () + type = integer + intent = in +[ntrnc] + standard_name = index_of_mass_number_concentration_of_rain_in_tracer_concentration_array + long_name = tracer index for rain number concentration + units = index + dimensions = () + type = integer + intent = in +[ntsnc] + standard_name = index_of_mass_number_concentration_of_snow_in_tracer_concentration_array + long_name = tracer index for snow number concentration + units = index + dimensions = () + type = integer + intent = in +[ntgl] + standard_name = index_of_graupel_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for graupel + units = index + dimensions = () + type = integer + intent = in +[ntgnc] + standard_name = index_of_mass_number_concentration_of_graupel_in_tracer_concentration_array + long_name = tracer index for graupel number concentration + units = index + dimensions = () + type = integer + intent = in +[nthl] + standard_name = index_of_hail_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for hail + units = index + dimensions = () + type = integer + intent = in +[nthnc] + standard_name = index_of_mass_number_concentration_of_hail_in_tracer_concentration_array + long_name = tracer index for hail number concentration + units = index + dimensions = () + type = integer + intent = in +[ntgv] + standard_name = index_of_graupel_volume_in_tracer_concentration_array + long_name = tracer index for graupel particle volume + units = index + dimensions = () + type = integer + intent = in +[nthv] + standard_name = index_of_hail_volume_in_tracer_concentration_array + long_name = tracer index for hail particle volume + units = index + dimensions = () + type = integer + intent = in +[clw] + standard_name = convective_transportable_tracers + long_name = array to contain cloud water and other convective trans. tracers + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers_for_convective_transport) + type = real + kind = kind_phys + intent = in +[ntrac] + standard_name = number_of_tracers + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = in +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out \ No newline at end of file diff --git a/physics/GFS_GWD_generic_post.F90 b/physics/GFS_GWD_generic_post.F90 new file mode 100644 index 000000000..58f18567d --- /dev/null +++ b/physics/GFS_GWD_generic_post.F90 @@ -0,0 +1,68 @@ +!> \file GFS_gwd_generic_post.F90 +!! This file contains the CCPP-compliant orographic gravity wave drag post +!! interstitial codes. +module GFS_GWD_generic_post + +contains + +!> \section arg_table_GFS_GWD_generic_post_run Argument Table +!! \htmlinclude GFS_GWD_generic_post_run.html +!! +!! \section general General Algorithm +!! \section detailed Detailed Algorithm +!> @{ + subroutine GFS_GWD_generic_post_run(lssav, ldiag3d, dtf, dusfcg, dvsfcg, dudt, dvdt, dtdt, & + & dugwd, dvgwd, flag_for_gwd_generic_tend, dtend, dtidx, index_of_temperature, index_of_x_wind, & + & index_of_y_wind, index_of_process_orographic_gwd, errmsg, errflg) + + use machine, only : kind_phys + implicit none + + logical, intent(in) :: lssav, ldiag3d, flag_for_gwd_generic_tend + + real(kind=kind_phys), intent(in) :: dusfcg(:), dvsfcg(:) + real(kind=kind_phys), intent(in) :: dudt(:,:), dvdt(:,:), dtdt(:,:) + real(kind=kind_phys), intent(in) :: dtf + + real(kind=kind_phys), intent(inout) :: dugwd(:), dvgwd(:) + + ! dtend only allocated only if ldiag3d is .true. + real(kind=kind_phys), intent(inout) :: dtend(:,:,:) + integer, intent(in) :: dtidx(:,:), index_of_temperature, & + & index_of_x_wind, index_of_y_wind, index_of_process_orographic_gwd + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + integer :: idtend + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (lssav) then + dugwd(:) = dugwd(:) + dusfcg(:)*dtf + dvgwd(:) = dvgwd(:) + dvsfcg(:)*dtf + + if (ldiag3d .and. flag_for_gwd_generic_tend) then + idtend = dtidx(index_of_temperature, index_of_process_orographic_gwd) + if(idtend>=1) then + dtend(:,:,idtend) = dtend(:,:,idtend) + dtdt*dtf + endif + + idtend = dtidx(index_of_x_wind, index_of_process_orographic_gwd) + if(idtend>=1) then + dtend(:,:,idtend) = dtend(:,:,idtend) + dudt*dtf + endif + + idtend = dtidx(index_of_y_wind, index_of_process_orographic_gwd) + if(idtend>=1) then + dtend(:,:,idtend) = dtend(:,:,idtend) + dvdt*dtf + endif + endif + endif + + end subroutine GFS_GWD_generic_post_run +!> @} + +end module GFS_GWD_generic_post diff --git a/physics/GFS_GWD_generic_post.meta b/physics/GFS_GWD_generic_post.meta new file mode 100644 index 000000000..204c16c84 --- /dev/null +++ b/physics/GFS_GWD_generic_post.meta @@ -0,0 +1,153 @@ +######################################################################## +[ccpp-table-properties] + name = GFS_GWD_generic_post + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = GFS_GWD_generic_post_run + type = scheme +[lssav] + standard_name = flag_for_diagnostics + long_name = flag for calculating diagnostic fields + units = flag + dimensions = () + type = logical + intent = in +[ldiag3d] + standard_name = flag_for_diagnostics_3D + long_name = flag for calculating 3-D diagnostic fields + units = flag + dimensions = () + type = logical + intent = in +[dtf] + standard_name = timestep_for_dynamics + long_name = dynamics time step + units = s + dimensions = () + type = real + kind = kind_phys + intent = in +[dusfcg] + standard_name = instantaneous_x_stress_due_to_gravity_wave_drag + long_name = zonal surface stress due to orographic gravity wave drag + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[dvsfcg] + standard_name = instantaneous_y_stress_due_to_gravity_wave_drag + long_name = meridional surface stress due to orographic gravity wave drag + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[dudt] + standard_name = process_split_cumulative_tendency_of_x_wind + long_name = zonal wind tendency due to model physics + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[dvdt] + standard_name = process_split_cumulative_tendency_of_y_wind + long_name = meridional wind tendency due to model physics + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[dtdt] + standard_name = process_split_cumulative_tendency_of_air_temperature + long_name = air temperature tendency due to model physics + units = K s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[dugwd] + standard_name = time_integral_of_x_stress_due_to_gravity_wave_drag + long_name = integral over time of zonal stress due to gravity wave drag + units = Pa s + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[dvgwd] + standard_name = time_integral_of_y_stress_due_to_gravity_wave_drag + long_name = integral over time of meridional stress due to gravity wave drag + units = Pa s + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[dtend] + standard_name = cumulative_change_of_state_variables + long_name = diagnostic tendencies for state variables + units = mixed + dimensions = (horizontal_loop_extent,vertical_layer_dimension,cumulative_change_of_state_variables_outer_index_max) + type = real + kind = kind_phys + intent = inout +[dtidx] + standard_name = cumulative_change_of_state_variables_outer_index + long_name = index of state-variable and process in last dimension of diagnostic tendencies array AKA cumulative_change_index + units = index + dimensions = (number_of_tracers_plus_one_hundred,number_of_cumulative_change_processes) + type = integer + intent = in +[index_of_temperature] + standard_name = index_of_temperature_in_cumulative_change_index + long_name = index of temperature in first dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[index_of_x_wind] + standard_name = index_of_x_wind_in_cumulative_change_index + long_name = index of x-wind in first dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[index_of_y_wind] + standard_name = index_of_y_wind_in_cumulative_change_index + long_name = index of x-wind in first dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[index_of_process_orographic_gwd] + standard_name = index_of_orographic_gravity_wave_drag_process_in_cumulative_change_index + long_name = index of orographic gravity wave drag process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[flag_for_gwd_generic_tend] + standard_name = flag_for_generic_tendency_due_to_gravity_wave_drag + long_name = true if GFS_GWD_generic should calculate tendencies + units = flag + dimensions = () + type = logical + intent = in +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out \ No newline at end of file diff --git a/physics/GFS_GWD_generic.F90 b/physics/GFS_GWD_generic_pre.F90 similarity index 60% rename from physics/GFS_GWD_generic.F90 rename to physics/GFS_GWD_generic_pre.F90 index a2c869e6a..1c355cc06 100644 --- a/physics/GFS_GWD_generic.F90 +++ b/physics/GFS_GWD_generic_pre.F90 @@ -1,4 +1,4 @@ -!> \file GFS_GWD_generic.F90 +!> \file GFS_GWD_generic_pre.F90 !! This file contains the CCPP-compliant orographic gravity wave !! drag pre interstitial codes. @@ -6,12 +6,6 @@ module GFS_GWD_generic_pre contains -!! \section arg_table_GFS_GWD_generic_pre_init Argument Table -!! \htmlinclude GFS_GWD_generic_pre_init.html -!! - subroutine GFS_GWD_generic_pre_init() - end subroutine GFS_GWD_generic_pre_init - !! \section arg_table_GFS_GWD_generic_pre_run Argument Table !! \htmlinclude GFS_GWD_generic_pre_run.html !! @@ -144,88 +138,4 @@ subroutine GFS_GWD_generic_pre_run( & end subroutine GFS_GWD_generic_pre_run !> @} -!! \section arg_table_GFS_GWD_generic_pre_finalize Argument Table -!! \htmlinclude GFS_GWD_generic_pre_finalize.html -!! - subroutine GFS_GWD_generic_pre_finalize() - end subroutine GFS_GWD_generic_pre_finalize - -end module GFS_GWD_generic_pre - -!> This module contains the CCPP-compliant orographic gravity wave drag post -!! interstitial codes. -module GFS_GWD_generic_post - -contains - - - subroutine GFS_GWD_generic_post_init() - end subroutine GFS_GWD_generic_post_init - -!! \section arg_table_GFS_GWD_generic_post_run Argument Table -!! \htmlinclude GFS_GWD_generic_post_run.html -!! -!! \section general General Algorithm -!! \section detailed Detailed Algorithm -!! @{ - subroutine GFS_GWD_generic_post_run(lssav, ldiag3d, dtf, dusfcg, dvsfcg, dudt, dvdt, dtdt, & - & dugwd, dvgwd, flag_for_gwd_generic_tend, dtend, dtidx, index_of_temperature, index_of_x_wind, & - & index_of_y_wind, index_of_process_orographic_gwd, errmsg, errflg) - - use machine, only : kind_phys - implicit none - - logical, intent(in) :: lssav, ldiag3d, flag_for_gwd_generic_tend - - real(kind=kind_phys), intent(in) :: dusfcg(:), dvsfcg(:) - real(kind=kind_phys), intent(in) :: dudt(:,:), dvdt(:,:), dtdt(:,:) - real(kind=kind_phys), intent(in) :: dtf - - real(kind=kind_phys), intent(inout) :: dugwd(:), dvgwd(:) - - ! dtend only allocated only if ldiag3d is .true. - real(kind=kind_phys), intent(inout) :: dtend(:,:,:) - integer, intent(in) :: dtidx(:,:), index_of_temperature, & - & index_of_x_wind, index_of_y_wind, index_of_process_orographic_gwd - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - integer :: idtend - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (lssav) then - dugwd(:) = dugwd(:) + dusfcg(:)*dtf - dvgwd(:) = dvgwd(:) + dvsfcg(:)*dtf - - if (ldiag3d .and. flag_for_gwd_generic_tend) then - idtend = dtidx(index_of_temperature, index_of_process_orographic_gwd) - if(idtend>=1) then - dtend(:,:,idtend) = dtend(:,:,idtend) + dtdt*dtf - endif - - idtend = dtidx(index_of_x_wind, index_of_process_orographic_gwd) - if(idtend>=1) then - dtend(:,:,idtend) = dtend(:,:,idtend) + dudt*dtf - endif - - idtend = dtidx(index_of_y_wind, index_of_process_orographic_gwd) - if(idtend>=1) then - dtend(:,:,idtend) = dtend(:,:,idtend) + dvdt*dtf - endif - endif - endif - - end subroutine GFS_GWD_generic_post_run -!> @} - -!! \section arg_table_GFS_GWD_generic_post_finalize Argument Table -!! \htmlinclude GFS_GWD_generic_post_finalize.html -!! - subroutine GFS_GWD_generic_post_finalize() - end subroutine GFS_GWD_generic_post_finalize - -end module GFS_GWD_generic_post +end module GFS_GWD_generic_pre \ No newline at end of file diff --git a/physics/GFS_GWD_generic.meta b/physics/GFS_GWD_generic_pre.meta similarity index 60% rename from physics/GFS_GWD_generic.meta rename to physics/GFS_GWD_generic_pre.meta index 78b2ee970..9bcc03300 100644 --- a/physics/GFS_GWD_generic.meta +++ b/physics/GFS_GWD_generic_pre.meta @@ -234,158 +234,4 @@ units = 1 dimensions = () type = integer - intent = out - -######################################################################## -[ccpp-table-properties] - name = GFS_GWD_generic_post - type = scheme - dependencies = machine.F - -######################################################################## -[ccpp-arg-table] - name = GFS_GWD_generic_post_run - type = scheme -[lssav] - standard_name = flag_for_diagnostics - long_name = flag for calculating diagnostic fields - units = flag - dimensions = () - type = logical - intent = in -[ldiag3d] - standard_name = flag_for_diagnostics_3D - long_name = flag for calculating 3-D diagnostic fields - units = flag - dimensions = () - type = logical - intent = in -[dtf] - standard_name = timestep_for_dynamics - long_name = dynamics time step - units = s - dimensions = () - type = real - kind = kind_phys - intent = in -[dusfcg] - standard_name = instantaneous_x_stress_due_to_gravity_wave_drag - long_name = zonal surface stress due to orographic gravity wave drag - units = Pa - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[dvsfcg] - standard_name = instantaneous_y_stress_due_to_gravity_wave_drag - long_name = meridional surface stress due to orographic gravity wave drag - units = Pa - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[dudt] - standard_name = process_split_cumulative_tendency_of_x_wind - long_name = zonal wind tendency due to model physics - units = m s-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[dvdt] - standard_name = process_split_cumulative_tendency_of_y_wind - long_name = meridional wind tendency due to model physics - units = m s-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[dtdt] - standard_name = process_split_cumulative_tendency_of_air_temperature - long_name = air temperature tendency due to model physics - units = K s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[dugwd] - standard_name = time_integral_of_x_stress_due_to_gravity_wave_drag - long_name = integral over time of zonal stress due to gravity wave drag - units = Pa s - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[dvgwd] - standard_name = time_integral_of_y_stress_due_to_gravity_wave_drag - long_name = integral over time of meridional stress due to gravity wave drag - units = Pa s - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[dtend] - standard_name = cumulative_change_of_state_variables - long_name = diagnostic tendencies for state variables - units = mixed - dimensions = (horizontal_loop_extent,vertical_layer_dimension,cumulative_change_of_state_variables_outer_index_max) - type = real - kind = kind_phys - intent = inout -[dtidx] - standard_name = cumulative_change_of_state_variables_outer_index - long_name = index of state-variable and process in last dimension of diagnostic tendencies array AKA cumulative_change_index - units = index - dimensions = (number_of_tracers_plus_one_hundred,number_of_cumulative_change_processes) - type = integer - intent = in -[index_of_temperature] - standard_name = index_of_temperature_in_cumulative_change_index - long_name = index of temperature in first dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[index_of_x_wind] - standard_name = index_of_x_wind_in_cumulative_change_index - long_name = index of x-wind in first dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[index_of_y_wind] - standard_name = index_of_y_wind_in_cumulative_change_index - long_name = index of x-wind in first dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[index_of_process_orographic_gwd] - standard_name = index_of_orographic_gravity_wave_drag_process_in_cumulative_change_index - long_name = index of orographic gravity wave drag process in second dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[flag_for_gwd_generic_tend] - standard_name = flag_for_generic_tendency_due_to_gravity_wave_drag - long_name = true if GFS_GWD_generic should calculate tendencies - units = flag - dimensions = () - type = logical - intent = in -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out + intent = out \ No newline at end of file diff --git a/physics/GFS_MP_generic.F90 b/physics/GFS_MP_generic_post.F90 similarity index 87% rename from physics/GFS_MP_generic.F90 rename to physics/GFS_MP_generic_post.F90 index cb072068e..a7be0ab4c 100644 --- a/physics/GFS_MP_generic.F90 +++ b/physics/GFS_MP_generic_post.F90 @@ -1,71 +1,6 @@ -!> \file GFS_MP_generic.F90 +!> \file GFS_MP_generic_post.F90 !! This file contains the subroutines that calculate diagnotics variables -!! before/after calling any microphysics scheme: - -!> This module contains the CCPP-compliant MP generic pre interstitial codes. - module GFS_MP_generic_pre - contains - - subroutine GFS_MP_generic_pre_init() - end subroutine GFS_MP_generic_pre_init - -!> \section arg_table_GFS_MP_generic_pre_run Argument Table -!! \htmlinclude GFS_MP_generic_pre_run.html -!! - subroutine GFS_MP_generic_pre_run(im, levs, ldiag3d, qdiag3d, do_aw, ntcw, nncl, & - ntrac, gt0, gq0, save_t, save_q, num_dfi_radar, errmsg, errflg) -! - use machine, only: kind_phys - - implicit none - integer, intent(in) :: im, levs, ntcw, nncl, ntrac, num_dfi_radar - logical, intent(in) :: ldiag3d, qdiag3d, do_aw - real(kind=kind_phys), dimension(:,:), intent(in) :: gt0 - real(kind=kind_phys), dimension(:,:,:), intent(in) :: gq0 - - real(kind=kind_phys), dimension(:,:), intent(inout) :: save_t - real(kind=kind_phys), dimension(:,:,:), intent(inout) :: save_q - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - integer :: i, k, n - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (ldiag3d .or. do_aw .or. num_dfi_radar>0) then - do k=1,levs - do i=1,im - save_t(i,k) = gt0(i,k) - enddo - enddo - endif - if (ldiag3d .or. do_aw) then - if(qdiag3d) then - do n=1,ntrac - do k=1,levs - do i=1,im - save_q(i,k,n) = gq0(i,k,n) - enddo - enddo - enddo - else if(do_aw) then - ! if qdiag3d, all q are saved already - save_q(1:im,:,1) = gq0(1:im,:,1) - do n=ntcw,ntcw+nncl-1 - save_q(1:im,:,n) = gq0(1:im,:,n) - enddo - endif - endif - - end subroutine GFS_MP_generic_pre_run - - subroutine GFS_MP_generic_pre_finalize() - end subroutine GFS_MP_generic_pre_finalize - - end module GFS_MP_generic_pre +!! after calling any microphysics scheme: !> This module contains the subroutine that calculates !! precipitation type and its post, which provides precipitation forcing @@ -73,9 +8,6 @@ end module GFS_MP_generic_pre module GFS_MP_generic_post contains - subroutine GFS_MP_generic_post_init() - end subroutine GFS_MP_generic_post_init - !>\defgroup gfs_calpreciptype GFS Precipitation Type Diagnostics Module !! \brief If dominant precip type is requested (i.e., Zhao-Carr MP scheme), 4 more algorithms in calpreciptype() !! will be called. the tallies are then summed in calwxt_dominant(). For GFDL cloud MP scheme, determine convective @@ -87,7 +19,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 +35,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 +126,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 +165,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 +252,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 @@ -458,7 +391,4 @@ subroutine GFS_MP_generic_post_run( end subroutine GFS_MP_generic_post_run !> @} - subroutine GFS_MP_generic_post_finalize() - end subroutine GFS_MP_generic_post_finalize - end module GFS_MP_generic_post diff --git a/physics/GFS_MP_generic.meta b/physics/GFS_MP_generic_post.meta similarity index 87% rename from physics/GFS_MP_generic.meta rename to physics/GFS_MP_generic_post.meta index 1526948e4..6b0f6cc0a 100644 --- a/physics/GFS_MP_generic.meta +++ b/physics/GFS_MP_generic_post.meta @@ -1,123 +1,3 @@ -[ccpp-table-properties] - name = GFS_MP_generic_pre - type = scheme - dependencies = machine.F - -######################################################################## -[ccpp-arg-table] - name = GFS_MP_generic_pre_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in -[levs] - standard_name = vertical_layer_dimension - long_name = vertical layer dimension - units = count - dimensions = () - type = integer - intent = in -[ldiag3d] - standard_name = flag_for_diagnostics_3D - long_name = logical flag for 3D diagnostics - units = flag - dimensions = () - type = logical - intent = in -[qdiag3d] - standard_name = flag_for_tracer_diagnostics_3D - long_name = logical flag for 3D tracer diagnostics - units = flag - dimensions = () - type = logical - intent = in -[do_aw] - standard_name = flag_for_Arakawa_Wu_adjustment - long_name = flag for Arakawa Wu scale-aware adjustment - units = flag - dimensions = () - type = logical - intent = in -[ntcw] - standard_name = index_of_cloud_liquid_water_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for cloud condensate (or liquid water) - units = index - dimensions = () - type = integer - intent = in -[nncl] - standard_name = number_of_condensate_species - long_name = number of cloud condensate types - units = count - dimensions = () - type = integer - intent = in -[ntrac] - standard_name = number_of_tracers - long_name = number of tracers - units = count - dimensions = () - type = integer - intent = in -[gt0] - standard_name = air_temperature_of_new_state - long_name = temperature updated by physics - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[gq0] - standard_name = tracer_concentration_of_new_state - long_name = tracer concentration updated by physics - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = in -[save_t] - standard_name = air_temperature_save - long_name = air temperature before entering a physics scheme - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[save_q] - standard_name = tracer_concentration_save - long_name = tracer concentration before entering a physics scheme - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = inout -[num_dfi_radar] - standard_name = number_of_radar_derived_temperature_or_convection_suppression_intervals - long_name = number of time ranges with radar-derived microphysics temperature tendencies or radar-derived convection suppression - units = count - dimensions = () - type = integer - intent = in -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out - ######################################################################## [ccpp-table-properties] name = GFS_MP_generic_post @@ -220,6 +100,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_MP_generic_pre.F90 b/physics/GFS_MP_generic_pre.F90 new file mode 100644 index 000000000..0910f9cd2 --- /dev/null +++ b/physics/GFS_MP_generic_pre.F90 @@ -0,0 +1,62 @@ +!> \file GFS_MP_generic_pre.F90 +!! This file contains the subroutines that calculate diagnotics variables +!! before calling any microphysics scheme: + +!> This module contains the CCPP-compliant MP generic pre interstitial codes. + module GFS_MP_generic_pre + contains + +!> \section arg_table_GFS_MP_generic_pre_run Argument Table +!! \htmlinclude GFS_MP_generic_pre_run.html +!! + subroutine GFS_MP_generic_pre_run(im, levs, ldiag3d, qdiag3d, do_aw, ntcw, nncl, & + ntrac, gt0, gq0, save_t, save_q, num_dfi_radar, errmsg, errflg) +! + use machine, only: kind_phys + + implicit none + integer, intent(in) :: im, levs, ntcw, nncl, ntrac, num_dfi_radar + logical, intent(in) :: ldiag3d, qdiag3d, do_aw + real(kind=kind_phys), dimension(:,:), intent(in) :: gt0 + real(kind=kind_phys), dimension(:,:,:), intent(in) :: gq0 + + real(kind=kind_phys), dimension(:,:), intent(inout) :: save_t + real(kind=kind_phys), dimension(:,:,:), intent(inout) :: save_q + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + integer :: i, k, n + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (ldiag3d .or. do_aw .or. num_dfi_radar>0) then + do k=1,levs + do i=1,im + save_t(i,k) = gt0(i,k) + enddo + enddo + endif + if (ldiag3d .or. do_aw) then + if(qdiag3d) then + do n=1,ntrac + do k=1,levs + do i=1,im + save_q(i,k,n) = gq0(i,k,n) + enddo + enddo + enddo + else if(do_aw) then + ! if qdiag3d, all q are saved already + save_q(1:im,:,1) = gq0(1:im,:,1) + do n=ntcw,ntcw+nncl-1 + save_q(1:im,:,n) = gq0(1:im,:,n) + enddo + endif + endif + + end subroutine GFS_MP_generic_pre_run + + end module GFS_MP_generic_pre \ No newline at end of file diff --git a/physics/GFS_MP_generic_pre.meta b/physics/GFS_MP_generic_pre.meta new file mode 100644 index 000000000..ac0393917 --- /dev/null +++ b/physics/GFS_MP_generic_pre.meta @@ -0,0 +1,119 @@ +[ccpp-table-properties] + name = GFS_MP_generic_pre + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = GFS_MP_generic_pre_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[levs] + standard_name = vertical_layer_dimension + long_name = vertical layer dimension + units = count + dimensions = () + type = integer + intent = in +[ldiag3d] + standard_name = flag_for_diagnostics_3D + long_name = logical flag for 3D diagnostics + units = flag + dimensions = () + type = logical + intent = in +[qdiag3d] + standard_name = flag_for_tracer_diagnostics_3D + long_name = logical flag for 3D tracer diagnostics + units = flag + dimensions = () + type = logical + intent = in +[do_aw] + standard_name = flag_for_Arakawa_Wu_adjustment + long_name = flag for Arakawa Wu scale-aware adjustment + units = flag + dimensions = () + type = logical + intent = in +[ntcw] + standard_name = index_of_cloud_liquid_water_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for cloud condensate (or liquid water) + units = index + dimensions = () + type = integer + intent = in +[nncl] + standard_name = number_of_condensate_species + long_name = number of cloud condensate types + units = count + dimensions = () + type = integer + intent = in +[ntrac] + standard_name = number_of_tracers + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = in +[gt0] + standard_name = air_temperature_of_new_state + long_name = temperature updated by physics + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[gq0] + standard_name = tracer_concentration_of_new_state + long_name = tracer concentration updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = in +[save_t] + standard_name = air_temperature_save + long_name = air temperature before entering a physics scheme + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[save_q] + standard_name = tracer_concentration_save + long_name = tracer concentration before entering a physics scheme + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = inout +[num_dfi_radar] + standard_name = number_of_radar_derived_temperature_or_convection_suppression_intervals + long_name = number of time ranges with radar-derived microphysics temperature tendencies or radar-derived convection suppression + units = count + dimensions = () + type = integer + intent = in +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out \ No newline at end of file diff --git a/physics/GFS_PBL_generic_common.F90 b/physics/GFS_PBL_generic_common.F90 new file mode 100644 index 000000000..9b3f83b57 --- /dev/null +++ b/physics/GFS_PBL_generic_common.F90 @@ -0,0 +1,73 @@ +!> \file GFS_PBL_generic_common.F90 +!! Contains code used in both pre/post PBL-related interstitial schemes to be used within the GFS physics suite. + + module GFS_PBL_generic_common + + implicit none + + private + + public :: set_aerosol_tracer_index + + contains + + subroutine set_aerosol_tracer_index(imp_physics, imp_physics_wsm6, & + imp_physics_thompson, ltaerosol, & + imp_physics_mg, ntgl, imp_physics_gfdl, & + imp_physics_zhao_carr, imp_physics_nssl,& + nssl_hail_on, nssl_ccn_on, kk, & + errmsg, errflg) + implicit none + ! + integer, intent(in ) :: imp_physics, imp_physics_wsm6, & + imp_physics_thompson, & + imp_physics_mg, ntgl, imp_physics_gfdl, & + imp_physics_zhao_carr,imp_physics_nssl + logical, intent(in ) :: ltaerosol, nssl_hail_on, nssl_ccn_on + integer, intent(out) :: kk + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + errflg = 0 + +! Set Interstitial%kk = last index in diffused tracer array before chemistry-aerosol tracers + if (imp_physics == imp_physics_wsm6) then +! WSM6 + kk = 4 + elseif (imp_physics == imp_physics_thompson) then +! Thompson + if(ltaerosol) then + kk = 12 + else + kk = 9 + endif +! MG + elseif (imp_physics == imp_physics_mg) then + if (ntgl > 0) then + kk = 12 + else + kk = 10 + endif + elseif (imp_physics == imp_physics_gfdl) then +! GFDL MP + kk = 7 + elseif (imp_physics == imp_physics_zhao_carr) then +! Zhao/Carr/Sundqvist + kk = 3 + elseif (imp_physics == imp_physics_nssl) then + IF ( nssl_hail_on ) THEN + kk = 16 + ELSE + kk = 13 + ENDIF + IF ( nssl_ccn_on ) kk = kk + 1 + else + write(errmsg,'(*(a))') 'Logic error: unknown microphysics option in set_aerosol_tracer_index' + kk = -999 + errflg = 1 + return + endif + + end subroutine set_aerosol_tracer_index + + end module GFS_PBL_generic_common \ No newline at end of file diff --git a/physics/GFS_PBL_generic.F90 b/physics/GFS_PBL_generic_post.F90 similarity index 57% rename from physics/GFS_PBL_generic.F90 rename to physics/GFS_PBL_generic_post.F90 index 5bbbefe52..484c84d84 100644 --- a/physics/GFS_PBL_generic.F90 +++ b/physics/GFS_PBL_generic_post.F90 @@ -1,335 +1,19 @@ -!> \file GFS_PBL_generic.F90 -!! Contains code related to PBL schemes to be used within the GFS physics suite. - - module GFS_PBL_generic_common - - implicit none - - private - - public :: set_aerosol_tracer_index - - contains - - subroutine set_aerosol_tracer_index(imp_physics, imp_physics_wsm6, & - imp_physics_thompson, ltaerosol, & - imp_physics_mg, ntgl, imp_physics_gfdl, & - imp_physics_zhao_carr, 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 - integer, intent(out) :: kk - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - errflg = 0 - -! Set Interstitial%kk = last index in diffused tracer array before chemistry-aerosol tracers - if (imp_physics == imp_physics_wsm6) then -! WSM6 - kk = 4 - elseif (imp_physics == imp_physics_thompson) then -! Thompson - if(ltaerosol) then - kk = 10 - else - kk = 7 - endif -! MG - elseif (imp_physics == imp_physics_mg) then - if (ntgl > 0) then - kk = 12 - else - kk = 10 - endif - elseif (imp_physics == imp_physics_gfdl) then -! GFDL MP - kk = 7 - elseif (imp_physics == imp_physics_zhao_carr) then -! Zhao/Carr/Sundqvist - kk = 3 - else - write(errmsg,'(*(a))') 'Logic error: unknown microphysics option in set_aerosol_tracer_index' - kk = -999 - errflg = 1 - return - endif - - end subroutine set_aerosol_tracer_index - - end module GFS_PBL_generic_common - - - module GFS_PBL_generic_pre - - contains - - subroutine GFS_PBL_generic_pre_init () - end subroutine GFS_PBL_generic_pre_init - - subroutine GFS_PBL_generic_pre_finalize() - end subroutine GFS_PBL_generic_pre_finalize - -!> \brief This scheme sets up the vertically diffused tracer array for any PBL scheme based on the microphysics scheme chosen -!! \section arg_table_GFS_PBL_generic_pre_run Argument Table -!! \htmlinclude GFS_PBL_generic_pre_run.html -!! - subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, rtg_ozone_index, & - ntqv, ntcw, ntiw, ntrw, ntsw, ntlnc, ntinc, ntrnc, ntsnc, ntgnc, & - ntwa, ntia, ntgl, ntoz, ntke, ntkev, nqrimef, trans_aero, ntchs, ntchm, & - imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, & - imp_physics_zhao_carr, imp_physics_mg, imp_physics_fer_hires, ltaerosol, & - hybedmf, do_shoc, satmedmf, qgrs, vdftra, save_u, save_v, save_t, save_q, & - flag_for_pbl_generic_tend, ldiag3d, qdiag3d, lssav, ugrs, vgrs, tgrs, errmsg, errflg) - - use machine, only : kind_phys - use GFS_PBL_generic_common, only : set_aerosol_tracer_index - - implicit none - - integer, parameter :: kp = kind_phys - integer, intent(out) :: rtg_ozone_index - integer, intent(in) :: im, levs, nvdiff, ntrac - integer, intent(in) :: ntqv, ntcw, ntiw, ntrw, ntsw, ntlnc, ntinc, ntrnc, ntsnc, ntgnc - integer, intent(in) :: ntwa, ntia, ntgl, ntoz, ntke, ntkev, nqrimef,ntchs, ntchm - 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 - - real(kind=kind_phys), dimension(:,:,:), intent(in) :: qgrs - real(kind=kind_phys), dimension(:,:), intent(in) :: ugrs, vgrs, tgrs - real(kind=kind_phys), dimension(:,:, :), intent(inout) :: vdftra - real(kind=kind_phys), dimension(:,:), intent(out) :: save_u, save_v, save_t - real(kind=kind_phys), dimension(:,:, :), intent(out) :: save_q - - ! CCPP error handling variables - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - real (kind=kind_phys), parameter :: zero = 0.0_kp, one=1.0_kp - - ! Local variables - integer :: i, k, kk, k1, n - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - rtg_ozone_index=-1 -!DH: dvdftra is only used if nvdiff != ntrac or (nvdiff == ntrac .and. ) - if (nvdiff == ntrac .and. (hybedmf .or. do_shoc .or. satmedmf)) then - vdftra = qgrs - rtg_ozone_index = ntoz - else - if (imp_physics == imp_physics_wsm6) then - ! WSM6 - do k=1,levs - do i=1,im - vdftra(i,k,1) = qgrs(i,k,ntqv) - vdftra(i,k,2) = qgrs(i,k,ntcw) - vdftra(i,k,3) = qgrs(i,k,ntiw) - vdftra(i,k,4) = qgrs(i,k,ntoz) - enddo - enddo - rtg_ozone_index = 4 - - ! Ferrier-Aligo - elseif (imp_physics == imp_physics_fer_hires) then - do k=1,levs - do i=1,im - vdftra(i,k,1) = qgrs(i,k,ntqv) - vdftra(i,k,2) = qgrs(i,k,ntcw) - vdftra(i,k,3) = qgrs(i,k,ntiw) - vdftra(i,k,4) = qgrs(i,k,ntrw) - vdftra(i,k,5) = qgrs(i,k,nqrimef) - vdftra(i,k,6) = qgrs(i,k,ntoz) - enddo - enddo - rtg_ozone_index = 6 - - elseif (imp_physics == imp_physics_thompson) then - ! Thompson - if(ltaerosol) then - do k=1,levs - do i=1,im - vdftra(i,k,1) = qgrs(i,k,ntqv) - vdftra(i,k,2) = qgrs(i,k,ntcw) - vdftra(i,k,3) = qgrs(i,k,ntiw) - vdftra(i,k,4) = qgrs(i,k,ntrw) - vdftra(i,k,5) = qgrs(i,k,ntsw) - vdftra(i,k,6) = qgrs(i,k,ntgl) - vdftra(i,k,7) = qgrs(i,k,ntlnc) - vdftra(i,k,8) = qgrs(i,k,ntinc) - vdftra(i,k,9) = qgrs(i,k,ntrnc) - vdftra(i,k,10) = qgrs(i,k,ntoz) - vdftra(i,k,11) = qgrs(i,k,ntwa) - vdftra(i,k,12) = qgrs(i,k,ntia) - enddo - enddo - rtg_ozone_index = 10 - else - do k=1,levs - do i=1,im - vdftra(i,k,1) = qgrs(i,k,ntqv) - vdftra(i,k,2) = qgrs(i,k,ntcw) - vdftra(i,k,3) = qgrs(i,k,ntiw) - vdftra(i,k,4) = qgrs(i,k,ntrw) - vdftra(i,k,5) = qgrs(i,k,ntsw) - vdftra(i,k,6) = qgrs(i,k,ntgl) - vdftra(i,k,7) = qgrs(i,k,ntinc) - vdftra(i,k,8) = qgrs(i,k,ntrnc) - vdftra(i,k,9) = qgrs(i,k,ntoz) - enddo - enddo - rtg_ozone_index = 9 - endif - ! MG - elseif (imp_physics == imp_physics_mg) then ! MG3/2 - if (ntgl > 0) then ! MG3 - do k=1,levs - do i=1,im - vdftra(i,k,1) = qgrs(i,k,ntqv) - vdftra(i,k,2) = qgrs(i,k,ntcw) - vdftra(i,k,3) = qgrs(i,k,ntiw) - vdftra(i,k,4) = qgrs(i,k,ntrw) - vdftra(i,k,5) = qgrs(i,k,ntsw) - vdftra(i,k,6) = qgrs(i,k,ntgl) - vdftra(i,k,7) = qgrs(i,k,ntlnc) - vdftra(i,k,8) = qgrs(i,k,ntinc) - vdftra(i,k,9) = qgrs(i,k,ntrnc) - vdftra(i,k,10) = qgrs(i,k,ntsnc) - vdftra(i,k,11) = qgrs(i,k,ntgnc) - vdftra(i,k,12) = qgrs(i,k,ntoz) - enddo - enddo - rtg_ozone_index = 12 - else ! MG2 - do k=1,levs - do i=1,im - vdftra(i,k,1) = qgrs(i,k,ntqv) - vdftra(i,k,2) = qgrs(i,k,ntcw) - vdftra(i,k,3) = qgrs(i,k,ntiw) - vdftra(i,k,4) = qgrs(i,k,ntrw) - vdftra(i,k,5) = qgrs(i,k,ntsw) - vdftra(i,k,6) = qgrs(i,k,ntlnc) - vdftra(i,k,7) = qgrs(i,k,ntinc) - vdftra(i,k,8) = qgrs(i,k,ntrnc) - vdftra(i,k,9) = qgrs(i,k,ntsnc) - vdftra(i,k,10) = qgrs(i,k,ntoz) - enddo - enddo - rtg_ozone_index = 10 - endif - elseif (imp_physics == imp_physics_gfdl) then - ! GFDL MP - do k=1,levs - do i=1,im - vdftra(i,k,1) = qgrs(i,k,ntqv) - vdftra(i,k,2) = qgrs(i,k,ntcw) - vdftra(i,k,3) = qgrs(i,k,ntiw) - vdftra(i,k,4) = qgrs(i,k,ntrw) - vdftra(i,k,5) = qgrs(i,k,ntsw) - vdftra(i,k,6) = qgrs(i,k,ntgl) - vdftra(i,k,7) = qgrs(i,k,ntoz) - enddo - enddo - rtg_ozone_index = 7 - elseif (imp_physics == imp_physics_zhao_carr) then -! Zhao/Carr/Sundqvist - do k=1,levs - do i=1,im - vdftra(i,k,1) = qgrs(i,k,ntqv) - vdftra(i,k,2) = qgrs(i,k,ntcw) - vdftra(i,k,3) = qgrs(i,k,ntoz) - enddo - enddo - rtg_ozone_index = 3 - 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, & - errmsg, errflg) - if (errflg /= 0) return - ! - k1 = kk - do n=ntchs,ntchm+ntchs-1 - k1 = k1 + 1 - do k=1,levs - do i=1,im - vdftra(i,k,k1) = qgrs(i,k,n) - enddo - enddo - enddo - endif -! - if (ntke>0) then - do k=1,levs - do i=1,im - vdftra(i,k,ntkev) = qgrs(i,k,ntke) - enddo - enddo - endif -! - endif - - if(ldiag3d .and. lssav .and. flag_for_pbl_generic_tend) then - do k=1,levs - do i=1,im - save_t(i,k) = tgrs(i,k) - save_u(i,k) = ugrs(i,k) - save_v(i,k) = vgrs(i,k) - enddo - enddo - if(qdiag3d) then - do k=1,levs - do i=1,im - save_q(i,k,ntqv) = qgrs(i,k,ntqv) - save_q(i,k,ntoz) = qgrs(i,k,ntoz) - enddo - enddo - if(ntke>0) then - do k=1,levs - do i=1,im - save_q(i,k,ntke) = qgrs(i,k,ntke) - enddo - enddo - endif - endif - endif - - end subroutine GFS_PBL_generic_pre_run - - end module GFS_PBL_generic_pre - +!> \file GFS_PBL_generic_post.F90 +!! Contains code related to PBL schemes to be called after PBL schemes within GFS-based physics suites. module GFS_PBL_generic_post contains - subroutine GFS_PBL_generic_post_init () - end subroutine GFS_PBL_generic_post_init - - subroutine GFS_PBL_generic_post_finalize () - end subroutine GFS_PBL_generic_post_finalize - !> \section arg_table_GFS_PBL_generic_post_run Argument Table !! \htmlinclude GFS_PBL_generic_post_run.html !! 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, cplaqm, cplchm, lssav, flag_for_pbl_generic_tend, ldiag3d, lsidea, hybedmf, do_shoc, satmedmf, & shinhong, do_ysu, dvdftra, dusfc1, dvsfc1, dtsfc1, dqsfc1, dtf, dudt, dvdt, dtdt, htrsw, htrlw, xmu, & dqdt, dusfc_cpl, dvsfc_cpl, dtsfc_cpl, dtend, dtidx, index_of_temperature, index_of_x_wind, index_of_y_wind, & index_of_process_pbl, dqsfc_cpl, dusfci_cpl, dvsfci_cpl, dtsfci_cpl, dqsfci_cpl, dusfc_diag, dvsfc_diag, dtsfc_diag, & @@ -346,10 +30,13 @@ 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 - logical, intent(in) :: ltaerosol, cplflx, cplchm, lssav, ldiag3d, lsidea + integer, intent(in) :: imp_physics_nssl + logical, intent(in) :: nssl_ccn_on, nssl_hail_on + logical, intent(in) :: ltaerosol, cplflx, cplaqm, cplchm, lssav, ldiag3d, lsidea logical, intent(in) :: hybedmf, do_shoc, satmedmf, shinhong, do_ysu logical, intent(in) :: flag_for_pbl_generic_tend @@ -419,7 +106,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 +234,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 @@ -619,6 +358,29 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, end if end if + if (cplaqm .and. .not.cplflx) then + do i=1,im + if (oceanfrac(i) > zero) then ! Ocean only, NO LAKES + if ( .not. wet(i)) then ! no open water + if (kdt > 1) then !use results from CICE + dtsfci_cpl(i) = dtsfc_cice(i) + dqsfci_cpl(i) = dqsfc_cice(i) + else !use PBL fluxes when CICE fluxes is unavailable + dtsfci_cpl(i) = dtsfc1(i)*hffac(i) + dqsfci_cpl(i) = dqsfc1(i) + end if + elseif (icy(i) .or. dry(i)) then ! use stress_ocean from sfc_diff for opw component at mixed point + rho = prsl(i,1) / (rd*t1(i)*(one+fvirt*max(q1(i), qmin))) + dtsfci_cpl(i) = cp * rho * hflx_wat(i) ! sensible heat flux over open ocean + dqsfci_cpl(i) = hvap * rho * evap_wat(i) ! latent heat flux over open ocean + else ! use results from PBL scheme for 100% open ocean + dtsfci_cpl(i) = dtsfc1(i)*hffac(i) + dqsfci_cpl(i) = dqsfc1(i) + endif + endif ! Ocean only, NO LAKES + enddo + end if + !-------------------------------------------------------lssav if loop ---------- if (lssav) then do i=1,im diff --git a/physics/GFS_PBL_generic.meta b/physics/GFS_PBL_generic_post.meta similarity index 72% rename from physics/GFS_PBL_generic.meta rename to physics/GFS_PBL_generic_post.meta index 27c659c2c..f12a60d60 100644 --- a/physics/GFS_PBL_generic.meta +++ b/physics/GFS_PBL_generic_post.meta @@ -1,11 +1,12 @@ +######################################################################## [ccpp-table-properties] - name = GFS_PBL_generic_pre + name = GFS_PBL_generic_post type = scheme - dependencies = GFS_PBL_generic.F90,machine.F + dependencies = GFS_PBL_generic_common.F90,machine.F ######################################################################## [ccpp-arg-table] - name = GFS_PBL_generic_pre_run + name = GFS_PBL_generic_post_run type = scheme [im] standard_name = horizontal_loop_extent @@ -35,13 +36,6 @@ dimensions = () type = integer intent = in -[rtg_ozone_index] - standard_name = vertically_diffused_tracer_index_of_ozone - long_name = number of tracers - units = count - dimensions = () - type = integer - intent = out [ntqv] standard_name = index_of_specific_humidity_in_tracer_concentration_array long_name = tracer index for water vapor (specific humidity) @@ -182,377 +176,41 @@ dimensions = () type = integer intent = in -[imp_physics] - standard_name = control_for_microphysics_scheme - long_name = choice of microphysics scheme - units = flag - dimensions = () - type = integer - intent = in -[imp_physics_gfdl] - standard_name = identifier_for_gfdl_microphysics_scheme - long_name = choice of GFDL microphysics scheme - units = flag - dimensions = () - type = integer - intent = in -[imp_physics_thompson] - standard_name = identifier_for_thompson_microphysics_scheme - long_name = choice of Thompson microphysics scheme - units = flag - dimensions = () - type = integer - intent = in -[imp_physics_wsm6] - standard_name = identifier_for_wsm6_microphysics_scheme - long_name = choice of WSM6 microphysics scheme - units = flag - dimensions = () - type = integer - intent = in -[imp_physics_zhao_carr] - standard_name = identifier_for_zhao_carr_microphysics_scheme - long_name = choice of Zhao-Carr microphysics scheme - units = flag - dimensions = () - type = integer - intent = in -[imp_physics_mg] - standard_name = identifier_for_morrison_gettelman_microphysics_scheme - long_name = choice of Morrison-Gettelman microphysics scheme - units = flag - dimensions = () - type = integer - intent = in -[imp_physics_fer_hires] - standard_name = identifier_for_fer_hires_microphysics_scheme - long_name = choice of Ferrier-Aligo microphysics scheme - units = flag - dimensions = () - type = integer - intent = in -[ltaerosol] - standard_name = flag_for_aerosol_physics - long_name = flag for aerosol physics - units = flag - dimensions = () - type = logical - intent = in -[hybedmf] - standard_name = flag_for_hybrid_edmf_pbl_scheme - long_name = flag for hybrid edmf pbl scheme (moninedmf) - units = flag - dimensions = () - type = logical - intent = in -[do_shoc] - standard_name = flag_for_shoc - long_name = flag for SHOC - units = flag - dimensions = () - type = logical - intent = in -[satmedmf] - standard_name = flag_for_scale_aware_TKE_moist_EDMF_PBL - long_name = flag for scale-aware TKE moist EDMF PBL scheme - units = flag - dimensions = () - type = logical - intent = in -[qgrs] - standard_name = tracer_concentration - long_name = model layer mean tracer concentration - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = in -[vdftra] - standard_name = vertically_diffused_tracer_concentration - long_name = tracer concentration diffused by PBL scheme - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_vertical_diffusion_tracers) - type = real - kind = kind_phys - intent = inout -[save_u] - standard_name = x_wind_save - long_name = x-wind before entering a physics scheme - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[save_v] - standard_name = y_wind_save - long_name = y-wind before entering a physics scheme - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[save_t] - standard_name = air_temperature_save - long_name = air temperature before entering a physics scheme - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[save_q] - standard_name = tracer_concentration_save - long_name = tracer concentration before entering a physics scheme - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = out -[flag_for_pbl_generic_tend] - standard_name = flag_for_generic_tendency_due_to_planetary_boundary_layer - long_name = true if GFS_PBL_generic should calculate tendencies - units = flag - dimensions = () - type = logical - intent = in -[ldiag3d] - standard_name = flag_for_diagnostics_3D - long_name = flag for 3d diagnostic fields - units = flag - dimensions = () - type = logical - intent = in -[qdiag3d] - standard_name = flag_for_tracer_diagnostics_3D - long_name = flag for 3d tracer diagnostic fields - units = flag - dimensions = () - type = logical - intent = in -[lssav] - standard_name = flag_for_diagnostics - long_name = logical flag for storing diagnostics - units = flag - dimensions = () - type = logical - intent = in -[ugrs] - standard_name = x_wind - long_name = zonal wind - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[vgrs] - standard_name = y_wind - long_name = meridional wind - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[tgrs] - standard_name = air_temperature - long_name = model layer mean temperature - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out - -######################################################################## -[ccpp-table-properties] - name = GFS_PBL_generic_post - type = scheme - dependencies = GFS_PBL_generic.F90,machine.F - -######################################################################## -[ccpp-arg-table] - name = GFS_PBL_generic_post_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in -[levs] - standard_name = vertical_layer_dimension - long_name = vertical layer dimension - units = count - dimensions = () - type = integer - intent = in -[nvdiff] - standard_name = number_of_vertical_diffusion_tracers - long_name = number of tracers to diffuse vertically - units = count - dimensions = () - type = integer - intent = in -[ntrac] - standard_name = number_of_tracers - long_name = number of tracers - units = count - dimensions = () - type = integer - intent = in -[ntqv] - standard_name = index_of_specific_humidity_in_tracer_concentration_array - long_name = tracer index for water vapor (specific humidity) - units = index - dimensions = () - type = integer - intent = in -[ntcw] - standard_name = index_of_cloud_liquid_water_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for cloud condensate (or liquid water) - units = index - dimensions = () - type = integer - intent = in -[ntiw] - standard_name = index_of_cloud_ice_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for ice water - units = index - dimensions = () - type = integer - intent = in -[ntrw] - standard_name = index_of_rain_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for rain water - units = index - dimensions = () - type = integer - intent = in -[ntsw] - standard_name = index_of_snow_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for snow water - units = index - dimensions = () - type = integer - intent = in -[ntlnc] - standard_name = index_of_mass_number_concentration_of_cloud_droplets_in_tracer_concentration_array - long_name = tracer index for liquid number concentration - units = index - dimensions = () - type = integer - intent = in -[ntinc] - standard_name = index_of_mass_number_concentration_of_cloud_ice_in_tracer_concentration_array - long_name = tracer index for ice number concentration - units = index - dimensions = () - type = integer - intent = in -[ntrnc] - standard_name = index_of_mass_number_concentration_of_rain_in_tracer_concentration_array - long_name = tracer index for rain number concentration - units = index - dimensions = () - type = integer - intent = in -[ntsnc] - standard_name = index_of_mass_number_concentration_of_snow_in_tracer_concentration_array - long_name = tracer index for snow number concentration - units = index - dimensions = () - type = integer - intent = in -[ntgnc] - standard_name = index_of_mass_number_concentration_of_graupel_in_tracer_concentration_array - long_name = tracer index for graupel number concentration - units = index - dimensions = () - type = integer - intent = in -[ntwa] - standard_name = index_of_mass_number_concentration_of_hygroscopic_aerosols_in_tracer_concentration_array - long_name = tracer index for water friendly aerosol - units = index - dimensions = () - type = integer - intent = in -[ntia] - standard_name = index_of_mass_number_concentration_of_nonhygroscopic_ice_nucleating_aerosols_in_tracer_concentration_array - long_name = tracer index for ice friendly aerosol - units = index - dimensions = () - type = integer - intent = in -[ntgl] - standard_name = index_of_graupel_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for graupel - units = index - dimensions = () - type = integer - intent = in -[ntoz] - standard_name = index_of_ozone_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for ozone mixing ratio +[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 -[ntke] - standard_name = index_of_turbulent_kinetic_energy_in_tracer_concentration_array - long_name = tracer index for turbulent kinetic energy +[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 -[ntkev] - standard_name = index_for_turbulent_kinetic_energy_vertical_diffusion_tracer - long_name = index for turbulent kinetic energy in the vertically diffused tracer array +[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 -[nqrimef] - standard_name = index_of_mass_weighted_rime_factor_in_tracer_concentration_array - long_name = tracer index for mass weighted rime factor +[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 -[trans_aero] - standard_name = flag_for_aerosol_convective_transport_and_PBL_diffusion - long_name = flag for aerosol convective transport and PBL diffusion - units = flag - dimensions = () - type = logical - intent = in -[ntchs] - standard_name = index_of_first_chemical_tracer_in_tracer_concentration_array - long_name = tracer index for first chemical tracer +[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 -[ntchm] - standard_name = number_of_chemical_tracers - long_name = number of chemical tracers - units = count - dimensions = () - type = integer - intent = in [imp_physics] standard_name = control_for_microphysics_scheme long_name = choice of microphysics scheme @@ -602,6 +260,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 +274,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) @@ -616,6 +295,13 @@ dimensions = () type = logical intent = in +[cplaqm] + standard_name = flag_for_air_quality_coupling + long_name = flag controlling cplaqm collection (default off) + units = flag + dimensions = () + type = logical + intent = in [cplchm] standard_name = flag_for_chemistry_coupling long_name = flag controlling cplchm collection (default off) diff --git a/physics/GFS_PBL_generic_pre.F90 b/physics/GFS_PBL_generic_pre.F90 new file mode 100644 index 000000000..0dbdf7225 --- /dev/null +++ b/physics/GFS_PBL_generic_pre.F90 @@ -0,0 +1,300 @@ +!> \file GFS_PBL_generic_pre.F90 +!! Contains code related to PBL schemes to be called prior to PBL schemes within GFS-based physics suites. + + module GFS_PBL_generic_pre + + contains + +!> \brief This scheme sets up the vertically diffused tracer array for any PBL scheme based on the microphysics scheme chosen +!! \section arg_table_GFS_PBL_generic_pre_run Argument Table +!! \htmlinclude GFS_PBL_generic_pre_run.html +!! + subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, rtg_ozone_index, & + ntqv, ntcw, ntiw, ntrw, ntsw, ntlnc, ntinc, ntrnc, ntsnc, ntgnc, & + ntwa, ntia, ntgl, ntoz, ntke, ntkev, nqrimef, trans_aero, ntchs, ntchm, & + ntccn, nthl, nthnc, ntgv, nthv, & + imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, & + imp_physics_zhao_carr, imp_physics_mg, imp_physics_fer_hires, imp_physics_nssl, & + ltaerosol, nssl_ccn_on, nssl_hail_on, & + hybedmf, do_shoc, satmedmf, qgrs, vdftra, save_u, save_v, save_t, save_q, & + flag_for_pbl_generic_tend, ldiag3d, qdiag3d, lssav, ugrs, vgrs, tgrs, errmsg, errflg) + + use machine, only : kind_phys + use GFS_PBL_generic_common, only : set_aerosol_tracer_index + + implicit none + + integer, parameter :: kp = kind_phys + integer, intent(out) :: rtg_ozone_index + integer, intent(in) :: im, levs, nvdiff, ntrac + integer, intent(in) :: ntqv, ntcw, ntiw, ntrw, ntsw, ntlnc, ntinc, ntrnc, ntsnc, ntgnc + integer, intent(in) :: ntwa, ntia, ntgl, ntoz, ntke, ntkev, nqrimef,ntchs, ntchm + integer, intent(in) :: ntccn, nthl, nthnc, ntgv, nthv + logical, intent(in) :: trans_aero, ldiag3d, qdiag3d, lssav + integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6 + integer, intent(in) :: imp_physics_zhao_carr, imp_physics_mg, imp_physics_fer_hires + logical, intent(in) :: ltaerosol, hybedmf, do_shoc, satmedmf, flag_for_pbl_generic_tend + integer, intent(in) :: imp_physics_nssl + logical, intent(in) :: nssl_hail_on, nssl_ccn_on + + real(kind=kind_phys), dimension(:,:,:), intent(in) :: qgrs + real(kind=kind_phys), dimension(:,:), intent(in) :: ugrs, vgrs, tgrs + real(kind=kind_phys), dimension(:,:, :), intent(inout) :: vdftra + real(kind=kind_phys), dimension(:,:), intent(out) :: save_u, save_v, save_t + real(kind=kind_phys), dimension(:,:, :), intent(out) :: save_q + + ! CCPP error handling variables + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + real (kind=kind_phys), parameter :: zero = 0.0_kp, one=1.0_kp + + ! Local variables + integer :: i, k, kk, k1, n + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + rtg_ozone_index=-1 +!DH: dvdftra is only used if nvdiff != ntrac or (nvdiff == ntrac .and. ) + if (nvdiff == ntrac .and. (hybedmf .or. do_shoc .or. satmedmf)) then + vdftra = qgrs + rtg_ozone_index = ntoz + else + if (imp_physics == imp_physics_wsm6) then + ! WSM6 + do k=1,levs + do i=1,im + vdftra(i,k,1) = qgrs(i,k,ntqv) + vdftra(i,k,2) = qgrs(i,k,ntcw) + vdftra(i,k,3) = qgrs(i,k,ntiw) + vdftra(i,k,4) = qgrs(i,k,ntoz) + enddo + enddo + rtg_ozone_index = 4 + + ! Ferrier-Aligo + elseif (imp_physics == imp_physics_fer_hires) then + do k=1,levs + do i=1,im + vdftra(i,k,1) = qgrs(i,k,ntqv) + vdftra(i,k,2) = qgrs(i,k,ntcw) + vdftra(i,k,3) = qgrs(i,k,ntiw) + vdftra(i,k,4) = qgrs(i,k,ntrw) + vdftra(i,k,5) = qgrs(i,k,nqrimef) + vdftra(i,k,6) = qgrs(i,k,ntoz) + enddo + enddo + rtg_ozone_index = 6 + + elseif (imp_physics == imp_physics_thompson) then + ! Thompson + if(ltaerosol) then + do k=1,levs + do i=1,im + vdftra(i,k,1) = qgrs(i,k,ntqv) + vdftra(i,k,2) = qgrs(i,k,ntcw) + vdftra(i,k,3) = qgrs(i,k,ntiw) + vdftra(i,k,4) = qgrs(i,k,ntrw) + vdftra(i,k,5) = qgrs(i,k,ntsw) + vdftra(i,k,6) = qgrs(i,k,ntgl) + vdftra(i,k,7) = qgrs(i,k,ntlnc) + vdftra(i,k,8) = qgrs(i,k,ntinc) + vdftra(i,k,9) = qgrs(i,k,ntrnc) + vdftra(i,k,10) = qgrs(i,k,ntoz) + vdftra(i,k,11) = qgrs(i,k,ntwa) + vdftra(i,k,12) = qgrs(i,k,ntia) + enddo + enddo + rtg_ozone_index = 10 + else + do k=1,levs + do i=1,im + vdftra(i,k,1) = qgrs(i,k,ntqv) + vdftra(i,k,2) = qgrs(i,k,ntcw) + vdftra(i,k,3) = qgrs(i,k,ntiw) + vdftra(i,k,4) = qgrs(i,k,ntrw) + vdftra(i,k,5) = qgrs(i,k,ntsw) + vdftra(i,k,6) = qgrs(i,k,ntgl) + vdftra(i,k,7) = qgrs(i,k,ntinc) + vdftra(i,k,8) = qgrs(i,k,ntrnc) + vdftra(i,k,9) = qgrs(i,k,ntoz) + enddo + enddo + rtg_ozone_index = 9 + endif + ! MG + elseif (imp_physics == imp_physics_mg) then ! MG3/2 + if (ntgl > 0) then ! MG3 + do k=1,levs + do i=1,im + vdftra(i,k,1) = qgrs(i,k,ntqv) + vdftra(i,k,2) = qgrs(i,k,ntcw) + vdftra(i,k,3) = qgrs(i,k,ntiw) + vdftra(i,k,4) = qgrs(i,k,ntrw) + vdftra(i,k,5) = qgrs(i,k,ntsw) + vdftra(i,k,6) = qgrs(i,k,ntgl) + vdftra(i,k,7) = qgrs(i,k,ntlnc) + vdftra(i,k,8) = qgrs(i,k,ntinc) + vdftra(i,k,9) = qgrs(i,k,ntrnc) + vdftra(i,k,10) = qgrs(i,k,ntsnc) + vdftra(i,k,11) = qgrs(i,k,ntgnc) + vdftra(i,k,12) = qgrs(i,k,ntoz) + enddo + enddo + rtg_ozone_index = 12 + else ! MG2 + do k=1,levs + do i=1,im + vdftra(i,k,1) = qgrs(i,k,ntqv) + vdftra(i,k,2) = qgrs(i,k,ntcw) + vdftra(i,k,3) = qgrs(i,k,ntiw) + vdftra(i,k,4) = qgrs(i,k,ntrw) + vdftra(i,k,5) = qgrs(i,k,ntsw) + vdftra(i,k,6) = qgrs(i,k,ntlnc) + vdftra(i,k,7) = qgrs(i,k,ntinc) + vdftra(i,k,8) = qgrs(i,k,ntrnc) + vdftra(i,k,9) = qgrs(i,k,ntsnc) + vdftra(i,k,10) = qgrs(i,k,ntoz) + enddo + enddo + rtg_ozone_index = 10 + endif + elseif (imp_physics == imp_physics_gfdl) then + ! GFDL MP + do k=1,levs + do i=1,im + vdftra(i,k,1) = qgrs(i,k,ntqv) + vdftra(i,k,2) = qgrs(i,k,ntcw) + vdftra(i,k,3) = qgrs(i,k,ntiw) + vdftra(i,k,4) = qgrs(i,k,ntrw) + vdftra(i,k,5) = qgrs(i,k,ntsw) + vdftra(i,k,6) = qgrs(i,k,ntgl) + vdftra(i,k,7) = qgrs(i,k,ntoz) + enddo + enddo + rtg_ozone_index = 7 + elseif (imp_physics == imp_physics_zhao_carr) then +! Zhao/Carr/Sundqvist + do k=1,levs + do i=1,im + vdftra(i,k,1) = qgrs(i,k,ntqv) + vdftra(i,k,2) = qgrs(i,k,ntcw) + vdftra(i,k,3) = qgrs(i,k,ntoz) + enddo + enddo + rtg_ozone_index = 3 + elseif (imp_physics == imp_physics_nssl ) then + ! nssl + IF ( nssl_hail_on ) THEN + do k=1,levs + do i=1,im + vdftra(i,k,1) = qgrs(i,k,ntqv) + vdftra(i,k,2) = qgrs(i,k,ntcw) + vdftra(i,k,3) = qgrs(i,k,ntiw) + vdftra(i,k,4) = qgrs(i,k,ntrw) + vdftra(i,k,5) = qgrs(i,k,ntsw) + vdftra(i,k,6) = qgrs(i,k,ntgl) + vdftra(i,k,7) = qgrs(i,k,nthl) + vdftra(i,k,8) = qgrs(i,k,ntlnc) + vdftra(i,k,9) = qgrs(i,k,ntinc) + vdftra(i,k,10) = qgrs(i,k,ntrnc) + vdftra(i,k,11) = qgrs(i,k,ntsnc) + vdftra(i,k,12) = qgrs(i,k,ntgnc) + vdftra(i,k,13) = qgrs(i,k,nthnc) + vdftra(i,k,14) = qgrs(i,k,ntgv) + vdftra(i,k,15) = qgrs(i,k,nthv) + vdftra(i,k,16) = qgrs(i,k,ntoz) + IF ( nssl_ccn_on ) THEN + vdftra(i,k,17) = qgrs(i,k,ntccn) + ENDIF + enddo + enddo + + ELSE + ! no hail + do k=1,levs + do i=1,im + vdftra(i,k,1) = qgrs(i,k,ntqv) + vdftra(i,k,2) = qgrs(i,k,ntcw) + vdftra(i,k,3) = qgrs(i,k,ntiw) + vdftra(i,k,4) = qgrs(i,k,ntrw) + vdftra(i,k,5) = qgrs(i,k,ntsw) + vdftra(i,k,6) = qgrs(i,k,ntgl) + vdftra(i,k,7) = qgrs(i,k,ntlnc) + vdftra(i,k,8) = qgrs(i,k,ntinc) + vdftra(i,k,9) = qgrs(i,k,ntrnc) + vdftra(i,k,10) = qgrs(i,k,ntsnc) + vdftra(i,k,11) = qgrs(i,k,ntgnc) + vdftra(i,k,12) = qgrs(i,k,ntgv) + vdftra(i,k,13) = qgrs(i,k,ntoz) + IF ( nssl_ccn_on ) THEN + vdftra(i,k,14) = qgrs(i,k,ntccn) + ENDIF + enddo + enddo + + ENDIF + + + endif +! + if (trans_aero) then + call set_aerosol_tracer_index(imp_physics, imp_physics_wsm6, & + imp_physics_thompson, ltaerosol, & + imp_physics_mg, ntgl, imp_physics_gfdl, & + imp_physics_zhao_carr, imp_physics_nssl,& + nssl_hail_on, nssl_ccn_on, kk, & + errmsg, errflg) + if (errflg /= 0) return + ! + k1 = kk + do n=ntchs,ntchm+ntchs-1 + k1 = k1 + 1 + do k=1,levs + do i=1,im + vdftra(i,k,k1) = qgrs(i,k,n) + enddo + enddo + enddo + endif +! + if (ntke>0) then + do k=1,levs + do i=1,im + vdftra(i,k,ntkev) = qgrs(i,k,ntke) + enddo + enddo + endif +! + endif + + if(ldiag3d .and. lssav .and. flag_for_pbl_generic_tend) then + do k=1,levs + do i=1,im + save_t(i,k) = tgrs(i,k) + save_u(i,k) = ugrs(i,k) + save_v(i,k) = vgrs(i,k) + enddo + enddo + if(qdiag3d) then + do k=1,levs + do i=1,im + save_q(i,k,ntqv) = qgrs(i,k,ntqv) + save_q(i,k,ntoz) = qgrs(i,k,ntoz) + enddo + enddo + if(ntke>0) then + do k=1,levs + do i=1,im + save_q(i,k,ntke) = qgrs(i,k,ntke) + enddo + enddo + endif + endif + endif + + end subroutine GFS_PBL_generic_pre_run + + end module GFS_PBL_generic_pre \ No newline at end of file diff --git a/physics/GFS_PBL_generic_pre.meta b/physics/GFS_PBL_generic_pre.meta new file mode 100644 index 000000000..5f765d508 --- /dev/null +++ b/physics/GFS_PBL_generic_pre.meta @@ -0,0 +1,432 @@ +[ccpp-table-properties] + name = GFS_PBL_generic_pre + type = scheme + dependencies = GFS_PBL_generic_common.F90,machine.F + +######################################################################## +[ccpp-arg-table] + name = GFS_PBL_generic_pre_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[levs] + standard_name = vertical_layer_dimension + long_name = vertical layer dimension + units = count + dimensions = () + type = integer + intent = in +[nvdiff] + standard_name = number_of_vertical_diffusion_tracers + long_name = number of tracers to diffuse vertically + units = count + dimensions = () + type = integer + intent = in +[ntrac] + standard_name = number_of_tracers + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = in +[rtg_ozone_index] + standard_name = vertically_diffused_tracer_index_of_ozone + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = out +[ntqv] + standard_name = index_of_specific_humidity_in_tracer_concentration_array + long_name = tracer index for water vapor (specific humidity) + units = index + dimensions = () + type = integer + intent = in +[ntcw] + standard_name = index_of_cloud_liquid_water_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for cloud condensate (or liquid water) + units = index + dimensions = () + type = integer + intent = in +[ntiw] + standard_name = index_of_cloud_ice_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for ice water + units = index + dimensions = () + type = integer + intent = in +[ntrw] + standard_name = index_of_rain_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for rain water + units = index + dimensions = () + type = integer + intent = in +[ntsw] + standard_name = index_of_snow_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for snow water + units = index + dimensions = () + type = integer + intent = in +[ntlnc] + standard_name = index_of_mass_number_concentration_of_cloud_droplets_in_tracer_concentration_array + long_name = tracer index for liquid number concentration + units = index + dimensions = () + type = integer + intent = in +[ntinc] + standard_name = index_of_mass_number_concentration_of_cloud_ice_in_tracer_concentration_array + long_name = tracer index for ice number concentration + units = index + dimensions = () + type = integer + intent = in +[ntrnc] + standard_name = index_of_mass_number_concentration_of_rain_in_tracer_concentration_array + long_name = tracer index for rain number concentration + units = index + dimensions = () + type = integer + intent = in +[ntsnc] + standard_name = index_of_mass_number_concentration_of_snow_in_tracer_concentration_array + long_name = tracer index for snow number concentration + units = index + dimensions = () + type = integer + intent = in +[ntgnc] + standard_name = index_of_mass_number_concentration_of_graupel_in_tracer_concentration_array + long_name = tracer index for graupel number concentration + units = index + dimensions = () + type = integer + intent = in +[ntwa] + standard_name = index_of_mass_number_concentration_of_hygroscopic_aerosols_in_tracer_concentration_array + long_name = tracer index for water friendly aerosol + units = index + dimensions = () + type = integer + intent = in +[ntia] + standard_name = index_of_mass_number_concentration_of_nonhygroscopic_ice_nucleating_aerosols_in_tracer_concentration_array + long_name = tracer index for ice friendly aerosol + units = index + dimensions = () + type = integer + intent = in +[ntgl] + standard_name = index_of_graupel_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for graupel + units = index + dimensions = () + type = integer + intent = in +[ntoz] + standard_name = index_of_ozone_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for ozone mixing ratio + units = index + dimensions = () + type = integer + intent = in +[ntke] + standard_name = index_of_turbulent_kinetic_energy_in_tracer_concentration_array + long_name = tracer index for turbulent kinetic energy + units = index + dimensions = () + type = integer + intent = in +[ntkev] + standard_name = index_for_turbulent_kinetic_energy_vertical_diffusion_tracer + long_name = index for turbulent kinetic energy in the vertically diffused tracer array + units = index + dimensions = () + type = integer + intent = in +[nqrimef] + standard_name = index_of_mass_weighted_rime_factor_in_tracer_concentration_array + long_name = tracer index for mass weighted rime factor + units = index + dimensions = () + type = integer + intent = in +[trans_aero] + standard_name = flag_for_aerosol_convective_transport_and_PBL_diffusion + long_name = flag for aerosol convective transport and PBL diffusion + units = flag + dimensions = () + type = logical + intent = in +[ntchs] + standard_name = index_of_first_chemical_tracer_in_tracer_concentration_array + long_name = tracer index for first chemical tracer + units = index + dimensions = () + type = integer + intent = in +[ntchm] + standard_name = number_of_chemical_tracers + long_name = number of chemical tracers + units = count + dimensions = () + type = integer + intent = in +[ntccn] + standard_name = index_of_cloud_condensation_nuclei_number_concentration_in_tracer_concentration_array + long_name = tracer index for cloud condensation nuclei number concentration + units = index + dimensions = () + type = integer + intent = in +[nthl] + standard_name = index_of_hail_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for hail + units = index + dimensions = () + type = integer + intent = in +[nthnc] + standard_name = index_of_mass_number_concentration_of_hail_in_tracer_concentration_array + long_name = tracer index for hail number concentration + units = index + dimensions = () + type = integer + intent = in +[ntgv] + standard_name = index_of_graupel_volume_in_tracer_concentration_array + long_name = tracer index for graupel particle volume + units = index + dimensions = () + type = integer + intent = in +[nthv] + standard_name = index_of_hail_volume_in_tracer_concentration_array + long_name = tracer index for hail particle volume + units = index + dimensions = () + type = integer + intent = in +[imp_physics] + standard_name = control_for_microphysics_scheme + long_name = choice of microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[imp_physics_gfdl] + standard_name = identifier_for_gfdl_microphysics_scheme + long_name = choice of GFDL microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[imp_physics_thompson] + standard_name = identifier_for_thompson_microphysics_scheme + long_name = choice of Thompson microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[imp_physics_wsm6] + standard_name = identifier_for_wsm6_microphysics_scheme + long_name = choice of WSM6 microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[imp_physics_zhao_carr] + standard_name = identifier_for_zhao_carr_microphysics_scheme + long_name = choice of Zhao-Carr microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[imp_physics_mg] + standard_name = identifier_for_morrison_gettelman_microphysics_scheme + long_name = choice of Morrison-Gettelman microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[imp_physics_fer_hires] + standard_name = identifier_for_fer_hires_microphysics_scheme + long_name = choice of Ferrier-Aligo microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[imp_physics_nssl] + standard_name = identifier_for_nssl_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[ltaerosol] + standard_name = flag_for_aerosol_physics + long_name = flag for aerosol physics + units = flag + dimensions = () + type = logical + intent = in +[nssl_ccn_on] + standard_name = nssl_ccn_on + long_name = CCN activation flag in NSSL micro + units = flag + dimensions = () + type = logical + intent = in +[nssl_hail_on] + standard_name = nssl_hail_on + long_name = hail activation flag in NSSL micro + units = flag + dimensions = () + type = logical + intent = in +[hybedmf] + standard_name = flag_for_hybrid_edmf_pbl_scheme + long_name = flag for hybrid edmf pbl scheme (moninedmf) + units = flag + dimensions = () + type = logical + intent = in +[do_shoc] + standard_name = flag_for_shoc + long_name = flag for SHOC + units = flag + dimensions = () + type = logical + intent = in +[satmedmf] + standard_name = flag_for_scale_aware_TKE_moist_EDMF_PBL + long_name = flag for scale-aware TKE moist EDMF PBL scheme + units = flag + dimensions = () + type = logical + intent = in +[qgrs] + standard_name = tracer_concentration + long_name = model layer mean tracer concentration + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = in +[vdftra] + standard_name = vertically_diffused_tracer_concentration + long_name = tracer concentration diffused by PBL scheme + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_vertical_diffusion_tracers) + type = real + kind = kind_phys + intent = inout +[save_u] + standard_name = x_wind_save + long_name = x-wind before entering a physics scheme + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[save_v] + standard_name = y_wind_save + long_name = y-wind before entering a physics scheme + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[save_t] + standard_name = air_temperature_save + long_name = air temperature before entering a physics scheme + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[save_q] + standard_name = tracer_concentration_save + long_name = tracer concentration before entering a physics scheme + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = out +[flag_for_pbl_generic_tend] + standard_name = flag_for_generic_tendency_due_to_planetary_boundary_layer + long_name = true if GFS_PBL_generic should calculate tendencies + units = flag + dimensions = () + type = logical + intent = in +[ldiag3d] + standard_name = flag_for_diagnostics_3D + long_name = flag for 3d diagnostic fields + units = flag + dimensions = () + type = logical + intent = in +[qdiag3d] + standard_name = flag_for_tracer_diagnostics_3D + long_name = flag for 3d tracer diagnostic fields + units = flag + dimensions = () + type = logical + intent = in +[lssav] + standard_name = flag_for_diagnostics + long_name = logical flag for storing diagnostics + units = flag + dimensions = () + type = logical + intent = in +[ugrs] + standard_name = x_wind + long_name = zonal wind + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[vgrs] + standard_name = y_wind + long_name = meridional wind + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[tgrs] + standard_name = air_temperature + long_name = model layer mean temperature + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out \ No newline at end of file diff --git a/physics/GFS_SCNV_generic.F90 b/physics/GFS_SCNV_generic_post.F90 similarity index 63% rename from physics/GFS_SCNV_generic.F90 rename to physics/GFS_SCNV_generic_post.F90 index 58447f6bf..adc8fc1c8 100644 --- a/physics/GFS_SCNV_generic.F90 +++ b/physics/GFS_SCNV_generic_post.F90 @@ -1,93 +1,10 @@ -!> \file GFS_SCNV_generic.F90 -!! Contains code related to shallow convective schemes to be used within the GFS physics suite. - - module GFS_SCNV_generic_pre - - contains - - subroutine GFS_SCNV_generic_pre_init () - end subroutine GFS_SCNV_generic_pre_init - - subroutine GFS_SCNV_generic_pre_finalize() - end subroutine GFS_SCNV_generic_pre_finalize - -!> \section arg_table_GFS_SCNV_generic_pre_run Argument Table -!! \htmlinclude GFS_SCNV_generic_pre_run.html -!! - subroutine GFS_SCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, gu0, gv0, gt0, gq0, & - save_u, save_v, save_t, save_q, ntqv, nsamftrac, flag_for_scnv_generic_tend, & - dtidx, index_of_process_scnv, ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntgnc, & - cscnv, satmedmf, trans_trac, ras, ntrac, clw, errmsg, errflg) - - use machine, only: kind_phys - - implicit none - - integer, intent(in) :: im, levs, ntqv, nsamftrac, index_of_process_scnv, dtidx(:,:) - integer, intent(in) :: ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntgnc,ntrac - logical, intent(in) :: ldiag3d, qdiag3d, flag_for_scnv_generic_tend - real(kind=kind_phys), dimension(:,:), intent(in) :: gu0, gv0, gt0 - real(kind=kind_phys), dimension(:,:,:), intent(in) :: gq0 - real(kind=kind_phys), dimension(:,:,:), intent(inout) :: save_q - real(kind=kind_phys), dimension(:,:), intent(inout) :: save_u, save_v, save_t - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - logical, intent(in) :: cscnv, satmedmf, trans_trac, ras - real(kind=kind_phys), dimension(:,:,:), intent(in) :: clw - - integer :: i, k, n, tracers - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (ldiag3d .and. flag_for_scnv_generic_tend) then - do k=1,levs - do i=1,im - save_u(i,k) = gu0(i,k) - save_v(i,k) = gv0(i,k) - save_t(i,k) = gt0(i,k) - enddo - enddo - if (qdiag3d) then - if (cscnv .or. satmedmf .or. trans_trac .or. ras) then - tracers = 2 - do n=2,ntrac - if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt .and. & - n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & - n /= ntsnc .and. n /= ntgl .and. n /= ntgnc) then - tracers = tracers + 1 - if(dtidx(100+n,index_of_process_scnv)>0) then - save_q(:,:,n) = clw(:,:,tracers) - endif - endif - enddo - else - do n=2,ntrac - if(dtidx(100+n,index_of_process_scnv)>0) then - save_q(:,:,n) = gq0(:,:,n) - endif - enddo - endif ! end if_ras or cfscnv or samf - save_q(:,:,ntqv) = gq0(:,:,ntqv) - endif - endif - - end subroutine GFS_SCNV_generic_pre_run - - - end module GFS_SCNV_generic_pre +!> \file GFS_SCNV_generic_post.F90 +!! Contains code related to shallow convective schemes to be used after shallow convection for GFS-based physics suites. module GFS_SCNV_generic_post contains - subroutine GFS_SCNV_generic_post_init () - end subroutine GFS_SCNV_generic_post_init - - subroutine GFS_SCNV_generic_post_finalize () - end subroutine GFS_SCNV_generic_post_finalize - !> \section arg_table_GFS_SCNV_generic_post_run Argument Table !! \htmlinclude GFS_SCNV_generic_post_run.html !! diff --git a/physics/GFS_SCNV_generic.meta b/physics/GFS_SCNV_generic_post.meta similarity index 62% rename from physics/GFS_SCNV_generic.meta rename to physics/GFS_SCNV_generic_post.meta index 5cbda127c..ab9f51562 100644 --- a/physics/GFS_SCNV_generic.meta +++ b/physics/GFS_SCNV_generic_post.meta @@ -1,261 +1,3 @@ -[ccpp-table-properties] - name = GFS_SCNV_generic_pre - type = scheme - dependencies = machine.F - -######################################################################## -[ccpp-arg-table] - name = GFS_SCNV_generic_pre_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in -[levs] - standard_name = vertical_layer_dimension - long_name = vertical layer dimension - units = count - dimensions = () - type = integer - intent = in -[ldiag3d] - standard_name = flag_for_diagnostics_3D - long_name = flag for 3d diagnostic fields - units = flag - dimensions = () - type = logical - intent = in -[qdiag3d] - standard_name = flag_for_tracer_diagnostics_3D - long_name = flag for 3d tracer diagnostic fields - units = flag - dimensions = () - type = logical - intent = in -[gu0] - standard_name = x_wind_of_new_state - long_name = updated x-direction wind - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[gv0] - standard_name = y_wind_of_new_state - long_name = updated y-direction wind - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[gt0] - standard_name = air_temperature_of_new_state - long_name = temperature updated by physics - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[gq0] - standard_name = tracer_concentration_of_new_state - long_name = tracer concentration updated by physics - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = in -[save_u] - standard_name = x_wind_save - long_name = x-wind before entering a physics scheme - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[save_v] - standard_name = y_wind_save - long_name = y-wind before entering a physics scheme - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[save_t] - standard_name = air_temperature_save - long_name = air temperature before entering a physics scheme - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[save_q] - standard_name = tracer_concentration_save - long_name = tracer concentration before entering a physics scheme - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = in -[ntqv] - standard_name = index_of_specific_humidity_in_tracer_concentration_array - long_name = tracer index for water vapor (specific humidity) - units = index - dimensions = () - type = integer - intent = in -[nsamftrac] - standard_name = number_of_tracers_for_samf - long_name = number of tracers for scale-aware mass flux schemes - units = count - dimensions = () - type = integer - intent = in -[flag_for_scnv_generic_tend] - standard_name = flag_for_generic_tendency_due_to_shallow_convection - long_name = true if GFS_SCNV_generic should calculate tendencies - units = flag - dimensions = () - type = logical - intent = in -[dtidx] - standard_name = cumulative_change_of_state_variables_outer_index - long_name = index of state-variable and process in last dimension of diagnostic tendencies array AKA cumulative_change_index - units = index - dimensions = (number_of_tracers_plus_one_hundred,number_of_cumulative_change_processes) - type = integer - intent = in -[index_of_process_scnv] - standard_name = index_of_shallow_convection_process_process_in_cumulative_change_index - long_name = index of shallow convection process in second dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[cscnv] - standard_name = flag_for_Chikira_Sugiyama_deep_convection - long_name = flag for Chikira-Sugiyama convection - units = flag - dimensions = () - type = logical - intent = in -[satmedmf] - standard_name = flag_for_scale_aware_TKE_moist_EDMF_PBL - long_name = flag for scale-aware TKE moist EDMF PBL scheme - units = flag - dimensions = () - type = logical - intent = in -[trans_trac] - standard_name = flag_for_convective_transport_of_tracers - long_name = flag for convective transport of tracers - units = flag - dimensions = () - type = logical - intent = in -[ras] - standard_name = flag_for_relaxed_arakawa_schubert_deep_convection - long_name = flag for ras convection scheme - units = flag - dimensions = () - type = logical - intent = in -[ntcw] - standard_name = index_of_cloud_liquid_water_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for cloud condensate (or liquid water) - units = index - dimensions = () - type = integer - intent = in -[ntiw] - standard_name = index_of_cloud_ice_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for ice water - units = index - dimensions = () - type = integer - intent = in -[ntclamt] - standard_name = index_of_cloud_area_fraction_in_atmosphere_layer_in_tracer_concentration_array - long_name = tracer index for cloud amount integer - units = index - dimensions = () - type = integer - intent = in -[ntrw] - standard_name = index_of_rain_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for rain water - units = index - dimensions = () - type = integer - intent = in -[ntsw] - standard_name = index_of_snow_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for snow water - units = index - dimensions = () - type = integer - intent = in -[ntrnc] - standard_name = index_of_mass_number_concentration_of_rain_in_tracer_concentration_array - long_name = tracer index for rain number concentration - units = index - dimensions = () - type = integer - intent = in -[ntsnc] - standard_name = index_of_mass_number_concentration_of_snow_in_tracer_concentration_array - long_name = tracer index for snow number concentration - units = index - dimensions = () - type = integer - intent = in -[ntgl] - standard_name = index_of_graupel_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for graupel - units = index - dimensions = () - type = integer - intent = in -[ntgnc] - standard_name = index_of_mass_number_concentration_of_graupel_in_tracer_concentration_array - long_name = tracer index for graupel number concentration - units = index - dimensions = () - type = integer - intent = in -[clw] - standard_name = convective_transportable_tracers - long_name = array to contain cloud water and other convective trans. tracers - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers_for_convective_transport) - type = real - kind = kind_phys - intent = in -[ntrac] - standard_name = number_of_tracers - long_name = number of tracers - units = count - dimensions = () - type = integer - intent = in -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out - ######################################################################## [ccpp-table-properties] name = GFS_SCNV_generic_post diff --git a/physics/GFS_SCNV_generic_pre.F90 b/physics/GFS_SCNV_generic_pre.F90 new file mode 100644 index 000000000..0740127bd --- /dev/null +++ b/physics/GFS_SCNV_generic_pre.F90 @@ -0,0 +1,73 @@ +!> \file GFS_SCNV_generic_pre.F90 +!! Contains code related to shallow convective schemes to be run prior to shallow convection for GFS-based physics suites. + + module GFS_SCNV_generic_pre + + contains + +!> \section arg_table_GFS_SCNV_generic_pre_run Argument Table +!! \htmlinclude GFS_SCNV_generic_pre_run.html +!! + subroutine GFS_SCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, gu0, gv0, gt0, gq0, & + save_u, save_v, save_t, save_q, ntqv, nsamftrac, flag_for_scnv_generic_tend, & + dtidx, index_of_process_scnv, ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntgnc, & + cscnv, satmedmf, trans_trac, ras, ntrac, clw, errmsg, errflg) + + use machine, only: kind_phys + + implicit none + + integer, intent(in) :: im, levs, ntqv, nsamftrac, index_of_process_scnv, dtidx(:,:) + integer, intent(in) :: ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntgnc,ntrac + logical, intent(in) :: ldiag3d, qdiag3d, flag_for_scnv_generic_tend + real(kind=kind_phys), dimension(:,:), intent(in) :: gu0, gv0, gt0 + real(kind=kind_phys), dimension(:,:,:), intent(in) :: gq0 + real(kind=kind_phys), dimension(:,:,:), intent(inout) :: save_q + real(kind=kind_phys), dimension(:,:), intent(inout) :: save_u, save_v, save_t + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + logical, intent(in) :: cscnv, satmedmf, trans_trac, ras + real(kind=kind_phys), dimension(:,:,:), intent(in) :: clw + + integer :: i, k, n, tracers + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (ldiag3d .and. flag_for_scnv_generic_tend) then + do k=1,levs + do i=1,im + save_u(i,k) = gu0(i,k) + save_v(i,k) = gv0(i,k) + save_t(i,k) = gt0(i,k) + enddo + enddo + if (qdiag3d) then + if (cscnv .or. satmedmf .or. trans_trac .or. ras) then + tracers = 2 + do n=2,ntrac + if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt .and. & + n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & + n /= ntsnc .and. n /= ntgl .and. n /= ntgnc) then + tracers = tracers + 1 + if(dtidx(100+n,index_of_process_scnv)>0) then + save_q(:,:,n) = clw(:,:,tracers) + endif + endif + enddo + else + do n=2,ntrac + if(dtidx(100+n,index_of_process_scnv)>0) then + save_q(:,:,n) = gq0(:,:,n) + endif + enddo + endif ! end if_ras or cfscnv or samf + save_q(:,:,ntqv) = gq0(:,:,ntqv) + endif + endif + + end subroutine GFS_SCNV_generic_pre_run + + + end module GFS_SCNV_generic_pre \ No newline at end of file diff --git a/physics/GFS_SCNV_generic_pre.meta b/physics/GFS_SCNV_generic_pre.meta new file mode 100644 index 000000000..07af85a70 --- /dev/null +++ b/physics/GFS_SCNV_generic_pre.meta @@ -0,0 +1,257 @@ +[ccpp-table-properties] + name = GFS_SCNV_generic_pre + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = GFS_SCNV_generic_pre_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[levs] + standard_name = vertical_layer_dimension + long_name = vertical layer dimension + units = count + dimensions = () + type = integer + intent = in +[ldiag3d] + standard_name = flag_for_diagnostics_3D + long_name = flag for 3d diagnostic fields + units = flag + dimensions = () + type = logical + intent = in +[qdiag3d] + standard_name = flag_for_tracer_diagnostics_3D + long_name = flag for 3d tracer diagnostic fields + units = flag + dimensions = () + type = logical + intent = in +[gu0] + standard_name = x_wind_of_new_state + long_name = updated x-direction wind + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[gv0] + standard_name = y_wind_of_new_state + long_name = updated y-direction wind + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[gt0] + standard_name = air_temperature_of_new_state + long_name = temperature updated by physics + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[gq0] + standard_name = tracer_concentration_of_new_state + long_name = tracer concentration updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = in +[save_u] + standard_name = x_wind_save + long_name = x-wind before entering a physics scheme + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[save_v] + standard_name = y_wind_save + long_name = y-wind before entering a physics scheme + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[save_t] + standard_name = air_temperature_save + long_name = air temperature before entering a physics scheme + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[save_q] + standard_name = tracer_concentration_save + long_name = tracer concentration before entering a physics scheme + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = in +[ntqv] + standard_name = index_of_specific_humidity_in_tracer_concentration_array + long_name = tracer index for water vapor (specific humidity) + units = index + dimensions = () + type = integer + intent = in +[nsamftrac] + standard_name = number_of_tracers_for_samf + long_name = number of tracers for scale-aware mass flux schemes + units = count + dimensions = () + type = integer + intent = in +[flag_for_scnv_generic_tend] + standard_name = flag_for_generic_tendency_due_to_shallow_convection + long_name = true if GFS_SCNV_generic should calculate tendencies + units = flag + dimensions = () + type = logical + intent = in +[dtidx] + standard_name = cumulative_change_of_state_variables_outer_index + long_name = index of state-variable and process in last dimension of diagnostic tendencies array AKA cumulative_change_index + units = index + dimensions = (number_of_tracers_plus_one_hundred,number_of_cumulative_change_processes) + type = integer + intent = in +[index_of_process_scnv] + standard_name = index_of_shallow_convection_process_process_in_cumulative_change_index + long_name = index of shallow convection process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[cscnv] + standard_name = flag_for_Chikira_Sugiyama_deep_convection + long_name = flag for Chikira-Sugiyama convection + units = flag + dimensions = () + type = logical + intent = in +[satmedmf] + standard_name = flag_for_scale_aware_TKE_moist_EDMF_PBL + long_name = flag for scale-aware TKE moist EDMF PBL scheme + units = flag + dimensions = () + type = logical + intent = in +[trans_trac] + standard_name = flag_for_convective_transport_of_tracers + long_name = flag for convective transport of tracers + units = flag + dimensions = () + type = logical + intent = in +[ras] + standard_name = flag_for_relaxed_arakawa_schubert_deep_convection + long_name = flag for ras convection scheme + units = flag + dimensions = () + type = logical + intent = in +[ntcw] + standard_name = index_of_cloud_liquid_water_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for cloud condensate (or liquid water) + units = index + dimensions = () + type = integer + intent = in +[ntiw] + standard_name = index_of_cloud_ice_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for ice water + units = index + dimensions = () + type = integer + intent = in +[ntclamt] + standard_name = index_of_cloud_area_fraction_in_atmosphere_layer_in_tracer_concentration_array + long_name = tracer index for cloud amount integer + units = index + dimensions = () + type = integer + intent = in +[ntrw] + standard_name = index_of_rain_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for rain water + units = index + dimensions = () + type = integer + intent = in +[ntsw] + standard_name = index_of_snow_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for snow water + units = index + dimensions = () + type = integer + intent = in +[ntrnc] + standard_name = index_of_mass_number_concentration_of_rain_in_tracer_concentration_array + long_name = tracer index for rain number concentration + units = index + dimensions = () + type = integer + intent = in +[ntsnc] + standard_name = index_of_mass_number_concentration_of_snow_in_tracer_concentration_array + long_name = tracer index for snow number concentration + units = index + dimensions = () + type = integer + intent = in +[ntgl] + standard_name = index_of_graupel_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for graupel + units = index + dimensions = () + type = integer + intent = in +[ntgnc] + standard_name = index_of_mass_number_concentration_of_graupel_in_tracer_concentration_array + long_name = tracer index for graupel number concentration + units = index + dimensions = () + type = integer + intent = in +[clw] + standard_name = convective_transportable_tracers + long_name = array to contain cloud water and other convective trans. tracers + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers_for_convective_transport) + type = real + kind = kind_phys + intent = in +[ntrac] + standard_name = number_of_tracers + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = in +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out \ No newline at end of file diff --git a/physics/GFS_cloud_diagnostics.F90 b/physics/GFS_cloud_diagnostics.F90 index 215143bb2..5dd757a43 100644 --- a/physics/GFS_cloud_diagnostics.F90 +++ b/physics/GFS_cloud_diagnostics.F90 @@ -39,43 +39,51 @@ end subroutine GFS_cloud_diagnostics_init !! \section arg_table_GFS_cloud_diagnostics_run !! \htmlinclude GFS_cloud_diagnostics_run.html !! - subroutine GFS_cloud_diagnostics_run(nCol, nLev, lsswr, lslwr, lat, de_lgth, p_lay, & + subroutine GFS_cloud_diagnostics_run(nCol, nLev, iovr_rand, iovr_maxrand, iovr_max, & + iovr_dcorr, iovr_exp, iovr_exprand, lsswr, lslwr, lat, de_lgth, p_lay, & cld_frac, p_lev, deltaZ, cloud_overlap_param, precip_overlap_param, con_pi, & mtopa, mbota, cldsa, errmsg, errflg) implicit none ! Inputs - integer, intent(in) :: & - nCol, & ! Number of horizontal grid-points - nLev ! Number of vertical-layers + integer, intent(in) :: & + nCol, & ! Number of horizontal grid-points + nLev ! Number of vertical-layers + integer, intent(in) :: & + iovr_rand, & ! Flag for random cloud overlap method + iovr_maxrand, & ! Flag for maximum-random cloud overlap method + iovr_max, & ! Flag for maximum cloud overlap method + iovr_dcorr, & ! Flag for decorrelation-length cloud overlap method + iovr_exp, & ! Flag for exponential cloud overlap method + iovr_exprand ! Flag for exponential-random cloud overlap method logical, intent(in) :: & - lsswr, & ! Call SW radiation? - lslwr ! Call LW radiation - real(kind_phys), intent(in) :: & - con_pi ! Physical constant: pi - real(kind_phys), dimension(:), intent(in) :: & - lat, & ! Latitude - de_lgth ! Decorrelation length + lsswr, & ! Call SW radiation? + lslwr ! Call LW radiation + real(kind_phys), intent(in) :: & + con_pi ! Physical constant: pi + real(kind_phys), dimension(:), intent(in) :: & + lat, & ! Latitude + de_lgth ! Decorrelation length real(kind_phys), dimension(:,:), intent(in) :: & - p_lay, & ! Pressure at model-layer - cld_frac ! Total cloud fraction + p_lay, & ! Pressure at model-layer + cld_frac ! Total cloud fraction real(kind_phys), dimension(:,:), intent(in) :: & - p_lev ! Pressure at model interfaces + p_lev ! Pressure at model interfaces real(kind_phys), dimension(:,:), intent(in) :: & - deltaZ, & ! Layer thickness (km) - cloud_overlap_param, & ! Cloud-overlap parameter - precip_overlap_param ! Precipitation overlap parameter + deltaZ, & ! Layer thickness (m) + cloud_overlap_param, & ! Cloud-overlap parameter + precip_overlap_param ! Precipitation overlap parameter ! Outputs - character(len=*), intent(out) :: & - errmsg ! Error message - integer, intent(out) :: & - errflg ! Error flag - integer,dimension(:,:),intent(out) :: & - mbota, & ! Vertical indices for cloud tops - mtopa ! Vertical indices for cloud bases - real(kind_phys), dimension(:,:), intent(out) :: & - cldsa ! Fraction of clouds for low, middle, high, total and BL + character(len=*), intent(out) :: & + errmsg ! Error message + integer, intent(out) :: & + errflg ! Error flag + integer,dimension(:,:),intent(out) :: & + mbota, & ! Vertical indices for cloud tops + mtopa ! Vertical indices for cloud bases + real(kind_phys),dimension(:,:), intent(out) :: & + cldsa ! Fraction of clouds for low, middle, high, total and BL ! Local variables integer i,id,iCol,iLay,icld @@ -105,8 +113,9 @@ subroutine GFS_cloud_diagnostics_run(nCol, nLev, lsswr, lslwr, lat, de_lgth, p_l ! layer indices for low, mid, and high clouds. The three cloud domain boundaries are ! defined by ptopc. The cloud overlapping method is defined by control flag 'iovr', which may ! be different for lw and sw radiation programs. - call gethml(p_lay/100., ptop1, cld_frac, cldcnv, deltaZ, de_lgth, cloud_overlap_param,& - nCol, nLev, cldsa, mtopa, mbota) + call gethml(p_lay*0.01, ptop1, cld_frac, cldcnv, deltaZ, de_lgth, cloud_overlap_param,& + nCol, nLev, iovr_rand, iovr_maxrand, iovr_max, iovr_dcorr, iovr_exp, & + iovr_exprand, cldsa, mtopa, mbota) end subroutine GFS_cloud_diagnostics_run @@ -116,76 +125,6 @@ subroutine GFS_cloud_diagnostics_finalize() end subroutine GFS_cloud_diagnostics_finalize ! ###################################################################################### - ! Initialization routine for High/Mid/Low cloud diagnostics. + ! Subroutine hml_cloud_diagnostics_initialize is removed (refer to GFS_rrtmgp_setup.F90) ! ###################################################################################### - subroutine hml_cloud_diagnostics_initialize(imp_physics, imp_physics_fer_hires, & - imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, & - imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, imp_physics_mg, nLev, & - mpi_rank, sigmainit, errflg) - implicit none - ! Inputs - integer, intent(in) :: & - imp_physics, & ! Flag for MP scheme - imp_physics_fer_hires, & ! Flag for fer-hires scheme - imp_physics_gfdl, & ! Flag for gfdl scheme - imp_physics_thompson, & ! Flag for thompsonscheme - imp_physics_wsm6, & ! Flag for wsm6 scheme - imp_physics_zhao_carr, & ! Flag for zhao-carr scheme - imp_physics_zhao_carr_pdf, & ! Flag for zhao-carr+PDF scheme - imp_physics_mg ! Flag for MG scheme - integer, intent(in) :: & - nLev, & ! Number of vertical-layers - mpi_rank - real(kind_phys), dimension(:), intent(in) :: & - sigmainit - ! Outputs - integer, intent(out) :: & - errflg - - ! Local variables - integer :: iLay, kl - - ! Initialize error flag - errflg = 0 - - if (mpi_rank == 0) print *, VTAGCLD !print out version tag - - if ( icldflg == 0 ) then - print *,' - Diagnostic Cloud Method has been discontinued' - errflg = 1 - else - if (mpi_rank == 0) then - print *,' - Using Prognostic Cloud Method' - if (imp_physics == imp_physics_zhao_carr) then - print *,' --- Zhao/Carr/Sundqvist microphysics' - elseif (imp_physics == imp_physics_zhao_carr_pdf) then - print *,' --- zhao/carr/sundqvist + pdf cloud' - elseif (imp_physics == imp_physics_gfdl) then - print *,' --- GFDL Lin cloud microphysics' - elseif (imp_physics == imp_physics_thompson) then - print *,' --- Thompson cloud microphysics' - elseif (imp_physics == imp_physics_wsm6) then - print *,' --- WSM6 cloud microphysics' - elseif (imp_physics == imp_physics_mg) then - print *,' --- MG cloud microphysics' - elseif (imp_physics == imp_physics_fer_hires) then - print *,' --- Ferrier-Aligo cloud microphysics' - else - print *,' !!! ERROR in cloud microphysc specification!!!', & - ' imp_physics (NP3D) =',imp_physics - errflg = 1 - endif - endif - endif - - ! Compute the top of BL cld (llyr), which is the topmost non cld(low) layer for - ! stratiform (at or above lowest 0.1 of the atmosphere). - lab_do_k0 : do iLay = nLev, 2, -1 - kl = iLay - if (sigmainit(iLay) < 0.9e0) exit lab_do_k0 - enddo lab_do_k0 - llyr = kl - - return - end subroutine hml_cloud_diagnostics_initialize end module GFS_cloud_diagnostics diff --git a/physics/GFS_cloud_diagnostics.meta b/physics/GFS_cloud_diagnostics.meta index aab5387d0..dd88bbc46 100644 --- a/physics/GFS_cloud_diagnostics.meta +++ b/physics/GFS_cloud_diagnostics.meta @@ -20,6 +20,48 @@ dimensions = () type = integer intent = in +[iovr_rand] + standard_name = flag_for_random_cloud_overlap_method + long_name = choice of random cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_maxrand] + standard_name = flag_for_maximum_random_cloud_overlap_method + long_name = choice of maximum-random cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_max] + standard_name = flag_for_maximum_cloud_overlap_method + long_name = choice of maximum cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_dcorr] + standard_name = flag_for_decorrelation_length_cloud_overlap_method + long_name = choice of decorrelation-length cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_exp] + standard_name = flag_for_exponential_cloud_overlap_method + long_name = choice of exponential cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_exprand] + standard_name = flag_for_exponential_random_cloud_overlap_method + long_name = choice of exponential-random cloud overlap method + units = flag + dimensions = () + type = integer + intent = in [lsswr] standard_name = flag_for_calling_shortwave_radiation long_name = logical flags for sw radiation calls diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index 183a9aff5..57495c945 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -316,8 +316,8 @@ module GFS_diagtoscreen !! subroutine GFS_diagtoscreen_init (Model, Data, Interstitial, errmsg, errflg) - use GFS_typedefs, only: GFS_control_type, GFS_data_type, & - GFS_interstitial_type + use GFS_typedefs, only: GFS_control_type, GFS_data_type + use CCPP_typedefs, only: GFS_interstitial_type implicit none @@ -349,8 +349,8 @@ end subroutine GFS_diagtoscreen_init !! subroutine GFS_diagtoscreen_timestep_init (Model, Data, Interstitial, errmsg, errflg) - use GFS_typedefs, only: GFS_control_type, GFS_data_type, & - GFS_interstitial_type + use GFS_typedefs, only: GFS_control_type, GFS_data_type + use CCPP_typedefs, only: GFS_interstitial_type implicit none @@ -397,8 +397,8 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, GFS_stateout_type, GFS_sfcprop_type, & GFS_coupling_type, GFS_grid_type, & GFS_tbd_type, GFS_cldprop_type, & - GFS_radtend_type, GFS_diag_type, & - GFS_interstitial_type + GFS_radtend_type, GFS_diag_type + use CCPP_typedefs, only: GFS_interstitial_type implicit none @@ -593,9 +593,9 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%acvb' , Tbd%acvb) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%acvt' , Tbd%acvt) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%hpbl' , Tbd%hpbl) - if (Model%imfdeepcnv .ge. 0 .or. Model%imfshalcnv .ge. 0) then + if(Model%imfdeepcnv>0 .or. Model%imfshalcnv>0) then call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%ud_mf' , Tbd%ud_mf) - end if + endif if (Model%do_sppt) then call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%dtdtnp' , Tbd%dtdtnp) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%dtotprcp' , Tbd%dtotprcp) @@ -729,7 +729,7 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, end if call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dkt ', Diag%dkt) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dku ', Diag%dku) - ! CCPP/MYNNPBL only + ! CCPP/MYNNEDMF only if (Model%do_mynnedmf) then if (Model%bl_mynn_output .ne. 0) then call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%edmf_a ', Diag%edmf_a) @@ -973,8 +973,8 @@ module GFS_interstitialtoscreen !! subroutine GFS_interstitialtoscreen_init (Model, Data, Interstitial, errmsg, errflg) - use GFS_typedefs, only: GFS_control_type, GFS_data_type, & - GFS_interstitial_type + use GFS_typedefs, only: GFS_control_type, GFS_data_type + use CCPP_typedefs, only: GFS_interstitial_type implicit none @@ -1007,8 +1007,8 @@ end subroutine GFS_interstitialtoscreen_init !! subroutine GFS_interstitialtoscreen_timestep_init (Model, Data, Interstitial, errmsg, errflg) - use GFS_typedefs, only: GFS_control_type, GFS_data_type, & - GFS_interstitial_type + use GFS_typedefs, only: GFS_control_type, GFS_data_type + use CCPP_typedefs, only: GFS_interstitial_type implicit none @@ -1057,8 +1057,8 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup GFS_stateout_type, GFS_sfcprop_type, & GFS_coupling_type, GFS_grid_type, & GFS_tbd_type, GFS_cldprop_type, & - GFS_radtend_type, GFS_diag_type, & - GFS_interstitial_type + GFS_radtend_type, GFS_diag_type + use CCPP_typedefs, only: GFS_interstitial_type implicit none @@ -1386,7 +1386,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 db818c3b8..106007cdc 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -18,11 +18,15 @@ 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, & + imp_physics_fer_hires, iovr_rand, iovr_maxrand, iovr_max, iovr_dcorr, & + iovr_exp, iovr_exprand, idcor_con, idcor_hogan, idcor_oreopoulos, & + julian, yearlen, lndp_var_list, lsswr, lslwr, & ltaerosol, lgfdlmprad, uni_cld, effr_in, do_mynnedmf, lmfshal, & lmfdeep2, fhswr, fhlwr, solhr, sup, con_eps, epsm1, fvirt, & rog, rocp, con_rd, xlat_d, xlat, xlon, coslat, sinlat, tsfc, slmsk, & @@ -36,7 +40,8 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & gasvmr_ccl4, gasvmr_cfc113, aerodp, clouds6, clouds7, clouds8, & clouds9, cldsa, cldfra, cldfra2d, lwp_ex,iwp_ex, lwp_fc,iwp_fc, & faersw1, faersw2, faersw3, faerlw1, faerlw2, faerlw3, alpha, & - spp_wts_rad, spp_rad, errmsg, errflg) + aero_dir_fdb, smoke_ext, dust_ext, & + spp_wts_rad, spp_rad, rrfs_smoke_band, errmsg, errflg) use machine, only: kind_phys @@ -51,12 +56,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & use module_radiation_aerosols, only: NF_AESW, NF_AELW, setaer, & ! aer_init, aer_update, & NSPC1 use module_radiation_clouds, only: NF_CLDS, & ! cld_init - & progcld1, progcld3, & - & progcld2, & - & progcld4, progcld5, & - & progcld6, & - & progcld_thompson, & - & progclduni, & + & radiation_clouds_prop, & & cal_cldfra3, & & find_cloudLayers, & & adjust_cloudIce, & @@ -86,7 +86,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,17 +96,33 @@ 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 + integer, intent(in) :: & + iovr_rand, & ! Flag for random cloud overlap method + iovr_maxrand, & ! Flag for maximum-random cloud overlap method + iovr_max, & ! Flag for maximum cloud overlap method + iovr_dcorr, & ! Flag for decorrelation-length cloud overlap method + iovr_exp, & ! Flag for exponential cloud overlap method + iovr_exprand, & ! Flag for exponential-random cloud overlap method + idcor_con, & + idcor_hogan, & + idcor_oreopoulos, & + rrfs_smoke_band ! Band number for rrfs-smoke dust and smoke + character(len=3), dimension(:), intent(in) :: lndp_var_list logical, intent(in) :: lsswr, lslwr, ltaerosol, lgfdlmprad, & uni_cld, effr_in, do_mynnedmf, & lmfshal, lmfdeep2, pert_clds + logical, intent(in) :: aero_dir_fdb + real(kind=kind_phys), dimension(:,:), intent(in) :: smoke_ext, dust_ext - integer, intent(in) :: spp_rad - real(kind_phys), intent(in) :: spp_wts_rad(:,:) + logical, intent(in) :: nssl_ccn_on, nssl_invertccn + integer, intent(in) :: spp_rad + real(kind_phys), intent(in) :: spp_wts_rad(:,:) real(kind=kind_phys), intent(in) :: fhswr, fhlwr, solhr, sup, julian, sppt_amp real(kind=kind_phys), intent(in) :: con_eps, epsm1, fvirt, rog, rocp, con_rd @@ -209,7 +226,9 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & real(kind=kind_phys), dimension(im,lm+LTP,min(4,ncnd)) :: ccnd real(kind=kind_phys), dimension(im,lm+LTP,2:ntrac) :: tracer1 - real(kind=kind_phys), dimension(im,lm+LTP,NF_CLDS) :: clouds + real(kind=kind_phys), dimension(im,lm+LTP) :: & + & cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, & + & cld_rwp, cld_rerain, cld_swp, cld_resnow real(kind=kind_phys), dimension(im,lm+LTP,NF_VGAS) :: gasvmr real(kind=kind_phys), dimension(im,lm+LTP,NBDSW,NF_AESW) :: faersw real(kind=kind_phys), dimension(im,lm+LTP,NBDLW,NF_AELW) :: faerlw @@ -601,6 +620,16 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & enddo enddo + !> Aerosol direct feedback effect by smoke and dust + if(aero_dir_fdb) then ! add smoke/dust extinctions + do k = 1, LMK + do i = 1, IM + ! 550nm (~18000/cm) + faersw1(i,k,rrfs_smoke_band) = faersw1(i,k,rrfs_smoke_band) + MIN(4.,smoke_ext(i,k) + dust_ext(i,k)) + enddo + enddo + endif + do j = 1,NBDLW do k = 1, LMK do i = 1, IM @@ -616,9 +645,9 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & !! (clouds,cldsa,mtopa,mbota) !!\n for prognostic cloud: !! - For Zhao/Moorthi's prognostic cloud scheme, -!! call module_radiation_clouds::progcld1() +!! call module_radiation_clouds::progcld_zhao_carr() !! - For Zhao/Moorthi's prognostic cloud+pdfcld, -!! call module_radiation_clouds::progcld3() +!! call module_radiation_clouds::progcld_zhao_carr_pdf() !! call module_radiation_clouds::progclduni() for unified cloud and ncnd>=2 ! --- ... obtain cloud information for radiation calculations @@ -647,7 +676,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 +685,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 @@ -781,6 +814,23 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & enddo enddo endif + + elseif (imp_physics == imp_physics_nssl ) then ! NSSL MP + cldcov = 0.0 + if(effr_in) then + do k=1,lm + k1 = k + kd + do i=1,im + effrl(i,k1) = effrl_inout(i,k)! re_cloud (i,k) + effri(i,k1) = effri_inout(i,k)! re_ice (i,k) + effrr(i,k1) = effrr_in(i,k) + effrs(i,k1) = effrs_inout(i,k) ! re_snow(i,k) + enddo + enddo + else + ! not used yet -- effr_in should always be true for now + endif + elseif (imp_physics == imp_physics_thompson) then ! Thompson MP ! ! Compute effective radii for QC, QI, QS with (GF, MYNN) or without (all others) sub-grid clouds @@ -870,135 +920,28 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & ccnd(1:IM,1:LMK,1) = ccnd(1:IM,1:LMK,1) + cnvw(1:IM,1:LMK) endif - if (imp_physics == imp_physics_zhao_carr .or. imp_physics == imp_physics_mg) then ! zhao/moorthi's prognostic cloud scheme - ! or unified cloud and/or with MG microphysics - - if (uni_cld .and. ncndl >= 2) then - call progclduni (plyr, plvl, tlyr, tvly, ccnd, ncndl, & ! --- inputs - xlat, xlon, slmsk, dz, delp, & - IM, LMK, LMP, cldcov, & - effrl, effri, effrr, effrs, effr_in, & - dzb, xlat_d, julian, yearlen, & - clouds, cldsa, mtopa, mbota, de_lgth, alpha) ! --- outputs - else - call progcld1 (plyr ,plvl, tlyr, tvly, qlyr, qstl, rhly, & ! --- inputs - ccnd(1:IM,1:LMK,1), xlat, xlon, slmsk, dz, & - delp, IM, LMK, LMP, uni_cld, lmfshal, lmfdeep2,& - cldcov, effrl, effri, effrr, effrs, effr_in, & - dzb, xlat_d, julian, yearlen, & - clouds, cldsa, mtopa, mbota, de_lgth, alpha) ! --- outputs - endif - - elseif(imp_physics == imp_physics_zhao_carr_pdf) then ! zhao/moorthi's prognostic cloud+pdfcld - - call progcld3 (plyr, plvl, tlyr, tvly, qlyr, qstl, rhly, & ! --- inputs - ccnd(1:IM,1:LMK,1), cnvw, cnvc, xlat, xlon, & - slmsk, dz, delp, im, lmk, lmp, deltaq, sup, kdt, & - me, dzb, xlat_d, julian, yearlen, & - clouds, cldsa, mtopa, mbota, de_lgth, alpha) ! --- outputs - - elseif (imp_physics == imp_physics_gfdl) then ! GFDL cloud scheme - - if (.not. lgfdlmprad) then - call progcld4 (plyr, plvl, tlyr, tvly, qlyr, qstl, rhly, & ! --- inputs - ccnd(1:IM,1:LMK,1), cnvw, cnvc, xlat, xlon, & - slmsk, cldcov, dz, delp, im, lmk, lmp, & - dzb, xlat_d, julian, yearlen, & - clouds, cldsa, mtopa, mbota, de_lgth, alpha) ! --- outputs - else - - call progclduni (plyr, plvl, tlyr, tvly, ccnd, ncndl, xlat, & ! --- inputs - xlon, slmsk, dz,delp, IM, LMK, LMP, cldcov, & - effrl, effri, effrr, effrs, effr_in, & - dzb, xlat_d, julian, yearlen, & - clouds, cldsa, mtopa, mbota, de_lgth, alpha) ! --- outputs -! call progcld4o (plyr, plvl, tlyr, tvly, qlyr, qstl, rhly, & ! --- inputs -! tracer1, xlat, xlon, slmsk, dz, delp, & -! ntrac-1, ntcw-1,ntiw-1,ntrw-1, & -! ntsw-1,ntgl-1,ntclamt-1, & -! im, lmk, lmp, & -! dzb, xlat_d, julian, yearlen, & -! clouds, cldsa, mtopa, mbota, de_lgth, alpha) ! --- outputs - endif - - elseif(imp_physics == imp_physics_fer_hires) then - if (kdt == 1) then - effrl_inout(:,:) = 10. - effri_inout(:,:) = 50. - effrs_inout(:,:) = 250. - endif - - call progcld5 (plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,tracer1, & ! --- inputs - xlat,xlon,slmsk,dz,delp, & - ntrac-1, ntcw-1,ntiw-1,ntrw-1, & - im, lmk, lmp, icloud, uni_cld, lmfshal, lmfdeep2, & - cldcov(:,1:LMK),effrl_inout(:,:), & - effri_inout(:,:), effrs_inout(:,:), & - dzb, xlat_d, julian, yearlen, & - clouds,cldsa,mtopa,mbota, de_lgth, alpha) ! --- outputs - - elseif(imp_physics == imp_physics_thompson) then ! Thompson MP - - if(do_mynnedmf .or. imfdeepcnv == imfdeepcnv_gf ) then ! MYNN PBL or GF conv - - if (icloud == 3) then - call progcld_thompson (plyr,plvl,tlyr,qlyr,qstl,rhly, & ! --- inputs - tracer1,xlat,xlon,slmsk,dz,delp, & - ntrac-1, ntcw-1,ntiw-1,ntrw-1, & - ntsw-1,ntgl-1, & - im, lm, lmp, uni_cld, lmfshal, lmfdeep2, & - cldcov(:,1:LM), effrl, effri, effrs, & - lwp_ex, iwp_ex, lwp_fc, iwp_fc, & - dzb, xlat_d, julian, yearlen, gridkm, & - clouds, cldsa, mtopa ,mbota, de_lgth, alpha) ! --- outputs - else - - !-- MYNN PBL or convective GF - !-- use cloud fractions with SGS clouds - do k=1,lmk - do i=1,im - clouds(i,k,1) = clouds1(i,k) - enddo - enddo - - ! --- use clduni as with the GFDL microphysics. - ! --- make sure that effr_in=.true. in the input.nml! - call progclduni (plyr, plvl, tlyr, tvly, ccnd, ncndl, & ! --- inputs - xlat, xlon, slmsk, dz, delp, IM, LMK, LMP, & - clouds(:,1:LMK,1), & - effrl, effri, effrr, effrs, effr_in , & - dzb, xlat_d, julian, yearlen, & - clouds, cldsa, mtopa, mbota, de_lgth, alpha) ! --- outputs - endif - - else - ! MYNN PBL or GF convective are not used - - if (icloud == 3) then - call progcld_thompson (plyr,plvl,tlyr,qlyr,qstl,rhly, & ! --- inputs - tracer1,xlat,xlon,slmsk,dz,delp, & - ntrac-1, ntcw-1,ntiw-1,ntrw-1, & - ntsw-1,ntgl-1, & - im, lm, lmp, uni_cld, lmfshal, lmfdeep2, & - cldcov(:,1:LM), effrl, effri, effrs, & - lwp_ex, iwp_ex, lwp_fc, iwp_fc, & - dzb, xlat_d, julian, yearlen, gridkm, & - clouds, cldsa, mtopa ,mbota, de_lgth, alpha) ! --- outputs - - else - call progcld6 (plyr,plvl,tlyr,qlyr,qstl,rhly, & ! --- inputs - tracer1,xlat,xlon,slmsk,dz,delp, & - ntrac-1, ntcw-1,ntiw-1,ntrw-1, & - ntsw-1,ntgl-1, & - im, lmk, lmp, uni_cld, lmfshal, lmfdeep2, & - cldcov(:,1:LMK), cnvw, effrl, effri, effrs,& - lwp_ex, iwp_ex, lwp_fc, iwp_fc, & - dzb, xlat_d, julian, yearlen, & - clouds, cldsa, mtopa ,mbota, de_lgth, alpha) ! --- outputs - endif - endif ! MYNN PBL or GF - - endif ! end if_imp_physics + call radiation_clouds_prop & + & ( plyr, plvl, tlyr, tvly, qlyr, qstl, rhly, & ! --- inputs: + & ccnd, ncndl, cnvw, cnvc, tracer1, & + & xlat, xlon, slmsk, dz, delp, IM, LM, LMK, LMP, & + & deltaq, sup, me, icloud, kdt, & + & ntrac, ntcw, ntiw, ntrw, ntsw, ntgl, ntclamt, & + & imp_physics, imp_physics_nssl, imp_physics_fer_hires, & + & imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, & + & imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, & + & imp_physics_mg, iovr_rand, iovr_maxrand, iovr_max, & + & iovr_dcorr, iovr_exp, iovr_exprand, idcor_con, & + & idcor_hogan, idcor_oreopoulos, & + & imfdeepcnv, imfdeepcnv_gf, do_mynnedmf, lgfdlmprad, & + & uni_cld, lmfshal, lmfdeep2, cldcov, clouds1, & + & effrl, effri, effrr, effrs, effr_in, & + & effrl_inout, effri_inout, effrs_inout, & + & lwp_ex, iwp_ex, lwp_fc, iwp_fc, & + & dzb, xlat_d, julian, yearlen, gridkm, & + & cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, & ! --- outputs: + & cld_rwp, cld_rerain, cld_swp, cld_resnow, & ! --- outputs: + & cldsa, mtopa, mbota, de_lgth, alpha & ! --- outputs: + & ) ! endif ! end_if_ntcw @@ -1012,7 +955,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & do k = 1, LMK do i = 1, IM ! compute beta distribution parameters - m = clouds(i,k,1) + m = cld_frac(i,k) if (m<0.99 .AND. m > 0.01) then s = sppt_amp*m*(1.-m) alpha0 = m*m*(1.-m)/(s*s)-m @@ -1020,25 +963,25 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & ! compute beta distribution value corresponding ! to the given percentile albPpert to use as new albedo call ppfbet(cldp1d(i),alpha0,beta0,iflag,cldtmp) - clouds(i,k,1) = cldtmp + cld_frac(i,k) = cldtmp else - clouds(i,k,1) = m + cld_frac(i,k) = m endif enddo ! end_do_i_loop enddo ! end_do_k_loop endif do k = 1, LM do i = 1, IM - clouds1(i,k) = clouds(i,k,1) - clouds2(i,k) = clouds(i,k,2) - clouds3(i,k) = clouds(i,k,3) - clouds4(i,k) = clouds(i,k,4) - clouds5(i,k) = clouds(i,k,5) - clouds6(i,k) = clouds(i,k,6) - clouds7(i,k) = clouds(i,k,7) - clouds8(i,k) = clouds(i,k,8) - clouds9(i,k) = clouds(i,k,9) - cldfra(i,k) = clouds(i,k,1) + clouds1(i,k) = cld_frac(i,k) + clouds2(i,k) = cld_lwp(i,k) + clouds3(i,k) = cld_reliq(i,k) + clouds4(i,k) = cld_iwp(i,k) + clouds5(i,k) = cld_reice(i,k) + clouds6(i,k) = cld_rwp(i,k) + clouds7(i,k) = cld_rerain(i,k) + clouds8(i,k) = cld_swp(i,k) + clouds9(i,k) = cld_resnow(i,k) + cldfra(i,k) = cld_frac(i,k) enddo enddo do i = 1, IM @@ -1058,9 +1001,9 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & enddo else do i=1,im - clouds3(i,k) = clouds3(i,k) - spp_wts_rad(i,k) * clouds3(i,k) - clouds5(i,k) = clouds5(i,k) - spp_wts_rad(i,k) * clouds5(i,k) - clouds9(i,k) = clouds9(i,k) - spp_wts_rad(i,k) * clouds9(i,k) + clouds3(i,k) = clouds3(i,k) - spp_wts_rad(i,levs) * clouds3(i,k) + clouds5(i,k) = clouds5(i,k) - spp_wts_rad(i,levs) * clouds5(i,k) + clouds9(i,k) = clouds9(i,k) - spp_wts_rad(i,levs) * clouds9(i,k) enddo endif enddo diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index 1eac8a571..2543cf58e 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 @@ -275,6 +324,69 @@ dimensions = () type = integer intent = in +[iovr_rand] + standard_name = flag_for_random_cloud_overlap_method + long_name = choice of random cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_maxrand] + standard_name = flag_for_maximum_random_cloud_overlap_method + long_name = choice of maximum-random cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_max] + standard_name = flag_for_maximum_cloud_overlap_method + long_name = choice of maximum cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_dcorr] + standard_name = flag_for_decorrelation_length_cloud_overlap_method + long_name = choice of decorrelation-length cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_exp] + standard_name = flag_for_exponential_cloud_overlap_method + long_name = choice of exponential cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_exprand] + standard_name = flag_for_exponential_random_cloud_overlap_method + long_name = choice of exponential-random cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[idcor_con] + standard_name = flag_for_constant_decorrelation_length_method + long_name = choice of decorrelation length computation (costant) + units = flag + dimensions = () + type = integer + intent = in +[idcor_hogan] + standard_name = flag_for_hogan_decorrelation_length_method + long_name = choice of decorrelation length computation (hogan) + units = flag + dimensions = () + type = integer + intent = in +[idcor_oreopoulos] + standard_name = flag_for_oreopoulos_decorrelation_length_method + long_name = choice of decorrelation length computation (oreopoulos) + units = flag + dimensions = () + type = integer + intent = in [julian] standard_name = forecast_julian_day long_name = julian day @@ -1082,6 +1194,29 @@ type = real kind = kind_phys intent = out +[aero_dir_fdb] + standard_name = do_smoke_aerosol_direct_feedback + long_name = flag for smoke and dust radiation feedback + units = flag + dimensions = () + type = logical + intent = in +[smoke_ext] + standard_name = extinction_coefficient_in_air_due_to_smoke + long_name = extinction coefficient in air due to smoke + units = various + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[dust_ext] + standard_name = extinction_coefficient_in_air_due_to_dust + long_name = extinction coefficient in air due to dust + units = various + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in [spp_wts_rad] standard_name = spp_weights_for_radiation_scheme long_name = spp weights for radiation scheme @@ -1097,6 +1232,13 @@ dimensions = () type = integer intent = in +[rrfs_smoke_band] + standard_name = index_of_shortwave_band_affected_by_smoke + long_name = rrtmg band number that smoke and dust should affect + units = count + dimensions = () + type = integer + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/GFS_rrtmgp_cloud_mp.F90 b/physics/GFS_rrtmgp_cloud_mp.F90 new file mode 100644 index 000000000..60d5a0a85 --- /dev/null +++ b/physics/GFS_rrtmgp_cloud_mp.F90 @@ -0,0 +1,874 @@ +! ######################################################################################## +! ######################################################################################## +module GFS_rrtmgp_cloud_mp + use machine, only: kind_phys + use radiation_tools, only: check_error_msg + use module_radiation_clouds, only: progcld_thompson + use rrtmgp_lw_cloud_optics, only: & + radliq_lwr => radliq_lwrLW, radliq_upr => radliq_uprLW,& + radice_lwr => radice_lwrLW, radice_upr => radice_uprLW + use module_mp_thompson, only: calc_effectRad, Nt_c, re_qc_min, re_qc_max, re_qi_min, & + re_qi_max, re_qs_min, re_qs_max + use module_mp_thompson_make_number_concentrations, only: make_IceNumber, & + make_DropletNumber, make_RainNumber + + real (kind_phys), parameter :: & + cld_limit_lower = 0.001, & + cld_limit_ovcst = 1.0 - 1.0e-8, & + reliq_def = 10.0 , & ! Default liq radius to 10 micron (used when effr_in=F) + reice_def = 50.0, & ! Default ice radius to 50 micron (used when effr_in=F) + rerain_def = 1000.0, & ! Default rain radius to 1000 micron (used when effr_in=F) + resnow_def = 250.0, & ! Default snow radius to 250 micron (used when effr_in=F) + reice_min = 10.0, & ! Minimum ice size allowed by GFDL MP scheme + reice_max = 150.0 ! Maximum ice size allowed by GFDL MP scheme + + public GFS_rrtmgp_cloud_mp_init, GFS_rrtmgp_cloud_mp_run, GFS_rrtmgp_cloud_mp_finalize + +contains + +!! \section arg_table_GFS_rrtmgp_cloud_mp_run +!! \htmlinclude GFS_rrtmgp_cloud_mp_run_html +!! + ! ###################################################################################### + ! ###################################################################################### + subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, & + i_cldrain, i_cldsnow, i_cldgrpl, i_cldtot, i_cldliq_nc, i_cldice_nc, i_twa, kdt, & + imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_samf, doSWrad, doLWrad, effr_in, lmfshal, & + ltaerosol, icloud, imp_physics, imp_physics_thompson, imp_physics_gfdl, & + lgfdlmprad, do_mynnedmf, uni_cld, lmfdeep2, p_lev, p_lay, t_lay, qs_lay, q_lay, & + relhum, lsmask, xlon, xlat, dx, tv_lay, effrin_cldliq, effrin_cldice, & + effrin_cldrain, effrin_cldsnow, tracer, cnv_mixratio, cld_cnv_frac, qci_conv, & + deltaZ, deltaZc, deltaP, qc_mynn, qi_mynn, cld_pbl_frac, con_g, con_rd, con_eps, & + con_ttp, doGP_cldoptics_PADE, doGP_cldoptics_LUT, cld_frac, cld_lwp, cld_reliq, & + cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, cld_rerain, precip_frac, & + cld_cnv_lwp, cld_cnv_reliq, cld_cnv_iwp, cld_cnv_reice, cld_pbl_lwp, & + cld_pbl_reliq, cld_pbl_iwp, cld_pbl_reice, lwp_ex, iwp_ex, lwp_fc, iwp_fc, & + errmsg, errflg) + implicit none + + ! Inputs + integer, intent(in) :: & + nCol, & ! Number of horizontal grid points + nLev, & ! Number of vertical layers + ncnd, & ! Number of cloud condensation types. + nTracers, & ! Number of tracers from model. + i_cldliq, & ! Index into tracer array for cloud liquid. + i_cldice, & ! Index into tracer array for cloud ice. + i_cldrain, & ! Index into tracer array for cloud rain. + i_cldsnow, & ! Index into tracer array for cloud snow. + i_cldgrpl, & ! Index into tracer array for cloud groupel. + i_cldtot, & ! Index into tracer array for cloud total amount. + i_cldliq_nc, & ! cloud liquid number concentration. + i_cldice_nc, & ! cloud ice number concentration. + i_twa, & ! water friendly aerosol. + imfdeepcnv, & ! Choice of mass-flux deep convection scheme + imfdeepcnv_gf, & ! Flag for Grell-Freitas deep convection scheme + imfdeepcnv_samf, & ! Flag for scale awware mass flux convection scheme + kdt, & ! Current forecast iteration + imp_physics, & ! Choice of microphysics scheme + imp_physics_thompson, & ! Choice of Thompson + imp_physics_gfdl, & ! Choice of GFDL + icloud ! Control for cloud are fraction option + logical, intent(in) :: & + doSWrad, & ! Call SW radiation? + doLWrad, & ! Call LW radiation? + effr_in, & ! Provide hydrometeor radii from macrophysics? + lmfshal, & ! Flag for mass-flux shallow convection scheme used by Xu-Randall + ltaerosol, & ! Flag for aerosol option + lgfdlmprad, & ! Flag for GFDLMP radiation interaction + do_mynnedmf, & ! Flag to activate MYNN-EDMF + uni_cld, & ! Flag for unified cloud scheme + lmfdeep2, & ! Flag for mass flux deep convection + doGP_cldoptics_LUT, & ! Flag to do GP cloud-optics (LUTs) + doGP_cldoptics_PADE ! (PADE approximation) + real(kind_phys), intent(in) :: & + con_g, & ! Physical constant: gravitational constant + con_rd, & ! Physical constant: gas-constant for dry air + con_ttp, & ! Triple point temperature of water (K) + con_eps ! Physical constant: gas constant air / gas constant H2O + real(kind_phys), dimension(:), intent(in) :: & + lsmask, & ! Land/Sea mask + xlon, & ! Longitude + xlat, & ! Latitude + dx ! Characteristic grid lengthscale (m) + real(kind_phys), dimension(:,:), intent(in) :: & + tv_lay, & ! Virtual temperature (K) + t_lay, & ! Temperature (K) + qs_lay, & ! Saturation vapor pressure (Pa) + q_lay, & ! water-vapor mixing ratio (kg/kg) + relhum, & ! Relative humidity + p_lay, & ! Pressure at model-layers (Pa) + cnv_mixratio, & ! Convective cloud mixing-ratio (kg/kg) + qci_conv, & ! Convective cloud condesate after rainout (kg/kg) + deltaZ, & ! Layer-thickness (m) + deltaZc, & ! Layer-thickness, from layer centers (m) + deltaP, & ! Layer-thickness (Pa) + qc_mynn, & ! + qi_mynn, & ! + cld_pbl_frac ! + real(kind_phys), dimension(:,:), intent(inout) :: & + effrin_cldliq, & ! Effective radius for stratiform liquid cloud-particles (microns) + effrin_cldice, & ! Effective radius for stratiform ice cloud-particles (microns) + effrin_cldsnow ! Effective radius for stratiform snow cloud-particles (microns) + real(kind_phys), dimension(:,:), intent(in) :: & + effrin_cldrain ! Effective radius for stratiform rain cloud-particles (microns) + real(kind_phys), dimension(:,:), intent(in) :: & + p_lev ! Pressure at model-level interfaces (Pa) + real(kind_phys), dimension(:,:,:),intent(in) :: & + tracer ! Cloud condensate amount in layer by type () + + ! Outputs + real(kind_phys), dimension(:), intent(inout) :: & + lwp_ex, & ! Total liquid water path from explicit microphysics + iwp_ex, & ! Total ice water path from explicit microphysics + lwp_fc, & ! Total liquid water path from cloud fraction scheme + iwp_fc ! Total ice water path from cloud fraction scheme + real(kind_phys), dimension(:,:),intent(inout) :: & + cld_frac, & ! Cloud-fraction for stratiform clouds + cld_lwp, & ! Water path for stratiform liquid cloud-particles + cld_reliq, & ! Effective radius for stratiform liquid cloud-particles + cld_iwp, & ! Water path for stratiform ice cloud-particles + cld_reice, & ! Effective radius for stratiform ice cloud-particles + cld_swp, & ! Water path for snow hydrometeors + cld_resnow, & ! Effective radius for snow hydrometeors + cld_rwp, & ! Water path for rain hydrometeors + cld_rerain, & ! Effective radius for rain hydrometeors + precip_frac, & ! Precipitation fraction + cld_cnv_frac, & ! Cloud-fraction for convective clouds + cld_cnv_lwp, & ! Water path for convective liquid cloud-particles + cld_cnv_reliq, & ! Effective radius for convective liquid cloud-particles + cld_cnv_iwp, & ! Water path for convective ice cloud-particles + cld_cnv_reice, & ! Effective radius for convective ice cloud-particles + cld_pbl_lwp, & ! Water path for SGS PBL liquid cloud-particles + cld_pbl_reliq, & ! Effective radius for SGS PBL liquid cloud-particles + cld_pbl_iwp, & ! Water path for SGS PBL ice cloud-particles + cld_pbl_reice ! Effective radius for SGS PBL ice cloud-particles + character(len=*), intent(out) :: & + errmsg ! Error message + integer, intent(out) :: & + errflg ! Error flag + + ! Local + integer :: iCol, iLay + real(kind_phys) :: alpha0 + real(kind_phys), dimension(nCol,nLev) :: cldcov, cldtot, cldcnv + + if (.not. (doSWrad .or. doLWrad)) return + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! ################################################################################### + ! GFDL Microphysics + ! ("Implicit" SGS cloud-coupling to the radiation) + ! ################################################################################### + if (imp_physics == imp_physics_gfdl) then + ! GFDL-Lin + if (.not. lgfdlmprad) then + errflg = 1 + errmsg = "ERROR: MP choice not available with RRTMGP" + return + ! GFDL-EMC + else + + ! "cld_frac" is modified prior to include subgrid scale cloudiness, see + ! module_SGSCloud_RadPre.F90. + do iLay = 1, nLev + do iCol = 1, nCol + ! + ! SGS clouds present, use cloud-fraction modified to include sgs clouds. + ! + if (imfdeepcnv==imfdeepcnv_gf .and. kdt>1) then + ! If no convective cloud condensate present, use GFDL MP cloud-fraction.... + if (qci_conv(iCol,iLay) <= 0.) then + cld_frac(iCol,iLay) = tracer(iCol,iLay,i_cldtot) + endif + ! + ! No SGS clouds, use GFDL MP cloud-fraction... + ! + else + cld_frac(iCol,iLay) = tracer(iCol,iLay,i_cldtot) + endif + enddo + enddo + + call cloud_mp_uni(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_cldrain, & + i_cldsnow, i_cldgrpl, i_cldtot, effr_in, kdt, lsmask, p_lev, p_lay, & + t_lay, tv_lay, effrin_cldliq, effrin_cldice, effrin_cldsnow, tracer, & + con_g, con_rd, con_ttp, cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice,& + cld_swp, cld_resnow, cld_rwp, cld_rerain, effrin_cldrain=effrin_cldrain) + end if + endif + + ! ################################################################################### + ! Thompson Microphysics + ! ("Explicit" SGS cloud-coupling to the radiation) + ! ################################################################################### + if (imp_physics == imp_physics_thompson) then + + ! MYNN-EDMF PBL clouds? + if(do_mynnedmf) then + call cloud_mp_MYNN(nCol, nLev, lsmask, t_lay, p_lev, p_lay, qs_lay, relhum, & + qc_mynn, qi_mynn, con_ttp, con_g, & + cld_pbl_lwp, cld_pbl_reliq, cld_pbl_iwp, cld_pbl_reice, cld_pbl_frac) + endif + + ! Grell-Freitas convective clouds? + if (imfdeepcnv == imfdeepcnv_gf) then + alpha0 = 100. + call cloud_mp_GF(nCol, nLev, lsmask, t_lay, p_lev, p_lay, qs_lay, relhum, & + qci_conv, con_ttp, con_g, alpha0, & + cld_cnv_lwp, cld_cnv_reliq, cld_cnv_iwp, cld_cnv_reice, cld_cnv_frac) + endif + + ! SAMF scale & aerosol-aware mass-flux convective clouds? + if (imfdeepcnv == imfdeepcnv_samf) then + alpha0 = 200. + call cloud_mp_SAMF(nCol, nLev, t_lay, p_lev, p_lay, qs_lay, relhum, & + cnv_mixratio, con_ttp, con_g, alpha0, & + cld_cnv_lwp, cld_cnv_reliq, cld_cnv_iwp, cld_cnv_reice, cld_cnv_frac) + endif + + ! Update particle size using modified mixing-ratios from Thompson. + call cmp_reff_Thompson(nLev, nCol, i_cldliq, i_cldice, i_cldsnow, i_cldice_nc, & + i_cldliq_nc, i_twa, q_lay, p_lay, t_lay, tracer, con_eps, con_rd, ltaerosol,& + effrin_cldliq, effrin_cldice, effrin_cldsnow) + cld_reliq = effrin_cldliq + cld_reice = effrin_cldice + cld_resnow = effrin_cldsnow + + ! Thomson MP using modified Xu-Randall cloud-fraction (additionally conditioned on RH) + alpha0 = 2000. + if (lmfshal) then + alpha0 = 100. + if (lmfdeep2) alpha0 = 200. + endif + call cloud_mp_thompson(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_cldrain,& + i_cldsnow, i_cldgrpl, p_lev, p_lay, tv_lay, t_lay, tracer, qs_lay, q_lay, & + relhum, con_g, con_rd, con_eps, alpha0, lwp_ex, iwp_ex, lwp_fc, iwp_fc, & + cld_frac, cld_lwp, cld_iwp, cld_swp, cld_rwp, cond_cfrac_onRH = .true.) + endif + + ! Bound effective radii for RRTMGP, LUT's for cloud-optics go from + ! 2.5 - 21.5 microns for liquid clouds, + ! 10 - 180 microns for ice-clouds + if (doGP_cldoptics_PADE .or. doGP_cldoptics_LUT) then + where(cld_reliq .lt. radliq_lwr) cld_reliq = radliq_lwr + where(cld_reliq .gt. radliq_upr) cld_reliq = radliq_upr + where(cld_reice .lt. radice_lwr) cld_reice = radice_lwr + where(cld_reice .gt. radice_upr) cld_reice = radice_upr + if (imfdeepcnv == imfdeepcnv_samf .or. imfdeepcnv == imfdeepcnv_gf) then + where(cld_cnv_reliq .lt. radliq_lwr) cld_cnv_reliq = radliq_lwr + where(cld_cnv_reliq .gt. radliq_upr) cld_cnv_reliq = radliq_upr + where(cld_cnv_reice .lt. radice_lwr) cld_cnv_reice = radice_lwr + where(cld_cnv_reice .gt. radice_upr) cld_cnv_reice = radice_upr + endif + if (do_mynnedmf) then + where(cld_pbl_reliq .lt. radliq_lwr) cld_pbl_reliq = radliq_lwr + where(cld_pbl_reliq .gt. radliq_upr) cld_pbl_reliq = radliq_upr + where(cld_pbl_reice .lt. radice_lwr) cld_pbl_reice = radice_lwr + where(cld_pbl_reice .gt. radice_upr) cld_pbl_reice = radice_upr + endif + endif + + precip_frac(1:nCol,1:nLev) = cld_frac(1:nCol,1:nLev) + + end subroutine GFS_rrtmgp_cloud_mp_run + + ! ###################################################################################### + ! Compute cloud radiative properties for Grell-Freitas convective cloud scheme. + ! (Adopted from module_SGSCloud_RadPre) + ! + ! - The total convective cloud condensate is partitoned by phase, using temperature, into + ! liquid/ice convective cloud mixing-ratios. Compute convective cloud LWP and IWP's. + ! + ! - The liquid and ice cloud effective particle sizes are assigned reference values*. + ! *TODO* Find references, include DOIs, parameterize magic numbers, etc... + ! + ! - The convective cloud-fraction is computed using Xu-Randall (1996). + ! (DJS asks: Does the GF scheme produce a cloud-fraction? If so, maybe use instead of + ! Xu-Randall? Xu-Randall is consistent with the Thompson MP scheme, but + ! not GFDL-EMC) + ! + ! ###################################################################################### + subroutine cloud_mp_GF(nCol, nLev, lsmask, t_lay, p_lev, p_lay, qs_lay, relhum, & + qci_conv, con_ttp, con_g, alpha0, cld_cnv_lwp, cld_cnv_reliq, cld_cnv_iwp, & + cld_cnv_reice, cld_cnv_frac) + implicit none + + ! Inputs + integer, intent(in) :: & + nCol, & ! Number of horizontal grid points + nLev ! Number of vertical layers + real(kind_phys), dimension(:), intent(in) :: & + lsmask ! Land/Sea mask + real(kind_phys), intent(in) :: & + con_g, & ! Physical constant: gravitational constant + con_ttp, & ! Triple point temperature of water (K) + alpha0 ! + real(kind_phys), dimension(:,:),intent(in) :: & + t_lay, & ! Temperature at layer centers (K) + p_lev, & ! Pressure at layer interfaces (Pa) + p_lay, & ! + qs_lay, & ! + relhum, & ! + qci_conv ! + ! Outputs + real(kind_phys), dimension(:,:),intent(inout) :: & + cld_cnv_lwp, & ! Convective cloud liquid water path + cld_cnv_reliq, & ! Convective cloud liquid effective radius + cld_cnv_iwp, & ! Convective cloud ice water path + cld_cnv_reice, & ! Convective cloud ice effecive radius + cld_cnv_frac ! Convective cloud-fraction (1) + ! Local + integer :: iCol, iLay + real(kind_phys) :: tem1, deltaP, clwc, qc, qi + + tem1 = 1.0e5/con_g + do iLay = 1, nLev + do iCol = 1, nCol + if (qci_conv(iCol,iLay) > 0.) then + ! Partition the convective clouds by phase. + qc = qci_conv(iCol,iLay)*( min(1., max(0., (t_lay(iCol,iLay)-244.)*0.04))) + qi = qci_conv(iCol,iLay)*(1. - min(1., max(0., (t_lay(iCol,iLay)-244.)*0.04))) + + ! Compute LWP/IWP + deltaP = abs(p_lev(iCol,iLay+1)-p_lev(iCol,iLay))*0.01 + cld_cnv_lwp(iCol,iLay) = max(0., qc * tem1 * deltaP) + cld_cnv_iwp(iCol,iLay) = max(0., qi * tem1 * deltaP) + + ! Particle sizes + if (nint(lsmask(iCol)) == 1) then !land + if(qc > 1.E-8) cld_cnv_reliq(iCol,iLay) = 5.4 + else + !eff radius cloud water (microns), from Miles et al. + if(qc > 1.E-8) cld_cnv_reliq(iCol,iLay) = 9.6 + endif + !eff radius cloud ice (microns), from Mishra et al. (2014, JGR Atmos, fig 6b) + if(qi > 1.E-8) cld_cnv_reice(iCol,iLay) = max(173.45 + 2.14*(t_lay(iCol,iLay)-273.15), 20.) + + ! Xu-Randall (1996) cloud-fraction. + cld_cnv_frac(iCol,iLay) = cld_frac_XuRandall(p_lay(iCol,iLay), & + qs_lay(iCol,iLay), relhum(iCol,iLay), qc+qi, alpha0) + endif + enddo + enddo + end subroutine cloud_mp_GF + + ! ###################################################################################### + ! Compute cloud radiative properties for MYNN-EDMF PBL cloud scheme. + ! (Adopted from module_SGSCloud_RadPre) + ! + ! - Cloud-fraction, liquid, and ice condensate mixing-ratios from MYNN-EDMF cloud scheme + ! are provided as inputs. Cloud LWP and IWP are computed. + ! + ! - The liquid and ice cloud effective particle sizes are assigned reference values*. + ! *TODO* Find references, include DOIs, parameterize magic numbers, etc... + ! + ! ###################################################################################### + subroutine cloud_mp_MYNN(nCol, nLev, lsmask, t_lay, p_lev, p_lay, qs_lay, relhum, & + qc_mynn, qi_mynn, con_ttp, con_g, cld_pbl_lwp, cld_pbl_reliq, cld_pbl_iwp, & + cld_pbl_reice, cld_pbl_frac) + implicit none + + ! Inputs + integer, intent(in) :: & + nCol, & ! Number of horizontal grid points + nLev ! Number of vertical layers + real(kind_phys), dimension(:), intent(in) :: & + lsmask ! Land/Sea mask + real(kind_phys), intent(in) :: & + con_g, & ! Physical constant: gravitational constant + con_ttp ! Triple point temperature of water (K) + real(kind_phys), dimension(:,:),intent(in) :: & + t_lay, & ! Temperature at layer centers (K) + p_lev, & ! Pressure at layer interfaces (Pa) + p_lay, & ! + qs_lay, & ! + relhum, & ! + qc_mynn, & ! Liquid cloud mixing-ratio (MYNN PBL cloud) + qi_mynn, & ! Ice cloud mixing-ratio (MYNN PBL cloud) + cld_pbl_frac ! Cloud-fraction (MYNN PBL cloud) + ! Outputs + real(kind_phys), dimension(:,:),intent(inout) :: & + cld_pbl_lwp, & ! Convective cloud liquid water path + cld_pbl_reliq, & ! Convective cloud liquid effective radius + cld_pbl_iwp, & ! Convective cloud ice water path + cld_pbl_reice ! Convective cloud ice effecive radius + + ! Local + integer :: iCol, iLay + real(kind_phys) :: tem1, qc, qi, deltaP + + tem1 = 1.0e5/con_g + do iLay = 1, nLev + do iCol = 1, nCol + if (cld_pbl_frac(iCol,iLay) > cld_limit_lower) then + ! Cloud mixing-ratios (DJS asks: Why is this done?) + qc = qc_mynn(iCol,iLay)*cld_pbl_frac(iCol,iLay) + qi = qi_mynn(iCol,iLay)*cld_pbl_frac(iCol,iLay) + + ! LWP/IWP + deltaP = abs(p_lev(iCol,iLay+1)-p_lev(iCol,iLay)) + cld_pbl_lwp(iCol,iLay) = max(0., qc * tem1 * deltaP) + cld_pbl_iwp(iCol,iLay) = max(0., qi * tem1 * deltaP) + + ! Particle sizes + if (nint(lsmask(iCol)) == 1) then + if(qc > 1.E-8) cld_pbl_reliq(iCol,iLay) = 5.4 + else + ! Cloud water (microns), from Miles et al. + if(qc > 1.E-8) cld_pbl_reliq(iCol,iLay) = 9.6 + endif + ! Cloud ice (microns), from Mishra et al. (2014, JGR Atmos, fig 6b) + if(qi > 1.E-8) cld_pbl_reice(iCol,iLay) = max(173.45 + 2.14*(t_lay(iCol,iLay)-273.15), 20.) + endif + enddo + enddo + end subroutine cloud_mp_MYNN + + ! ###################################################################################### + ! Compute cloud radiative properties for SAMF convective cloud scheme. + ! + ! - The total-cloud convective mixing-ratio is partitioned by phase into liquid/ice + ! cloud properties. LWP and IWP are computed. + ! + ! - The liquid and ice cloud effective particle sizes are assigned reference values. + ! + ! - The convective cloud-fraction is computed using Xu-Randall (1996). + ! (DJS asks: Does the SAMF scheme produce a cloud-fraction?) + ! + ! ###################################################################################### + subroutine cloud_mp_SAMF(nCol, nLev, t_lay, p_lev, p_lay, qs_lay, relhum, & + cnv_mixratio, con_ttp, con_g, alpha0, cld_cnv_lwp, cld_cnv_reliq, cld_cnv_iwp, & + cld_cnv_reice, cld_cnv_frac) + implicit none + + ! Inputs + integer, intent(in) :: & + nCol, & ! Number of horizontal grid points + nLev ! Number of vertical layers + real(kind_phys), intent(in) :: & + con_g, & ! Physical constant: gravitational constant + con_ttp, & ! Triple point temperature of water (K) + alpha0 ! + real(kind_phys), dimension(:,:),intent(in) :: & + t_lay, & ! Temperature at layer centers (K) + p_lev, & ! Pressure at layer interfaces (Pa) + p_lay, & ! + qs_lay, & ! + relhum, & ! + cnv_mixratio ! Convective cloud mixing-ratio (kg/kg) + ! Outputs + real(kind_phys), dimension(:,:),intent(inout) :: & + cld_cnv_lwp, & ! Convective cloud liquid water path + cld_cnv_reliq, & ! Convective cloud liquid effective radius + cld_cnv_iwp, & ! Convective cloud ice water path + cld_cnv_reice, & ! Convective cloud ice effecive radius + cld_cnv_frac ! Convective cloud-fraction (1) + ! Local + integer :: iCol, iLay + real(kind_phys) :: tem1, deltaP, clwc + + do iLay = 1, nLev + do iCol = 1, nCol + if (cnv_mixratio(iCol,iLay) > 0._kind_phys) then + tem1 = min(1.0, max(0.0, (con_ttp-t_lay(iCol,iLay))*0.05)) + deltaP = abs(p_lev(iCol,iLay+1)-p_lev(iCol,iLay))*0.01 + clwc = max(0.0, cnv_mixratio(iCol,iLay)) * con_g * deltaP + cld_cnv_iwp(iCol,iLay) = clwc * tem1 + cld_cnv_lwp(iCol,iLay) = clwc - cld_cnv_iwp(iCol,iLay) + cld_cnv_reliq(iCol,iLay) = reliq_def + cld_cnv_reice(iCol,iLay) = reice_def + + ! Xu-Randall (1996) cloud-fraction. + cld_cnv_frac(iCol,iLay) = cld_frac_XuRandall(p_lay(iCol,iLay), & + qs_lay(iCol,iLay), relhum(iCol,iLay), cnv_mixratio(iCol,iLay), alpha0) + endif + enddo + enddo + + end subroutine cloud_mp_SAMF + + ! ###################################################################################### + ! This routine computes the cloud radiative properties for a "unified cloud". + ! + ! - "unified cloud" implies that the cloud-fraction is PROVIDED. + ! + ! - The cloud water path is computed for all provided cloud mixing-ratios and hydrometeors. + ! + ! - If particle sizes are provided, they are used. If not, default values are assigned. + ! + ! ###################################################################################### + subroutine cloud_mp_uni(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_cldrain, & + i_cldsnow, i_cldgrpl, i_cldtot, effr_in, kdt, lsmask, p_lev, p_lay, t_lay, tv_lay,& + effrin_cldliq, effrin_cldice, effrin_cldsnow, tracer, con_g, con_rd, con_ttp, & + cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, & + cld_rerain, effrin_cldrain) + implicit none + + ! Inputs + integer, intent(in) :: & + nCol, & ! Number of horizontal grid points + nLev, & ! Number of vertical layers + ncnd, & ! Number of cloud condensation types. + nTracers, & ! Number of tracers from model. + i_cldliq, & ! Index into tracer array for cloud liquid. + i_cldice, & ! Index into tracer array for cloud ice. + i_cldrain, & ! Index into tracer array for cloud rain. + i_cldsnow, & ! Index into tracer array for cloud snow. + i_cldgrpl, & ! Index into tracer array for cloud groupel. + i_cldtot, & ! Index into tracer array for cloud total amount. + kdt + logical, intent(in) :: & + effr_in ! Provide hydrometeor radii from macrophysics? + real(kind_phys), intent(in) :: & + con_g, & ! Physical constant: gravitational constant + con_ttp, & ! Triple point temperature of water (K) + con_rd ! Physical constant: gas-constant for dry air + real(kind_phys), dimension(:), intent(in) :: & + lsmask + real(kind_phys), dimension(:,:), intent(in) :: & + t_lay, & ! Temperature at model-layers (K) + tv_lay, & ! Virtual temperature (K) + p_lay, & ! Pressure at model-layers (Pa) + cld_frac, & ! Total cloud fraction + effrin_cldliq, & ! Effective radius for liquid cloud-particles (microns) + effrin_cldice, & ! Effective radius for ice cloud-particles (microns) + effrin_cldsnow ! Effective radius for snow cloud-particles (microns) + real(kind_phys), dimension(:,:), intent(in) ,optional :: & + effrin_cldrain ! Effective radius for rain cloud-particles (microns) + real(kind_phys), dimension(:,:), intent(in) :: & + p_lev ! Pressure at model-level interfaces (Pa) + real(kind_phys), dimension(:,:,:),intent(in) :: & + tracer ! Cloud condensate amount in layer by type () + + ! Outputs + real(kind_phys), dimension(:,:),intent(inout) :: & + cld_lwp, & ! Cloud liquid water path + cld_reliq, & ! Cloud liquid effective radius + cld_iwp, & ! Cloud ice water path + cld_reice, & ! Cloud ice effecive radius + cld_swp, & ! Cloud snow water path + cld_resnow, & ! Cloud snow effective radius + cld_rwp, & ! Cloud rain water path + cld_rerain ! Cloud rain effective radius + + ! Local variables + real(kind_phys) :: tem1,tem2,tem3,pfac,deltaP + real(kind_phys), dimension(nCol, nLev, min(4,ncnd)) :: cld_condensate + integer :: iCol,iLay,l,ncndl + + ! Cloud condensate + cld_condensate(1:nCol,1:nLev,1) = tracer(1:nCol,1:nLev,i_cldliq) ! -liquid water + cld_condensate(1:nCol,1:nLev,2) = tracer(1:nCol,1:nLev,i_cldice) ! -ice water + if (ncnd > 2) then + cld_condensate(1:nCol,1:nLev,3) = tracer(1:nCol,1:nLev,i_cldrain) ! -rain water + cld_condensate(1:nCol,1:nLev,4) = tracer(1:nCol,1:nLev,i_cldsnow) + &! -snow + grapuel + tracer(1:nCol,1:nLev,i_cldgrpl) + endif + + ! Cloud water path (g/m2) + tem1 = 1.0e5/con_g + do iLay = 1, nLev + do iCol = 1, nCol + ! Compute liquid/ice condensate path from mixing ratios (kg/kg)->(g/m2) + if (cld_frac(iCol,iLay) > cld_limit_lower) then + deltaP = abs(p_lev(iCol,iLay+1)-p_lev(iCol,iLay))*0.01 + cld_lwp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,1) * tem1 * deltaP) + cld_iwp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,2) * tem1 * deltaP) + if (ncnd > 2) then + cld_rwp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,3) * tem1 * deltaP) + cld_swp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,4) * tem1 * deltaP) + endif + endif + enddo + enddo + + ! Particle size + do iLay = 1, nLev + do iCol = 1, nCol + ! Use radii provided from the macrophysics + if (effr_in) then + cld_reliq(iCol,iLay) = effrin_cldliq(iCol,iLay) + cld_reice(iCol,iLay) = max(reice_min, min(reice_max,effrin_cldice(iCol,iLay))) + cld_resnow(iCol,iLay) = effrin_cldsnow(iCol,iLay) + if (present(effrin_cldrain)) then + cld_rerain(iCol,iLay) = effrin_cldrain(iCol,iLay) + else + cld_rerain(iCol,iLay) = rerain_def + endif + else + ! Compute effective liquid cloud droplet radius over land. + if (nint(lsmask(iCol)) == 1) then + cld_reliq(iCol,iLay) = 5.0 + 5.0 * min(1.0, max(0.0, (con_ttp-t_lay(iCol,iLay))*0.05)) + endif + ! Compute effective ice cloud droplet radius following Heymsfield + ! and McFarquhar (1996) \cite heymsfield_and_mcfarquhar_1996. + tem2 = t_lay(iCol,iLay) - con_ttp + if (cld_iwp(iCol,iLay) > 0.0) then + deltaP = abs(p_lev(iCol,iLay+1)-p_lev(iCol,iLay))*0.01 + tem3 = (con_g/con_rd ) * cld_iwp(iCol,iLay) * (0.01*p_lay(iCol,iLay)) / (deltaP*tv_lay(iCol,iLay)) + if (tem2 < -50.0) then + cld_reice(iCol,iLay) = (1250.0/9.917) * tem3 ** 0.109 + elseif (tem2 < -40.0) then + cld_reice(iCol,iLay) = (1250.0/9.337) * tem3 ** 0.08 + elseif (tem2 < -30.0) then + cld_reice(iCol,iLay) = (1250.0/9.208) * tem3 ** 0.055 + else + cld_reice(iCol,iLay) = (1250.0/9.387) * tem3 ** 0.031 + endif + cld_reice(iCol,iLay) = max(10.0, min(cld_reice(iCol,iLay), 150.0)) + endif + endif ! effr_in + enddo ! nCol + enddo ! nLev + + end subroutine cloud_mp_uni + ! ###################################################################################### + ! This routine computes the cloud radiative properties for the Thompson cloud micro- + ! physics scheme. + ! + ! - The cloud water path is computed for all provided cloud mixing-ratios and hydrometeors. + ! + ! - There are no assumptions about particle size applied here. Effective particle sizes + ! are updated prior to this routine, see cmp_reff_Thompson(). + ! + ! - The cloud-fraction is computed using Xu-Randall** (1996). + ! **Additionally, Conditioned on relative-humidity** + ! + ! ###################################################################################### + subroutine cloud_mp_thompson(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_cldrain,& + i_cldsnow, i_cldgrpl, p_lev, p_lay, tv_lay, t_lay, tracer, qs_lay, q_lay, relhum, & + con_g, con_rd, con_eps, alpha0, lwp_ex, iwp_ex, lwp_fc, iwp_fc, cld_frac, cld_lwp,& + cld_iwp, cld_swp, cld_rwp, cond_cfrac_onRH) + implicit none + + ! Inputs + logical, intent(in), optional :: & + cond_cfrac_onRH + integer, intent(in) :: & + nCol, & ! Number of horizontal grid points + nLev, & ! Number of vertical layers + ncnd, & ! Number of cloud condensation types. + nTracers, & ! Number of tracers from model. + i_cldliq, & ! Index into tracer array for cloud liquid amount. + i_cldice, & ! cloud ice amount. + i_cldrain, & ! cloud rain amount. + i_cldsnow, & ! cloud snow amount. + i_cldgrpl ! cloud groupel amount. + real(kind_phys), intent(in) :: & + con_g, & ! Physical constant: gravitational constant + con_rd, & ! Physical constant: gas-constant for dry air + con_eps, & ! Physical constant: gas constant air / gas constant H2O + alpha0 ! + real(kind_phys), dimension(:,:), intent(in) :: & + tv_lay, & ! Virtual temperature (K) + t_lay, & ! Temperature (K) + qs_lay, & ! Saturation vapor pressure (Pa) + q_lay, & ! water-vapor mixing ratio (kg/kg) + relhum, & ! Relative humidity + p_lay ! Pressure at model-layers (Pa) + real(kind_phys), dimension(:,:), intent(in) :: & + p_lev ! Pressure at model-level interfaces (Pa) + real(kind_phys), dimension(:,:,:),intent(in) :: & + tracer ! Cloud condensate amount in layer by type () + + ! In/Outs + real(kind_phys), dimension(:), intent(inout) :: & + lwp_ex, & ! total liquid water path from explicit microphysics + iwp_ex, & ! total ice water path from explicit microphysics + lwp_fc, & ! total liquid water path from cloud fraction scheme + iwp_fc ! total ice water path from cloud fraction scheme + real(kind_phys), dimension(:,:), intent(inout) :: & + cld_frac, & ! Total cloud fraction + cld_lwp, & ! Cloud liquid water path + cld_iwp, & ! Cloud ice water path + cld_swp, & ! Cloud snow water path + cld_rwp ! Cloud rain water path + + ! Local variables + real(kind_phys) :: tem1, pfac, cld_mr, deltaP + real(kind_phys), dimension(nCol, nLev, min(4,ncnd)) :: cld_condensate + integer :: iCol,iLay,l + + ! Cloud condensate + cld_condensate(1:nCol,1:nLev,1) = tracer(1:nCol,1:nLev,i_cldliq) ! -liquid water + cld_condensate(1:nCol,1:nLev,2) = tracer(1:nCol,1:nLev,i_cldice) ! -ice water + cld_condensate(1:nCol,1:nLev,3) = tracer(1:nCol,1:nLev,i_cldrain) ! -rain water + cld_condensate(1:nCol,1:nLev,4) = tracer(1:nCol,1:nLev,i_cldsnow) + &! -snow + grapuel + tracer(1:nCol,1:nLev,i_cldgrpl) + + cld_lwp(:,:) = 0.0 + cld_iwp(:,:) = 0.0 + cld_rwp(:,:) = 0.0 + cld_swp(:,:) = 0.0 + cld_frac(:,:) = 0.0 + tem1 = 1.0e5/con_g + do iLay = 1, nLev-1 + do iCol = 1, nCol + ! Compute liquid/ice condensate path from mixing ratios (kg/kg)->(g/m2) + deltaP = abs(p_lev(iCol,iLay+1)-p_lev(iCol,iLay))*0.01 + cld_lwp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,1) * tem1 * deltaP) + cld_iwp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,2) * tem1 * deltaP) + cld_rwp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,3) * tem1 * deltaP) + cld_swp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,4) * tem1 * deltaP) + + ! Xu-Randall (1996) cloud-fraction. **Additionally, Conditioned on relative-humidity** + if (present(cond_cfrac_onRH) .and. relhum(iCol,iLay) > 0.99) then + cld_frac(iCol,iLay) = 1._kind_phys + else + cld_mr = cld_condensate(iCol,iLay,1) + cld_condensate(iCol,iLay,2) + & + cld_condensate(iCol,iLay,4) + cld_frac(iCol,iLay) = cld_frac_XuRandall(p_lay(iCol,iLay), & + qs_lay(iCol,iLay), relhum(iCol,iLay), cld_mr, alpha0) + endif + enddo + enddo + + ! Sum the liquid water and ice paths that come from explicit micro + ! What portion of water and ice contents is associated with the partly cloudy boxes? + do iCol = 1, nCol + lwp_ex(iCol) = 0.0 + iwp_ex(iCol) = 0.0 + lwp_fc(iCol) = 0.0 + iwp_fc(iCol) = 0.0 + do iLay = 1, nLev-1 + lwp_ex(iCol) = lwp_ex(iCol) + cld_lwp(iCol,iLay) + iwp_ex(iCol) = iwp_ex(iCol) + cld_iwp(iCol,iLay) + cld_swp(iCol,iLay) + if (cld_frac(iCol,iLay) .ge. cld_limit_lower .and. & + cld_frac(iCol,iLay) .lt. cld_limit_ovcst) then + lwp_fc(iCol) = lwp_fc(iCol) + cld_lwp(iCol,iLay) + iwp_fc(iCol) = iwp_fc(iCol) + cld_iwp(iCol,iLay) + cld_swp(iCol,iLay) + endif + enddo + lwp_fc(iCol) = lwp_fc(iCol)*1.E-3 + iwp_fc(iCol) = iwp_fc(iCol)*1.E-3 + lwp_ex(iCol) = lwp_ex(iCol)*1.E-3 + iwp_ex(iCol) = iwp_ex(iCol)*1.E-3 + enddo + + end subroutine cloud_mp_thompson + + ! ###################################################################################### + ! This function computes the cloud-fraction following. + ! Xu-Randall(1996) A Semiempirical Cloudiness Parameterization for Use in Climate Models + ! https://doi.org/10.1175/1520-0469(1996)053<3084:ASCPFU>2.0.CO;2 + ! + ! cld_frac = {1-exp[-alpha*cld_mr/((1-relhum)*qs_lay)**lambda]}*relhum**P + ! + ! ###################################################################################### + function cld_frac_XuRandall(p_lay, qs_lay, relhum, cld_mr, alpha) + implicit none + ! Inputs + real(kind_phys), intent(in) :: & + p_lay, & ! Pressure (Pa) + qs_lay, & ! Saturation vapor-pressure (Pa) + relhum, & ! Relative humidity + cld_mr, & ! Total cloud mixing ratio + alpha ! Scheme parameter (default=100) + + ! Outputs + real(kind_phys) :: cld_frac_XuRandall + + ! Locals + real(kind_phys) :: clwt, clwm, onemrh, tem1, tem2, tem3 + + ! Parameters + real(kind_phys) :: & + lambda = 0.50, & ! + P = 0.25 + + clwt = 1.0e-6 * (p_lay*0.001) + if (cld_mr > clwt) then + onemrh = max(1.e-10, 1.0 - relhum) + tem1 = alpha / min(max((onemrh*qs_lay)**lambda,0.0001),1.0) + tem2 = max(min(tem1*(cld_mr - clwt), 50.0 ), 0.0 ) + tem3 = sqrt(sqrt(relhum)) ! This assumes "p" = 0.25. Identical, but cheaper than relhum**p + ! + cld_frac_XuRandall = max( tem3*(1.0-exp(-tem2)), 0.0 ) + else + cld_frac_XuRandall = 0.0 + endif + + return + end function + + ! ###################################################################################### + ! This routine is a wrapper to update the Thompson effective particle sizes used by the + ! RRTMGP radiation scheme. + ! + ! ###################################################################################### + subroutine cmp_reff_Thompson(nLev, nCol, i_cldliq, i_cldice, i_cldsnow, i_cldice_nc, & + i_cldliq_nc, i_twa, q_lay, p_lay, t_lay, tracer, con_eps, con_rd, ltaerosol, & + effrin_cldliq, effrin_cldice, effrin_cldsnow) + implicit none + + ! Inputs + integer, intent(in) :: nLev, nCol, i_cldliq, i_cldice, i_cldsnow, i_cldice_nc, & + i_cldliq_nc, i_twa + logical, intent(in) :: ltaerosol + real(kind_phys), intent(in) :: con_eps,con_rd + real(kind_phys), dimension(:,:),intent(in) :: q_lay, p_lay, t_lay + real(kind_phys), dimension(:,:,:),intent(in) :: tracer + + ! Outputs + real(kind_phys), dimension(:,:), intent(inout) :: effrin_cldliq, effrin_cldice, & + effrin_cldsnow + + ! Local + integer :: iCol, iLay + real(kind_phys) :: rho, orho + real(kind_phys),dimension(nCol,nLev) :: qv_mp, qc_mp, qi_mp, qs_mp, ni_mp, nc_mp, & + nwfa, re_cloud, re_ice, re_snow + + ! Prepare cloud mixing-ratios and number concentrations for calc_effectRa + do iLay = 1, nLev + do iCol = 1, nCol + qv_mp(iCol,iLay) = q_lay(iCol,iLay)/(1.-q_lay(iCol,iLay)) + rho = con_eps*p_lay(iCol,iLay)/(con_rd*t_lay(iCol,iLay)*(qv_mp(iCol,iLay)+con_eps)) + orho = 1./rho + qc_mp(iCol,iLay) = tracer(iCol,iLay,i_cldliq) / (1.-q_lay(iCol,iLay)) + qi_mp(iCol,iLay) = tracer(iCol,iLay,i_cldice) / (1.-q_lay(iCol,iLay)) + qs_mp(iCol,iLay) = tracer(iCol,iLay,i_cldsnow) / (1.-q_lay(iCol,iLay)) + ni_mp(iCol,iLay) = tracer(iCol,iLay,i_cldice_nc) / (1.-q_lay(iCol,iLay)) + if (ltaerosol) then + nc_mp(iCol,iLay) = tracer(iCol,iLay,i_cldliq_nc) / (1.-q_lay(iCol,iLay)) + nwfa(iCol,iLay) = tracer(iCol,iLay,i_twa) + if (qc_mp(iCol,iLay) > 1.e-12 .and. nc_mp(iCol,iLay) < 100.) then + nc_mp(iCol,iLay) = make_DropletNumber(qc_mp(iCol,iLay)*rho, nwfa(iCol,iLay)*rho) * orho + endif + else + nc_mp(iCol,iLay) = nt_c*orho + endif + if (qi_mp(iCol,iLay) > 1.e-12 .and. ni_mp(iCol,iLay) < 100.) then + ni_mp(iCol,iLay) = make_IceNumber(qi_mp(iCol,iLay)*rho, t_lay(iCol,iLay)) * orho + endif + enddo + enddo + + ! Compute effective radii for liquid/ice/snow. + do iCol=1,nCol + call calc_effectRad (t_lay(iCol,:), p_lay(iCol,:), qv_mp(iCol,:), qc_mp(iCol,:), & + nc_mp(iCol,:), qi_mp(iCol,:), ni_mp(iCol,:), qs_mp(iCol,:), & + re_cloud(iCol,:), re_ice(iCol,:), re_snow(iCol,:), 1, nLev ) + do iLay = 1, nLev + re_cloud(iCol,iLay) = MAX(re_qc_min, MIN(re_cloud(iCol,iLay), re_qc_max)) + re_ice(iCol,iLay) = MAX(re_qi_min, MIN(re_ice(iCol,iLay), re_qi_max)) + re_snow(iCol,iLay) = MAX(re_qs_min, MIN(re_snow(iCol,iLay), re_qs_max)) + enddo + enddo + + ! Scale to microns. + do iLay = 1, nLev + do iCol = 1, nCol + effrin_cldliq(iCol,iLay) = re_cloud(iCol,iLay)*1.e6 + effrin_cldice(iCol,iLay) = re_ice(iCol,iLay)*1.e6 + effrin_cldsnow(iCol,iLay) = re_snow(iCol,iLay)*1.e6 + enddo + enddo + + end subroutine cmp_reff_Thompson + +end module GFS_rrtmgp_cloud_mp diff --git a/physics/GFS_rrtmgp_thompsonmp_pre.meta b/physics/GFS_rrtmgp_cloud_mp.meta similarity index 55% rename from physics/GFS_rrtmgp_thompsonmp_pre.meta rename to physics/GFS_rrtmgp_cloud_mp.meta index ff8d0e13b..88530d84c 100644 --- a/physics/GFS_rrtmgp_thompsonmp_pre.meta +++ b/physics/GFS_rrtmgp_cloud_mp.meta @@ -1,11 +1,11 @@ [ccpp-table-properties] - name = GFS_rrtmgp_thompsonmp_pre + name = GFS_rrtmgp_cloud_mp type = scheme - dependencies = radiation_tools.F90, module_mp_thompson_make_number_concentrations.F90, module_mp_thompson.F90, rrtmgp_lw_cloud_optics.F90 + dependencies = radiation_tools.F90, radiation_clouds.f, module_mp_thompson_make_number_concentrations.F90, module_mp_thompson.F90, rrtmgp_lw_cloud_optics.F90 ######################################################################## [ccpp-arg-table] - name = GFS_rrtmgp_thompsonmp_pre_run + name = GFS_rrtmgp_cloud_mp_run type = scheme [nCol] standard_name = horizontal_loop_extent @@ -35,19 +35,12 @@ dimensions = () type = integer intent = in -[doSWrad] - standard_name = flag_for_calling_shortwave_radiation - long_name = logical flags for sw radiation calls +[icloud] + standard_name = control_for_cloud_area_fraction_option + long_name = cloud effect to the optical depth and cloud fraction in radiation units = flag dimensions = () - type = logical - intent = in -[doLWrad] - standard_name = flag_for_calling_longwave_radiation - long_name = logical flags for lw radiation calls - units = flag - dimensions = () - type = logical + type = integer intent = in [i_cldliq] standard_name = index_of_cloud_liquid_water_mixing_ratio_in_tracer_concentration_array @@ -112,6 +105,20 @@ dimensions = () type = integer intent = in +[doSWrad] + standard_name = flag_for_calling_shortwave_radiation + long_name = logical flags for sw radiation calls + units = flag + dimensions = () + type = logical + intent = in +[doLWrad] + standard_name = flag_for_calling_longwave_radiation + long_name = logical flags for lw radiation calls + units = flag + dimensions = () + type = logical + intent = in [effr_in] standard_name = flag_for_cloud_effective_radii long_name = flag for cloud effective radii calculations in GFDL microphysics @@ -119,6 +126,129 @@ dimensions = () type = logical intent = in +[kdt] + standard_name = index_of_timestep + long_name = current forecast iteration + units = index + dimensions = () + type = integer + intent = in +[imp_physics] + standard_name = control_for_microphysics_scheme + long_name = choice of microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[imp_physics_thompson] + standard_name = identifier_for_thompson_microphysics_scheme + long_name = choice of Thompson microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[imp_physics_gfdl] + standard_name = identifier_for_gfdl_microphysics_scheme + long_name = choice of GFDL microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[do_mynnedmf] + standard_name = flag_for_mellor_yamada_nakanishi_niino_pbl_scheme + long_name = flag to activate MYNN-EDMF + units = flag + dimensions = () + type = logical + intent = in +[uni_cld] + standard_name = flag_for_shoc_cloud_area_fraction_for_radiation + long_name = flag for uni_cld + units = flag + dimensions = () + type = logical + intent = in +[lmfdeep2] + standard_name = flag_for_scale_aware_mass_flux_deep_convection_for_radiation + long_name = flag for some scale-aware mass-flux convection scheme active + units = flag + dimensions = () + type = logical + intent = in +[lmfshal] + standard_name = flag_for_cloud_area_fraction_option_for_radiation + long_name = flag for lmfshal + units = flag + dimensions = () + type = logical + intent = in +[ltaerosol] + standard_name = flag_for_aerosol_physics + long_name = flag for aerosol physics + units = flag + dimensions = () + type = logical + intent = in +[imfdeepcnv] + standard_name = control_for_deep_convection_scheme + long_name = flag for mass-flux deep convection scheme + units = flag + dimensions = () + type = integer + intent = in +[imfdeepcnv_gf] + standard_name = identifier_for_grell_freitas_deep_convection + long_name = flag for Grell-Freitas deep convection scheme + units = flag + dimensions = () + type = integer + intent = in +[imfdeepcnv_samf] + standard_name = identifer_for_scale_aware_mass_flux_deep_convection + long_name = flag for SAMF deep convection scheme + units = flag + dimensions = () + type = integer + intent = in +[lgfdlmprad] + standard_name = flag_for_GFDL_microphysics_radiation_interaction + long_name = flag for GFDL microphysics-radiation interaction + units = flag + dimensions = () + type = logical + intent = in +[lsmask] + standard_name = area_type + long_name = landmask: sea/land/ice=0/1/2 + units = flag + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[xlat] + standard_name = latitude + long_name = latitude + units = radian + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[xlon] + standard_name = longitude + long_name = longitude + units = radian + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[dx] + standard_name = characteristic_grid_lengthscale + long_name = relative dx for the grid cell + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in [p_lev] standard_name = air_pressure_at_interface_for_RRTMGP long_name = air pressure at vertical interface for radiation calculation @@ -151,6 +281,30 @@ type = real kind = kind_phys intent = in +[qs_lay] + standard_name = saturation_vapor_pressure + long_name = saturation vapor pressure + units = Pa + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[q_lay] + standard_name = water_vapor_mixing_ratio + long_name = water vaport mixing ratio + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[relhum] + standard_name = relative_humidity + long_name = layer relative humidity + units = frac + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in [effrin_cldliq] standard_name = effective_radius_of_stratiform_cloud_liquid_water_particle long_name = eff. radius of cloud liquid water particle in micrometer @@ -167,6 +321,14 @@ type = real kind = kind_phys intent = inout +[effrin_cldrain] + standard_name = effective_radius_of_stratiform_cloud_rain_particle + long_name = effective radius of cloud rain particle in micrometers + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in [effrin_cldsnow] standard_name = effective_radius_of_stratiform_cloud_snow_particle long_name = effective radius of cloud snow particle in micrometers @@ -183,26 +345,66 @@ type = real kind = kind_phys intent = in -[qs_lay] - standard_name = saturation_vapor_pressure - long_name = saturation vapor pressure +[cnv_mixratio] + standard_name = convective_cloud_water_mixing_ratio + long_name = moist convective cloud water mixing ratio + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_cnv_frac] + standard_name = convective_cloud_fraction_for_RRTMGP + long_name = layer convective cloud fraction + units = frac + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[qci_conv] + standard_name = convective_cloud_condesate_after_rainout + long_name = convective cloud condesate after rainout + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[deltaZ] + standard_name = layer_thickness + long_name = layer_thickness + units = m + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[deltaZc] + standard_name = layer_thickness_from_layer_center + long_name = layer_thickness + units = m + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[deltaP] + standard_name = layer_thickness_in_Pa + long_name = layer_thickness_in_Pa units = Pa dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = in -[q_lay] - standard_name = water_vapor_mixing_ratio - long_name = water vaport mixing ratio +[qc_mynn] + standard_name = subgrid_scale_cloud_liquid_water_mixing_ratio + long_name = subgrid cloud water mixing ratio from PBL scheme units = kg kg-1 dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = in -[relhum] - standard_name = relative_humidity - long_name = layer relative humidity - units = frac +[qi_mynn] + standard_name = subgrid_scale_cloud_ice_mixing_ratio + long_name = subgrid cloud ice mixing ratio from PBL scheme + units = kg kg-1 dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys @@ -231,40 +433,13 @@ type = real kind = kind_phys intent = in -[lmfshal] - standard_name = flag_for_cloud_area_fraction_option_for_radiation - long_name = flag for lmfshal - units = flag - dimensions = () - type = logical - intent = in -[ltaerosol] - standard_name = flag_for_aerosol_physics - long_name = flag for aerosol physics - units = flag - dimensions = () - type = logical - intent = in -[do_mynnedmf] - standard_name = flag_for_mellor_yamada_nakanishi_niino_pbl_scheme - long_name = flag to activate MYNN-EDMF - units = flag - dimensions = () - type = logical - intent = in -[imfdeepcnv] - standard_name = control_for_deep_convection_scheme - long_name = flag for mass-flux deep convection scheme - units = flag - dimensions = () - type = integer - intent = in -[imfdeepcnv_gf] - standard_name = identifier_for_grell_freitas_deep_convection - long_name = flag for Grell-Freitas deep convection scheme - units = flag +[con_ttp] + standard_name = triple_point_temperature_of_water + long_name = triple point temperature of water + units = K dimensions = () - type = integer + type = real + kind = kind_phys intent = in [doGP_cldoptics_PADE] standard_name = flag_to_calc_lw_cld_optics_using_RRTMGP_PADE @@ -360,6 +535,110 @@ type = real kind = kind_phys intent = inout +[cld_cnv_lwp] + standard_name = convective_cloud_liquid_water_path + long_name = layer convective cloud liquid water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[cld_cnv_iwp] + standard_name = convective_cloud_ice_water_path + long_name = layer convective cloud ice water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[cld_cnv_reliq] + standard_name = mean_effective_radius_for_liquid_convective_cloud + long_name = mean effective radius for liquid convective cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[cld_cnv_reice] + standard_name = mean_effective_radius_for_ice_convective_cloud + long_name = mean effective radius for ice convective cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[cld_pbl_frac] + standard_name = subgrid_scale_cloud_area_fraction_in_atmosphere_layer + long_name = subgrid cloud fraction from PBL scheme + units = frac + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_pbl_lwp] + standard_name = MYNN_SGS_cloud_liquid_water_path + long_name = layer convective cloud liquid water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[cld_pbl_iwp] + standard_name = MYNN_SGS_cloud_ice_water_path + long_name = layer convective cloud ice water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[cld_pbl_reliq] + standard_name = mean_effective_radius_for_liquid_MYNN_SGS_cloud + long_name = mean effective radius for liquid MYNN_SGS cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[cld_pbl_reice] + standard_name = mean_effective_radius_for_ice_MYNN_SGS_cloud + long_name = mean effective radius for ice MYNN_SGS cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[lwp_ex] + standard_name = liq_water_path_from_microphysics + long_name = total liquid water path from explicit microphysics + units = kg m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[iwp_ex] + standard_name = ice_water_path_from_microphysics + long_name = total ice water path from explicit microphysics + units = kg m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[lwp_fc] + standard_name = liq_water_path_from_cloud_fraction + long_name = total liquid water path from cloud fraction scheme + units = kg m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[iwp_fc] + standard_name = ice_water_path_from_cloud_fraction + long_name = total ice water path from cloud fraction scheme + units = kg m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/GFS_rrtmgp_cloud_overlap.F90 b/physics/GFS_rrtmgp_cloud_overlap.F90 new file mode 100644 index 000000000..13794641b --- /dev/null +++ b/physics/GFS_rrtmgp_cloud_overlap.F90 @@ -0,0 +1,126 @@ +! ######################################################################################## +! +! ######################################################################################## +module GFS_rrtmgp_cloud_overlap + use machine, only: kind_phys + use radiation_tools, only: check_error_msg + use module_radiation_cloud_overlap, only: cmp_dcorr_lgth, get_alpha_exper + + public GFS_rrtmgp_cloud_overlap_init, GFS_rrtmgp_cloud_overlap_run, GFS_rrtmgp_cloud_overlap_finalize + +contains + ! ###################################################################################### + ! ###################################################################################### +!! \section arg_table_GFS_rrtmgp_cloud_overlap_run +!! \htmlinclude GFS_rrtmgp_cloud_overlap_run.html +!! + subroutine GFS_rrtmgp_cloud_overlap_run(nCol, nLev, yearlen, doSWrad, doLWrad, & + julian, lat, p_lev, p_lay, tv_lay, deltaZc, con_pi, con_g, con_rd, con_epsq, & + dcorr_con, idcor, iovr, iovr_dcorr, iovr_exp, iovr_exprand, idcor_con, & + idcor_hogan, idcor_oreopoulos, cld_frac, cld_cnv_frac, iovr_convcld, top_at_1, & + imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_samf, de_lgth, cloud_overlap_param, & + cnv_cloud_overlap_param, precip_overlap_param, errmsg, errflg) + implicit none + + ! Inputs + integer, intent(in) :: & + nCol, & ! Number of horizontal grid points + nLev, & ! Number of vertical layers + yearlen, & ! Length of current year (365/366) WTF? + imfdeepcnv, & ! + imfdeepcnv_gf, & ! + imfdeepcnv_samf, & ! + iovr, & ! Choice of cloud-overlap method + iovr_convcld, & ! Choice of convective cloud-overlap method + iovr_dcorr, & ! Flag for decorrelation-length cloud overlap method + iovr_exp, & ! Flag for exponential cloud overlap method + iovr_exprand, & ! Flag for exponential-random cloud overlap method + idcor, & ! Choice of method for decorrelation length computation + idcor_con, & ! Flag for decorrelation-length. Use constant value + idcor_hogan, & ! Flag for decorrelation-length. (https://rmets.onlinelibrary.wiley.com/doi/full/10.1002/qj.647) + idcor_oreopoulos ! Flag for decorrelation-length. (10.5194/acp-12-9097-2012) + logical, intent(in) :: & + top_at_1, & ! Vertical ordering flag + doSWrad, & ! Call SW radiation? + doLWrad ! Call LW radiation + real(kind_phys), intent(in) :: & + julian, & ! Julian day + con_pi, & ! Physical constant: pi + con_g, & ! Physical constant: gravitational constant + con_rd, & ! Physical constant: gas-constant for dry air + con_epsq, & ! Physical constant: Minimum value for specific humidity + dcorr_con ! Decorrelation-length (used if idcor = idcor_con) + real(kind_phys), dimension(:), intent(in) :: & + lat ! Latitude + real(kind_phys), dimension(:,:), intent(in) :: & + tv_lay, & ! Virtual temperature (K) + p_lay, & ! Pressure at model-layers (Pa) + cld_frac, & ! Total cloud fraction + cld_cnv_frac ! Convective cloud-fraction + real(kind_phys), dimension(:,:), intent(in) :: & + p_lev, & ! Pressure at model-level interfaces (Pa) + deltaZc ! Layer thickness (from layer-centers)(m) + + ! Outputs + real(kind_phys), dimension(:),intent(out) :: & + de_lgth ! Decorrelation length + real(kind_phys), dimension(:,:),intent(out) :: & + cloud_overlap_param, & ! Cloud-overlap parameter + cnv_cloud_overlap_param,& ! Convective cloud-overlap parameter + precip_overlap_param ! Precipitation overlap parameter + character(len=*), intent(out) :: & + errmsg ! Error message + integer, intent(out) :: & + errflg ! Error flag + + ! Local variables + integer :: iCol,iLay + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (.not. (doSWrad .or. doLWrad)) return + + ! + ! Cloud decorrelation length + ! + if (idcor == idcor_hogan) then + call cmp_dcorr_lgth(nCol, lat, con_pi, de_lgth) + endif + if (idcor == idcor_oreopoulos) then + call cmp_dcorr_lgth(nCol, lat*(180._kind_phys/con_pi), julian, yearlen, de_lgth) + endif + if (idcor == idcor_con) then + de_lgth(:) = dcorr_con + endif + + ! + ! Cloud overlap parameter + ! + if (iovr == iovr_dcorr .or. iovr == iovr_exp .or. iovr == iovr_exprand) then + call get_alpha_exper(nCol, nLev, iovr, iovr_exprand, deltaZc*0.001, de_lgth, cld_frac, cloud_overlap_param) + else + de_lgth(:) = 0. + cloud_overlap_param(:,:) = 0. + endif + + ! + ! Convective cloud overlap parameter + ! + if (imfdeepcnv == imfdeepcnv_samf .or. imfdeepcnv == imfdeepcnv_gf) then + if (iovr_convcld == iovr_dcorr .or. iovr_convcld == iovr_exp .or. iovr_convcld == iovr_exprand) then + call get_alpha_exper(nCol, nLev, iovr_convcld, iovr_exprand, deltaZc*0.001, de_lgth, cld_cnv_frac, cnv_cloud_overlap_param) + else + de_lgth(:) = 0. + cnv_cloud_overlap_param(:,:) = 0. + endif + endif + + ! + ! Compute precipitation overlap parameter (Hack. Using same as cloud for now) + ! + precip_overlap_param = cloud_overlap_param + + end subroutine GFS_rrtmgp_cloud_overlap_run +end module GFS_rrtmgp_cloud_overlap diff --git a/physics/GFS_rrtmgp_cloud_overlap_pre.meta b/physics/GFS_rrtmgp_cloud_overlap.meta similarity index 81% rename from physics/GFS_rrtmgp_cloud_overlap_pre.meta rename to physics/GFS_rrtmgp_cloud_overlap.meta index a4620cfa2..f7d12bed5 100644 --- a/physics/GFS_rrtmgp_cloud_overlap_pre.meta +++ b/physics/GFS_rrtmgp_cloud_overlap.meta @@ -1,11 +1,11 @@ [ccpp-table-properties] - name = GFS_rrtmgp_cloud_overlap_pre + name = GFS_rrtmgp_cloud_overlap type = scheme dependencies = radiation_tools.F90, radiation_cloud_overlap.F90 ######################################################################## [ccpp-arg-table] - name = GFS_rrtmgp_cloud_overlap_pre_run + name = GFS_rrtmgp_cloud_overlap_run type = scheme [nCol] standard_name = horizontal_loop_extent @@ -82,6 +82,14 @@ type = real kind = kind_phys intent = in +[deltaZc] + standard_name = layer_thickness_from_layer_center + long_name = layer_thickness + units = m + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in [con_pi] standard_name = pi long_name = ratio of a circle's circumference to its diameter @@ -136,6 +144,13 @@ dimensions = () type = integer intent = in +[iovr_convcld] + standard_name = flag_for_convective_cloud_overlap_method_for_radiation + long_name = flag for convective cloud overlap method + units = flag + dimensions = () + type = integer + intent = in [iovr_dcorr] standard_name = flag_for_decorrelation_length_cloud_overlap_method long_name = choice of decorrelation-length cloud overlap method @@ -186,6 +201,14 @@ type = real kind = kind_phys intent = in +[cld_cnv_frac] + standard_name = convective_cloud_fraction_for_RRTMGP + long_name = layer convective cloud fraction + units = frac + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in [top_at_1] standard_name = flag_for_vertical_ordering_in_RRTMGP long_name = flag for vertical ordering in RRTMGP @@ -193,6 +216,27 @@ dimensions = () type = logical intent = in +[imfdeepcnv] + standard_name = control_for_deep_convection_scheme + long_name = flag for mass-flux deep convection scheme + units = flag + dimensions = () + type = integer + intent = in +[imfdeepcnv_gf] + standard_name = identifier_for_grell_freitas_deep_convection + long_name = flag for Grell-Freitas deep convection scheme + units = flag + dimensions = () + type = integer + intent = in +[imfdeepcnv_samf] + standard_name = identifer_for_scale_aware_mass_flux_deep_convection + long_name = flag for SAMF deep convection scheme + units = flag + dimensions = () + type = integer + intent = in [de_lgth] standard_name = cloud_decorrelation_length long_name = cloud decorrelation length @@ -217,10 +261,10 @@ type = real kind = kind_phys intent = out -[deltaZc] - standard_name = layer_thickness - long_name = layer_thickness - units = m +[cnv_cloud_overlap_param] + standard_name = convective_cloud_overlap_param + long_name = convective cloud overlap parameter + units = km dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys diff --git a/physics/GFS_rrtmgp_cloud_overlap_pre.F90 b/physics/GFS_rrtmgp_cloud_overlap_pre.F90 deleted file mode 100644 index f85621d8f..000000000 --- a/physics/GFS_rrtmgp_cloud_overlap_pre.F90 +++ /dev/null @@ -1,182 +0,0 @@ -! ######################################################################################## -! -! ######################################################################################## -module GFS_rrtmgp_cloud_overlap_pre - use machine, only: kind_phys - use radiation_tools, only: check_error_msg - use module_radiation_cloud_overlap, only: cmp_dcorr_lgth, get_alpha_exp - - public GFS_rrtmgp_cloud_overlap_pre_init, GFS_rrtmgp_cloud_overlap_pre_run, GFS_rrtmgp_cloud_overlap_pre_finalize - -contains - ! ###################################################################################### - ! ###################################################################################### - subroutine GFS_rrtmgp_cloud_overlap_pre_init() - end subroutine GFS_rrtmgp_cloud_overlap_pre_init - - ! ###################################################################################### - ! ###################################################################################### -!! \section arg_table_GFS_rrtmgp_cloud_overlap_pre_run -!! \htmlinclude GFS_rrtmgp_cloud_overlap_pre_run.html -!! - subroutine GFS_rrtmgp_cloud_overlap_pre_run(nCol, nLev, yearlen, doSWrad, doLWrad, & - julian, lat, p_lev, p_lay, tv_lay, con_pi, con_g, con_rd, con_epsq, dcorr_con, & - idcor, iovr, iovr_dcorr, iovr_exp, iovr_exprand, idcor_con, idcor_hogan, & - idcor_oreopoulos, cld_frac, top_at_1, & - de_lgth, cloud_overlap_param, precip_overlap_param, deltaZc, errmsg, errflg) - implicit none - - ! Inputs - integer, intent(in) :: & - nCol, & ! Number of horizontal grid points - nLev, & ! Number of vertical layers - yearlen, & ! Length of current year (365/366) WTF? - iovr, & ! Choice of cloud-overlap method - iovr_dcorr, & ! Flag for decorrelation-length cloud overlap method - iovr_exp, & ! Flag for exponential cloud overlap method - iovr_exprand, & ! Flag for exponential-random cloud overlap method - idcor, & ! Choice of method for decorrelation length computation - idcor_con, & ! Flag for decorrelation-length. Use constant value - idcor_hogan, & ! Flag for decorrelation-length. (https://rmets.onlinelibrary.wiley.com/doi/full/10.1002/qj.647) - idcor_oreopoulos ! Flag for decorrelation-length. (10.5194/acp-12-9097-2012) - logical, intent(in) :: & - top_at_1, & ! Vertical ordering flag - doSWrad, & ! Call SW radiation? - doLWrad ! Call LW radiation - real(kind_phys), intent(in) :: & - julian, & ! Julian day - con_pi, & ! Physical constant: pi - con_g, & ! Physical constant: gravitational constant - con_rd, & ! Physical constant: gas-constant for dry air - con_epsq, & ! Physical constant: Minimum value for specific humidity - dcorr_con ! Decorrelation-length (used if idcor = idcor_con) - real(kind_phys), dimension(:), intent(in) :: & - lat ! Latitude - real(kind_phys), dimension(:,:), intent(in) :: & - tv_lay, & ! Virtual temperature (K) - p_lay, & ! Pressure at model-layers (Pa) - cld_frac ! Total cloud fraction - real(kind_phys), dimension(:,:), intent(in) :: & - p_lev ! Pressure at model-level interfaces (Pa) - - ! Outputs - real(kind_phys), dimension(:),intent(out) :: & - de_lgth ! Decorrelation length - real(kind_phys), dimension(:,:),intent(out) :: & - cloud_overlap_param, & ! Cloud-overlap parameter - precip_overlap_param, & ! Precipitation overlap parameter - deltaZc ! Layer thickness (from layer-centers)(km) - character(len=*), intent(out) :: & - errmsg ! Error message - integer, intent(out) :: & - errflg ! Error flag - - ! Local variables - real(kind_phys) :: tem1,pfac - real(kind_phys), dimension(nLev+1) :: hgtb - real(kind_phys), dimension(nLev) :: hgtc - integer :: iCol,iLay,l - real(kind_phys), dimension(nCol,nLev) :: deltaZ - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (.not. (doSWrad .or. doLWrad)) return - - ! - ! Compute layer-thickness between layer boundaries (deltaZ) and layer centers (deltaZc) - ! - do iCol=1,nCol - if (top_at_1) then - ! Layer thickness (km) - do iLay=1,nLev - deltaZ(iCol,iLay) = ((con_rd/con_g)*0.001) * abs(log(p_lev(iCol,iLay+1)) - log(p_lev(iCol,iLay))) * tv_lay(iCol,iLay) - enddo - ! Height at layer boundaries - hgtb(nLev+1) = 0._kind_phys - do iLay=nLev,1,-1 - hgtb(iLay)= hgtb(iLay+1) + deltaZ(iCol,iLay) - enddo - ! Height at layer centers - do iLay = nLev, 1, -1 - pfac = abs(log(p_lev(iCol,iLay+1)) - log(p_lay(iCol,iLay))) / & - abs(log(p_lev(iCol,iLay+1)) - log(p_lev(iCol,iLay))) - hgtc(iLay) = hgtb(iLay+1) + pfac * (hgtb(iLay) - hgtb(iLay+1)) - enddo - ! Layer thickness between centers - do iLay = nLev-1, 1, -1 - deltaZc(iCol,iLay) = hgtc(iLay) - hgtc(iLay+1) - enddo - deltaZc(iCol,nLev) = hgtc(nLev) - hgtb(nLev+1) - else - do iLay=nLev,1,-1 - deltaZ(iCol,iLay) = ((con_rd/con_g)*0.001) * abs(log(p_lev(iCol,iLay)) - log(p_lev(iCol,iLay+1))) * tv_lay(iCol,iLay) - enddo - ! Height at layer boundaries - hgtb(1) = 0._kind_phys - do iLay=1,nLev - hgtb(iLay+1)= hgtb(iLay) + deltaZ(iCol,iLay) - enddo - ! Height at layer centers - do iLay = 1, nLev - pfac = abs(log(p_lev(iCol,iLay)) - log(p_lay(iCol,iLay) )) / & - abs(log(p_lev(iCol,iLay)) - log(p_lev(iCol,iLay+1))) - hgtc(iLay) = hgtb(iLay) + pfac * (hgtb(iLay+1) - hgtb(iLay)) - enddo - ! Layer thickness between centers - do iLay = 2, nLev - deltaZc(iCol,iLay) = hgtc(iLay) - hgtc(iLay-1) - enddo - deltaZc(iCol,1) = hgtc(1) - hgtb(1) - endif - enddo - - ! - ! Cloud decorrelation length - ! - if (idcor == idcor_hogan) then - call cmp_dcorr_lgth(nCol, lat, con_pi, de_lgth) - endif - if (idcor == idcor_oreopoulos) then - call cmp_dcorr_lgth(nCol, lat*(180._kind_phys/con_pi), julian, yearlen, de_lgth) - endif - if (idcor == idcor_con) then - de_lgth(:) = dcorr_con - endif - - ! - ! Cloud overlap parameter - ! - if (iovr == iovr_dcorr .or. iovr == iovr_exp .or. iovr == iovr_exprand) then - call get_alpha_exp(nCol, nLev, deltaZc, de_lgth, cloud_overlap_param) - else - de_lgth(:) = 0. - cloud_overlap_param(:,:) = 0. - endif - - ! For exponential random overlap... - ! Decorrelate layers when a clear layer follows a cloudy layer to enforce - ! random correlation between non-adjacent blocks of cloudy layers - if (iovr == iovr_exprand) then - do iLay = 1, nLev - do iCol = 1, nCol - if (cld_frac(iCol,iLay) .eq. 0. .and. cld_frac(iCol,iLay-1) .gt. 0.) then - cloud_overlap_param(iCol,iLay) = 0._kind_phys - endif - enddo - enddo - endif - - ! - ! Compute precipitation overlap parameter (Hack. Using same as cloud for now) - ! - precip_overlap_param = cloud_overlap_param - - end subroutine GFS_rrtmgp_cloud_overlap_pre_run - - ! ######################################################################################### - ! ######################################################################################### - subroutine GFS_rrtmgp_cloud_overlap_pre_finalize() - end subroutine GFS_rrtmgp_cloud_overlap_pre_finalize -end module GFS_rrtmgp_cloud_overlap_pre diff --git a/physics/GFS_rrtmgp_gfdlmp_pre.meta b/physics/GFS_rrtmgp_gfdlmp_pre.meta deleted file mode 100644 index c45054613..000000000 --- a/physics/GFS_rrtmgp_gfdlmp_pre.meta +++ /dev/null @@ -1,303 +0,0 @@ -[ccpp-table-properties] - name = GFS_rrtmgp_gfdlmp_pre - type = scheme - dependencies = radiation_tools.F90, radiation_cloud_overlap.F90, rrtmgp_lw_cloud_optics.F90 - -######################################################################## -[ccpp-arg-table] - name = GFS_rrtmgp_gfdlmp_pre_run - type = scheme -[nCol] - standard_name = horizontal_loop_extent - long_name = horizontal dimension - units = count - dimensions = () - type = integer - intent = in -[nLev] - standard_name = vertical_layer_dimension - long_name = number of vertical levels - units = count - dimensions = () - type = integer - intent = in -[nTracers] - standard_name = number_of_tracers - long_name = number of tracers - units = count - dimensions = () - type = integer - intent = in -[ncnd] - standard_name = number_of_condensate_species - long_name = number of cloud condensate types - units = count - dimensions = () - type = integer - intent = in -[i_cldliq] - standard_name = index_of_cloud_liquid_water_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for cloud condensate (or liquid water) - units = index - dimensions = () - type = integer - intent = in -[i_cldice] - standard_name = index_of_cloud_ice_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for ice water - units = index - dimensions = () - type = integer - intent = in -[i_cldrain] - standard_name = index_of_rain_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for rain water - units = index - dimensions = () - type = integer - intent = in -[i_cldsnow] - standard_name = index_of_snow_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for snow water - units = index - dimensions = () - type = integer - intent = in -[i_cldgrpl] - standard_name = index_of_graupel_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for graupel - units = index - dimensions = () - type = integer - intent = in -[i_cldtot] - standard_name = index_of_cloud_area_fraction_in_atmosphere_layer_in_tracer_concentration_array - long_name = tracer index for cloud amount integer - units = index - dimensions = () - type = integer - intent = in -[doSWrad] - standard_name = flag_for_calling_shortwave_radiation - long_name = logical flags for sw radiation calls - units = flag - dimensions = () - type = logical - intent = in -[doLWrad] - standard_name = flag_for_calling_longwave_radiation - long_name = logical flags for lw radiation calls - units = flag - dimensions = () - type = logical - intent = in -[effr_in] - standard_name = flag_for_cloud_effective_radii - long_name = flag for cloud effective radii calculations in GFDL microphysics - units = flag - dimensions = () - type = logical - intent = in -[kdt] - standard_name = index_of_timestep - long_name = current forecast iteration - units = index - dimensions = () - type = integer - intent = in -[do_mynnedmf] - standard_name = flag_for_mellor_yamada_nakanishi_niino_pbl_scheme - long_name = flag to activate MYNN-EDMF - units = flag - dimensions = () - type = logical - intent = in -[p_lev] - standard_name = air_pressure_at_interface_for_RRTMGP - long_name = air pressure at vertical interface for radiation calculation - units = Pa - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = in -[p_lay] - standard_name = air_pressure_at_layer_for_RRTMGP - long_name = air pressure at vertical layer for radiation calculation - units = Pa - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[tv_lay] - standard_name = virtual_temperature - long_name = layer virtual temperature - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[effrin_cldliq] - standard_name = effective_radius_of_stratiform_cloud_liquid_water_particle - long_name = eff. radius of cloud liquid water particle in micrometer - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[effrin_cldice] - standard_name = effective_radius_of_stratiform_cloud_ice_particle - long_name = eff. radius of cloud ice water particle in micrometer - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[effrin_cldrain] - standard_name = effective_radius_of_stratiform_cloud_rain_particle - long_name = effective radius of cloud rain particle in micrometers - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[effrin_cldsnow] - standard_name = effective_radius_of_stratiform_cloud_snow_particle - long_name = effective radius of cloud snow particle in micrometers - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[tracer] - standard_name = chemical_tracers - long_name = chemical tracers - units = g g-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = in -[con_g] - standard_name = gravitational_acceleration - long_name = gravitational acceleration - units = m s-2 - dimensions = () - type = real - kind = kind_phys - intent = in -[con_rd] - standard_name = gas_constant_of_dry_air - long_name = ideal gas constant for dry air - units = J kg-1 K-1 - dimensions = () - type = real - kind = kind_phys - intent = in -[doGP_cldoptics_PADE] - standard_name = flag_to_calc_lw_cld_optics_using_RRTMGP_PADE - long_name = logical flag to control cloud optics scheme. - units = flag - dimensions = () - type = logical - intent = in -[doGP_cldoptics_LUT] - standard_name = flag_to_calc_lw_cld_optics_using_RRTMGP_LUT - long_name = logical flag to control cloud optics scheme. - units = flag - dimensions = () - type = logical - intent = in -[cld_frac] - standard_name = total_cloud_fraction - long_name = layer total cloud fraction - units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[cld_lwp] - standard_name = cloud_liquid_water_path - long_name = layer cloud liquid water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[cld_reliq] - standard_name = mean_effective_radius_for_liquid_cloud - long_name = mean effective radius for liquid cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[cld_iwp] - standard_name = cloud_ice_water_path - long_name = layer cloud ice water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[cld_reice] - standard_name = mean_effective_radius_for_ice_cloud - long_name = mean effective radius for ice cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[cld_swp] - standard_name = cloud_snow_water_path - long_name = layer cloud snow water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[cld_resnow] - standard_name = mean_effective_radius_for_snow_flake - long_name = mean effective radius for snow cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[cld_rwp] - standard_name = cloud_rain_water_path - long_name = layer cloud rain water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[cld_rerain] - standard_name = mean_effective_radius_for_rain_drop - long_name = mean effective radius for rain cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[precip_frac] - standard_name = precipitation_fraction_by_layer - long_name = precipitation fraction in each layer - units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out diff --git a/physics/GFS_rrtmgp_pre.F90 b/physics/GFS_rrtmgp_pre.F90 index d3620a5fd..faf8d4986 100644 --- a/physics/GFS_rrtmgp_pre.F90 +++ b/physics/GFS_rrtmgp_pre.F90 @@ -99,11 +99,11 @@ end subroutine GFS_rrtmgp_pre_init !! \htmlinclude GFS_rrtmgp_pre_run.html !! subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhswr, fhlwr, & - xlat, xlon, prsl, tgrs, prslk, prsi, qgrs, tsfc, coslat, sinlat, con_eps, con_epsm1,& - con_fvirt, con_epsqs, solhr, minGPpres, maxGPpres, minGPtemp, maxGPtemp, raddt, & - p_lay, t_lay, p_lev, t_lev, tsfg, tsfa, qs_lay, q_lay, tv_lay, relhum, tracer, & - active_gases_array, gas_concentrations, tsfc_radtime, coszen, coszdg, top_at_1, iSFC,& - iTOA, errmsg, errflg) + xlat, xlon, prsl, tgrs, prslk, prsi, qgrs, tsfc, coslat, sinlat, con_g, con_rd, & + con_eps, con_epsm1, con_fvirt, con_epsqs, solhr, minGPpres, maxGPpres, minGPtemp, & + maxGPtemp, raddt, p_lay, t_lay, p_lev, t_lev, tsfg, tsfa, qs_lay, q_lay, tv_lay, & + relhum, tracer, deltaZ, deltaZc, deltaP, active_gases_array, gas_concentrations, & + tsfc_radtime, coszen, coszdg, top_at_1, iSFC, iTOA, errmsg, errflg) ! Inputs integer, intent(in) :: & @@ -122,25 +122,28 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhsw fhswr, & ! Frequency of SW radiation call. fhlwr ! Frequency of LW radiation call. real(kind_phys), intent(in) :: & + con_g, & ! Physical constant: gravitational constant + con_rd, & ! Physical constant: gas-constant for dry air con_eps, & ! Physical constant: Epsilon (Rd/Rv) con_epsm1, & ! Physical constant: Epsilon (Rd/Rv) minus one con_fvirt, & ! Physical constant: Inverse of epsilon minus one con_epsqs, & ! Physical constant: Minimum saturation mixing-ratio (kg/kg) solhr ! Time in hours after 00z at the current timestep - real(kind_phys), dimension(nCol), intent(in) :: & + real(kind_phys), dimension(:), intent(in) :: & xlon, & ! Longitude xlat, & ! Latitude tsfc, & ! Surface skin temperature (K) coslat, & ! Cosine(latitude) sinlat ! Sine(latitude) - real(kind_phys), dimension(nCol,nLev), intent(in) :: & + real(kind_phys), dimension(:,:), intent(in) :: & prsl, & ! Pressure at model-layer centers (Pa) tgrs, & ! Temperature at model-layer centers (K) - prslk ! Exner function at model layer centers (1) - real(kind_phys), dimension(nCol,nLev+1), intent(in) :: & + prslk, & ! Exner function at model layer centers (1) prsi ! Pressure at model-interfaces (Pa) - real(kind_phys), dimension(nCol,nLev,nTracers), intent(in) :: & + real(kind_phys), dimension(:,:,:), intent(in) :: & qgrs ! Tracer concentrations (kg/kg) + character(len=*), dimension(:), intent(in) :: & + active_gases_array ! List of active gases from namelist as array ! Outputs character(len=*), intent(out) :: & @@ -153,36 +156,38 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhsw top_at_1 ! Vertical ordering flag real(kind_phys), intent(inout) :: & raddt ! Radiation time-step - real(kind_phys), dimension(ncol), intent(inout) :: & + real(kind_phys), dimension(:), intent(inout) :: & tsfg, & ! Ground temperature tsfa, & ! Skin temperature - tsfc_radtime ! Surface temperature at radiation timestep - real(kind_phys), dimension(nCol,nLev), intent(inout) :: & + tsfc_radtime, & ! Surface temperature at radiation timestep + coszen, & ! Cosine of SZA + coszdg ! Cosine of SZA, daytime + real(kind_phys), dimension(:,:), intent(inout) :: & p_lay, & ! Pressure at model-layer t_lay, & ! Temperature at model layer q_lay, & ! Water-vapor mixing ratio (kg/kg) tv_lay, & ! Virtual temperature at model-layers relhum, & ! Relative-humidity at model-layers - qs_lay ! Saturation vapor pressure at model-layers - real(kind_phys), dimension(nCol,nLev+1), intent(inout) :: & + qs_lay, & ! Saturation vapor pressure at model-layers + deltaZ, & ! Layer thickness (m) + deltaZc, & ! Layer thickness (m) (between layer centers) + deltaP, & ! Layer thickness (Pa) p_lev, & ! Pressure at model-interface t_lev ! Temperature at model-interface - real(kind_phys), dimension(nCol, nLev, nTracers),intent(inout) :: & + real(kind_phys), dimension(:,:,:),intent(inout) :: & tracer ! Array containing trace gases - character(len=*), dimension(:), intent(in) :: & - active_gases_array ! List of active gases from namelist as array type(ty_gas_concs), intent(inout) :: & gas_concentrations ! RRTMGP DDT: gas volumne mixing ratios - real(kind_phys), dimension(:), intent(inout) :: & - coszen, & ! Cosine of SZA - coszdg ! Cosine of SZA, daytime - + ! Local variables - integer :: i, j, iCol, iBand, iLay + integer :: i, j, iCol, iBand, iLay, iLev, iSFC_ilev real(kind_phys),dimension(nCol,nLev) :: vmr_o3, vmr_h2o - real(kind_phys) :: es, tem1, tem2 + real(kind_phys) :: es, tem1, tem2, pfac + real(kind_phys), dimension(nLev+1) :: hgtb + real(kind_phys), dimension(nLev) :: hgtc real(kind_phys), dimension(nCol,nLev) :: o3_lay real(kind_phys), dimension(nCol,nLev, NF_VGAS) :: gas_vmr + real(kind_phys) :: con_rdog ! Initialize CCPP error handling variables errmsg = '' @@ -197,9 +202,11 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhsw if (top_at_1) then iSFC = nLev iTOA = 1 + iSFC_ilev = iSFC + 1 else iSFC = 1 iTOA = nLev + iSFC_ilev = 1 endif ! ####################################################################################### @@ -220,8 +227,8 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhsw t_lay(1:NCOL,:) = tgrs(1:NCOL,:) ! Bound temperature/pressure at layer centers. - do iCol=1,NCOL - do iLay=1,nLev + do iLay=1,nLev + do iCol=1,NCOL if (t_lay(iCol,iLay) .le. minGPtemp) then t_lay(iCol,iLay) = minGPtemp + epsilon(minGPtemp) endif @@ -239,6 +246,12 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhsw ! Temperature at layer-interfaces call cmp_tlev(nCol,nLev,minGPpres,p_lay,t_lay,p_lev,tsfc,t_lev) + do iLev=1,nLev+1 + do iCol=1,nCol + if (t_lev(iCol,iLev) .le. minGPtemp) t_lev(iCol,iLev) = minGPtemp + epsilon(minGPtemp) + if (t_lev(iCol,iLev) .ge. maxGPtemp) t_lev(iCol,iLev) = maxGPtemp - epsilon(maxGPtemp) + enddo + enddo ! Save surface temperature at radiation time-step, used for LW flux adjustment betwen ! radiation calls. @@ -247,8 +260,8 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhsw ! Compute a bunch of thermodynamic fields needed by the cloud microphysics schemes. ! Relative humidity, saturation mixing-ratio, vapor mixing-ratio, virtual temperature, ! layer thickness,... - do iCol=1,NCOL - do iLay=1,nLev + do iLay=1,nLev + do iCol=1,NCOL es = min( p_lay(iCol,iLay), fpvs( t_lay(iCol,iLay) ) ) ! fpvs and prsl in pa qs_lay(iCol,iLay) = max( con_epsqs, con_eps * es / (p_lay(iCol,iLay) + con_epsm1*es) ) relhum(iCol,iLay) = max( 0._kind_phys, min( 1._kind_phys, max(con_epsqs, q_lay(iCol,iLay))/qs_lay(iCol,iLay) ) ) @@ -256,6 +269,57 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhsw enddo enddo + ! + ! Compute layer-thickness between layer boundaries (deltaZ) and layer centers (deltaZc) + ! + deltaP = abs(p_lev(:,2:nLev+1)-p_lev(:,1:nLev)) + con_rdog = con_rd/con_g + do iCol=1,nCol + if (top_at_1) then + ! Layer thickness (m) + do iLay=1,nLev + deltaZ(iCol,iLay) = con_rdog * abs(log(p_lev(iCol,iLay+1)) - log(p_lev(iCol,iLay))) * tv_lay(iCol,iLay) + enddo + ! Height at layer boundaries + hgtb(nLev+1) = 0._kind_phys + do iLay=nLev,1,-1 + hgtb(iLay)= hgtb(iLay+1) + deltaZ(iCol,iLay) + enddo + ! Height at layer centers + do iLay = nLev, 1, -1 + pfac = abs(log(p_lev(iCol,iLay+1)) - log(p_lay(iCol,iLay))) / & + abs(log(p_lev(iCol,iLay+1)) - log(p_lev(iCol,iLay))) + hgtc(iLay) = hgtb(iLay+1) + pfac * (hgtb(iLay) - hgtb(iLay+1)) + enddo + ! Layer thickness between centers + do iLay = nLev-1, 1, -1 + deltaZc(iCol,iLay) = hgtc(iLay) - hgtc(iLay+1) + enddo + deltaZc(iCol,nLev) = hgtc(nLev) - hgtb(nLev+1) + else + ! Layer thickness (m) + do iLay=nLev,1,-1 + deltaZ(iCol,iLay) = con_rdog * abs(log(p_lev(iCol,iLay)) - log(p_lev(iCol,iLay+1))) * tv_lay(iCol,iLay) + enddo + ! Height at layer boundaries + hgtb(1) = 0._kind_phys + do iLay=1,nLev + hgtb(iLay+1)= hgtb(iLay) + deltaZ(iCol,iLay) + enddo + ! Height at layer centers + do iLay = 1, nLev + pfac = abs(log(p_lev(iCol,iLay)) - log(p_lay(iCol,iLay) )) / & + abs(log(p_lev(iCol,iLay)) - log(p_lev(iCol,iLay+1))) + hgtc(iLay) = hgtb(iLay) + pfac * (hgtb(iLay+1) - hgtb(iLay)) + enddo + ! Layer thickness between centers + do iLay = 2, nLev + deltaZc(iCol,iLay) = hgtc(iLay) - hgtc(iLay-1) + enddo + deltaZc(iCol,1) = hgtc(1) - hgtb(1) + endif + enddo + ! ####################################################################################### ! Get layer ozone mass mixing ratio ! ####################################################################################### @@ -305,7 +369,7 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhsw ! ####################################################################################### ! Setup surface ground temperature and ground/air skin temperature if required. ! ####################################################################################### - tsfg(1:NCOL) = tsfc(1:NCOL) + tsfg(1:NCOL) = t_lev(1:NCOL,iSFC_ilev) tsfa(1:NCOL) = t_lay(1:NCOL,iSFC) ! ####################################################################################### diff --git a/physics/GFS_rrtmgp_pre.meta b/physics/GFS_rrtmgp_pre.meta index 501dacfa1..88face855 100644 --- a/physics/GFS_rrtmgp_pre.meta +++ b/physics/GFS_rrtmgp_pre.meta @@ -204,6 +204,22 @@ type = real kind = kind_phys intent = in +[con_g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_rd] + standard_name = gas_constant_of_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in [con_eps] standard_name = ratio_of_dry_air_to_water_vapor_gas_constants long_name = rd/rv @@ -308,6 +324,30 @@ type = real kind = kind_phys intent = inout +[deltaZ] + standard_name = layer_thickness + long_name = layer_thickness + units = m + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[deltaZc] + standard_name = layer_thickness_from_layer_center + long_name = layer_thickness + units = m + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[deltaP] + standard_name = layer_thickness_in_Pa + long_name = layer_thickness_in_Pa + units = Pa + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout [top_at_1] standard_name = flag_for_vertical_ordering_in_RRTMGP long_name = flag for vertical ordering in RRTMGP diff --git a/physics/GFS_rrtmgp_setup.F90 b/physics/GFS_rrtmgp_setup.F90 index d518cb6e3..f7f657b50 100644 --- a/physics/GFS_rrtmgp_setup.F90 +++ b/physics/GFS_rrtmgp_setup.F90 @@ -5,7 +5,7 @@ module GFS_rrtmgp_setup use module_radiation_astronomy, only : sol_init, sol_update use module_radiation_aerosols, only : aer_init, aer_update use module_radiation_gases, only : gas_init, gas_update - use GFS_cloud_diagnostics, only : hml_cloud_diagnostics_initialize + ! use GFS_cloud_diagnostics, only : hml_cloud_diagnostics_initialize ! *NOTE* These parameters below are required radiation_****** modules. They are not ! directly used by the RRTMGP routines. use physparam, only : isolar, ictmflg, ico2flg, ioznflg, iaerflg, & @@ -130,10 +130,10 @@ subroutine GFS_rrtmgp_setup_init(do_RRTMGP, imp_physics, imp_physics_fer_hires, call sol_init ( me ) call aer_init ( levr, me ) call gas_init ( me ) - call hml_cloud_diagnostics_initialize(imp_physics, imp_physics_fer_hires, & - imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, & - imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, imp_physics_mg, levr, me, si,& - errflg) + !call hml_cloud_diagnostics_initialize(imp_physics, imp_physics_fer_hires, & + ! imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, & + ! imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, imp_physics_mg, levr, me, si,& + ! errflg) if ( me == 0 ) then print *,' return from rad_initialize (GFS_rrtmgp_setup_init) - after calling radinit' diff --git a/physics/GFS_rrtmgp_sw_post.F90 b/physics/GFS_rrtmgp_sw_post.F90 index 377afdadc..fafa162d9 100644 --- a/physics/GFS_rrtmgp_sw_post.F90 +++ b/physics/GFS_rrtmgp_sw_post.F90 @@ -52,7 +52,7 @@ subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky coszdg ! Cosine(SZA), daytime real(kind_phys), dimension(nCol, nLev+1), intent(in) :: & p_lev ! Pressure @ model layer-interfaces (Pa) - real(kind_phys), dimension(sw_gas_props%get_nband(),ncol), intent(in) :: & + real(kind_phys), dimension(ncol), intent(in) :: & sfc_alb_nir_dir, & ! Surface albedo (direct) sfc_alb_nir_dif, & ! Surface albedo (diffuse) sfc_alb_uvvis_dir, & ! Surface albedo (direct) @@ -170,10 +170,10 @@ subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky nirdfdi(i) = scmpsw(i)%nirdf visbmdi(i) = scmpsw(i)%visbm visdfdi(i) = scmpsw(i)%visdf - nirbmui(i) = scmpsw(i)%nirbm * sfc_alb_nir_dir(1,i) - nirdfui(i) = scmpsw(i)%nirdf * sfc_alb_nir_dif(1,i) - visbmui(i) = scmpsw(i)%visbm * sfc_alb_uvvis_dir(1,i) - visdfui(i) = scmpsw(i)%visdf * sfc_alb_uvvis_dif(1,i) + nirbmui(i) = scmpsw(i)%nirbm * sfc_alb_nir_dir(i) + nirdfui(i) = scmpsw(i)%nirdf * sfc_alb_nir_dif(i) + visbmui(i) = scmpsw(i)%visbm * sfc_alb_uvvis_dir(i) + visdfui(i) = scmpsw(i)%visdf * sfc_alb_uvvis_dif(i) enddo else ! if_nday_block ! ####################################################################################### diff --git a/physics/GFS_rrtmgp_sw_post.meta b/physics/GFS_rrtmgp_sw_post.meta index 0e93b78e6..7da3b10b0 100644 --- a/physics/GFS_rrtmgp_sw_post.meta +++ b/physics/GFS_rrtmgp_sw_post.meta @@ -112,34 +112,34 @@ kind = kind_phys intent = in [sfc_alb_nir_dir] - standard_name = surface_albedo_nearIR_direct - long_name = near-IR (direct) surface albedo (sfc_alb_nir_dir) - units = none - dimensions = (number_of_shortwave_bands,horizontal_loop_extent) + standard_name = surface_albedo_due_to_near_IR_direct + long_name = surface albedo due to near IR direct beam + units = frac + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in [sfc_alb_nir_dif] - standard_name = surface_albedo_nearIR_diffuse - long_name = near-IR (diffuse) surface albedo (sfc_alb_nir_dif) - units = none - dimensions = (number_of_shortwave_bands,horizontal_loop_extent) + standard_name = surface_albedo_due_to_near_IR_diffused + long_name = surface albedo due to near IR diffused beam + units = frac + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in [sfc_alb_uvvis_dir] - standard_name = surface_albedo_uvvis_direct - long_name = UVVIS (direct) surface albedo (sfc_alb_uvvis_dir) - units = none - dimensions = (number_of_shortwave_bands,horizontal_loop_extent) + standard_name = surface_albedo_due_to_UV_and_VIS_direct + long_name = surface albedo due to UV+VIS direct beam + units = frac + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in [sfc_alb_uvvis_dif] - standard_name = surface_albedo_uvvis_diffuse - long_name = UVVIS (diffuse) surface albedo (sfc_alb_uvvis_dif) - units = none - dimensions = (number_of_shortwave_bands,horizontal_loop_extent) + standard_name = surface_albedo_due_to_UV_and_VIS_diffused + long_name = surface albedo due to UV+VIS diffused beam + units = frac + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in diff --git a/physics/GFS_rrtmgp_thompsonmp_pre.F90 b/physics/GFS_rrtmgp_thompsonmp_pre.F90 deleted file mode 100644 index 85877704f..000000000 --- a/physics/GFS_rrtmgp_thompsonmp_pre.F90 +++ /dev/null @@ -1,291 +0,0 @@ -! ######################################################################################## -! This module contains the interface between the THOMPSON macrophysics and the RRTMGP radiation -! schemes. Only compatable with Model%imp_physics = Model%imp_physics_thompson -! ######################################################################################## -module GFS_rrtmgp_thompsonmp_pre - use machine, only: & - kind_phys - use radiation_tools, only: & - check_error_msg - use module_mp_thompson, only: & - calc_effectRad, Nt_c, & - re_qc_min, re_qc_max, & - re_qi_min, re_qi_max, & - re_qs_min, re_qs_max - use module_mp_thompson_make_number_concentrations, only: & - make_IceNumber, & - make_DropletNumber, & - make_RainNumber - use rrtmgp_lw_cloud_optics, only: radliq_lwr => radliq_lwrLW, radliq_upr => radliq_uprLW,& - radice_lwr => radice_lwrLW, radice_upr => radice_uprLW - implicit none - - ! Parameters specific to THOMPSON MP scheme. - real(kind_phys), parameter :: & - rerain_def = 1000.0 ! Default rain radius to 1000 microns - - public GFS_rrtmgp_thompsonmp_pre_init, GFS_rrtmgp_thompsonmp_pre_run, GFS_rrtmgp_thompsonmp_pre_finalize - -contains - ! ###################################################################################### - ! ###################################################################################### - subroutine GFS_rrtmgp_thompsonmp_pre_init() - end subroutine GFS_rrtmgp_thompsonmp_pre_init - - ! ###################################################################################### - ! ###################################################################################### -!! \section arg_table_GFS_rrtmgp_thompsonmp_pre_run -!! \htmlinclude GFS_rrtmgp_thompsonmp_pre_run.html -!! - subroutine GFS_rrtmgp_thompsonmp_pre_run(nCol, nLev, nTracers, ncnd, doSWrad, doLWrad, & - i_cldliq, i_cldice, i_cldrain, i_cldsnow, i_cldgrpl, i_cldtot, i_cldliq_nc, & - i_cldice_nc, i_twa, effr_in, p_lev, p_lay, tv_lay, t_lay, effrin_cldliq, & - effrin_cldice, effrin_cldsnow, tracer, qs_lay, q_lay, relhum, con_g, con_rd, & - con_eps, lmfshal, ltaerosol, do_mynnedmf, imfdeepcnv, imfdeepcnv_gf, & - doGP_cldoptics_PADE, doGP_cldoptics_LUT, & - cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, & - cld_rerain, precip_frac, errmsg, errflg) - - ! Inputs - integer, intent(in) :: & - nCol, & ! Number of horizontal grid points - nLev, & ! Number of vertical layers - ncnd, & ! Number of cloud condensation types. - nTracers, & ! Number of tracers from model. - i_cldliq, & ! Index into tracer array for cloud liquid amount. - i_cldice, & ! cloud ice amount. - i_cldrain, & ! cloud rain amount. - i_cldsnow, & ! cloud snow amount. - i_cldgrpl, & ! cloud groupel amount. - i_cldtot, & ! cloud total amount. - i_cldliq_nc, & ! cloud liquid number concentration. - i_cldice_nc, & ! cloud ice number concentration. - i_twa, & ! water friendly aerosol. - imfdeepcnv, & ! Choice of mass-flux deep convection scheme - imfdeepcnv_gf ! Flag for Grell-Freitas deep convection scheme - logical, intent(in) :: & - doSWrad, & ! Call SW radiation? - doLWrad, & ! Call LW radiation - effr_in, & ! Use cloud effective radii provided by model? - lmfshal, & ! Flag for mass-flux shallow convection scheme used by Xu-Randall - ltaerosol, & ! Flag for aerosol option - do_mynnedmf, & ! Flag to activate MYNN-EDMF - doGP_cldoptics_LUT,& ! Flag to do GP cloud-optics (LUTs) - doGP_cldoptics_PADE ! (PADE approximation) - real(kind_phys), intent(in) :: & - con_g, & ! Physical constant: gravitational constant - con_rd, & ! Physical constant: gas-constant for dry air - con_eps ! Physical constant: gas constant air / gas constant H2O - - real(kind_phys), dimension(:,:), intent(in) :: & - tv_lay, & ! Virtual temperature (K) - t_lay, & ! Temperature (K) - qs_lay, & ! Saturation vapor pressure (Pa) - q_lay, & ! water-vapor mixing ratio (kg/kg) - relhum, & ! Relative humidity - p_lay ! Pressure at model-layers (Pa) - real(kind_phys), dimension(:,:), intent(in) :: & - p_lev ! Pressure at model-level interfaces (Pa) - real(kind_phys), dimension(:,:,:),intent(in) :: & - tracer ! Cloud condensate amount in layer by type () - - ! In/Outs - real(kind_phys), dimension(:,:), intent(inout) :: & - cld_frac, & ! Total cloud fraction - cld_lwp, & ! Cloud liquid water path - cld_reliq, & ! Cloud liquid effective radius - cld_iwp, & ! Cloud ice water path - cld_reice, & ! Cloud ice effecive radius - cld_swp, & ! Cloud snow water path - cld_resnow, & ! Cloud snow effective radius - cld_rwp, & ! Cloud rain water path - cld_rerain, & ! Cloud rain effective radius - precip_frac, & ! Precipitation fraction - effrin_cldliq, & ! Effective radius for liquid cloud-particles (microns) - effrin_cldice, & ! Effective radius for ice cloud-particles (microns) - effrin_cldsnow ! Effective radius for snow cloud-particles (microns) - - ! Outputs - character(len=*), intent(out) :: & - errmsg ! Error message - integer, intent(out) :: & - errflg ! Error flag - - ! Local variables - real(kind_phys) :: alpha0, pfac, tem1, cld_mr - real(kind_phys), dimension(nCol, nLev, min(4,ncnd)) :: cld_condensate - integer :: iCol,iLay,l - real(kind_phys) :: rho, orho - real(kind_phys), dimension(nCol,nLev) :: deltaP, deltaZ, re_cloud, re_ice,& - re_snow, qv_mp, qc_mp, qi_mp, qs_mp, nc_mp, ni_mp, nwfa - logical :: top_at_1 - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (.not. (doSWrad .or. doLWrad)) return - - ! Cloud condensate - cld_condensate(1:nCol,1:nLev,1) = tracer(1:nCol,1:nLev,i_cldliq) ! -liquid water - cld_condensate(1:nCol,1:nLev,2) = tracer(1:nCol,1:nLev,i_cldice) ! -ice water - cld_condensate(1:nCol,1:nLev,3) = tracer(1:nCol,1:nLev,i_cldrain) ! -rain water - cld_condensate(1:nCol,1:nLev,4) = tracer(1:nCol,1:nLev,i_cldsnow) + &! -snow + grapuel - tracer(1:nCol,1:nLev,i_cldgrpl) - - ! Cloud water path (g/m2) - deltaP = abs(p_lev(:,2:nLev+1)-p_lev(:,1:nLev))/100. - do iLay = 1, nLev - do iCol = 1, nCol - ! Compute liquid/ice condensate path from mixing ratios (kg/kg)->(g/m2) - tem1 = (1.0e5/con_g) * deltaP(iCol,iLay) - cld_lwp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,1) * tem1) - cld_iwp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,2) * tem1) - cld_rwp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,3) * tem1) - cld_swp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,4) * tem1) - enddo - enddo - - ! Cloud particle sizes and number concentrations... - - ! Prepare cloud mixing-ratios and number concentrations for calc_effectRad, - ! and update number concentrations, consistent with sub-grid clouds - do iLay = 1, nLev - do iCol = 1, nCol - qv_mp(iCol,iLay) = q_lay(iCol,iLay)/(1.-q_lay(iCol,iLay)) - rho = con_eps*p_lay(iCol,iLay)/(con_rd*t_lay(iCol,iLay)*(qv_mp(iCol,iLay)+con_eps)) - orho = 1./rho - qc_mp(iCol,iLay) = tracer(iCol,iLay,i_cldliq) / (1.-q_lay(iCol,iLay)) - qi_mp(iCol,iLay) = tracer(iCol,iLay,i_cldice) / (1.-q_lay(iCol,iLay)) - qs_mp(iCol,iLay) = tracer(iCol,iLay,i_cldsnow) / (1.-q_lay(iCol,iLay)) - ni_mp(iCol,iLay) = tracer(iCol,iLay,i_cldice_nc) / (1.-q_lay(iCol,iLay)) - if (ltaerosol) then - nc_mp(iCol,iLay) = tracer(iCol,iLay,i_cldliq_nc) / (1.-q_lay(iCol,iLay)) - nwfa(iCol,iLay) = tracer(iCol,iLay,i_twa) - if (qc_mp(iCol,iLay) > 1.e-12 .and. nc_mp(iCol,iLay) < 100.) then - nc_mp(iCol,iLay) = make_DropletNumber(qc_mp(iCol,iLay)*rho, nwfa(iCol,iLay)*rho) * orho - endif - else - nc_mp(iCol,iLay) = nt_c*orho - endif - if (qi_mp(iCol,iLay) > 1.e-12 .and. ni_mp(iCol,iLay) < 100.) then - ni_mp(iCol,iLay) = make_IceNumber(qi_mp(iCol,iLay)*rho, t_lay(iCol,iLay)) * orho - endif - enddo - enddo - - ! Compute effective radii for liquid/ice/snow using subgrid scale clouds - ! Call Thompson's subroutine to compute effective radii - do iCol=1,nCol - call calc_effectRad (t_lay(iCol,:), p_lay(iCol,:), qv_mp(iCol,:), qc_mp(iCol,:), & - nc_mp(iCol,:), qi_mp(iCol,:), ni_mp(iCol,:), qs_mp(iCol,:), & - re_cloud(iCol,:), re_ice(iCol,:), re_snow(iCol,:), 1, nLev ) - do iLay = 1, nLev - re_cloud(iCol,iLay) = MAX(re_qc_min, MIN(re_cloud(iCol,iLay), re_qc_max)) - re_ice(iCol,iLay) = MAX(re_qi_min, MIN(re_ice(iCol,iLay), re_qi_max)) - re_snow(iCol,iLay) = MAX(re_qs_min, MIN(re_snow(iCol,iLay), re_qs_max)) - enddo - enddo - - ! Scale Thompson's effective radii from meter to micron - do iLay = 1, nLev - do iCol = 1, nCol - effrin_cldliq(iCol,iLay) = re_cloud(iCol,iLay)*1.e6 - effrin_cldice(iCol,iLay) = re_ice(iCol,iLay)*1.e6 - effrin_cldsnow(iCol,iLay) = re_snow(iCol,iLay)*1.e6 - enddo - enddo - - ! Bound effective radii for RRTMGP, LUT's for cloud-optics go from - ! 2.5 - 21.5 microns for liquid clouds, - ! 10 - 180 microns for ice-clouds - if (doGP_cldoptics_PADE .or. doGP_cldoptics_LUT) then - do iLay = 1, nLev - do iCol = 1, nCol - if (effrin_cldliq(iCol,iLay) .lt. radliq_lwr) effrin_cldliq(iCol,iLay) = radliq_lwr - if (effrin_cldliq(iCol,iLay) .gt. radliq_upr) effrin_cldliq(iCol,iLay) = radliq_upr - if (effrin_cldice(iCol,iLay) .lt. radice_lwr) effrin_cldice(iCol,iLay) = radice_lwr - if (effrin_cldice(iCol,iLay) .gt. radice_upr) effrin_cldice(iCol,iLay) = radice_upr - enddo - enddo - endif - - ! Update global effective radii arrays. - do iLay = 1, nLev - do iCol = 1, nCol - cld_reliq(iCol,iLay) = effrin_cldliq(iCol,iLay) - cld_reice(iCol,iLay) = effrin_cldice(iCol,iLay) - cld_resnow(iCol,iLay) = effrin_cldsnow(iCol,iLay) - cld_rerain(iCol,iLay) = rerain_def - enddo - enddo - ! Compute cloud-fraction. Else, use value provided - if(.not. do_mynnedmf .and. imfdeepcnv .ne. imfdeepcnv_gf ) then ! MYNN PBL or GF conv - ! Cloud-fraction - if( lmfshal) alpha0 = 100. ! Default (from GATE simulations) - if(.not. lmfshal) alpha0 = 2000. - ! Xu-Randall (1996) cloud-fraction - do iLay = 1, nLev - do iCol = 1, nCol - cld_mr = cld_condensate(iCol,iLay,1) + cld_condensate(iCol,iLay,2) + & - cld_condensate(iCol,iLay,4) - cld_frac(iCol,iLay) = cld_frac_XuRandall(p_lay(iCol,iLay), & - qs_lay(iCol,iLay), relhum(iCol,iLay), cld_mr, alpha0) - enddo - enddo - endif - - ! Precipitation fraction (Hack. For now use cloud-fraction) - precip_frac(1:nCol,1:nLev) = cld_frac(1:nCol,1:nLev) - - end subroutine GFS_rrtmgp_thompsonmp_pre_run - - ! ###################################################################################### - ! ###################################################################################### - subroutine GFS_rrtmgp_thompsonmp_pre_finalize() - end subroutine GFS_rrtmgp_thompsonmp_pre_finalize - - ! ###################################################################################### - ! This function computes the cloud-fraction following. - ! Xu-Randall(1996) A Semiempirical Cloudiness Parameterization for Use in Climate Models - ! https://doi.org/10.1175/1520-0469(1996)053<3084:ASCPFU>2.0.CO;2 - ! - ! cld_frac = {1-exp[-alpha*cld_mr/((1-relhum)*qs_lay)**lambda]}*relhum**P - ! - ! ###################################################################################### - function cld_frac_XuRandall(p_lay, qs_lay, relhum, cld_mr, alpha) - - ! Inputs - real(kind_phys), intent(in) :: & - p_lay, & ! Pressure (Pa) - qs_lay, & ! Saturation vapor-pressure (Pa) - relhum, & ! Relative humidity - cld_mr, & ! Total cloud mixing ratio - alpha ! Scheme parameter (default=100) - - ! Outputs - real(kind_phys) :: cld_frac_XuRandall - - ! Locals - real(kind_phys) :: clwt, clwm, onemrh, tem1, tem2, tem3 - - ! Parameters - real(kind_phys) :: & - lambda = 0.50, & ! - P = 0.25 - - clwt = 1.0e-6 * (p_lay*0.001) - if (cld_mr > clwt) then - onemrh = max(1.e-10, 1.0 - relhum) - tem1 = alpha / min(max((onemrh*qs_lay)**lambda,0.0001),1.0) - tem2 = max(min(tem1*(cld_mr - clwt), 50.0 ), 0.0 ) - tem3 = sqrt(sqrt(relhum)) ! This assumes "p" = 0.25. Identical, but cheaper than relhum**p - ! - cld_frac_XuRandall = max( tem3*(1.0-exp(-tem2)), 0.0 ) - else - cld_frac_XuRandall = 0.0 - endif - - return - end function -end module GFS_rrtmgp_thompsonmp_pre diff --git a/physics/GFS_rrtmgp_zhaocarr_pre.F90 b/physics/GFS_rrtmgp_zhaocarr_pre.F90 deleted file mode 100644 index d7eecd090..000000000 --- a/physics/GFS_rrtmgp_zhaocarr_pre.F90 +++ /dev/null @@ -1,253 +0,0 @@ -! ######################################################################################## -! This module contains the interface between the Zhao-Carr macrophysics and the RRTMGP -! radiation schemes. Only compatable with imp_physics = imp_physics_zhaocarr -! ######################################################################################## -module GFS_rrtmgp_zhaocarr_pre - use machine, only: kind_phys - use radiation_tools, only: check_error_msg - use funcphys, only: fpvs - use module_radiation_clouds, only: get_alpha_dcorr - - ! Zhao-Carr MP parameters. - real(kind_phys), parameter :: & - reliq_def = 10.0 , & ! Default liq radius to 10 micron - reice_def = 50.0, & ! Default ice radius to 50 micron - rerain_def = 1000.0, & ! Default rain radius to 1000 micron - resnow_def = 250.0 ! Default snow radius to 250 micron - - public GFS_rrtmgp_zhaocarr_pre_init, GFS_rrtmgp_zhaocarr_pre_run, GFS_rrtmgp_zhaocarr_pre_finalize - -contains - ! ###################################################################################### - ! ###################################################################################### - subroutine GFS_rrtmgp_zhaocarr_pre_init() - end subroutine GFS_rrtmgp_zhaocarr_pre_init - - ! ###################################################################################### - ! ###################################################################################### -!! \section arg_table_GFS_rrtmgp_zhaocarr_pre_run -!! \htmlinclude GFS_rrtmgp_zhaocarr_pre_run.html -!! - subroutine GFS_rrtmgp_zhaocarr_pre_run(nCol, nLev, nCnd, nTracers, i_cldliq, lsswr, & - lslwr, effr_in, uni_cld, lmfshal, lat, lsmask, p_lev, p_lay, t_lay, relhum, & - tv_lay, effrin_cldliq, effrin_cldice, effrin_cldrain, effrin_cldsnow, & - shoc_sgs_cldfrac, cncvw, tracer, & - con_ttp, con_epsq, con_epsqs, con_eps, con_epsm1, con_g, con_rd, con_pi, & - cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, & - cld_rerain, deltaZ, de_lgth, cloud_overlap_param, errmsg, errflg) - implicit none - - ! Inputs - integer, intent(in) :: & - nCol, & ! Number of horizontal grid points - nLev, & ! Number of vertical layers - nCnd, & ! Number of cloud condensation types. - nTracers, & ! Number of tracers from model. - i_cldliq ! Index into tracer array for cloud liquid. - logical, intent(in) :: & - lsswr, & ! Call SW radiation? - lslwr, & ! Call LW radiation - effr_in, & ! Provide hydrometeor radii from macrophysics? - uni_cld, & ! - lmfshal - real(kind_phys), intent(in) :: & - con_eps, & ! rd/rv - con_epsm1, & ! (rd/rv) - 1 - con_epsq, & ! Floor value for specific humidity - con_epsqs, & ! Floor value for saturation mixing ratio - con_g, & ! Gravitational acceleration (m/s2) - con_ttp, & ! Triple point temperature of water (K) - con_rd, & ! Ideal gas constant for dry air (J/kg/K) - con_pi ! Pi - real(kind_phys), dimension(:), intent(in) :: & - lsmask, & ! Land/Sea mask - lat ! Latitude - real(kind_phys), dimension(:, :), intent(in) :: & - tv_lay, & ! Virtual temperature (K) - p_lay, & ! Pressure at model-layers (Pa) - t_lay, & ! Temperature at model-layers (K) - relhum, & ! Relative humidity at model-layers () - effrin_cldliq, & ! Effective radius for liquid cloud-particles (microns) - effrin_cldice, & ! Effective radius for ice cloud-particles (microns) - effrin_cldrain, & ! Effective radius for rain cloud-particles (microns) - effrin_cldsnow, & ! Effective radius for snow cloud-particles (microns) - shoc_sgs_cldfrac, & ! Subgrid-scale cloud fraction from the SHOC scheme - cncvw ! Convective cloud water mixing ratio (kg/kg) - real(kind_phys), dimension(:, :), intent(in) :: & - p_lev ! Pressure at model-level interfaces (Pa) - real(kind_phys), dimension(:, :, :),intent(in) :: & - tracer ! Cloud condensate amount in layer by type () - - ! Outputs - real(kind_phys), dimension(:),intent(out) :: & - de_lgth ! Decorrelation length - real(kind_phys), dimension(:, :),intent(out) :: & - cld_frac, & ! Total cloud fraction - cld_lwp, & ! Cloud liquid water path - cld_reliq, & ! Cloud liquid effective radius - cld_iwp, & ! Cloud ice water path - cld_reice, & ! Cloud ice effecive radius - cld_swp, & ! Cloud snow water path - cld_resnow, & ! Cloud snow effective radius - cld_rwp, & ! Cloud rain water path - cld_rerain, & ! Cloud rain effective radius - deltaZ, & ! Layer thickness (km) - cloud_overlap_param ! Cloud-overlap parameter - character(len=*), intent(out) :: & - errmsg ! Error message - integer, intent(out) :: & - errflg ! Error flag - - ! Local variables - real(kind_phys) :: tem1,tem2,tem3,clwt,onemrh,clwm,clwmin,es,qs,value - real(kind_phys), dimension(nCol, nLev, min(4,nCnd)) :: cld_condensate - integer :: iCol,iLay - real(kind_phys), dimension(nCol,nLev) :: deltaP - - if (.not. (lsswr .or. lslwr)) return - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - ! Initialize outputs - cld_lwp(:,:) = 0.0 - cld_reliq(:,:) = 0.0 - cld_iwp(:,:) = 0.0 - cld_reice(:,:) = 0.0 - cld_rwp(:,:) = 0.0 - cld_rerain(:,:) = 0.0 - cld_swp(:,:) = 0.0 - cld_resnow(:,:) = 0.0 - - ! #################################################################################### - ! Pull out cloud information for Zhao-Carr MP scheme. - ! #################################################################################### - ! Condensate - cld_condensate(1:nCol,1:nLev,1) = tracer(1:nCol,1:nLev,i_cldliq) ! Liquid water - - ! Set really tiny suspended particle amounts to clear - do iLay=1,nLev - do iCol=1,nCol - if (cld_condensate(iCol,iLay,1) < con_epsq) cld_condensate(iCol,iLay,1) = 0.0 - enddo - enddo - - ! Use radii provided from the macrophysics? - if (effr_in) then - cld_reliq(1:nCol,1:nLev) = effrin_cldliq(1:nCol,1:nLev) - cld_reice(1:nCol,1:nLev) = effrin_cldice(1:nCol,1:nLev) - cld_rerain(1:nCol,1:nLev) = effrin_cldrain(1:nCol,1:nLev) - cld_resnow(1:nCol,1:nLev) = effrin_cldsnow(1:nCol,1:nLev) - endif - - ! Use cloud-fraction from SHOC? - if (uni_cld) then - cld_frac(1:nCol,1:nLev) = shoc_sgs_cldfrac(1:nCol,1:nLev) - ! Compute cloud-fraction? - else - clwmin = 0.0e-6 - if (.not. lmfshal) then - do iLay = 1,nLev - do iCol = 1, nCol - es = min( p_lay(iCol,iLay), fpvs( t_lay(iCol,iLay) ) ) ! fpvs and prsl in pa - qs = max( con_epsqs, con_eps * es / (p_lay(iCol,iLay) + con_epsm1*es) ) - clwt = 1.0e-6 * (p_lay(iCol,iLay)*0.00001) - if (cld_condensate(iCol,iLay,1) > clwt) then - onemrh= max( 1.e-10, 1.0-relhum(iCol,iLay) ) - clwm = clwmin / max( 0.01, p_lay(iCol,iLay)*0.00001 ) - tem1 = min(max(sqrt(sqrt(onemrh*qs)),0.0001),1.0) - tem1 = 2000.0 / tem1 - value = max( min( tem1*(cld_condensate(iCol,iLay,1)-clwm), 50.0 ), 0.0 ) - tem2 = sqrt( sqrt(relhum(iCol,iLay)) ) - cld_frac(iCol,iLay) = max( tem2*(1.0-exp(-value)), 0.0 ) - endif - enddo - enddo - else - do iLay=1,nLev - do iCol = 1, nCol - es = min( p_lay(iCol,iLay), fpvs( t_lay(iCol,iLay) ) ) ! fpvs and prsl in pa - qs = max( con_epsqs, con_eps * es / (p_lay(iCol,iLay) + con_epsm1*es) ) - clwt = 1.0e-6 * (p_lay(iCol,iLay)*0.00001) - if (cld_condensate(iCol,iLay,1) > clwt) then - onemrh= max( 1.e-10, 1.0-relhum(iCol,iLay) ) - clwm = clwmin / max( 0.01, p_lay(iCol,iLay)*0.00001 ) - tem1 = min(max((onemrh*qs)**0.49,0.0001),1.0) !jhan - tem1 = 100.0 / tem1 - value = max( min( tem1*(cld_condensate(iCol,iLay,1)-clwm), 50.0 ), 0.0 ) - tem2 = sqrt( sqrt(relhum(iCol,iLay)) ) - cld_frac(iCol,iLay) = max( tem2*(1.0-exp(-value)), 0.0 ) - endif - enddo - enddo - endif - endif - - ! Add suspended convective cloud water to grid-scale cloud water only for cloud - ! fraction & radiation computation it is to enhance cloudiness due to suspended convec - ! cloud water for zhao/moorthi's (imp_phys=99) - cld_condensate(1:nCol,1:nLev,1) = cld_condensate(1:nCol,1:nLev,1) + cncvw(1:nCol,1:nLev) - - ! Compute cloud liquid/ice condensate path. - deltaP = abs(p_lev(:,2:nLev+1)-p_lev(:,1:nLev))/100. - do iLay=1,nLev - do iCol=1,nCol - tem1 = max(0.0, cld_condensate(iCol,iLay,1)) * (1.0e5/con_g) * deltaP(iCol,iLay) - cld_iwp(iCol,iLay) = tem1*(t_lay(iCol,iLay) - 273.16) - cld_lwp(iCol,iLay) = tem1 - cld_iwp(iCol,iLay) - enddo - enddo - - ! Compute effective liquid cloud droplet radius over land. - if(.not. effr_in) then - do iCol = 1, nCol - if (nint(lsmask(iCol)) == 1) then - do iLay = 1, nLev - cld_reliq(iCol,iLay) = 5.0 + 5.0 * (t_lay(iCol,iLay) - 273.16) - enddo - endif - enddo - - ! Compute effective ice cloud droplet radius following Heymsfield - ! and McFarquhar (1996) \cite heymsfield_and_mcfarquhar_1996. - do iLay=1,nLev - do iCol=1,nCol - tem2 = t_lay(iCol,iLay) - con_ttp - if (cld_iwp(iCol,iLay) > 0.0) then - tem3 = (con_g/con_rd ) * cld_iwp(iCol,iLay) * (0.01*p_lay(iCol,iLay)) / (deltaP(iCol,iLay)*tv_lay(iCol,iLay)) - if (tem2 < -50.0) then - cld_reice(iCol,iLay) = (1250.0/9.917) * tem3 ** 0.109 - elseif (tem2 < -40.0) then - cld_reice(iCol,iLay) = (1250.0/9.337) * tem3 ** 0.08 - elseif (tem2 < -30.0) then - cld_reice(iCol,iLay) = (1250.0/9.208) * tem3 ** 0.055 - else - cld_reice(iCol,iLay) = (1250.0/9.387) * tem3 ** 0.031 - endif - cld_reice(iCol,iLay) = max(10.0, min(cld_reice(iCol,iLay), 150.0)) - endif - enddo - enddo - endif - - ! #################################################################################### - ! Cloud (and precipitation) overlap ! #################################################################################### - ! Compute layer-thickness - do iCol=1,nCol - do iLay=1,nLev - deltaZ(iCol,iLay) = ((con_rd/con_g)*0.001) * abs(log(p_lev(iCol,iLay)) - log(p_lev(iCol,iLay+1))) * tv_lay(iCol,iLay) - enddo - enddo - - ! Cloud overlap parameter - call get_alpha_dcorr(nCol, nLev, lat, con_pi, deltaZ, de_lgth, cloud_overlap_param) - - end subroutine GFS_rrtmgp_zhaocarr_pre_run - - ! ######################################################################################### - ! ######################################################################################### - subroutine GFS_rrtmgp_zhaocarr_pre_finalize() - end subroutine GFS_rrtmgp_zhaocarr_pre_finalize - -end module GFS_rrtmgp_zhaocarr_pre diff --git a/physics/GFS_rrtmgp_zhaocarr_pre.meta b/physics/GFS_rrtmgp_zhaocarr_pre.meta deleted file mode 100644 index 2eb333115..000000000 --- a/physics/GFS_rrtmgp_zhaocarr_pre.meta +++ /dev/null @@ -1,366 +0,0 @@ -[ccpp-table-properties] - name = GFS_rrtmgp_zhaocarr_pre - type = scheme - dependencies = radiation_tools.F90 - -######################################################################## -[ccpp-arg-table] - name = GFS_rrtmgp_zhaocarr_pre_run - type = scheme -[ncol] - standard_name = horizontal_loop_extent - long_name = horizontal dimension - units = count - dimensions = () - type = integer - intent = in -[nLev] - standard_name = vertical_layer_dimension - long_name = number of vertical levels - units = count - dimensions = () - type = integer - intent = in -[ncnd] - standard_name = number_of_condensate_species - long_name = number of cloud condensate types - units = count - dimensions = () - type = integer - intent = in -[nTracers] - standard_name = number_of_tracers - long_name = number of tracers - units = count - dimensions = () - type = integer - intent = in -[i_cldliq] - standard_name = index_of_cloud_liquid_water_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for cloud condensate (or liquid water) - units = index - dimensions = () - type = integer - intent = in -[lsswr] - standard_name = flag_for_calling_shortwave_radiation - long_name = logical flags for sw radiation calls - units = flag - dimensions = () - type = logical - intent = in -[lslwr] - standard_name = flag_for_calling_longwave_radiation - long_name = logical flags for lw radiation calls - units = flag - dimensions = () - type = logical - intent = in -[effr_in] - standard_name = flag_for_cloud_effective_radii - long_name = flag for cloud effective radii calculations in GFDL microphysics - units = flag - dimensions = () - type = logical - intent = in -[uni_cld] - standard_name = flag_for_shoc_cloud_area_fraction_for_radiation - long_name = flag for uni_cld - units = flag - dimensions = () - type = logical - intent = in -[lmfshal] - standard_name = flag_for_cloud_area_fraction_option_for_radiation - long_name = flag for lmfshal - units = flag - dimensions = () - type = logical - intent = in -[lat] - standard_name = latitude - long_name = latitude - units = radian - dimensions = (horizontal_loop_extent) - type = real - intent = in - kind = kind_phys -[lsmask] - standard_name = area_type - long_name = landmask: sea/land/ice=0/1/2 - units = flag - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[p_lev] - standard_name = air_pressure_at_interface_for_RRTMGP - long_name = air pressure at vertical interface for radiation calculation - units = Pa - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = in -[p_lay] - standard_name = air_pressure_at_layer_for_RRTMGP - long_name = air pressure at vertical layer for radiation calculation - units = Pa - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[t_lay] - standard_name = air_temperature_at_layer_for_RRTMGP - long_name = air temperature at vertical layer for radiation calculation - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[relhum] - standard_name = relative_humidity - long_name = layer relative humidity - units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[tv_lay] - standard_name = virtual_temperature - long_name = layer virtual temperature - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[effrin_cldliq] - standard_name = effective_radius_of_stratiform_cloud_liquid_water_particle - long_name = eff. radius of cloud liquid water particle in micrometer - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[effrin_cldice] - standard_name = effective_radius_of_stratiform_cloud_ice_particle - long_name = eff. radius of cloud ice water particle in micrometer - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[effrin_cldrain] - standard_name = effective_radius_of_stratiform_cloud_rain_particle - long_name = effective radius of cloud rain particle in micrometers - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[effrin_cldsnow] - standard_name = effective_radius_of_stratiform_cloud_snow_particle - long_name = effective radius of cloud snow particle in micrometers - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[shoc_sgs_cldfrac] - standard_name = subgrid_scale_cloud_fraction_from_shoc - long_name = subgrid-scale cloud fraction from the SHOC scheme - units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cncvw] - standard_name = convective_cloud_condensate_mixing_ratio - long_name = convective cloud water mixing ratio in the phy_f3d array - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[tracer] - standard_name = chemical_tracers - long_name = chemical tracers - units = g g-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = in -[con_ttp] - standard_name = triple_point_temperature_of_water - long_name = triple point temperature of water - units = K - dimensions = () - type = real - kind = kind_phys - intent = in -[con_epsq] - standard_name = minimum_value_of_specific_humidity - long_name = floor value for specific humidity - units = kg kg-1 - dimensions = () - type = real - kind = kind_phys - intent = in -[con_epsqs] - standard_name = minimum_value_of_saturation_mixing_ratio - long_name = floor value for saturation mixing ratio - units = kg kg-1 - dimensions = () - type = real - kind = kind_phys - intent = in -[con_eps] - standard_name = ratio_of_dry_air_to_water_vapor_gas_constants - long_name = rd/rv - units = none - dimensions = () - type = real - kind = kind_phys - intent = in -[con_epsm1] - standard_name = ratio_of_dry_air_to_water_vapor_gas_constants_minus_one - long_name = (rd/rv) - 1 - units = none - dimensions = () - type = real - kind = kind_phys - intent = in -[con_g] - standard_name = gravitational_acceleration - long_name = gravitational acceleration - units = m s-2 - dimensions = () - type = real - kind = kind_phys - intent = in -[con_rd] - standard_name = gas_constant_of_dry_air - long_name = ideal gas constant for dry air - units = J kg-1 K-1 - dimensions = () - type = real - kind = kind_phys - intent = in -[con_pi] - standard_name = pi - long_name = ratio of a circle's circumference to its diameter - units = none - dimensions = () - type = real - kind = kind_phys - intent = in -[cld_frac] - standard_name = total_cloud_fraction - long_name = layer total cloud fraction - units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[cld_lwp] - standard_name = cloud_liquid_water_path - long_name = layer cloud liquid water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[cld_reliq] - standard_name = mean_effective_radius_for_liquid_cloud - long_name = mean effective radius for liquid cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[cld_iwp] - standard_name = cloud_ice_water_path - long_name = layer cloud ice water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[cld_reice] - standard_name = mean_effective_radius_for_ice_cloud - long_name = mean effective radius for ice cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[cld_swp] - standard_name = cloud_snow_water_path - long_name = layer cloud snow water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[cld_resnow] - standard_name = mean_effective_radius_for_snow_flake - long_name = mean effective radius for snow cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[cld_rwp] - standard_name = cloud_rain_water_path - long_name = layer cloud rain water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[cld_rerain] - standard_name = mean_effective_radius_for_rain_drop - long_name = mean effective radius for rain cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[deltaZ] - standard_name = layer_thickness - long_name = layer_thickness - units = m - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[de_lgth] - standard_name = cloud_decorrelation_length - long_name = cloud decorrelation length - units = km - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[cloud_overlap_param] - standard_name = cloud_overlap_param - long_name = cloud overlap parameter - units = km - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out diff --git a/physics/GFS_suite_interstitial.F90 b/physics/GFS_suite_interstitial.F90 deleted file mode 100644 index 6963e94c3..000000000 --- a/physics/GFS_suite_interstitial.F90 +++ /dev/null @@ -1,972 +0,0 @@ -!> \file GFS_suite_interstitial.f90 -!! Contains code related to more than one scheme in the GFS physics suite. - - module GFS_suite_interstitial_rad_reset - - contains - - subroutine GFS_suite_interstitial_rad_reset_init () - end subroutine GFS_suite_interstitial_rad_reset_init - - subroutine GFS_suite_interstitial_rad_reset_finalize() - end subroutine GFS_suite_interstitial_rad_reset_finalize - -!> \section arg_table_GFS_suite_interstitial_rad_reset_run Argument Table -!! \htmlinclude GFS_suite_interstitial_rad_reset_run.html -!! - subroutine GFS_suite_interstitial_rad_reset_run (Interstitial, Model, errmsg, errflg) - - use machine, only: kind_phys - use GFS_typedefs, only: GFS_control_type, GFS_interstitial_type - - implicit none - - ! interface variables - type(GFS_interstitial_type), intent(inout) :: Interstitial - type(GFS_control_type), intent(in) :: Model - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - errmsg = '' - errflg = 0 - - call Interstitial%rad_reset(Model) - - end subroutine GFS_suite_interstitial_rad_reset_run - - end module GFS_suite_interstitial_rad_reset - - - module GFS_suite_interstitial_phys_reset - - contains - - subroutine GFS_suite_interstitial_phys_reset_init () - end subroutine GFS_suite_interstitial_phys_reset_init - - subroutine GFS_suite_interstitial_phys_reset_finalize() - end subroutine GFS_suite_interstitial_phys_reset_finalize - -!> \section arg_table_GFS_suite_interstitial_phys_reset_run Argument Table -!! \htmlinclude GFS_suite_interstitial_phys_reset_run.html -!! - subroutine GFS_suite_interstitial_phys_reset_run (Interstitial, Model, errmsg, errflg) - - use machine, only: kind_phys - use GFS_typedefs, only: GFS_control_type, GFS_interstitial_type - - implicit none - - ! interface variables - type(GFS_interstitial_type), intent(inout) :: Interstitial - type(GFS_control_type), intent(in ) :: Model - character(len=*), intent( out) :: errmsg - integer, intent( out) :: errflg - - errmsg = '' - errflg = 0 - - call Interstitial%phys_reset(Model) - - end subroutine GFS_suite_interstitial_phys_reset_run - - end module GFS_suite_interstitial_phys_reset - - - module GFS_suite_interstitial_1 - - contains - - subroutine GFS_suite_interstitial_1_init () - end subroutine GFS_suite_interstitial_1_init - - subroutine GFS_suite_interstitial_1_finalize() - end subroutine GFS_suite_interstitial_1_finalize - -!> \section arg_table_GFS_suite_interstitial_1_run Argument Table -!! \htmlinclude GFS_suite_interstitial_1_run.html -!! - subroutine GFS_suite_interstitial_1_run (im, levs, ntrac, dtf, dtp, slmsk, area, dxmin, dxinv, pgr, & - islmsk, work1, work2, psurf, dudt, dvdt, dtdt, dqdt, errmsg, errflg) - - use machine, only: kind_phys - - implicit none - - ! interface variables - integer, intent(in ) :: im, levs, ntrac - real(kind=kind_phys), intent(in ) :: dtf, dtp, dxmin, dxinv - real(kind=kind_phys), intent(in ), dimension(:) :: slmsk, area, pgr - - integer, intent(out), dimension(:) :: islmsk - real(kind=kind_phys), intent(out), dimension(:) :: work1, work2, psurf - real(kind=kind_phys), intent(out), dimension(:,:) :: dudt, dvdt, dtdt - real(kind=kind_phys), intent(out), dimension(:,:,:) :: dqdt - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! local variables - real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys - integer :: i, k, n - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - do i = 1, im - islmsk(i) = nint(slmsk(i)) - - work1(i) = (log(area(i)) - dxmin) * dxinv - work1(i) = max(zero, min(one, work1(i))) - work2(i) = one - work1(i) - psurf(i) = pgr(i) - end do - - do k=1,levs - do i=1,im - dudt(i,k) = zero - dvdt(i,k) = zero - dtdt(i,k) = zero - enddo - enddo - do n=1,ntrac - do k=1,levs - do i=1,im - dqdt(i,k,n) = zero - enddo - enddo - enddo - - end subroutine GFS_suite_interstitial_1_run - - end module GFS_suite_interstitial_1 - - - module GFS_suite_interstitial_2 - - use machine, only: kind_phys - real(kind=kind_phys), parameter :: one = 1.0_kind_phys - logical :: linit_mod = .false. - - contains - - subroutine GFS_suite_interstitial_2_init () - end subroutine GFS_suite_interstitial_2_init - - subroutine GFS_suite_interstitial_2_finalize() - end subroutine GFS_suite_interstitial_2_finalize - -!> \section arg_table_GFS_suite_interstitial_2_run Argument Table -!! \htmlinclude GFS_suite_interstitial_2_run.html -!! - subroutine GFS_suite_interstitial_2_run (im, levs, lssav, ldiag3d, lsidea, flag_cice, shal_cnv, old_monin, mstrat, & - do_shoc, frac_grid, imfshalcnv, dtf, xcosz, adjsfcdsw, adjsfcdlw, cice, pgr, ulwsfc_cice, lwhd, htrsw, htrlw, xmu, ctei_rm, & - work1, work2, prsi, tgrs, prsl, qgrs_water_vapor, qgrs_cloud_water, cp, hvap, prslk, suntim, adjsfculw, adjsfculw_lnd, & - adjsfculw_ice, adjsfculw_wat, dlwsfc, ulwsfc, psmean, dtend, dtidx, index_of_process_longwave, index_of_process_shortwave, & - index_of_process_pbl, index_of_process_dcnv, index_of_process_scnv, index_of_process_mp, index_of_temperature, & - ctei_rml, ctei_r, kinver, dry, icy, wet, frland, huge, use_LW_jacobian, htrlwu, errmsg, errflg) - - implicit none - - ! interface variables - integer, intent(in ) :: im, levs, imfshalcnv - logical, intent(in ) :: lssav, ldiag3d, lsidea, shal_cnv - logical, intent(in ) :: old_monin, mstrat, do_shoc, frac_grid, use_LW_jacobian - real(kind=kind_phys), intent(in ) :: dtf, cp, hvap - - logical, intent(in ), dimension(:) :: flag_cice - real(kind=kind_phys), intent(in ), dimension(:) :: ctei_rm - real(kind=kind_phys), intent(in ), dimension(:) :: xcosz, adjsfcdsw, adjsfcdlw, pgr, xmu, work1, work2 - real(kind=kind_phys), intent(in ), dimension(:) :: ulwsfc_cice - real(kind=kind_phys), intent(in ), dimension(:) :: cice - real(kind=kind_phys), intent(in ), dimension(:,:) :: htrsw, htrlw, htrlwu, tgrs, prsl, qgrs_water_vapor, qgrs_cloud_water, prslk - real(kind=kind_phys), intent(in ), dimension(:,:) :: prsi - real(kind=kind_phys), intent(in ), dimension(:,:,:) :: lwhd - integer, intent(inout), dimension(:) :: kinver - real(kind=kind_phys), intent(inout), dimension(:) :: suntim, dlwsfc, ulwsfc, psmean, ctei_rml, ctei_r - real(kind=kind_phys), intent(in ), dimension(:) :: adjsfculw_lnd, adjsfculw_ice, adjsfculw_wat - real(kind=kind_phys), intent(inout), dimension(:) :: adjsfculw - - ! dtend is only allocated if ldiag3d is .true. - real(kind=kind_phys), optional, intent(inout), dimension(:,:,:) :: dtend - integer, intent(in), dimension(:,:) :: dtidx - integer, intent(in) :: index_of_process_longwave, index_of_process_shortwave, & - index_of_process_pbl, index_of_process_dcnv, index_of_process_scnv, & - index_of_process_mp, index_of_temperature - - logical, intent(in ), dimension(:) :: dry, icy, wet - real(kind=kind_phys), intent(in ), dimension(:) :: frland - real(kind=kind_phys), intent(in ) :: huge - - character(len=*), intent( out) :: errmsg - integer, intent( out) :: errflg - - ! local variables - real(kind=kind_phys), parameter :: czmin = 0.0001_kind_phys ! cos(89.994) - integer :: i, k, idtend - real(kind=kind_phys) :: tem1, tem2, tem, hocp - logical, dimension(im) :: invrsn - real(kind=kind_phys), dimension(im) :: tx1, tx2 - - real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys - real(kind=kind_phys), parameter :: qmin = 1.0e-10_kind_phys, epsln=1.0e-10_kind_phys - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - hocp = hvap/cp - - if (lssav) then ! --- ... accumulate/save output variables - -! --- ... sunshine duration time is defined as the length of time (in mdl output -! interval) that solar radiation falling on a plane perpendicular to the -! direction of the sun >= 120 w/m2 - - do i = 1, im - if ( xcosz(i) >= czmin ) then ! zenth angle > 89.994 deg - tem1 = adjsfcdsw(i) / xcosz(i) - if ( tem1 >= 120.0_kind_phys ) then - suntim(i) = suntim(i) + dtf - endif - endif - enddo - -! --- ... sfc lw fluxes used by atmospheric model are saved for output - if (frac_grid) then - do i=1,im - tem = (one - frland(i)) * cice(i) ! tem = ice fraction wrt whole cell - if (flag_cice(i)) then - adjsfculw(i) = adjsfculw_lnd(i) * frland(i) & - + ulwsfc_cice(i) * tem & - + adjsfculw_wat(i) * (one - frland(i) - tem) - else - adjsfculw(i) = adjsfculw_lnd(i) * frland(i) & - + adjsfculw_ice(i) * tem & - + adjsfculw_wat(i) * (one - frland(i) - tem) - endif - enddo - else - do i=1,im - if (dry(i)) then ! all land - adjsfculw(i) = adjsfculw_lnd(i) - elseif (icy(i)) then ! ice (and water) - tem = one - cice(i) - if (flag_cice(i)) then - if (wet(i) .and. adjsfculw_wat(i) /= huge) then - adjsfculw(i) = ulwsfc_cice(i)*cice(i) + adjsfculw_wat(i)*tem - else - adjsfculw(i) = ulwsfc_cice(i) - endif - else - if (wet(i) .and. adjsfculw_wat(i) /= huge) then - adjsfculw(i) = adjsfculw_ice(i)*cice(i) + adjsfculw_wat(i)*tem - else - adjsfculw(i) = adjsfculw_ice(i) - endif - endif - else ! all water - adjsfculw(i) = adjsfculw_wat(i) - endif - enddo - endif - - do i=1,im - dlwsfc(i) = dlwsfc(i) + adjsfcdlw(i)*dtf - ulwsfc(i) = ulwsfc(i) + adjsfculw(i)*dtf - psmean(i) = psmean(i) + pgr(i)*dtf ! mean surface pressure - enddo - - if (ldiag3d) then - if (lsidea) then - idtend = dtidx(index_of_temperature,index_of_process_longwave) - if(idtend>=1) then - dtend(:,:,idtend) = dtend(:,:,idtend) + lwhd(:,:,1)*dtf - endif - - idtend = dtidx(index_of_temperature,index_of_process_shortwave) - if(idtend>=1) then - dtend(:,:,idtend) = dtend(:,:,idtend) + lwhd(:,:,2)*dtf - endif - - idtend = dtidx(index_of_temperature,index_of_process_pbl) - if(idtend>=1) then - dtend(:,:,idtend) = dtend(:,:,idtend) + lwhd(:,:,3)*dtf - endif - - idtend = dtidx(index_of_temperature,index_of_process_dcnv) - if(idtend>=1) then - dtend(:,:,idtend) = dtend(:,:,idtend) + lwhd(:,:,4)*dtf - endif - - idtend = dtidx(index_of_temperature,index_of_process_scnv) - if(idtend>=1) then - dtend(:,:,idtend) = dtend(:,:,idtend) + lwhd(:,:,5)*dtf - endif - - idtend = dtidx(index_of_temperature,index_of_process_mp) - if(idtend>=1) then - dtend(:,:,idtend) = dtend(:,:,idtend) + lwhd(:,:,6)*dtf - endif - else - idtend = dtidx(index_of_temperature,index_of_process_longwave) - if(idtend>=1) then - if (use_LW_jacobian) then - dtend(:,:,idtend) = dtend(:,:,idtend) + htrlwu(:,:)*dtf - else - dtend(:,:,idtend) = dtend(:,:,idtend) + htrlw(:,:)*dtf - endif - endif - - idtend = dtidx(index_of_temperature,index_of_process_shortwave) - if(idtend>=1) then - do k=1,levs - do i=1,im - dtend(i,k,idtend) = dtend(i,k,idtend) + htrsw(i,k)*dtf*xmu(i) - enddo - enddo - endif - endif - endif - endif ! end if_lssav_block - - do i=1, im - invrsn(i) = .false. - tx1(i) = zero - tx2(i) = 10.0_kind_phys - ctei_r(i) = 10.0_kind_phys - enddo - - if ((((imfshalcnv == 0 .and. shal_cnv) .or. old_monin) .and. mstrat) & - .or. do_shoc) then - ctei_rml(:) = ctei_rm(1)*work1(:) + ctei_rm(2)*work2(:) - do k=1,levs/2 - do i=1,im - if (prsi(i,1)-prsi(i,k+1) < 0.35_kind_phys*prsi(i,1) & - .and. (.not. invrsn(i))) then - tem = (tgrs(i,k+1) - tgrs(i,k)) & - / (prsl(i,k) - prsl(i,k+1)) - - if (((tem > 0.0001_kind_phys) .and. (tx1(i) < zero)) .or. & - ((tem-abs(tx1(i)) > zero) .and. (tx2(i) < zero))) then - invrsn(i) = .true. - - if (qgrs_water_vapor(i,k) > qgrs_water_vapor(i,k+1)) then - tem1 = tgrs(i,k+1) + hocp*max(qgrs_water_vapor(i,k+1),qmin) - tem2 = tgrs(i,k) + hocp*max(qgrs_water_vapor(i,k),qmin) - - tem1 = tem1 / prslk(i,k+1) - tem2 / prslk(i,k) - -! --- ... (cp/l)(deltathetae)/(deltatwater) > ctei_rm -> conditon for CTEI - ctei_r(i) = (one/hocp)*tem1/(qgrs_water_vapor(i,k+1)-qgrs_water_vapor(i,k) & - + qgrs_cloud_water(i,k+1)-qgrs_cloud_water(i,k)) - else - ctei_r(i) = 10.0_kind_phys - endif - - if ( ctei_rml(i) > ctei_r(i) ) then - kinver(i) = k - else - kinver(i) = levs - endif - endif - - tx2(i) = tx1(i) - tx1(i) = tem - endif - enddo - enddo - endif - - end subroutine GFS_suite_interstitial_2_run - - end module GFS_suite_interstitial_2 - - - module GFS_suite_stateout_reset - - contains - - subroutine GFS_suite_stateout_reset_init () - end subroutine GFS_suite_stateout_reset_init - - subroutine GFS_suite_stateout_reset_finalize() - end subroutine GFS_suite_stateout_reset_finalize - -!> \section arg_table_GFS_suite_stateout_reset_run Argument Table -!! \htmlinclude GFS_suite_stateout_reset_run.html -!! - subroutine GFS_suite_stateout_reset_run (im, levs, ntrac, & - tgrs, ugrs, vgrs, qgrs, & - gt0 , gu0 , gv0 , gq0 , & - errmsg, errflg) - - use machine, only: kind_phys - - implicit none - - ! interface variables - integer, intent(in ) :: im - integer, intent(in ) :: levs - integer, intent(in ) :: ntrac - real(kind=kind_phys), intent(in ), dimension(:,:) :: tgrs, ugrs, vgrs - real(kind=kind_phys), intent(in ), dimension(:,:,:) :: qgrs - real(kind=kind_phys), intent(out), dimension(:,:) :: gt0, gu0, gv0 - real(kind=kind_phys), intent(out), dimension(:,:,:) :: gq0 - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - gt0(:,:) = tgrs(:,:) - gu0(:,:) = ugrs(:,:) - gv0(:,:) = vgrs(:,:) - gq0(:,:,:) = qgrs(:,:,:) - - end subroutine GFS_suite_stateout_reset_run - - end module GFS_suite_stateout_reset - - - module GFS_suite_stateout_update - - contains - - subroutine GFS_suite_stateout_update_init () - end subroutine GFS_suite_stateout_update_init - - subroutine GFS_suite_stateout_update_finalize() - end subroutine GFS_suite_stateout_update_finalize - -!> \section arg_table_GFS_suite_stateout_update_run Argument Table -!! \htmlinclude GFS_suite_stateout_update_run.html -!! - subroutine GFS_suite_stateout_update_run (im, levs, ntrac, dtp, & - tgrs, ugrs, vgrs, qgrs, dudt, dvdt, dtdt, dqdt, & - gt0, gu0, gv0, gq0, ntiw, nqrimef, imp_physics, & - imp_physics_fer_hires, epsq, errmsg, errflg) - - use machine, only: kind_phys - - implicit none - - ! Interface variables - integer, intent(in ) :: im - integer, intent(in ) :: levs - integer, intent(in ) :: ntrac - integer, intent(in ) :: imp_physics,imp_physics_fer_hires - integer, intent(in ) :: ntiw, nqrimef - real(kind=kind_phys), intent(in ) :: dtp, epsq - - real(kind=kind_phys), intent(in ), dimension(:,:) :: tgrs, ugrs, vgrs - real(kind=kind_phys), intent(in ), dimension(:,:,:) :: qgrs - real(kind=kind_phys), intent(in ), dimension(:,:) :: dudt, dvdt, dtdt - real(kind=kind_phys), intent(in ), dimension(:,:,:) :: dqdt - real(kind=kind_phys), intent(out), dimension(:,:) :: gt0, gu0, gv0 - real(kind=kind_phys), intent(out), dimension(:,:,:) :: gq0 - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - integer :: i, k - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - gt0(:,:) = tgrs(:,:) + dtdt(:,:) * dtp - gu0(:,:) = ugrs(:,:) + dudt(:,:) * dtp - gv0(:,:) = vgrs(:,:) + dvdt(:,:) * dtp - gq0(:,:,:) = qgrs(:,:,:) + dqdt(:,:,:) * dtp - - if (imp_physics == imp_physics_fer_hires) then - do k=1,levs - do i=1,im - if(gq0(i,k,ntiw) > epsq) then - gq0(i,k,nqrimef) = max(1., gq0(i,k,nqrimef)/gq0(i,k,ntiw)) - else - gq0(i,k,nqrimef) = 1. - end if - end do - end do - end if - - end subroutine GFS_suite_stateout_update_run - - end module GFS_suite_stateout_update - - - module GFS_suite_interstitial_3 - - contains - - subroutine GFS_suite_interstitial_3_init () - end subroutine GFS_suite_interstitial_3_init - - subroutine GFS_suite_interstitial_3_finalize() - end subroutine GFS_suite_interstitial_3_finalize - -!> \section arg_table_GFS_suite_interstitial_3_run Argument Table -!! \htmlinclude GFS_suite_interstitial_3_run.html -!! - subroutine GFS_suite_interstitial_3_run (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, & - prsl, prslk, rhcbot,rhcpbl, rhctop, rhcmax, islmsk, & - work1, work2, kpbl, kinver, ras, me, save_lnc, save_inc, & - ldiag3d, qdiag3d, index_of_process_conv_trans, & - clw, rhc, save_qc, save_qi, save_tcp, errmsg, errflg) - - use machine, only: kind_phys - - implicit none - - ! interface variables - 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 - integer, intent(in ), dimension(:) :: islmsk, kpbl, kinver - logical, intent(in ) :: cscnv, satmedmf, trans_trac, do_shoc, ltaerosol, ras - - integer, intent(in) :: ntinc, ntlnc - logical, intent(in) :: ldiag3d, qdiag3d - integer, dimension(:,:), intent(in) :: dtidx - real, dimension(:,:), intent(out) :: save_lnc, save_inc - - real(kind=kind_phys), intent(in ) :: rhcbot, rhcmax, rhcpbl, rhctop - real(kind=kind_phys), intent(in ), dimension(:) :: work1, work2 - real(kind=kind_phys), intent(in ), dimension(:,:) :: prsl, prslk - real(kind=kind_phys), intent(in ), dimension(:,:) :: prsi - real(kind=kind_phys), intent(in ), dimension(:) :: xlon, xlat - real(kind=kind_phys), intent(in ), dimension(:,:) :: gt0 - real(kind=kind_phys), intent(in ), dimension(:,:,:) :: gq0 - - real(kind=kind_phys), intent(inout), dimension(:,:) :: rhc, save_qc - ! save_qi is not allocated for Zhao-Carr MP - real(kind=kind_phys), intent(inout), dimension(:,:) :: save_qi - real(kind=kind_phys), intent(inout), dimension(:,:) :: save_tcp - real(kind=kind_phys), intent(inout), dimension(:,:,:) :: clw - - character(len=*), intent( out) :: errmsg - integer, intent( out) :: errflg - - ! local variables - integer :: i,k,n,tracers,kk - real(kind=kind_phys) :: tem, tem1, tem2 - real(kind=kind_phys), dimension(im) :: tx1, tx2, tx3, tx4 - - !real(kind=kind_phys),parameter :: slope_mg = 0.02, slope_upmg = 0.04, & - ! turnrhcrit = 0.900, turnrhcrit_upper = 0.150 - ! in the following inverse of slope_mg and slope_upmg are specified - real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys - real(kind=kind_phys), parameter :: slope_mg = 50.0_kind_phys, & - slope_upmg = 25.0_kind_phys - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (cscnv .or. satmedmf .or. trans_trac .or. ras) then - tracers = 2 - do n=2,ntrac - if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt .and. & - n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & - n /= ntsnc .and. n /= ntgl .and. n /= ntgnc) then - tracers = tracers + 1 - do k=1,levs - do i=1,im - clw(i,k,tracers) = gq0(i,k,n) - enddo - enddo - endif - enddo - endif ! end if_ras or cfscnv or samf - - if (ntcw > 0) then - if (imp_physics == imp_physics_mg .and. rhcpbl < 0.5_kind_phys) then ! compute rhc for GMAO macro physics cloud pdf - do i=1,im - tx1(i) = one / prsi(i,1) - tx2(i) = one - rhcmax*work1(i)-rhcbot*work2(i) - - kk = min(kinver(i), max(2,kpbl(i))) - tx3(i) = prsi(i,kk)*tx1(i) - tx4(i) = rhcpbl - rhctop*abs(cos(xlat(i))) - enddo - do k = 1, levs - do i = 1, im - tem = prsl(i,k) * tx1(i) - tem1 = min(max((tem-tx3(i))*slope_mg, -20.0_kind_phys), 20.0_kind_phys) - ! Using rhcpbl and rhctop from the namelist instead of 0.3 and 0.2 - ! and rhcbot represents pbl top critical relative humidity - tem2 = min(max((tx4(i)-tem)*slope_upmg, -20.0_kind_phys), 20.0_kind_phys) ! Anning - if (islmsk(i) > 0) then - tem1 = one / (one+exp(tem1+tem1)) - else - tem1 = 2.0_kind_phys / (one+exp(tem1+tem1)) - endif - tem2 = one / (one+exp(tem2)) - - rhc(i,k) = min(rhcmax, max(0.7_kind_phys, one-tx2(i)*tem1*tem2)) - enddo - enddo - else - do k=1,levs - do i=1,im - kk = max(10,kpbl(i)) - if (k < kk) then - tem = rhcbot - (rhcbot-rhcpbl) * (one-prslk(i,k)) / (one-prslk(i,kk)) - else - tem = rhcpbl - (rhcpbl-rhctop) * (prslk(i,kk)-prslk(i,k)) / prslk(i,kk) - endif - tem = rhcmax * work1(i) + tem * work2(i) - rhc(i,k) = max(zero, min(one,tem)) - enddo - enddo - endif - else - rhc(:,:) = 1.0 - endif - - if (imp_physics == imp_physics_zhao_carr .or. imp_physics == imp_physics_zhao_carr_pdf) then ! zhao-carr microphysics - !GF* move to GFS_MP_generic_pre (from gscond/precpd) - ! do i=1,im - ! psautco_l(i) = Model%psautco(1)*work1(i) + Model%psautco(2)*work2(i) - ! prautco_l(i) = Model%prautco(1)*work1(i) + Model%prautco(2)*work2(i) - ! enddo - !*GF - do k=1,levs - do i=1,im - clw(i,k,1) = gq0(i,k,ntcw) - enddo - enddo - elseif (imp_physics == imp_physics_gfdl) then - clw(1:im,:,1) = gq0(1:im,:,ntcw) - elseif (imp_physics == imp_physics_thompson) then - do k=1,levs - do i=1,im - clw(i,k,1) = gq0(i,k,ntiw) ! ice - clw(i,k,2) = gq0(i,k,ntcw) ! water - save_tcp(i,k) = gt0(i,k) - enddo - enddo - if(ltaerosol) then - save_qi(:,:) = clw(:,:,1) - save_qc(:,:) = clw(:,:,2) - else - save_qi(:,:) = clw(:,:,1) - endif - elseif (imp_physics == imp_physics_wsm6 .or. imp_physics == imp_physics_mg .or. imp_physics == imp_physics_fer_hires) then - do k=1,levs - do i=1,im - clw(i,k,1) = gq0(i,k,ntiw) ! ice - clw(i,k,2) = gq0(i,k,ntcw) ! water - enddo - enddo - endif - - if(imp_physics == imp_physics_thompson .and. ldiag3d .and. qdiag3d) then - if(dtidx(100+ntlnc,index_of_process_conv_trans)>0) then - save_lnc = gq0(:,:,ntlnc) - endif - if(dtidx(100+ntinc,index_of_process_conv_trans)>0) then - save_inc = gq0(:,:,ntinc) - endif - endif - - end subroutine GFS_suite_interstitial_3_run - - end module GFS_suite_interstitial_3 - - module GFS_suite_interstitial_4 - - contains - - subroutine GFS_suite_interstitial_4_init () - end subroutine GFS_suite_interstitial_4_init - - subroutine GFS_suite_interstitial_4_finalize() - end subroutine GFS_suite_interstitial_4_finalize - -!> \section arg_table_GFS_suite_interstitial_4_run Argument Table -!! \htmlinclude GFS_suite_interstitial_4_run.html -!! - subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntrac, ntcw, ntiw, ntclamt, & - ntrw, ntsw, ntrnc, ntsnc, ntgl, ntgnc, ntlnc, ntinc, nn, imp_physics, imp_physics_gfdl, imp_physics_thompson, & - imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, convert_dry_rho, dtf, save_qc, save_qi, con_pi, dtidx, dtend,& - index_of_process_conv_trans, gq0, clw, prsl, save_tcp, con_rd, con_eps, nwfa, spechum, ldiag3d, & - qdiag3d, save_lnc, save_inc, ntk, ntke, errmsg, errflg) - - use machine, only: kind_phys - use module_mp_thompson_make_number_concentrations, only: make_IceNumber, make_DropletNumber - - implicit none - - ! interface variables - - 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 - - logical, intent(in) :: ltaerosol, convert_dry_rho - - real(kind=kind_phys), intent(in ) :: con_pi, dtf - real(kind=kind_phys), intent(in ), dimension(:,:) :: save_qc - ! save_qi is not allocated for Zhao-Carr MP - real(kind=kind_phys), intent(in ), dimension(:,:) :: save_qi, save_lnc, save_inc - - ! dtend and dtidx are only allocated if ldiag3d - logical, intent(in) :: ldiag3d, qdiag3d - real(kind=kind_phys), dimension(:,:,:), intent(inout) :: dtend - integer, dimension(:,:), intent(in) :: dtidx - integer, intent(in) :: index_of_process_conv_trans,ntk,ntke - - real(kind=kind_phys), dimension(:,:,:), intent(inout) :: gq0 - real(kind=kind_phys), dimension(:,:,:), intent(inout) :: clw - real(kind=kind_phys), dimension(:,:), intent(in) :: prsl - real(kind=kind_phys), intent(in) :: con_rd, con_eps - real(kind=kind_phys), dimension(:,:), intent(in) :: nwfa, save_tcp - real(kind=kind_phys), dimension(:,:), intent(in) :: spechum - - character(len=*), intent( out) :: errmsg - integer, intent( out) :: errflg - - ! local variables - real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys - integer :: i,k,n,tracers,idtend - - real(kind=kind_phys) :: rho, orho - real(kind=kind_phys), dimension(im,levs) :: qv_mp !< kg kg-1 (dry mixing ratio) - real(kind=kind_phys), dimension(im,levs) :: qc_mp !< kg kg-1 (dry mixing ratio) - real(kind=kind_phys), dimension(im,levs) :: qi_mp !< kg kg-1 (dry mixing ratio) - real(kind=kind_phys), dimension(im,levs) :: nc_mp !< kg-1 (dry mixing ratio) - real(kind=kind_phys), dimension(im,levs) :: ni_mp !< kg-1 (dry mixing ratio) - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - ! This code was previously in GFS_SCNV_generic_post, but it really belongs - ! here, because it fixes the convective transportable_tracers mess for Zhao-Carr - ! and GFDL MP from GFS_suite_interstitial_3. This whole code around clw(:,:,2) - ! being set to -999 for Zhao-Carr MP (which doesn't have cloud ice) and GFDL-MP - ! (which does have cloud ice, but for some reason it was decided to code it up - ! in the same way as for Zhao-Carr, nowadays unnecessary and confusing) needs - ! to be cleaned up. The convection schemes doing something different internally - ! based on clw(i,k,2) being -999.0 or not is not a good idea. - do k=1,levs - do i=1,im - if (clw(i,k,2) <= -999.0) clw(i,k,2) = 0.0 - enddo - enddo - - if(ldiag3d) then - if(ntk>0 .and. ntk<=size(clw,3)) then - idtend=dtidx(100+ntke,index_of_process_conv_trans) - if(idtend>=1) then - dtend(:,:,idtend) = dtend(:,:,idtend) + clw(:,:,ntk)-gq0(:,:,ntk) - endif - endif - if(ntcw>0) then - if (imp_physics == imp_physics_zhao_carr .or. & - imp_physics == imp_physics_zhao_carr_pdf .or. & - imp_physics == imp_physics_gfdl) then - idtend=dtidx(100+ntcw,index_of_process_conv_trans) - if(idtend>=1) then - dtend(:,:,idtend) = dtend(:,:,idtend) + clw(:,:,1)+clw(:,:,2) - gq0(:,:,ntcw) - endif - else if(ntiw>0) then - idtend=dtidx(100+ntiw,index_of_process_conv_trans) - if(idtend>=1) then - dtend(:,:,idtend) = dtend(:,:,idtend) + clw(:,:,1)-gq0(:,:,ntiw) - endif - idtend=dtidx(100+ntcw,index_of_process_conv_trans) - if(idtend>=1) then - dtend(:,:,idtend) = dtend(:,:,idtend) + clw(:,:,2)-gq0(:,:,ntcw) - endif - else - idtend=dtidx(100+ntcw,index_of_process_conv_trans) - if(idtend>=1) then - dtend(:,:,idtend) = dtend(:,:,idtend) + clw(:,:,1)+clw(:,:,2) - gq0(:,:,ntcw) - endif - endif - endif - endif - -! --- update the tracers due to deep & shallow cumulus convective transport -! (except for suspended water and ice) - - if (tracers_total > 0) then - tracers = 2 - do n=2,ntrac -! if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt) then - if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt .and. & - n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & - n /= ntsnc .and. n /= ntgl .and. n /= ntgnc ) then - tracers = tracers + 1 - if(n/=ntk .and. n/=ntlnc .and. n/=ntinc .and. n /= ntcw .and. n /= ntiw) then - idtend=dtidx(100+n,index_of_process_conv_trans) - if(idtend>=1) then - dtend(:,:,idtend) = dtend(:,:,idtend) + clw(:,:,tracers)-gq0(:,:,n) - endif - endif - do k=1,levs - do i=1,im - gq0(i,k,n) = clw(i,k,tracers) - enddo - enddo - endif - enddo - endif - - if (ntcw > 0) then - -! for microphysics - if (imp_physics == imp_physics_zhao_carr .or. & - imp_physics == imp_physics_zhao_carr_pdf .or. & - imp_physics == imp_physics_gfdl) then - gq0(1:im,:,ntcw) = clw(1:im,:,1) + clw(1:im,:,2) - - elseif (ntiw > 0) then - do k=1,levs - do i=1,im - gq0(i,k,ntiw) = clw(i,k,1) ! ice - gq0(i,k,ntcw) = clw(i,k,2) ! water - enddo - enddo - - if (imp_physics == imp_physics_thompson .and. (ntlnc>0 .or. ntinc>0)) then - if_convert_dry_rho: if (convert_dry_rho) then - do k=1,levs - do i=1,im - !> - Convert specific humidity to dry mixing ratio - qv_mp(i,k) = spechum(i,k) / (one-spechum(i,k)) - !> - Density of air in kg m-3 and inverse density - rho = con_eps*prsl(i,k) / (con_rd*save_tcp(i,k)*(qv_mp(i,k)+con_eps)) - orho = one/rho - if (ntlnc>0) then - !> - Convert moist mixing ratio to dry mixing ratio - qc_mp(i,k) = (clw(i,k,2)-save_qc(i,k)) / (one-spechum(i,k)) - !> - Convert number concentration from moist to dry - nc_mp(i,k) = gq0(i,k,ntlnc) / (one-spechum(i,k)) - nc_mp(i,k) = max(zero, nc_mp(i,k) + make_DropletNumber(qc_mp(i,k) * rho, nwfa(i,k)*rho) * orho) - !> - Convert number concentrations from dry to moist - gq0(i,k,ntlnc) = nc_mp(i,k) / (one+qv_mp(i,k)) - endif - if (ntinc>0) then - !> - Convert moist mixing ratio to dry mixing ratio - qi_mp(i,k) = (clw(i,k,1)-save_qi(i,k)) / (one-spechum(i,k)) - !> - Convert number concentration from moist to dry - ni_mp(i,k) = gq0(i,k,ntinc) / (one-spechum(i,k)) - ni_mp(i,k) = max(zero, ni_mp(i,k) + make_IceNumber(qi_mp(i,k) * rho, save_tcp(i,k)) * orho) - !> - Convert number concentrations from dry to moist - gq0(i,k,ntinc) = ni_mp(i,k) / (one+qv_mp(i,k)) - endif - enddo - enddo - else - do k=1,levs - do i=1,im - !> - Density of air in kg m-3 and inverse density - rho = con_eps*prsl(i,k) / (con_rd*save_tcp(i,k)*(spechum(i,k)+con_eps)) - orho = one/rho - if (ntlnc>0) then - !> - Update cloud water mixing ratio - qc_mp(i,k) = (clw(i,k,2)-save_qc(i,k)) - !> - Update cloud water number concentration - gq0(i,k,ntlnc) = max(zero, gq0(i,k,ntlnc) + make_DropletNumber(qc_mp(i,k) * rho, nwfa(i,k)*rho) * orho) - endif - if (ntinc>0) then - !> - Update cloud ice mixing ratio - qi_mp(i,k) = (clw(i,k,1)-save_qi(i,k)) - !> - Update cloud ice number concentration - gq0(i,k,ntinc) = max(zero, gq0(i,k,ntinc) + make_IceNumber(qi_mp(i,k) * rho, save_tcp(i,k)) * orho) - endif - enddo - enddo - end if if_convert_dry_rho - if(ldiag3d .and. qdiag3d) then - idtend = dtidx(100+ntlnc,index_of_process_conv_trans) - if(idtend>0) then - dtend(:,:,idtend) = dtend(:,:,idtend) + gq0(:,:,ntlnc) - save_lnc - endif - idtend = dtidx(100+ntinc,index_of_process_conv_trans) - if(idtend>0) then - dtend(:,:,idtend) = dtend(:,:,idtend) + gq0(:,:,ntinc) - save_inc - endif - endif - endif - - else - do k=1,levs - do i=1,im - gq0(i,k,ntcw) = clw(i,k,1) + clw(i,k,2) - enddo - enddo - endif ! end if_ntiw - - else - do k=1,levs - do i=1,im - clw(i,k,1) = clw(i,k,1) + clw(i,k,2) - enddo - enddo - endif ! end if_ntcw - - end subroutine GFS_suite_interstitial_4_run - - end module GFS_suite_interstitial_4 - - module GFS_suite_interstitial_5 - - contains - - subroutine GFS_suite_interstitial_5_init () - end subroutine GFS_suite_interstitial_5_init - - subroutine GFS_suite_interstitial_5_finalize() - end subroutine GFS_suite_interstitial_5_finalize - -!> \section arg_table_GFS_suite_interstitial_5_run Argument Table -!! \htmlinclude GFS_suite_interstitial_5_run.html -!! - subroutine GFS_suite_interstitial_5_run (im, levs, ntrac, ntcw, ntiw, nn, gq0, clw, errmsg, errflg) - - use machine, only: kind_phys - - implicit none - - ! interface variables - integer, intent(in ) :: im, levs, ntrac, ntcw, ntiw, nn - - real(kind=kind_phys), intent(in ), dimension(:,:,:) :: gq0 - - real(kind=kind_phys), intent(out), dimension(:,:,:) :: clw - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! local variables - integer :: i,k - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - do k=1,levs - do i=1,im - clw(i,k,1) = gq0(i,k,ntiw) ! ice - clw(i,k,2) = gq0(i,k,ntcw) ! water - enddo - enddo - - end subroutine GFS_suite_interstitial_5_run - - end module GFS_suite_interstitial_5 - diff --git a/physics/GFS_suite_interstitial.meta b/physics/GFS_suite_interstitial.meta deleted file mode 100644 index 43b3d5efa..000000000 --- a/physics/GFS_suite_interstitial.meta +++ /dev/null @@ -1,1909 +0,0 @@ -[ccpp-table-properties] - name = GFS_suite_interstitial_rad_reset - type = scheme - dependencies = machine.F,module_mp_thompson_make_number_concentrations.F90 - -######################################################################## -[ccpp-arg-table] - name = GFS_suite_interstitial_rad_reset_run - type = scheme -[Interstitial] - standard_name = GFS_interstitial_type_instance - long_name = derived type GFS_interstitial_type in FV3 - units = DDT - dimensions = () - type = GFS_interstitial_type - intent = inout -[Model] - standard_name = GFS_control_type_instance - long_name = Fortran DDT containing FV3-GFS model control parameters - units = DDT - dimensions = () - type = GFS_control_type - intent = in -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out - -######################################################################## -[ccpp-table-properties] - name = GFS_suite_interstitial_phys_reset - type = scheme - dependencies = machine.F,module_mp_thompson_make_number_concentrations.F90 - -######################################################################## -[ccpp-arg-table] - name = GFS_suite_interstitial_phys_reset_run - type = scheme -[Interstitial] - standard_name = GFS_interstitial_type_instance - long_name = derived type GFS_interstitial_type in FV3 - units = DDT - dimensions = () - type = GFS_interstitial_type - intent = inout -[Model] - standard_name = GFS_control_type_instance - long_name = Fortran DDT containing FV3-GFS model control parameters - units = DDT - dimensions = () - type = GFS_control_type - intent = in -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out - -######################################################################## -[ccpp-table-properties] - name = GFS_suite_interstitial_1 - type = scheme - dependencies = machine.F,module_mp_thompson_make_number_concentrations.F90 - -######################################################################## -[ccpp-arg-table] - name = GFS_suite_interstitial_1_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in -[levs] - standard_name = vertical_layer_dimension - long_name = vertical layer dimension - units = count - dimensions = () - type = integer - intent = in -[ntrac] - standard_name = number_of_tracers - long_name = number of tracers - units = count - dimensions = () - type = integer - intent = in -[dtf] - standard_name = timestep_for_dynamics - long_name = dynamics timestep - units = s - dimensions = () - type = real - kind = kind_phys - intent = in -[dtp] - standard_name = timestep_for_physics - long_name = physics timestep - units = s - dimensions = () - type = real - kind = kind_phys - intent = in -[slmsk] - standard_name = area_type - long_name = landmask: sea/land/ice=0/1/2 - units = flag - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[area] - standard_name = cell_area - long_name = area of the grid cell - units = m2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[dxmin] - standard_name = min_grid_scale - long_name = minimum scaling factor for critical relative humidity - units = m2 rad-2 - dimensions = () - type = real - kind = kind_phys - intent = in -[dxinv] - standard_name = reciprocal_of_grid_scale_range - long_name = inverse scaling factor for critical relative humidity - units = rad2 m-2 - dimensions = () - type = real - kind = kind_phys - intent = in -[pgr] - standard_name = surface_air_pressure - long_name = surface pressure - units = Pa - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[islmsk] - standard_name = sea_land_ice_mask - long_name = landmask: sea/land/ice=0/1/2 - units = flag - dimensions = (horizontal_loop_extent) - type = integer - intent = out -[work1] - standard_name = grid_size_related_coefficient_used_in_scale_sensitive_schemes - long_name = grid size related coefficient used in scale-sensitive schemes - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[work2] - standard_name = grid_size_related_coefficient_used_in_scale_sensitive_schemes_complement - long_name = complement to work1 - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[psurf] - standard_name = surface_air_pressure_diag - long_name = surface air pressure diagnostic - units = Pa - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[dudt] - standard_name = process_split_cumulative_tendency_of_x_wind - long_name = updated tendency of the x wind - units = m s-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[dvdt] - standard_name = process_split_cumulative_tendency_of_y_wind - long_name = updated tendency of the y wind - units = m s-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[dtdt] - standard_name = process_split_cumulative_tendency_of_air_temperature - long_name = updated tendency of the temperature - units = K s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[dqdt] - standard_name = process_split_cumulative_tendency_of_tracers - long_name = updated tendency of the tracers - units = kg kg-1 s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = out -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out - -######################################################################## -[ccpp-table-properties] - name = GFS_suite_interstitial_2 - type = scheme - dependencies = machine.F,module_mp_thompson_make_number_concentrations.F90 - -######################################################################## -[ccpp-arg-table] - name = GFS_suite_interstitial_2_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in -[levs] - standard_name = vertical_layer_dimension - long_name = vertical layer dimension - units = count - dimensions = () - type = integer - intent = in -[lssav] - standard_name = flag_for_diagnostics - long_name = logical flag for storing diagnostics - units = flag - dimensions = () - type = logical - intent = in -[ldiag3d] - standard_name = flag_for_diagnostics_3D - long_name = flag for 3d diagnostic fields - units = flag - dimensions = () - type = logical - intent = in -[lsidea] - standard_name = flag_for_integrated_dynamics_through_earths_atmosphere - long_name = flag for idealized physics - units = flag - dimensions = () - type = logical - intent = in -[flag_cice] - standard_name = flag_for_cice - long_name = flag for cice - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = in -[shal_cnv] - standard_name = flag_for_simplified_arakawa_schubert_shallow_convection - long_name = flag for calling shallow convection - units = flag - dimensions = () - type = logical - intent = in -[old_monin] - standard_name = flag_for_old_PBL_scheme - long_name = flag for using old PBL schemes - units = flag - dimensions = () - type = logical - intent = in -[mstrat] - standard_name = flag_for_moorthi_stratus - long_name = flag for moorthi approach for stratus - units = flag - dimensions = () - type = logical - intent = in -[do_shoc] - standard_name = flag_for_shoc - long_name = flag for SHOC - units = flag - dimensions = () - type = logical - intent = in -[frac_grid] - standard_name = flag_for_fractional_landmask - long_name = flag for fractional grid - units = flag - dimensions = () - type = logical - intent = in -[imfshalcnv] - standard_name = control_for_shallow_convection_scheme - long_name = flag for mass-flux shallow convection scheme - units = flag - dimensions = () - type = integer - intent = in -[dtf] - standard_name = timestep_for_dynamics - long_name = dynamics timestep - units = s - dimensions = () - type = real - kind = kind_phys - intent = in -[xcosz] - standard_name = instantaneous_cosine_of_zenith_angle - long_name = cosine of zenith angle at current time - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[adjsfcdsw] - standard_name = surface_downwelling_shortwave_flux - long_name = surface downwelling shortwave flux at current time - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[adjsfcdlw] - standard_name = surface_downwelling_longwave_flux - long_name = surface downwelling longwave flux at current time - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[cice] - standard_name = sea_ice_area_fraction_of_sea_area_fraction - long_name = ice fraction over open water - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[pgr] - standard_name = surface_air_pressure - long_name = surface pressure - units = Pa - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[ulwsfc_cice] - standard_name = surface_upwelling_longwave_flux_from_coupled_process - long_name = surface upwelling longwave flux for coupling - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[lwhd] - standard_name = tendency_of_air_temperature_due_to_integrated_dynamics_through_earths_atmosphere - long_name = idea sky lw heating rates - units = K s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,6) - type = real - kind = kind_phys - intent = in -[htrsw] - standard_name = tendency_of_air_temperature_due_to_shortwave_heating_on_radiation_timestep - long_name = total sky sw heating rate - units = K s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[htrlw] - standard_name = tendency_of_air_temperature_due_to_longwave_heating_on_radiation_timestep - long_name = total sky lw heating rate - units = K s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[xmu] - standard_name = zenith_angle_temporal_adjustment_factor_for_shortwave_fluxes - long_name = zenith angle temporal adjustment factor for shortwave fluxes - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[ctei_rm] - standard_name = tunable_parameter_for_critical_cloud_top_entrainment_instability_criteria - long_name = critical cloud top entrainment instability criteria - units = none - dimensions = (2) - type = real - kind = kind_phys - intent = in -[work1] - standard_name = grid_size_related_coefficient_used_in_scale_sensitive_schemes - long_name = grid size related coefficient used in scale-sensitive schemes - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[work2] - standard_name = grid_size_related_coefficient_used_in_scale_sensitive_schemes_complement - long_name = complement to work1 - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[prsi] - standard_name = air_pressure_at_interface - long_name = air pressure at model layer interfaces - units = Pa - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = in -[tgrs] - standard_name = air_temperature - long_name = model layer mean temperature - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[prsl] - standard_name = air_pressure - long_name = mean layer pressure - units = Pa - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[qgrs_water_vapor] - standard_name = specific_humidity - long_name = water vapor specific humidity - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[qgrs_cloud_water] - standard_name = cloud_liquid_water_mixing_ratio - long_name = ratio of mass of cloud water to mass of dry air plus vapor (without condensates) - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cp] - standard_name = specific_heat_of_dry_air_at_constant_pressure - long_name = specific heat of dry air at constant pressure - units = J kg-1 K-1 - dimensions = () - type = real - kind = kind_phys - intent = in -[hvap] - standard_name = latent_heat_of_vaporization_of_water_at_0C - long_name = latent heat of evaporation/sublimation - units = J kg-1 - dimensions = () - type = real - kind = kind_phys - intent = in -[prslk] - standard_name = dimensionless_exner_function - long_name = dimensionless Exner function at model layer centers - units = none - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[suntim] - standard_name = duration_of_sunshine - long_name = sunshine duration time - units = s - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[use_LW_jacobian] - standard_name = flag_to_calc_RRTMGP_LW_jacobian - long_name = logical flag to control RRTMGP LW calculation - units = flag - dimensions = () - type = logical - intent = in -[htrlwu] - standard_name = updated_tendency_of_air_temperature_due_to_longwave_heating_on_physics_timestep - long_name = total sky longwave heating rate on physics time step - units = K s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[adjsfculw] - standard_name = surface_upwelling_longwave_flux - long_name = surface upwelling longwave flux at current time - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[adjsfculw_lnd] - standard_name = surface_upwelling_longwave_flux_over_land - long_name = surface upwelling longwave flux at current time over land - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[adjsfculw_ice] - standard_name = surface_upwelling_longwave_flux_over_ice - long_name = surface upwelling longwave flux at current time over ice - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[adjsfculw_wat] - standard_name = surface_upwelling_longwave_flux_over_water - long_name = surface upwelling longwave flux at current time over water - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[dlwsfc] - standard_name = cumulative_surface_downwelling_longwave_flux_multiplied_by_timestep - long_name = cumulative surface downwelling LW flux multiplied by timestep - units = W m-2 s - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[ulwsfc] - standard_name = cumulative_surface_upwelling_longwave_flux_multiplied_by_timestep - long_name = cumulative surface upwelling LW flux multiplied by timestep - units = W m-2 s - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[psmean] - standard_name = cumulative_surface_pressure_multiplied_by_timestep - long_name = cumulative surface pressure multiplied by timestep - units = Pa s - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[dtend] - standard_name = cumulative_change_of_state_variables - long_name = diagnostic tendencies for state variables - units = mixed - dimensions = (horizontal_loop_extent,vertical_layer_dimension,cumulative_change_of_state_variables_outer_index_max) - type = real - kind = kind_phys - intent = inout -[dtidx] - standard_name = cumulative_change_of_state_variables_outer_index - long_name = index of state-variable and process in last dimension of diagnostic tendencies array AKA cumulative_change_index - units = index - dimensions = (number_of_tracers_plus_one_hundred,number_of_cumulative_change_processes) - type = integer - intent = in -[index_of_process_longwave] - standard_name = index_of_longwave_heating_process_in_cumulative_change_index - long_name = index of longwave heating process in second dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[index_of_process_shortwave] - standard_name = index_of_shortwave_heating_process_in_cumulative_change_index - long_name = index of shortwave heating process in second dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[index_of_process_pbl] - standard_name = index_of_subgrid_scale_vertical_mixing_process_in_cumulative_change_index - long_name = index of subgrid scale vertical mixing process in second dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[index_of_process_dcnv] - standard_name = index_of_deep_convection_process_process_in_cumulative_change_index - long_name = index of deep convection process in second dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[index_of_process_scnv] - standard_name = index_of_shallow_convection_process_process_in_cumulative_change_index - long_name = index of shallow convection process in second dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[index_of_process_mp] - standard_name = index_of_microphysics_process_process_in_cumulative_change_index - long_name = index of microphysics transport process in second dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[index_of_temperature] - standard_name = index_of_temperature_in_cumulative_change_index - long_name = index of temperature in first dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[ctei_rml] - standard_name = grid_sensitive_critical_cloud_top_entrainment_instability_criteria - long_name = grid sensitive critical cloud top entrainment instability criteria - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[ctei_r] - standard_name = cloud_top_entrainment_instability_value - long_name = cloud top entrainment instability value - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[kinver] - standard_name = index_of_highest_temperature_inversion - long_name = index of highest temperature inversion - units = index - dimensions = (horizontal_loop_extent) - type = integer - intent = inout -[dry] - standard_name = flag_nonzero_land_surface_fraction - long_name = flag indicating presence of some land surface area fraction - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = in -[icy] - standard_name = flag_nonzero_sea_ice_surface_fraction - long_name = flag indicating presence of some sea ice surface area fraction - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = in -[wet] - standard_name = flag_nonzero_wet_surface_fraction - long_name = flag indicating presence of some ocean or lake surface area fraction - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = in -[frland] - standard_name = land_area_fraction_for_microphysics - long_name = land area fraction used in microphysics schemes - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[huge] - standard_name = netcdf_float_fillvalue - long_name = definition of NetCDF float FillValue - units = none - dimensions = () - type = real - kind = kind_phys - intent = in -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out - -######################################################################## -[ccpp-table-properties] - name = GFS_suite_stateout_reset - type = scheme - dependencies = machine.F,module_mp_thompson_make_number_concentrations.F90 - -######################################################################## -[ccpp-arg-table] - name = GFS_suite_stateout_reset_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in -[levs] - standard_name = vertical_layer_dimension - long_name = vertical layer dimension - units = count - dimensions = () - type = integer - intent = in -[ntrac] - standard_name = number_of_tracers - long_name = number of tracers - units = count - dimensions = () - type = integer - intent = in -[tgrs] - standard_name = air_temperature - long_name = model layer mean temperature - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[ugrs] - standard_name = x_wind - long_name = zonal wind - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[vgrs] - standard_name = y_wind - long_name = meridional wind - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[qgrs] - standard_name = tracer_concentration - long_name = model layer mean tracer concentration - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = in -[gt0] - standard_name = air_temperature_of_new_state - long_name = temperature updated by physics - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[gu0] - standard_name = x_wind_of_new_state - long_name = zonal wind updated by physics - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[gv0] - standard_name = y_wind_of_new_state - long_name = meridional wind updated by physics - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[gq0] - standard_name = tracer_concentration_of_new_state - long_name = tracer concentration updated by physics - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = out -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out - -######################################################################## -[ccpp-table-properties] - name = GFS_suite_stateout_update - type = scheme - dependencies = machine.F,module_mp_thompson_make_number_concentrations.F90 - -######################################################################## -[ccpp-arg-table] - name = GFS_suite_stateout_update_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in -[levs] - standard_name = vertical_layer_dimension - long_name = vertical layer dimension - units = count - dimensions = () - type = integer - intent = in -[ntrac] - standard_name = number_of_tracers - long_name = number of tracers - units = count - dimensions = () - type = integer - intent = in -[dtp] - standard_name = timestep_for_physics - long_name = physics timestep - units = s - dimensions = () - type = real - kind = kind_phys - intent = in -[tgrs] - standard_name = air_temperature - long_name = model layer mean temperature - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[ugrs] - standard_name = x_wind - long_name = zonal wind - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[vgrs] - standard_name = y_wind - long_name = meridional wind - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[qgrs] - standard_name = tracer_concentration - long_name = model layer mean tracer concentration - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = in -[dudt] - standard_name = process_split_cumulative_tendency_of_x_wind - long_name = updated tendency of the x wind - units = m s-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[dvdt] - standard_name = process_split_cumulative_tendency_of_y_wind - long_name = updated tendency of the y wind - units = m s-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[dtdt] - standard_name = process_split_cumulative_tendency_of_air_temperature - long_name = updated tendency of the temperature - units = K s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[dqdt] - standard_name = process_split_cumulative_tendency_of_tracers - long_name = updated tendency of the tracers - units = kg kg-1 s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = in -[gt0] - standard_name = air_temperature_of_new_state - long_name = temperature updated by physics - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[gu0] - standard_name = x_wind_of_new_state - long_name = zonal wind updated by physics - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[gv0] - standard_name = y_wind_of_new_state - long_name = meridional wind updated by physics - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[gq0] - standard_name = tracer_concentration_of_new_state - long_name = tracer concentration updated by physics - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = out -[ntiw] - standard_name = index_of_cloud_ice_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for ice water - units = index - dimensions = () - type = integer - intent = in -[nqrimef] - standard_name = index_of_mass_weighted_rime_factor_in_tracer_concentration_array - long_name = tracer index for mass weighted rime factor - units = index - dimensions = () - type = integer - intent = in -[imp_physics] - standard_name = control_for_microphysics_scheme - long_name = choice of microphysics scheme - units = flag - dimensions = () - type = integer - intent = in -[imp_physics_fer_hires] - standard_name = identifier_for_fer_hires_microphysics_scheme - long_name = choice of Ferrier-Aligo microphysics scheme - units = flag - dimensions = () - type = integer - intent = in -[epsq] - standard_name = minimum_value_of_specific_humidity - long_name = floor value for specific humidity - units = kg kg-1 - dimensions = () - type = real - kind = kind_phys - intent = in -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out - -######################################################################## -[ccpp-table-properties] - name = GFS_suite_interstitial_3 - type = scheme - dependencies = machine.F,module_mp_thompson_make_number_concentrations.F90 - -######################################################################## -[ccpp-arg-table] - name = GFS_suite_interstitial_3_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in -[levs] - standard_name = vertical_layer_dimension - long_name = vertical layer dimension - units = count - dimensions = () - type = integer - intent = in -[nn] - standard_name = number_of_tracers_for_convective_transport - long_name = number of tracers for convective transport - units = count - dimensions = () - type = integer - intent = in -[cscnv] - standard_name = flag_for_Chikira_Sugiyama_deep_convection - long_name = flag for Chikira-Sugiyama convection - units = flag - dimensions = () - type = logical - intent = in -[satmedmf] - standard_name = flag_for_scale_aware_TKE_moist_EDMF_PBL - long_name = flag for scale-aware TKE moist EDMF PBL scheme - units = flag - dimensions = () - type = logical - intent = in -[trans_trac] - standard_name = flag_for_convective_transport_of_tracers - long_name = flag for convective transport of tracers - units = flag - dimensions = () - type = logical - intent = in -[do_shoc] - standard_name = flag_for_shoc - long_name = flag for SHOC - units = flag - dimensions = () - type = logical - intent = in -[ltaerosol] - standard_name = flag_for_aerosol_physics - long_name = flag for aerosol physics - units = flag - dimensions = () - type = logical - intent = in -[ntrac] - standard_name = number_of_tracers - long_name = number of tracers - units = count - dimensions = () - type = integer - intent = in -[ntcw] - standard_name = index_of_cloud_liquid_water_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for cloud condensate (or liquid water) - units = index - dimensions = () - type = integer - intent = in -[ntiw] - standard_name = index_of_cloud_ice_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for ice water - units = index - dimensions = () - type = integer - intent = in -[ntclamt] - standard_name = index_of_cloud_area_fraction_in_atmosphere_layer_in_tracer_concentration_array - long_name = tracer index for cloud amount integer - units = index - dimensions = () - type = integer - intent = in -[ntrw] - standard_name = index_of_rain_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for rain water - units = index - dimensions = () - type = integer - intent = in -[ntsw] - standard_name = index_of_snow_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for snow water - units = index - dimensions = () - type = integer - intent = in -[ntrnc] - standard_name = index_of_mass_number_concentration_of_rain_in_tracer_concentration_array - long_name = tracer index for rain number concentration - units = index - dimensions = () - type = integer - intent = in -[ntsnc] - standard_name = index_of_mass_number_concentration_of_snow_in_tracer_concentration_array - long_name = tracer index for snow number concentration - units = index - dimensions = () - type = integer - intent = in -[ntgl] - standard_name = index_of_graupel_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for graupel - units = index - dimensions = () - type = integer - intent = in -[ntgnc] - standard_name = index_of_mass_number_concentration_of_graupel_in_tracer_concentration_array - long_name = tracer index for graupel number concentration - units = index - dimensions = () - type = integer - intent = in -[xlon] - standard_name = longitude - long_name = longitude - units = radian - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[xlat] - standard_name = latitude - long_name = latitude - units = radian - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[gt0] - standard_name = air_temperature_of_new_state - long_name = temperature updated by physics - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[gq0] - standard_name = tracer_concentration_of_new_state - long_name = tracer concentration updated by physics - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = in -[imp_physics] - standard_name = control_for_microphysics_scheme - long_name = choice of microphysics scheme - units = flag - dimensions = () - type = integer - intent = in -[imp_physics_mg] - standard_name = identifier_for_morrison_gettelman_microphysics_scheme - long_name = choice of Morrison-Gettelman microphysics scheme - units = flag - dimensions = () - type = integer - intent = in -[imp_physics_zhao_carr] - standard_name = identifier_for_zhao_carr_microphysics_scheme - long_name = choice of Zhao-Carr microphysics scheme - units = flag - dimensions = () - type = integer - intent = in -[imp_physics_zhao_carr_pdf] - standard_name = identifier_for_zhao_carr_pdf_microphysics_scheme - long_name = choice of Zhao-Carr microphysics scheme with PDF clouds - units = flag - dimensions = () - type = integer - intent = in -[imp_physics_gfdl] - standard_name = identifier_for_gfdl_microphysics_scheme - long_name = choice of GFDL microphysics scheme - units = flag - dimensions = () - type = integer - intent = in -[imp_physics_thompson] - standard_name = identifier_for_thompson_microphysics_scheme - long_name = choice of Thompson microphysics scheme - units = flag - dimensions = () - type = integer - intent = in -[imp_physics_wsm6] - standard_name = identifier_for_wsm6_microphysics_scheme - long_name = choice of WSM6 microphysics scheme - units = flag - dimensions = () - type = integer - intent = in -[imp_physics_fer_hires] - standard_name = identifier_for_fer_hires_microphysics_scheme - long_name = choice of Ferrier-Aligo microphysics scheme - units = flag - dimensions = () - type = integer - intent = in -[prsi] - standard_name = air_pressure_at_interface - long_name = air pressure at model layer interfaces - units = Pa - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = in -[prsl] - standard_name = air_pressure - long_name = mean layer pressure - units = Pa - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[prslk] - standard_name = dimensionless_exner_function - long_name = dimensionless Exner function at model layer centers - units = none - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[rhcbot] - standard_name = critical_relative_humidity_at_surface - long_name = critical relative humidity at the surface - units = frac - dimensions = () - type = real - kind = kind_phys - intent = in -[rhcpbl] - standard_name = critical_relative_humidity_at_PBL_top - long_name = critical relative humidity at the PBL top - units = frac - dimensions = () - type = real - kind = kind_phys - intent = in -[rhctop] - standard_name = critical_relative_humidity_at_toa - long_name = critical relative humidity at the top of atmosphere - units = frac - dimensions = () - type = real - kind = kind_phys - intent = in -[rhcmax] - standard_name = max_critical_relative_humidity - long_name = maximum critical relative humidity - units = frac - dimensions = () - type = real - kind = kind_phys - intent = in -[islmsk] - standard_name = sea_land_ice_mask - long_name = sea/land/ice mask (=0/1/2) - units = flag - dimensions = (horizontal_loop_extent) - type = integer - intent = in -[work1] - standard_name = grid_size_related_coefficient_used_in_scale_sensitive_schemes - long_name = grid size related coefficient used in scale-sensitive schemes - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[work2] - standard_name = grid_size_related_coefficient_used_in_scale_sensitive_schemes_complement - long_name = complement to work1 - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[kpbl] - standard_name = vertical_index_at_top_of_atmosphere_boundary_layer - long_name = vertical index at top atmospheric boundary layer - units = index - dimensions = (horizontal_loop_extent) - type = integer - intent = in -[kinver] - standard_name = index_of_highest_temperature_inversion - long_name = index of highest temperature inversion - units = index - dimensions = (horizontal_loop_extent) - type = integer - intent = in -[ras] - standard_name = flag_for_relaxed_arakawa_schubert_deep_convection - long_name = flag for ras convection scheme - units = flag - dimensions = () - type = logical - intent = in -[me] - standard_name = mpi_rank - long_name = current MPI-rank - units = index - dimensions = () - type = integer - intent = in -[clw] - standard_name = convective_transportable_tracers - long_name = array to contain cloud water and other convective trans. tracers - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers_for_convective_transport) - type = real - kind = kind_phys - intent = inout -[rhc] - standard_name = critical_relative_humidity - long_name = critical relative humidity - units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[save_qc] - standard_name = cloud_condensed_water_mixing_ratio_save - long_name = ratio of mass of cloud water to mass of dry air plus vapor (without condensates) before entering a physics scheme - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[save_qi] - standard_name = ice_water_mixing_ratio_save - long_name = cloud ice water mixing ratio before entering a physics scheme - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[save_tcp] - standard_name = air_temperature_save_from_convective_parameterization - long_name = air temperature after cumulus parameterization - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[ldiag3d] - standard_name = flag_for_diagnostics_3D - long_name = flag for 3d diagnostic fields - units = flag - dimensions = () - type = logical - intent = in -[qdiag3d] - standard_name = flag_for_tracer_diagnostics_3D - long_name = flag for 3d tracer diagnostic fields - units = flag - dimensions = () - type = logical - intent = in -[index_of_process_conv_trans] - standard_name = index_of_convective_transport_process_in_cumulative_change_index - long_name = index of convective transport process in second dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[save_lnc] - standard_name = liquid_cloud_number_concentration_save - long_name = liquid cloud number concentration before entering a physics scheme - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[save_inc] - standard_name = ice_cloud_number_concentration_save - long_name = ice cloud number concentration before entering a physics scheme - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[ntlnc] - standard_name = index_of_mass_number_concentration_of_cloud_droplets_in_tracer_concentration_array - long_name = tracer index for liquid number concentration - units = index - dimensions = () - type = integer - intent = in -[ntinc] - standard_name = index_of_mass_number_concentration_of_cloud_ice_in_tracer_concentration_array - long_name = tracer index for ice number concentration - units = index - dimensions = () - type = integer - intent = in -[dtidx] - standard_name = cumulative_change_of_state_variables_outer_index - long_name = index of state-variable and process in last dimension of diagnostic tendencies array AKA cumulative_change_index - units = index - dimensions = (number_of_tracers_plus_one_hundred,number_of_cumulative_change_processes) - type = integer - intent = in -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out - -######################################################################## -[ccpp-table-properties] - name = GFS_suite_interstitial_4 - type = scheme - dependencies = machine.F,module_mp_thompson_make_number_concentrations.F90 - -######################################################################## -[ccpp-arg-table] - name = GFS_suite_interstitial_4_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in -[levs] - standard_name = vertical_layer_dimension - long_name = vertical layer dimension - units = count - dimensions = () - type = integer - intent = in -[ltaerosol] - standard_name = flag_for_aerosol_physics - long_name = flag for aerosol physics - units = flag - dimensions = () - type = logical - intent = in -[tracers_total] - standard_name = number_of_total_tracers - long_name = total number of tracers - units = count - dimensions = () - type = integer - intent = in -[ntrac] - standard_name = number_of_tracers - long_name = number of tracers - units = count - dimensions = () - type = integer - intent = in -[ntcw] - standard_name = index_of_cloud_liquid_water_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for cloud condensate (or liquid water) - units = index - dimensions = () - type = integer - intent = in -[ntiw] - standard_name = index_of_cloud_ice_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for ice water - units = index - dimensions = () - type = integer - intent = in -[ntclamt] - standard_name = index_of_cloud_area_fraction_in_atmosphere_layer_in_tracer_concentration_array - long_name = tracer index for cloud amount integer - units = index - dimensions = () - type = integer - intent = in -[ntrw] - standard_name = index_of_rain_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for rain water - units = index - dimensions = () - type = integer - intent = in -[ntsw] - standard_name = index_of_snow_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for snow water - units = index - dimensions = () - type = integer - intent = in -[ntrnc] - standard_name = index_of_mass_number_concentration_of_rain_in_tracer_concentration_array - long_name = tracer index for rain number concentration - units = index - dimensions = () - type = integer - intent = in -[ntsnc] - standard_name = index_of_mass_number_concentration_of_snow_in_tracer_concentration_array - long_name = tracer index for snow number concentration - units = index - dimensions = () - type = integer - intent = in -[ntgl] - standard_name = index_of_graupel_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for graupel - units = index - dimensions = () - type = integer - intent = in -[ntgnc] - standard_name = index_of_mass_number_concentration_of_graupel_in_tracer_concentration_array - long_name = tracer index for graupel number concentration - units = index - dimensions = () - type = integer - intent = in -[ntlnc] - standard_name = index_of_mass_number_concentration_of_cloud_droplets_in_tracer_concentration_array - long_name = tracer index for liquid number concentration - units = index - dimensions = () - type = integer - intent = in -[ntinc] - standard_name = index_of_mass_number_concentration_of_cloud_ice_in_tracer_concentration_array - long_name = tracer index for ice number concentration - units = index - dimensions = () - type = integer - intent = in -[nn] - standard_name = number_of_tracers_for_convective_transport - long_name = number of tracers for convective transport - units = count - dimensions = () - type = integer - intent = in -[imp_physics] - standard_name = control_for_microphysics_scheme - long_name = choice of microphysics scheme - units = flag - dimensions = () - type = integer - intent = in -[imp_physics_gfdl] - standard_name = identifier_for_gfdl_microphysics_scheme - long_name = choice of GFDL microphysics scheme - units = flag - dimensions = () - type = integer - intent = in -[imp_physics_thompson] - standard_name = identifier_for_thompson_microphysics_scheme - long_name = choice of Thompson microphysics scheme - units = flag - dimensions = () - type = integer - intent = in -[imp_physics_zhao_carr] - standard_name = identifier_for_zhao_carr_microphysics_scheme - long_name = choice of Zhao-Carr microphysics scheme - units = flag - dimensions = () - type = integer - intent = in -[imp_physics_zhao_carr_pdf] - standard_name = identifier_for_zhao_carr_pdf_microphysics_scheme - long_name = choice of Zhao-Carr microphysics scheme with PDF clouds - units = flag - dimensions = () - type = integer - intent = in -[convert_dry_rho] - standard_name = flag_for_converting_hydrometeors_from_moist_to_dry_air - long_name = flag for converting hydrometeors from moist to dry air - units = flag - dimensions = () - type = logical - intent = in -[dtf] - standard_name = timestep_for_dynamics - long_name = dynamics timestep - units = s - dimensions = () - type = real - kind = kind_phys - intent = in -[save_qc] - standard_name = cloud_condensed_water_mixing_ratio_save - long_name = ratio of mass of cloud water to mass of dry air plus vapor (without condensates) before entering a physics scheme - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[save_qi] - standard_name = ice_water_mixing_ratio_save - long_name = cloud ice water mixing ratio before entering a physics scheme - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[save_lnc] - standard_name = liquid_cloud_number_concentration_save - long_name = liquid cloud number concentration before entering a physics scheme - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[save_inc] - standard_name = ice_cloud_number_concentration_save - long_name = ice cloud number concentration before entering a physics scheme - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[con_pi] - standard_name = pi - long_name = ratio of a circle's circumference to its diameter - units = none - dimensions = () - type = real - kind = kind_phys - intent = in -[gq0] - standard_name = tracer_concentration_of_new_state - long_name = tracer concentration updated by physics - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = inout -[clw] - standard_name = convective_transportable_tracers - long_name = array to contain cloud water and other convective trans. tracers - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers_for_convective_transport) - type = real - kind = kind_phys - intent = inout -[prsl] - standard_name = air_pressure - long_name = mean layer pressure - units = Pa - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[save_tcp] - standard_name = air_temperature_save_from_convective_parameterization - long_name = air temperature after cumulus parameterization - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[con_rd] - standard_name = gas_constant_of_dry_air - long_name = ideal gas constant for dry air - units = J kg-1 K-1 - dimensions = () - type = real - kind = kind_phys - intent = in -[con_eps] - standard_name = ratio_of_dry_air_to_water_vapor_gas_constants - long_name = rd/rv - units = none - dimensions = () - type = real - kind = kind_phys - intent = in -[nwfa] - standard_name = mass_number_concentration_of_hygroscopic_aerosols - long_name = number concentration of water-friendly aerosols - units = kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[spechum] - standard_name = specific_humidity - long_name = water vapor specific humidity - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[dtidx] - standard_name = cumulative_change_of_state_variables_outer_index - long_name = index of state-variable and process in last dimension of diagnostic tendencies array AKA cumulative_change_index - units = index - dimensions = (number_of_tracers_plus_one_hundred,number_of_cumulative_change_processes) - type = integer - intent = in -[dtend] - standard_name = cumulative_change_of_state_variables - long_name = diagnostic tendencies for state variables - units = mixed - dimensions = (horizontal_loop_extent,vertical_layer_dimension,cumulative_change_of_state_variables_outer_index_max) - type = real - kind = kind_phys - intent = inout -[ntk] - standard_name = index_for_turbulent_kinetic_energy_convective_transport_tracer - long_name = index for turbulent kinetic energy in the convectively transported tracer array - units = index - dimensions = () - type = integer - intent = in -[ntke] - standard_name = index_of_turbulent_kinetic_energy_in_tracer_concentration_array - long_name = tracer index for turbulent kinetic energy - units = index - dimensions = () - type = integer - intent = in -[ldiag3d] - standard_name = flag_for_diagnostics_3D - long_name = flag for 3d diagnostic fields - units = flag - dimensions = () - type = logical - intent = in -[qdiag3d] - standard_name = flag_for_tracer_diagnostics_3D - long_name = flag for 3d tracer diagnostic fields - units = flag - dimensions = () - type = logical - intent = in -[index_of_process_conv_trans] - standard_name = index_of_convective_transport_process_in_cumulative_change_index - long_name = index of convective transport process in second dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out - -######################################################################## -[ccpp-table-properties] - name = GFS_suite_interstitial_5 - type = scheme - dependencies = machine.F,module_mp_thompson_make_number_concentrations.F90 - -######################################################################## -[ccpp-arg-table] - name = GFS_suite_interstitial_5_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in -[levs] - standard_name = vertical_layer_dimension - long_name = vertical layer dimension - units = count - dimensions = () - type = integer - intent = in -[ntrac] - standard_name = number_of_tracers - long_name = number of tracers - units = count - dimensions = () - type = integer - intent = in -[ntcw] - standard_name = index_of_cloud_liquid_water_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for cloud condensate (or liquid water) - units = index - dimensions = () - type = integer - intent = in -[ntiw] - standard_name = index_of_cloud_ice_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for ice water - units = index - dimensions = () - type = integer - intent = in -[nn] - standard_name = number_of_tracers_for_convective_transport - long_name = number of tracers for convective transport - units = count - dimensions = () - type = integer - intent = in -[gq0] - standard_name = tracer_concentration_of_new_state - long_name = tracer concentration updated by physics - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = in -[clw] - standard_name = convective_transportable_tracers - long_name = array to contain cloud water and other convective trans. tracers - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers_for_convective_transport) - type = real - kind = kind_phys - intent = inout -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out diff --git a/physics/GFS_suite_interstitial_1.F90 b/physics/GFS_suite_interstitial_1.F90 new file mode 100644 index 000000000..0bfd4f4df --- /dev/null +++ b/physics/GFS_suite_interstitial_1.F90 @@ -0,0 +1,66 @@ +!> \file GFS_suite_interstitial_1.f90 +!! Contains code to calculate scale-aware variables used in cs_conv, gwdc, and precpd and to reset tendencies used in the +!! process-split section of GFS-based physics suites. + + module GFS_suite_interstitial_1 + + contains + +!> \section arg_table_GFS_suite_interstitial_1_run Argument Table +!! \htmlinclude GFS_suite_interstitial_1_run.html +!! + subroutine GFS_suite_interstitial_1_run (im, levs, ntrac, dtf, dtp, slmsk, area, dxmin, dxinv, pgr, & + islmsk, work1, work2, psurf, dudt, dvdt, dtdt, dqdt, errmsg, errflg) + + use machine, only: kind_phys + + implicit none + + ! interface variables + integer, intent(in ) :: im, levs, ntrac + real(kind=kind_phys), intent(in ) :: dtf, dtp, dxmin, dxinv + real(kind=kind_phys), intent(in ), dimension(:) :: slmsk, area, pgr + + integer, intent(out), dimension(:) :: islmsk + real(kind=kind_phys), intent(out), dimension(:) :: work1, work2, psurf + real(kind=kind_phys), intent(out), dimension(:,:) :: dudt, dvdt, dtdt + real(kind=kind_phys), intent(out), dimension(:,:,:) :: dqdt + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! local variables + real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys + integer :: i, k, n + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + do i = 1, im + islmsk(i) = nint(slmsk(i)) + + work1(i) = (log(area(i)) - dxmin) * dxinv + work1(i) = max(zero, min(one, work1(i))) + work2(i) = one - work1(i) + psurf(i) = pgr(i) + end do + + do k=1,levs + do i=1,im + dudt(i,k) = zero + dvdt(i,k) = zero + dtdt(i,k) = zero + enddo + enddo + do n=1,ntrac + do k=1,levs + do i=1,im + dqdt(i,k,n) = zero + enddo + enddo + enddo + + end subroutine GFS_suite_interstitial_1_run + + end module GFS_suite_interstitial_1 \ No newline at end of file diff --git a/physics/GFS_suite_interstitial_1.meta b/physics/GFS_suite_interstitial_1.meta new file mode 100644 index 000000000..a465ed320 --- /dev/null +++ b/physics/GFS_suite_interstitial_1.meta @@ -0,0 +1,165 @@ +######################################################################## +[ccpp-table-properties] + name = GFS_suite_interstitial_1 + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = GFS_suite_interstitial_1_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[levs] + standard_name = vertical_layer_dimension + long_name = vertical layer dimension + units = count + dimensions = () + type = integer + intent = in +[ntrac] + standard_name = number_of_tracers + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = in +[dtf] + standard_name = timestep_for_dynamics + long_name = dynamics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in +[dtp] + standard_name = timestep_for_physics + long_name = physics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in +[slmsk] + standard_name = area_type + long_name = landmask: sea/land/ice=0/1/2 + units = flag + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[area] + standard_name = cell_area + long_name = area of the grid cell + units = m2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[dxmin] + standard_name = min_grid_scale + long_name = minimum scaling factor for critical relative humidity + units = m2 rad-2 + dimensions = () + type = real + kind = kind_phys + intent = in +[dxinv] + standard_name = reciprocal_of_grid_scale_range + long_name = inverse scaling factor for critical relative humidity + units = rad2 m-2 + dimensions = () + type = real + kind = kind_phys + intent = in +[pgr] + standard_name = surface_air_pressure + long_name = surface pressure + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[islmsk] + standard_name = sea_land_ice_mask + long_name = landmask: sea/land/ice=0/1/2 + units = flag + dimensions = (horizontal_loop_extent) + type = integer + intent = out +[work1] + standard_name = grid_size_related_coefficient_used_in_scale_sensitive_schemes + long_name = grid size related coefficient used in scale-sensitive schemes + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[work2] + standard_name = grid_size_related_coefficient_used_in_scale_sensitive_schemes_complement + long_name = complement to work1 + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[psurf] + standard_name = surface_air_pressure_diag + long_name = surface air pressure diagnostic + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[dudt] + standard_name = process_split_cumulative_tendency_of_x_wind + long_name = updated tendency of the x wind + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[dvdt] + standard_name = process_split_cumulative_tendency_of_y_wind + long_name = updated tendency of the y wind + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[dtdt] + standard_name = process_split_cumulative_tendency_of_air_temperature + long_name = updated tendency of the temperature + units = K s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[dqdt] + standard_name = process_split_cumulative_tendency_of_tracers + long_name = updated tendency of the tracers + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = out +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out \ No newline at end of file diff --git a/physics/GFS_suite_interstitial_2.F90 b/physics/GFS_suite_interstitial_2.F90 new file mode 100644 index 000000000..c72e5c7b2 --- /dev/null +++ b/physics/GFS_suite_interstitial_2.F90 @@ -0,0 +1,236 @@ +!> \file GFS_suite_interstitial_2.f90 +!! Contains code related used to calculate radiation-based and PBL-based diagnostics that are executed after radiation time interpolation and before the surface layer. + + module GFS_suite_interstitial_2 + + use machine, only: kind_phys + real(kind=kind_phys), parameter :: one = 1.0_kind_phys + logical :: linit_mod = .false. + + contains + +!> \section arg_table_GFS_suite_interstitial_2_run Argument Table +!! \htmlinclude GFS_suite_interstitial_2_run.html +!! + subroutine GFS_suite_interstitial_2_run (im, levs, lssav, ldiag3d, lsidea, flag_cice, shal_cnv, old_monin, mstrat, & + do_shoc, frac_grid, imfshalcnv, dtf, xcosz, adjsfcdsw, adjsfcdlw, cice, pgr, ulwsfc_cice, lwhd, htrsw, htrlw, xmu, ctei_rm, & + work1, work2, prsi, tgrs, prsl, qgrs_water_vapor, qgrs_cloud_water, cp, hvap, prslk, suntim, adjsfculw, adjsfculw_lnd, & + adjsfculw_ice, adjsfculw_wat, dlwsfc, ulwsfc, psmean, dtend, dtidx, index_of_process_longwave, index_of_process_shortwave, & + index_of_process_pbl, index_of_process_dcnv, index_of_process_scnv, index_of_process_mp, index_of_temperature, & + ctei_rml, ctei_r, kinver, dry, icy, wet, frland, huge, use_LW_jacobian, htrlwu, errmsg, errflg) + + implicit none + + ! interface variables + integer, intent(in ) :: im, levs, imfshalcnv + logical, intent(in ) :: lssav, ldiag3d, lsidea, shal_cnv + logical, intent(in ) :: old_monin, mstrat, do_shoc, frac_grid, use_LW_jacobian + real(kind=kind_phys), intent(in ) :: dtf, cp, hvap + + logical, intent(in ), dimension(:) :: flag_cice + real(kind=kind_phys), intent(in ), dimension(:) :: ctei_rm + real(kind=kind_phys), intent(in ), dimension(:) :: xcosz, adjsfcdsw, adjsfcdlw, pgr, xmu, work1, work2 + real(kind=kind_phys), intent(in ), dimension(:) :: ulwsfc_cice + real(kind=kind_phys), intent(in ), dimension(:) :: cice + real(kind=kind_phys), intent(in ), dimension(:,:) :: htrsw, htrlw, htrlwu, tgrs, prsl, qgrs_water_vapor, qgrs_cloud_water, prslk + real(kind=kind_phys), intent(in ), dimension(:,:) :: prsi + real(kind=kind_phys), intent(in ), dimension(:,:,:) :: lwhd + integer, intent(inout), dimension(:) :: kinver + real(kind=kind_phys), intent(inout), dimension(:) :: suntim, dlwsfc, ulwsfc, psmean, ctei_rml, ctei_r + real(kind=kind_phys), intent(in ), dimension(:) :: adjsfculw_lnd, adjsfculw_ice, adjsfculw_wat + real(kind=kind_phys), intent(inout), dimension(:) :: adjsfculw + + ! dtend is only allocated if ldiag3d is .true. + real(kind=kind_phys), optional, intent(inout), dimension(:,:,:) :: dtend + integer, intent(in), dimension(:,:) :: dtidx + integer, intent(in) :: index_of_process_longwave, index_of_process_shortwave, & + index_of_process_pbl, index_of_process_dcnv, index_of_process_scnv, & + index_of_process_mp, index_of_temperature + + logical, intent(in ), dimension(:) :: dry, icy, wet + real(kind=kind_phys), intent(in ), dimension(:) :: frland + real(kind=kind_phys), intent(in ) :: huge + + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg + + ! local variables + real(kind=kind_phys), parameter :: czmin = 0.0001_kind_phys ! cos(89.994) + integer :: i, k, idtend + real(kind=kind_phys) :: tem1, tem2, tem, hocp + logical, dimension(im) :: invrsn + real(kind=kind_phys), dimension(im) :: tx1, tx2 + + real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys + real(kind=kind_phys), parameter :: qmin = 1.0e-10_kind_phys, epsln=1.0e-10_kind_phys + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + hocp = hvap/cp + + if (lssav) then ! --- ... accumulate/save output variables + +! --- ... sunshine duration time is defined as the length of time (in mdl output +! interval) that solar radiation falling on a plane perpendicular to the +! direction of the sun >= 120 w/m2 + + do i = 1, im + if ( xcosz(i) >= czmin ) then ! zenth angle > 89.994 deg + tem1 = adjsfcdsw(i) / xcosz(i) + if ( tem1 >= 120.0_kind_phys ) then + suntim(i) = suntim(i) + dtf + endif + endif + enddo + +! --- ... sfc lw fluxes used by atmospheric model are saved for output + if (frac_grid) then + do i=1,im + tem = (one - frland(i)) * cice(i) ! tem = ice fraction wrt whole cell + if (flag_cice(i)) then + adjsfculw(i) = adjsfculw_lnd(i) * frland(i) & + + ulwsfc_cice(i) * tem & + + adjsfculw_wat(i) * (one - frland(i) - tem) + else + adjsfculw(i) = adjsfculw_lnd(i) * frland(i) & + + adjsfculw_ice(i) * tem & + + adjsfculw_wat(i) * (one - frland(i) - tem) + endif + enddo + else + do i=1,im + if (dry(i)) then ! all land + adjsfculw(i) = adjsfculw_lnd(i) + elseif (icy(i)) then ! ice (and water) + tem = one - cice(i) + if (flag_cice(i)) then + if (wet(i) .and. adjsfculw_wat(i) /= huge) then + adjsfculw(i) = ulwsfc_cice(i)*cice(i) + adjsfculw_wat(i)*tem + else + adjsfculw(i) = ulwsfc_cice(i) + endif + else + if (wet(i) .and. adjsfculw_wat(i) /= huge) then + adjsfculw(i) = adjsfculw_ice(i)*cice(i) + adjsfculw_wat(i)*tem + else + adjsfculw(i) = adjsfculw_ice(i) + endif + endif + else ! all water + adjsfculw(i) = adjsfculw_wat(i) + endif + enddo + endif + + do i=1,im + dlwsfc(i) = dlwsfc(i) + adjsfcdlw(i)*dtf + ulwsfc(i) = ulwsfc(i) + adjsfculw(i)*dtf + psmean(i) = psmean(i) + pgr(i)*dtf ! mean surface pressure + enddo + + if (ldiag3d) then + if (lsidea) then + idtend = dtidx(index_of_temperature,index_of_process_longwave) + if(idtend>=1) then + dtend(:,:,idtend) = dtend(:,:,idtend) + lwhd(:,:,1)*dtf + endif + + idtend = dtidx(index_of_temperature,index_of_process_shortwave) + if(idtend>=1) then + dtend(:,:,idtend) = dtend(:,:,idtend) + lwhd(:,:,2)*dtf + endif + + idtend = dtidx(index_of_temperature,index_of_process_pbl) + if(idtend>=1) then + dtend(:,:,idtend) = dtend(:,:,idtend) + lwhd(:,:,3)*dtf + endif + + idtend = dtidx(index_of_temperature,index_of_process_dcnv) + if(idtend>=1) then + dtend(:,:,idtend) = dtend(:,:,idtend) + lwhd(:,:,4)*dtf + endif + + idtend = dtidx(index_of_temperature,index_of_process_scnv) + if(idtend>=1) then + dtend(:,:,idtend) = dtend(:,:,idtend) + lwhd(:,:,5)*dtf + endif + + idtend = dtidx(index_of_temperature,index_of_process_mp) + if(idtend>=1) then + dtend(:,:,idtend) = dtend(:,:,idtend) + lwhd(:,:,6)*dtf + endif + else + idtend = dtidx(index_of_temperature,index_of_process_longwave) + if(idtend>=1) then + if (use_LW_jacobian) then + dtend(:,:,idtend) = dtend(:,:,idtend) + htrlwu(:,:)*dtf + else + dtend(:,:,idtend) = dtend(:,:,idtend) + htrlw(:,:)*dtf + endif + endif + + idtend = dtidx(index_of_temperature,index_of_process_shortwave) + if(idtend>=1) then + do k=1,levs + do i=1,im + dtend(i,k,idtend) = dtend(i,k,idtend) + htrsw(i,k)*dtf*xmu(i) + enddo + enddo + endif + endif + endif + endif ! end if_lssav_block + + do i=1, im + invrsn(i) = .false. + tx1(i) = zero + tx2(i) = 10.0_kind_phys + ctei_r(i) = 10.0_kind_phys + enddo + + if ((((imfshalcnv == 0 .and. shal_cnv) .or. old_monin) .and. mstrat) & + .or. do_shoc) then + ctei_rml(:) = ctei_rm(1)*work1(:) + ctei_rm(2)*work2(:) + do k=1,levs/2 + do i=1,im + if (prsi(i,1)-prsi(i,k+1) < 0.35_kind_phys*prsi(i,1) & + .and. (.not. invrsn(i))) then + tem = (tgrs(i,k+1) - tgrs(i,k)) & + / (prsl(i,k) - prsl(i,k+1)) + + if (((tem > 0.0001_kind_phys) .and. (tx1(i) < zero)) .or. & + ((tem-abs(tx1(i)) > zero) .and. (tx2(i) < zero))) then + invrsn(i) = .true. + + if (qgrs_water_vapor(i,k) > qgrs_water_vapor(i,k+1)) then + tem1 = tgrs(i,k+1) + hocp*max(qgrs_water_vapor(i,k+1),qmin) + tem2 = tgrs(i,k) + hocp*max(qgrs_water_vapor(i,k),qmin) + + tem1 = tem1 / prslk(i,k+1) - tem2 / prslk(i,k) + +! --- ... (cp/l)(deltathetae)/(deltatwater) > ctei_rm -> conditon for CTEI + ctei_r(i) = (one/hocp)*tem1/(qgrs_water_vapor(i,k+1)-qgrs_water_vapor(i,k) & + + qgrs_cloud_water(i,k+1)-qgrs_cloud_water(i,k)) + else + ctei_r(i) = 10.0_kind_phys + endif + + if ( ctei_rml(i) > ctei_r(i) ) then + kinver(i) = k + else + kinver(i) = levs + endif + endif + + tx2(i) = tx1(i) + tx1(i) = tem + endif + enddo + enddo + endif + + end subroutine GFS_suite_interstitial_2_run + + end module GFS_suite_interstitial_2 \ No newline at end of file diff --git a/physics/GFS_suite_interstitial_2.meta b/physics/GFS_suite_interstitial_2.meta new file mode 100644 index 000000000..1f4300574 --- /dev/null +++ b/physics/GFS_suite_interstitial_2.meta @@ -0,0 +1,488 @@ +######################################################################## +[ccpp-table-properties] + name = GFS_suite_interstitial_2 + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = GFS_suite_interstitial_2_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[levs] + standard_name = vertical_layer_dimension + long_name = vertical layer dimension + units = count + dimensions = () + type = integer + intent = in +[lssav] + standard_name = flag_for_diagnostics + long_name = logical flag for storing diagnostics + units = flag + dimensions = () + type = logical + intent = in +[ldiag3d] + standard_name = flag_for_diagnostics_3D + long_name = flag for 3d diagnostic fields + units = flag + dimensions = () + type = logical + intent = in +[lsidea] + standard_name = flag_for_integrated_dynamics_through_earths_atmosphere + long_name = flag for idealized physics + units = flag + dimensions = () + type = logical + intent = in +[flag_cice] + standard_name = flag_for_cice + long_name = flag for cice + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in +[shal_cnv] + standard_name = flag_for_simplified_arakawa_schubert_shallow_convection + long_name = flag for calling shallow convection + units = flag + dimensions = () + type = logical + intent = in +[old_monin] + standard_name = flag_for_old_PBL_scheme + long_name = flag for using old PBL schemes + units = flag + dimensions = () + type = logical + intent = in +[mstrat] + standard_name = flag_for_moorthi_stratus + long_name = flag for moorthi approach for stratus + units = flag + dimensions = () + type = logical + intent = in +[do_shoc] + standard_name = flag_for_shoc + long_name = flag for SHOC + units = flag + dimensions = () + type = logical + intent = in +[frac_grid] + standard_name = flag_for_fractional_landmask + long_name = flag for fractional grid + units = flag + dimensions = () + type = logical + intent = in +[imfshalcnv] + standard_name = control_for_shallow_convection_scheme + long_name = flag for mass-flux shallow convection scheme + units = flag + dimensions = () + type = integer + intent = in +[dtf] + standard_name = timestep_for_dynamics + long_name = dynamics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in +[xcosz] + standard_name = instantaneous_cosine_of_zenith_angle + long_name = cosine of zenith angle at current time + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[adjsfcdsw] + standard_name = surface_downwelling_shortwave_flux + long_name = surface downwelling shortwave flux at current time + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[adjsfcdlw] + standard_name = surface_downwelling_longwave_flux + long_name = surface downwelling longwave flux at current time + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[cice] + standard_name = sea_ice_area_fraction_of_sea_area_fraction + long_name = ice fraction over open water + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[pgr] + standard_name = surface_air_pressure + long_name = surface pressure + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[ulwsfc_cice] + standard_name = surface_upwelling_longwave_flux_from_coupled_process + long_name = surface upwelling longwave flux for coupling + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[lwhd] + standard_name = tendency_of_air_temperature_due_to_integrated_dynamics_through_earths_atmosphere + long_name = idea sky lw heating rates + units = K s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,6) + type = real + kind = kind_phys + intent = in +[htrsw] + standard_name = tendency_of_air_temperature_due_to_shortwave_heating_on_radiation_timestep + long_name = total sky sw heating rate + units = K s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[htrlw] + standard_name = tendency_of_air_temperature_due_to_longwave_heating_on_radiation_timestep + long_name = total sky lw heating rate + units = K s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[xmu] + standard_name = zenith_angle_temporal_adjustment_factor_for_shortwave_fluxes + long_name = zenith angle temporal adjustment factor for shortwave fluxes + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[ctei_rm] + standard_name = tunable_parameter_for_critical_cloud_top_entrainment_instability_criteria + long_name = critical cloud top entrainment instability criteria + units = none + dimensions = (2) + type = real + kind = kind_phys + intent = in +[work1] + standard_name = grid_size_related_coefficient_used_in_scale_sensitive_schemes + long_name = grid size related coefficient used in scale-sensitive schemes + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[work2] + standard_name = grid_size_related_coefficient_used_in_scale_sensitive_schemes_complement + long_name = complement to work1 + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[prsi] + standard_name = air_pressure_at_interface + long_name = air pressure at model layer interfaces + units = Pa + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = in +[tgrs] + standard_name = air_temperature + long_name = model layer mean temperature + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[prsl] + standard_name = air_pressure + long_name = mean layer pressure + units = Pa + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[qgrs_water_vapor] + standard_name = specific_humidity + long_name = water vapor specific humidity + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[qgrs_cloud_water] + standard_name = cloud_liquid_water_mixing_ratio + long_name = ratio of mass of cloud water to mass of dry air plus vapor (without condensates) + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cp] + standard_name = specific_heat_of_dry_air_at_constant_pressure + long_name = specific heat of dry air at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[hvap] + standard_name = latent_heat_of_vaporization_of_water_at_0C + long_name = latent heat of evaporation/sublimation + units = J kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[prslk] + standard_name = dimensionless_exner_function + long_name = dimensionless Exner function at model layer centers + units = none + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[suntim] + standard_name = duration_of_sunshine + long_name = sunshine duration time + units = s + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[use_LW_jacobian] + standard_name = flag_to_calc_RRTMGP_LW_jacobian + long_name = logical flag to control RRTMGP LW calculation + units = flag + dimensions = () + type = logical + intent = in +[htrlwu] + standard_name = updated_tendency_of_air_temperature_due_to_longwave_heating_on_physics_timestep + long_name = total sky longwave heating rate on physics time step + units = K s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[adjsfculw] + standard_name = surface_upwelling_longwave_flux + long_name = surface upwelling longwave flux at current time + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[adjsfculw_lnd] + standard_name = surface_upwelling_longwave_flux_over_land + long_name = surface upwelling longwave flux at current time over land + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[adjsfculw_ice] + standard_name = surface_upwelling_longwave_flux_over_ice + long_name = surface upwelling longwave flux at current time over ice + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[adjsfculw_wat] + standard_name = surface_upwelling_longwave_flux_over_water + long_name = surface upwelling longwave flux at current time over water + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[dlwsfc] + standard_name = cumulative_surface_downwelling_longwave_flux_multiplied_by_timestep + long_name = cumulative surface downwelling LW flux multiplied by timestep + units = W m-2 s + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[ulwsfc] + standard_name = cumulative_surface_upwelling_longwave_flux_multiplied_by_timestep + long_name = cumulative surface upwelling LW flux multiplied by timestep + units = W m-2 s + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[psmean] + standard_name = cumulative_surface_pressure_multiplied_by_timestep + long_name = cumulative surface pressure multiplied by timestep + units = Pa s + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[dtend] + standard_name = cumulative_change_of_state_variables + long_name = diagnostic tendencies for state variables + units = mixed + dimensions = (horizontal_loop_extent,vertical_layer_dimension,cumulative_change_of_state_variables_outer_index_max) + type = real + kind = kind_phys + intent = inout +[dtidx] + standard_name = cumulative_change_of_state_variables_outer_index + long_name = index of state-variable and process in last dimension of diagnostic tendencies array AKA cumulative_change_index + units = index + dimensions = (number_of_tracers_plus_one_hundred,number_of_cumulative_change_processes) + type = integer + intent = in +[index_of_process_longwave] + standard_name = index_of_longwave_heating_process_in_cumulative_change_index + long_name = index of longwave heating process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[index_of_process_shortwave] + standard_name = index_of_shortwave_heating_process_in_cumulative_change_index + long_name = index of shortwave heating process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[index_of_process_pbl] + standard_name = index_of_subgrid_scale_vertical_mixing_process_in_cumulative_change_index + long_name = index of subgrid scale vertical mixing process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[index_of_process_dcnv] + standard_name = index_of_deep_convection_process_process_in_cumulative_change_index + long_name = index of deep convection process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[index_of_process_scnv] + standard_name = index_of_shallow_convection_process_process_in_cumulative_change_index + long_name = index of shallow convection process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[index_of_process_mp] + standard_name = index_of_microphysics_process_process_in_cumulative_change_index + long_name = index of microphysics transport process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[index_of_temperature] + standard_name = index_of_temperature_in_cumulative_change_index + long_name = index of temperature in first dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[ctei_rml] + standard_name = grid_sensitive_critical_cloud_top_entrainment_instability_criteria + long_name = grid sensitive critical cloud top entrainment instability criteria + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[ctei_r] + standard_name = cloud_top_entrainment_instability_value + long_name = cloud top entrainment instability value + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[kinver] + standard_name = index_of_highest_temperature_inversion + long_name = index of highest temperature inversion + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = inout +[dry] + standard_name = flag_nonzero_land_surface_fraction + long_name = flag indicating presence of some land surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in +[icy] + standard_name = flag_nonzero_sea_ice_surface_fraction + long_name = flag indicating presence of some sea ice surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in +[wet] + standard_name = flag_nonzero_wet_surface_fraction + long_name = flag indicating presence of some ocean or lake surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in +[frland] + standard_name = land_area_fraction_for_microphysics + long_name = land area fraction used in microphysics schemes + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[huge] + standard_name = netcdf_float_fillvalue + long_name = definition of NetCDF float FillValue + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out \ No newline at end of file diff --git a/physics/GFS_suite_interstitial_3.F90 b/physics/GFS_suite_interstitial_3.F90 new file mode 100644 index 000000000..79ab481ec --- /dev/null +++ b/physics/GFS_suite_interstitial_3.F90 @@ -0,0 +1,195 @@ +!> \file GFS_suite_interstitial_3.F90 +!! Contains code to setup convectively-transported tracers, calculate critical relative humidity, and save cloud number concentrations + + module GFS_suite_interstitial_3 + + contains + +!> \section arg_table_GFS_suite_interstitial_3_run Argument Table +!! \htmlinclude GFS_suite_interstitial_3_run.html +!! + subroutine GFS_suite_interstitial_3_run (otsptflag, & + im, levs, nn, cscnv, & + satmedmf, trans_trac, do_shoc, ltaerosol, ntrac, ntcw, & + ntiw, ntclamt, ntrw, ntsw, ntrnc, ntsnc, ntgl, ntgnc, & + xlon, xlat, gt0, gq0, imp_physics, imp_physics_mg, & + imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, & + imp_physics_gfdl, imp_physics_thompson, dtidx, ntlnc, & + imp_physics_wsm6, imp_physics_fer_hires, prsi, ntinc, & + imp_physics_nssl, & + prsl, prslk, rhcbot,rhcpbl, rhctop, rhcmax, islmsk, & + work1, work2, kpbl, kinver, ras, me, save_lnc, save_inc, & + ldiag3d, qdiag3d, index_of_process_conv_trans, & + clw, rhc, save_qc, save_qi, save_tcp, errmsg, errflg) + + use machine, only: kind_phys + + implicit none + + ! interface variables + logical, intent(in) :: otsptflag(:)! on/off switch for tracer transport (size ntrac) + integer, intent(in ) :: im, levs, nn, ntrac, ntcw, ntiw, ntclamt, ntrw, ntsw,& + ntrnc, ntsnc, ntgl, ntgnc, imp_physics, imp_physics_mg, imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, & + imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6,imp_physics_fer_hires, & + imp_physics_nssl, me, index_of_process_conv_trans + integer, intent(in ), dimension(:) :: islmsk, kpbl, kinver + logical, intent(in ) :: cscnv, satmedmf, trans_trac, do_shoc, ltaerosol, ras + + integer, intent(in) :: ntinc, ntlnc + logical, intent(in) :: ldiag3d, qdiag3d + integer, dimension(:,:), intent(in) :: dtidx + real, dimension(:,:), intent(out) :: save_lnc, save_inc + + real(kind=kind_phys), intent(in ) :: rhcbot, rhcmax, rhcpbl, rhctop + real(kind=kind_phys), intent(in ), dimension(:) :: work1, work2 + real(kind=kind_phys), intent(in ), dimension(:,:) :: prsl, prslk + real(kind=kind_phys), intent(in ), dimension(:,:) :: prsi + real(kind=kind_phys), intent(in ), dimension(:) :: xlon, xlat + real(kind=kind_phys), intent(in ), dimension(:,:) :: gt0 + real(kind=kind_phys), intent(in ), dimension(:,:,:) :: gq0 + + real(kind=kind_phys), intent(inout), dimension(:,:) :: rhc, save_qc + ! save_qi is not allocated for Zhao-Carr MP + real(kind=kind_phys), intent(inout), dimension(:,:) :: save_qi + real(kind=kind_phys), intent(inout), dimension(:,:) :: save_tcp + real(kind=kind_phys), intent(inout), dimension(:,:,:) :: clw + + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg + + ! local variables + integer :: i,k,n,tracers,kk + real(kind=kind_phys) :: tem, tem1, tem2 + real(kind=kind_phys), dimension(im) :: tx1, tx2, tx3, tx4 + + !real(kind=kind_phys),parameter :: slope_mg = 0.02, slope_upmg = 0.04, & + ! turnrhcrit = 0.900, turnrhcrit_upper = 0.150 + ! in the following inverse of slope_mg and slope_upmg are specified + real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys + real(kind=kind_phys), parameter :: slope_mg = 50.0_kind_phys, & + slope_upmg = 25.0_kind_phys + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (cscnv .or. satmedmf .or. trans_trac .or. ras) then + tracers = 2 + do n=2,ntrac +! if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt .and. & +! n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & +! n /= ntsnc .and. n /= ntgl .and. n /= ntgnc) then + IF ( otsptflag(n) ) THEN + tracers = tracers + 1 + do k=1,levs + do i=1,im + clw(i,k,tracers) = gq0(i,k,n) + enddo + enddo + endif + enddo + endif ! end if_ras or cfscnv or samf + + if (ntcw > 0) then + if (imp_physics == imp_physics_mg .and. rhcpbl < 0.5_kind_phys) then ! compute rhc for GMAO macro physics cloud pdf + do i=1,im + tx1(i) = one / prsi(i,1) + tx2(i) = one - rhcmax*work1(i)-rhcbot*work2(i) + + kk = min(kinver(i), max(2,kpbl(i))) + tx3(i) = prsi(i,kk)*tx1(i) + tx4(i) = rhcpbl - rhctop*abs(cos(xlat(i))) + enddo + do k = 1, levs + do i = 1, im + tem = prsl(i,k) * tx1(i) + tem1 = min(max((tem-tx3(i))*slope_mg, -20.0_kind_phys), 20.0_kind_phys) + ! Using rhcpbl and rhctop from the namelist instead of 0.3 and 0.2 + ! and rhcbot represents pbl top critical relative humidity + tem2 = min(max((tx4(i)-tem)*slope_upmg, -20.0_kind_phys), 20.0_kind_phys) ! Anning + if (islmsk(i) > 0) then + tem1 = one / (one+exp(tem1+tem1)) + else + tem1 = 2.0_kind_phys / (one+exp(tem1+tem1)) + endif + tem2 = one / (one+exp(tem2)) + + rhc(i,k) = min(rhcmax, max(0.7_kind_phys, one-tx2(i)*tem1*tem2)) + enddo + enddo + else + do k=1,levs + do i=1,im + kk = max(10,kpbl(i)) + if (k < kk) then + tem = rhcbot - (rhcbot-rhcpbl) * (one-prslk(i,k)) / (one-prslk(i,kk)) + else + tem = rhcpbl - (rhcpbl-rhctop) * (prslk(i,kk)-prslk(i,k)) / prslk(i,kk) + endif + tem = rhcmax * work1(i) + tem * work2(i) + rhc(i,k) = max(zero, min(one,tem)) + enddo + enddo + endif + else + rhc(:,:) = 1.0 + endif + + if (imp_physics == imp_physics_zhao_carr .or. imp_physics == imp_physics_zhao_carr_pdf) then ! zhao-carr microphysics + !GF* move to GFS_MP_generic_pre (from gscond/precpd) + ! do i=1,im + ! psautco_l(i) = Model%psautco(1)*work1(i) + Model%psautco(2)*work2(i) + ! prautco_l(i) = Model%prautco(1)*work1(i) + Model%prautco(2)*work2(i) + ! enddo + !*GF + do k=1,levs + do i=1,im + clw(i,k,1) = gq0(i,k,ntcw) + enddo + enddo + elseif (imp_physics == imp_physics_gfdl) then + clw(1:im,:,1) = gq0(1:im,:,ntcw) + elseif (imp_physics == imp_physics_thompson) then + do k=1,levs + do i=1,im + clw(i,k,1) = gq0(i,k,ntiw) ! ice + clw(i,k,2) = gq0(i,k,ntcw) ! water + save_tcp(i,k) = gt0(i,k) + enddo + enddo + if(ltaerosol) then + save_qi(:,:) = clw(:,:,1) + save_qc(:,:) = clw(:,:,2) + else + save_qi(:,:) = clw(:,:,1) + endif + else if (imp_physics == imp_physics_nssl ) then + do k=1,levs + do i=1,im + clw(i,k,1) = gq0(i,k,ntiw) ! cloud ice + clw(i,k,2) = gq0(i,k,ntcw) ! cloud droplets + enddo + enddo + save_qi(:,:) = clw(:,:,1) + save_qc(:,:) = clw(:,:,2) + elseif (imp_physics == imp_physics_wsm6 .or. imp_physics == imp_physics_mg .or. imp_physics == imp_physics_fer_hires) then + do k=1,levs + do i=1,im + clw(i,k,1) = gq0(i,k,ntiw) ! ice + clw(i,k,2) = gq0(i,k,ntcw) ! water + enddo + enddo + endif + + if(imp_physics == imp_physics_thompson .and. ldiag3d .and. qdiag3d) then + if(dtidx(100+ntlnc,index_of_process_conv_trans)>0) then + save_lnc = gq0(:,:,ntlnc) + endif + if(dtidx(100+ntinc,index_of_process_conv_trans)>0) then + save_inc = gq0(:,:,ntinc) + endif + endif + + end subroutine GFS_suite_interstitial_3_run + + end module GFS_suite_interstitial_3 \ No newline at end of file diff --git a/physics/GFS_suite_interstitial_3.meta b/physics/GFS_suite_interstitial_3.meta new file mode 100644 index 000000000..22a11d0ea --- /dev/null +++ b/physics/GFS_suite_interstitial_3.meta @@ -0,0 +1,458 @@ +######################################################################## +[ccpp-table-properties] + name = GFS_suite_interstitial_3 + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = GFS_suite_interstitial_3_run + type = scheme +[otsptflag] + standard_name = flag_convective_tracer_transport_interstitial + long_name = flag for interstitial tracer transport + units = flag + dimensions = (number_of_tracers) + type = logical + intent = in +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[levs] + standard_name = vertical_layer_dimension + long_name = vertical layer dimension + units = count + dimensions = () + type = integer + intent = in +[nn] + standard_name = number_of_tracers_for_convective_transport + long_name = number of tracers for convective transport + units = count + dimensions = () + type = integer + intent = in +[cscnv] + standard_name = flag_for_Chikira_Sugiyama_deep_convection + long_name = flag for Chikira-Sugiyama convection + units = flag + dimensions = () + type = logical + intent = in +[satmedmf] + standard_name = flag_for_scale_aware_TKE_moist_EDMF_PBL + long_name = flag for scale-aware TKE moist EDMF PBL scheme + units = flag + dimensions = () + type = logical + intent = in +[trans_trac] + standard_name = flag_for_convective_transport_of_tracers + long_name = flag for convective transport of tracers + units = flag + dimensions = () + type = logical + intent = in +[do_shoc] + standard_name = flag_for_shoc + long_name = flag for SHOC + units = flag + dimensions = () + type = logical + intent = in +[ltaerosol] + standard_name = flag_for_aerosol_physics + long_name = flag for aerosol physics + units = flag + dimensions = () + type = logical + intent = in +[ntrac] + standard_name = number_of_tracers + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = in +[ntcw] + standard_name = index_of_cloud_liquid_water_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for cloud condensate (or liquid water) + units = index + dimensions = () + type = integer + intent = in +[ntiw] + standard_name = index_of_cloud_ice_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for ice water + units = index + dimensions = () + type = integer + intent = in +[ntclamt] + standard_name = index_of_cloud_area_fraction_in_atmosphere_layer_in_tracer_concentration_array + long_name = tracer index for cloud amount integer + units = index + dimensions = () + type = integer + intent = in +[ntrw] + standard_name = index_of_rain_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for rain water + units = index + dimensions = () + type = integer + intent = in +[ntsw] + standard_name = index_of_snow_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for snow water + units = index + dimensions = () + type = integer + intent = in +[ntrnc] + standard_name = index_of_mass_number_concentration_of_rain_in_tracer_concentration_array + long_name = tracer index for rain number concentration + units = index + dimensions = () + type = integer + intent = in +[ntsnc] + standard_name = index_of_mass_number_concentration_of_snow_in_tracer_concentration_array + long_name = tracer index for snow number concentration + units = index + dimensions = () + type = integer + intent = in +[ntgl] + standard_name = index_of_graupel_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for graupel + units = index + dimensions = () + type = integer + intent = in +[ntgnc] + standard_name = index_of_mass_number_concentration_of_graupel_in_tracer_concentration_array + long_name = tracer index for graupel number concentration + units = index + dimensions = () + type = integer + intent = in +[xlon] + standard_name = longitude + long_name = longitude + units = radian + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[xlat] + standard_name = latitude + long_name = latitude + units = radian + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[gt0] + standard_name = air_temperature_of_new_state + long_name = temperature updated by physics + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[gq0] + standard_name = tracer_concentration_of_new_state + long_name = tracer concentration updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = in +[imp_physics] + standard_name = control_for_microphysics_scheme + long_name = choice of microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[imp_physics_mg] + standard_name = identifier_for_morrison_gettelman_microphysics_scheme + long_name = choice of Morrison-Gettelman microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[imp_physics_zhao_carr] + standard_name = identifier_for_zhao_carr_microphysics_scheme + long_name = choice of Zhao-Carr microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[imp_physics_zhao_carr_pdf] + standard_name = identifier_for_zhao_carr_pdf_microphysics_scheme + long_name = choice of Zhao-Carr microphysics scheme with PDF clouds + units = flag + dimensions = () + type = integer + intent = in +[imp_physics_gfdl] + standard_name = identifier_for_gfdl_microphysics_scheme + long_name = choice of GFDL microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[imp_physics_thompson] + standard_name = identifier_for_thompson_microphysics_scheme + long_name = choice of Thompson microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[imp_physics_wsm6] + standard_name = identifier_for_wsm6_microphysics_scheme + long_name = choice of WSM6 microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[imp_physics_fer_hires] + standard_name = identifier_for_fer_hires_microphysics_scheme + long_name = choice of Ferrier-Aligo microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[imp_physics_nssl] + standard_name = identifier_for_nssl_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[prsi] + standard_name = air_pressure_at_interface + long_name = air pressure at model layer interfaces + units = Pa + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = in +[prsl] + standard_name = air_pressure + long_name = mean layer pressure + units = Pa + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[prslk] + standard_name = dimensionless_exner_function + long_name = dimensionless Exner function at model layer centers + units = none + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[rhcbot] + standard_name = critical_relative_humidity_at_surface + long_name = critical relative humidity at the surface + units = frac + dimensions = () + type = real + kind = kind_phys + intent = in +[rhcpbl] + standard_name = critical_relative_humidity_at_PBL_top + long_name = critical relative humidity at the PBL top + units = frac + dimensions = () + type = real + kind = kind_phys + intent = in +[rhctop] + standard_name = critical_relative_humidity_at_toa + long_name = critical relative humidity at the top of atmosphere + units = frac + dimensions = () + type = real + kind = kind_phys + intent = in +[rhcmax] + standard_name = max_critical_relative_humidity + long_name = maximum critical relative humidity + units = frac + dimensions = () + type = real + kind = kind_phys + intent = in +[islmsk] + standard_name = sea_land_ice_mask + long_name = sea/land/ice mask (=0/1/2) + units = flag + dimensions = (horizontal_loop_extent) + type = integer + intent = in +[work1] + standard_name = grid_size_related_coefficient_used_in_scale_sensitive_schemes + long_name = grid size related coefficient used in scale-sensitive schemes + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[work2] + standard_name = grid_size_related_coefficient_used_in_scale_sensitive_schemes_complement + long_name = complement to work1 + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[kpbl] + standard_name = vertical_index_at_top_of_atmosphere_boundary_layer + long_name = vertical index at top atmospheric boundary layer + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = in +[kinver] + standard_name = index_of_highest_temperature_inversion + long_name = index of highest temperature inversion + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = in +[ras] + standard_name = flag_for_relaxed_arakawa_schubert_deep_convection + long_name = flag for ras convection scheme + units = flag + dimensions = () + type = logical + intent = in +[me] + standard_name = mpi_rank + long_name = current MPI-rank + units = index + dimensions = () + type = integer + intent = in +[clw] + standard_name = convective_transportable_tracers + long_name = array to contain cloud water and other convective trans. tracers + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers_for_convective_transport) + type = real + kind = kind_phys + intent = inout +[rhc] + standard_name = critical_relative_humidity + long_name = critical relative humidity + units = frac + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[save_qc] + standard_name = cloud_condensed_water_mixing_ratio_save + long_name = ratio of mass of cloud water to mass of dry air plus vapor (without condensates) before entering a physics scheme + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[save_qi] + standard_name = ice_water_mixing_ratio_save + long_name = cloud ice water mixing ratio before entering a physics scheme + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[save_tcp] + standard_name = air_temperature_save_from_convective_parameterization + long_name = air temperature after cumulus parameterization + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[ldiag3d] + standard_name = flag_for_diagnostics_3D + long_name = flag for 3d diagnostic fields + units = flag + dimensions = () + type = logical + intent = in +[qdiag3d] + standard_name = flag_for_tracer_diagnostics_3D + long_name = flag for 3d tracer diagnostic fields + units = flag + dimensions = () + type = logical + intent = in +[index_of_process_conv_trans] + standard_name = index_of_convective_transport_process_in_cumulative_change_index + long_name = index of convective transport process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[save_lnc] + standard_name = liquid_cloud_number_concentration_save + long_name = liquid cloud number concentration before entering a physics scheme + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[save_inc] + standard_name = ice_cloud_number_concentration_save + long_name = ice cloud number concentration before entering a physics scheme + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[ntlnc] + standard_name = index_of_mass_number_concentration_of_cloud_droplets_in_tracer_concentration_array + long_name = tracer index for liquid number concentration + units = index + dimensions = () + type = integer + intent = in +[ntinc] + standard_name = index_of_mass_number_concentration_of_cloud_ice_in_tracer_concentration_array + long_name = tracer index for ice number concentration + units = index + dimensions = () + type = integer + intent = in +[dtidx] + standard_name = cumulative_change_of_state_variables_outer_index + long_name = index of state-variable and process in last dimension of diagnostic tendencies array AKA cumulative_change_index + units = index + dimensions = (number_of_tracers_plus_one_hundred,number_of_cumulative_change_processes) + type = integer + intent = in +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out \ No newline at end of file diff --git a/physics/GFS_suite_interstitial_4.F90 b/physics/GFS_suite_interstitial_4.F90 new file mode 100644 index 000000000..cbabb991b --- /dev/null +++ b/physics/GFS_suite_interstitial_4.F90 @@ -0,0 +1,293 @@ +!> \file GFS_suite_interstitial_4.F90 +!! Contains code to calculate tendencies of tracers due to convective transport, updates tracers after convective transport, and updates cloud condensation nuclei. + + module GFS_suite_interstitial_4 + + contains + +!> \section arg_table_GFS_suite_interstitial_4_run Argument Table +!! \htmlinclude GFS_suite_interstitial_4_run.html +!! + subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntrac, ntcw, ntiw, ntclamt, & + ntrw, ntsw, ntrnc, ntsnc, ntgl, ntgnc, ntlnc, ntinc, ntccn, nn, imp_physics, imp_physics_gfdl, imp_physics_thompson, & + imp_physics_nssl, nssl_invertccn, nssl_ccn_on, & + imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, convert_dry_rho, dtf, save_qc, save_qi, con_pi, dtidx, dtend,& + index_of_process_conv_trans, gq0, clw, prsl, save_tcp, con_rd, con_eps, nssl_cccn, nwfa, spechum, ldiag3d, & + qdiag3d, save_lnc, save_inc, ntk, ntke, otsptflag, errmsg, errflg) + + use machine, only: kind_phys + use module_mp_thompson_make_number_concentrations, only: make_IceNumber, make_DropletNumber + + implicit none + + ! interface variables + + logical, intent(in) :: otsptflag(:)! on/off switch for tracer transport by updraft and + integer, intent(in ) :: im, levs, tracers_total, ntrac, ntcw, ntiw, ntclamt, ntrw, & + ntsw, ntrnc, ntsnc, ntgl, ntgnc, ntlnc, ntinc, ntccn, nn, imp_physics, imp_physics_gfdl, imp_physics_thompson, & + imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, imp_physics_nssl + + logical, intent(in) :: ltaerosol, convert_dry_rho + logical, intent(in) :: nssl_ccn_on, nssl_invertccn + + real(kind=kind_phys), intent(in ) :: con_pi, dtf + real(kind=kind_phys), intent(in ), dimension(:,:) :: save_qc + ! save_qi is not allocated for Zhao-Carr MP + real(kind=kind_phys), intent(in ), dimension(:,:) :: save_qi, save_lnc, save_inc + + ! dtend and dtidx are only allocated if ldiag3d + logical, intent(in) :: ldiag3d, qdiag3d + real(kind=kind_phys), dimension(:,:,:), intent(inout) :: dtend + integer, dimension(:,:), intent(in) :: dtidx + integer, intent(in) :: index_of_process_conv_trans,ntk,ntke + + real(kind=kind_phys), dimension(:,:,:), intent(inout) :: gq0 + real(kind=kind_phys), dimension(:,:,:), intent(inout) :: clw + real(kind=kind_phys), dimension(:,:), intent(in) :: prsl + real(kind=kind_phys), intent(in) :: con_rd, con_eps, nssl_cccn + real(kind=kind_phys), dimension(:,:), intent(in) :: nwfa, save_tcp + real(kind=kind_phys), dimension(:,:), intent(in) :: spechum + + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg + + ! local variables + real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys + integer :: i,k,n,tracers,idtend + real(kind=kind_phys) :: liqm, icem, xccn, xcwmas, xccw, xcimas, qccn + + real(kind=kind_phys) :: rho, orho + real(kind=kind_phys), dimension(im,levs) :: qv_mp !< kg kg-1 (dry mixing ratio) + real(kind=kind_phys), dimension(im,levs) :: qc_mp !< kg kg-1 (dry mixing ratio) + real(kind=kind_phys), dimension(im,levs) :: qi_mp !< kg kg-1 (dry mixing ratio) + real(kind=kind_phys), dimension(im,levs) :: nc_mp !< kg-1 (dry mixing ratio) + real(kind=kind_phys), dimension(im,levs) :: ni_mp !< kg-1 (dry mixing ratio) + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! This code was previously in GFS_SCNV_generic_post, but it really belongs + ! here, because it fixes the convective transportable_tracers mess for Zhao-Carr + ! and GFDL MP from GFS_suite_interstitial_3. This whole code around clw(:,:,2) + ! being set to -999 for Zhao-Carr MP (which doesn't have cloud ice) and GFDL-MP + ! (which does have cloud ice, but for some reason it was decided to code it up + ! in the same way as for Zhao-Carr, nowadays unnecessary and confusing) needs + ! to be cleaned up. The convection schemes doing something different internally + ! based on clw(i,k,2) being -999.0 or not is not a good idea. + do k=1,levs + do i=1,im + if (clw(i,k,2) <= -999.0) clw(i,k,2) = 0.0 + enddo + enddo + + if(ldiag3d) then + if(ntk>0 .and. ntk<=size(clw,3)) then + idtend=dtidx(100+ntke,index_of_process_conv_trans) + if(idtend>=1) then + dtend(:,:,idtend) = dtend(:,:,idtend) + clw(:,:,ntk)-gq0(:,:,ntk) + endif + endif + if(ntcw>0) then + if (imp_physics == imp_physics_zhao_carr .or. & + imp_physics == imp_physics_zhao_carr_pdf .or. & + imp_physics == imp_physics_gfdl) then + idtend=dtidx(100+ntcw,index_of_process_conv_trans) + if(idtend>=1) then + dtend(:,:,idtend) = dtend(:,:,idtend) + clw(:,:,1)+clw(:,:,2) - gq0(:,:,ntcw) + endif + else if(ntiw>0) then + idtend=dtidx(100+ntiw,index_of_process_conv_trans) + if(idtend>=1) then + dtend(:,:,idtend) = dtend(:,:,idtend) + clw(:,:,1)-gq0(:,:,ntiw) + endif + idtend=dtidx(100+ntcw,index_of_process_conv_trans) + if(idtend>=1) then + dtend(:,:,idtend) = dtend(:,:,idtend) + clw(:,:,2)-gq0(:,:,ntcw) + endif + else + idtend=dtidx(100+ntcw,index_of_process_conv_trans) + if(idtend>=1) then + dtend(:,:,idtend) = dtend(:,:,idtend) + clw(:,:,1)+clw(:,:,2) - gq0(:,:,ntcw) + endif + endif + endif + endif + +! --- update the tracers due to deep & shallow cumulus convective transport +! (except for suspended water and ice) + + if (tracers_total > 0) then + tracers = 2 + do n=2,ntrac +! if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt) then +! if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt .and. & +! n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & +! n /= ntsnc .and. n /= ntgl .and. n /= ntgnc & +! .and. & +! n /= nthl .and. n /= nthnc .and. n /= ntgv .and. & +! n /= nthv .and. n /= ntccn & +! ) then + IF ( otsptflag(n) ) THEN + tracers = tracers + 1 + if(n/=ntk .and. n/=ntlnc .and. n/=ntinc .and. n /= ntcw .and. n /= ntiw) then + idtend=dtidx(100+n,index_of_process_conv_trans) + if(idtend>=1) then + dtend(:,:,idtend) = dtend(:,:,idtend) + clw(:,:,tracers)-gq0(:,:,n) + endif + endif + do k=1,levs + do i=1,im + gq0(i,k,n) = clw(i,k,tracers) + enddo + enddo + endif + enddo + endif + + if (ntcw > 0) then + +! for microphysics + if (imp_physics == imp_physics_zhao_carr .or. & + imp_physics == imp_physics_zhao_carr_pdf .or. & + imp_physics == imp_physics_gfdl) then + gq0(1:im,:,ntcw) = clw(1:im,:,1) + clw(1:im,:,2) + + elseif (ntiw > 0) then + do k=1,levs + do i=1,im + gq0(i,k,ntiw) = clw(i,k,1) ! ice + gq0(i,k,ntcw) = clw(i,k,2) ! water + enddo + enddo + + if ( imp_physics == imp_physics_nssl ) then + liqm = con_pi/6.*1.e3*(18.e-6)**3 ! 4./3.*con_pi*1.e-12 + icem = con_pi/6.*1.e3*(120.e-6)**3 ! 4./3.*con_pi*3.2768*1.e-14*890. + qccn = nssl_cccn/1.225 !1.225 is a reference air density and should match what is used in module_mp_nssl_2mom.F90 (rho00) + do k=1,levs + do i=1,im + ! check number of available ccn + IF ( nssl_ccn_on ) THEN + IF ( nssl_invertccn ) THEN + xccn = qccn - gq0(i,k,ntccn) + ELSE + xccn = gq0(i,k,ntccn) + ENDIF + ELSE + xccn = Max(0.0, qccn - gq0(i,k,ntlnc)) + ENDIF + + IF ( gq0(i,k,ntlnc) > 0.0 .and. save_qc(i,k) > 0.0 ) THEN + xcwmas = Max( liqm, clw(i,k,2)/gq0(i,k,ntlnc) ) + ELSE + xcwmas = liqm + ENDIF + + IF ( gq0(i,k,ntinc) > 0.0 .and. save_qi(i,k) > 0.0 ) THEN + xcimas = Max( liqm, clw(i,k,1)/gq0(i,k,ntinc) ) + ELSE + xcimas = icem + ENDIF + + IF ( xccn > 0.0 ) THEN + xccw = Min( xccn, max(0.0, (clw(i,k,2)-save_qc(i,k))) / xcwmas ) + gq0(i,k,ntlnc) = gq0(i,k,ntlnc) + xccw + IF ( nssl_ccn_on ) THEN + IF ( nssl_invertccn ) THEN + ! ccn are activated CCN, so add + gq0(i,k,ntccn) = gq0(i,k,ntccn) + xccw + ELSE + ! ccn are unactivated CCN, so subtract + gq0(i,k,ntccn) = gq0(i,k,ntccn) - xccw + ENDIF + ENDIF + ENDIF + + gq0(i,k,ntinc) = gq0(i,k,ntinc) & + + max(0.0, (clw(i,k,1)-save_qi(i,k))) / xcimas + enddo + enddo + endif + + if (imp_physics == imp_physics_thompson .and. (ntlnc>0 .or. ntinc>0)) then + if_convert_dry_rho: if (convert_dry_rho) then + do k=1,levs + do i=1,im + !> - Convert specific humidity to dry mixing ratio + qv_mp(i,k) = spechum(i,k) / (one-spechum(i,k)) + !> - Density of air in kg m-3 and inverse density + rho = con_eps*prsl(i,k) / (con_rd*save_tcp(i,k)*(qv_mp(i,k)+con_eps)) + orho = one/rho + if (ntlnc>0) then + !> - Convert moist mixing ratio to dry mixing ratio + qc_mp(i,k) = (clw(i,k,2)-save_qc(i,k)) / (one-spechum(i,k)) + !> - Convert number concentration from moist to dry + nc_mp(i,k) = gq0(i,k,ntlnc) / (one-spechum(i,k)) + nc_mp(i,k) = max(zero, nc_mp(i,k) + make_DropletNumber(qc_mp(i,k) * rho, nwfa(i,k)*rho) * orho) + !> - Convert number concentrations from dry to moist + gq0(i,k,ntlnc) = nc_mp(i,k) / (one+qv_mp(i,k)) + endif + if (ntinc>0) then + !> - Convert moist mixing ratio to dry mixing ratio + qi_mp(i,k) = (clw(i,k,1)-save_qi(i,k)) / (one-spechum(i,k)) + !> - Convert number concentration from moist to dry + ni_mp(i,k) = gq0(i,k,ntinc) / (one-spechum(i,k)) + ni_mp(i,k) = max(zero, ni_mp(i,k) + make_IceNumber(qi_mp(i,k) * rho, save_tcp(i,k)) * orho) + !> - Convert number concentrations from dry to moist + gq0(i,k,ntinc) = ni_mp(i,k) / (one+qv_mp(i,k)) + endif + enddo + enddo + else + do k=1,levs + do i=1,im + !> - Density of air in kg m-3 and inverse density + rho = con_eps*prsl(i,k) / (con_rd*save_tcp(i,k)*(spechum(i,k)+con_eps)) + orho = one/rho + if (ntlnc>0) then + !> - Update cloud water mixing ratio + qc_mp(i,k) = (clw(i,k,2)-save_qc(i,k)) + !> - Update cloud water number concentration + gq0(i,k,ntlnc) = max(zero, gq0(i,k,ntlnc) + make_DropletNumber(qc_mp(i,k) * rho, nwfa(i,k)*rho) * orho) + endif + if (ntinc>0) then + !> - Update cloud ice mixing ratio + qi_mp(i,k) = (clw(i,k,1)-save_qi(i,k)) + !> - Update cloud ice number concentration + gq0(i,k,ntinc) = max(zero, gq0(i,k,ntinc) + make_IceNumber(qi_mp(i,k) * rho, save_tcp(i,k)) * orho) + endif + enddo + enddo + end if if_convert_dry_rho + if(ldiag3d .and. qdiag3d) then + idtend = dtidx(100+ntlnc,index_of_process_conv_trans) + if(idtend>0) then + dtend(:,:,idtend) = dtend(:,:,idtend) + gq0(:,:,ntlnc) - save_lnc + endif + idtend = dtidx(100+ntinc,index_of_process_conv_trans) + if(idtend>0) then + dtend(:,:,idtend) = dtend(:,:,idtend) + gq0(:,:,ntinc) - save_inc + endif + endif + endif + + else + do k=1,levs + do i=1,im + gq0(i,k,ntcw) = clw(i,k,1) + clw(i,k,2) + enddo + enddo + endif ! end if_ntiw + + else + do k=1,levs + do i=1,im + clw(i,k,1) = clw(i,k,1) + clw(i,k,2) + enddo + enddo + endif ! end if_ntcw + + end subroutine GFS_suite_interstitial_4_run + + end module GFS_suite_interstitial_4 \ No newline at end of file diff --git a/physics/GFS_suite_interstitial_4.meta b/physics/GFS_suite_interstitial_4.meta new file mode 100644 index 000000000..92870d95f --- /dev/null +++ b/physics/GFS_suite_interstitial_4.meta @@ -0,0 +1,391 @@ +######################################################################## +[ccpp-table-properties] + name = GFS_suite_interstitial_4 + type = scheme + dependencies = machine.F,module_mp_thompson_make_number_concentrations.F90 + +######################################################################## +[ccpp-arg-table] + name = GFS_suite_interstitial_4_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[levs] + standard_name = vertical_layer_dimension + long_name = vertical layer dimension + units = count + dimensions = () + type = integer + intent = in +[ltaerosol] + standard_name = flag_for_aerosol_physics + long_name = flag for aerosol physics + units = flag + dimensions = () + type = logical + intent = in +[tracers_total] + standard_name = number_of_total_tracers + long_name = total number of tracers + units = count + dimensions = () + type = integer + intent = in +[ntrac] + standard_name = number_of_tracers + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = in +[ntcw] + standard_name = index_of_cloud_liquid_water_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for cloud condensate (or liquid water) + units = index + dimensions = () + type = integer + intent = in +[ntiw] + standard_name = index_of_cloud_ice_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for ice water + units = index + dimensions = () + type = integer + intent = in +[ntclamt] + standard_name = index_of_cloud_area_fraction_in_atmosphere_layer_in_tracer_concentration_array + long_name = tracer index for cloud amount integer + units = index + dimensions = () + type = integer + intent = in +[ntrw] + standard_name = index_of_rain_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for rain water + units = index + dimensions = () + type = integer + intent = in +[ntsw] + standard_name = index_of_snow_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for snow water + units = index + dimensions = () + type = integer + intent = in +[ntrnc] + standard_name = index_of_mass_number_concentration_of_rain_in_tracer_concentration_array + long_name = tracer index for rain number concentration + units = index + dimensions = () + type = integer + intent = in +[ntsnc] + standard_name = index_of_mass_number_concentration_of_snow_in_tracer_concentration_array + long_name = tracer index for snow number concentration + units = index + dimensions = () + type = integer + intent = in +[ntgl] + standard_name = index_of_graupel_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for graupel + units = index + dimensions = () + type = integer + intent = in +[ntgnc] + standard_name = index_of_mass_number_concentration_of_graupel_in_tracer_concentration_array + long_name = tracer index for graupel number concentration + units = index + dimensions = () + type = integer + intent = in +[ntlnc] + standard_name = index_of_mass_number_concentration_of_cloud_droplets_in_tracer_concentration_array + long_name = tracer index for liquid number concentration + units = index + dimensions = () + type = integer + intent = in +[ntinc] + standard_name = index_of_mass_number_concentration_of_cloud_ice_in_tracer_concentration_array + long_name = tracer index for ice number concentration + units = index + dimensions = () + type = integer + intent = in +[nn] + standard_name = number_of_tracers_for_convective_transport + long_name = number of tracers for convective transport + units = count + dimensions = () + type = integer + intent = in +[ntccn] + standard_name = index_of_cloud_condensation_nuclei_number_concentration_in_tracer_concentration_array + long_name = tracer index for cloud condensation nuclei number concentration + units = index + dimensions = () + type = integer + intent = in +[imp_physics] + standard_name = control_for_microphysics_scheme + long_name = choice of microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[imp_physics_gfdl] + standard_name = identifier_for_gfdl_microphysics_scheme + long_name = choice of GFDL microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[imp_physics_thompson] + standard_name = identifier_for_thompson_microphysics_scheme + long_name = choice of Thompson microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[imp_physics_zhao_carr] + standard_name = identifier_for_zhao_carr_microphysics_scheme + long_name = choice of Zhao-Carr microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[imp_physics_zhao_carr_pdf] + standard_name = identifier_for_zhao_carr_pdf_microphysics_scheme + long_name = choice of Zhao-Carr microphysics scheme with PDF clouds + units = flag + dimensions = () + type = integer + intent = in +[convert_dry_rho] + standard_name = flag_for_converting_hydrometeors_from_moist_to_dry_air + long_name = flag for converting hydrometeors from moist to dry air + units = flag + dimensions = () + type = logical + intent = in +[imp_physics_nssl] + standard_name = identifier_for_nssl_microphysics_scheme + long_name = choice of NSSL 2-moment microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[nssl_ccn_on] + standard_name = nssl_ccn_on + long_name = CCN activation flag in NSSL micro + units = flag + dimensions = () + type = logical + intent = in +[nssl_invertccn] + standard_name = nssl_invertccn + long_name = flag to invert CCN in NSSL micro + units = flag + dimensions = () + type = logical + intent = in +[dtf] + standard_name = timestep_for_dynamics + long_name = dynamics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in +[save_qc] + standard_name = cloud_condensed_water_mixing_ratio_save + long_name = ratio of mass of cloud water to mass of dry air plus vapor (without condensates) before entering a physics scheme + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[save_qi] + standard_name = ice_water_mixing_ratio_save + long_name = cloud ice water mixing ratio before entering a physics scheme + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[save_lnc] + standard_name = liquid_cloud_number_concentration_save + long_name = liquid cloud number concentration before entering a physics scheme + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[save_inc] + standard_name = ice_cloud_number_concentration_save + long_name = ice cloud number concentration before entering a physics scheme + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[con_pi] + standard_name = pi + long_name = ratio of a circle's circumference to its diameter + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[gq0] + standard_name = tracer_concentration_of_new_state + long_name = tracer concentration updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = inout +[clw] + standard_name = convective_transportable_tracers + long_name = array to contain cloud water and other convective trans. tracers + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers_for_convective_transport) + type = real + kind = kind_phys + intent = inout +[prsl] + standard_name = air_pressure + long_name = mean layer pressure + units = Pa + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[save_tcp] + standard_name = air_temperature_save_from_convective_parameterization + long_name = air temperature after cumulus parameterization + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[con_rd] + standard_name = gas_constant_of_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_eps] + standard_name = ratio_of_dry_air_to_water_vapor_gas_constants + long_name = rd/rv + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[nssl_cccn] + standard_name = nssl_ccn_concentration + long_name = CCN concentration + units = m-3 + dimensions = () + type = real + kind = kind_phys + intent = in +[nwfa] + standard_name = mass_number_concentration_of_hygroscopic_aerosols + long_name = number concentration of water-friendly aerosols + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[spechum] + standard_name = specific_humidity + long_name = water vapor specific humidity + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[dtidx] + standard_name = cumulative_change_of_state_variables_outer_index + long_name = index of state-variable and process in last dimension of diagnostic tendencies array AKA cumulative_change_index + units = index + dimensions = (number_of_tracers_plus_one_hundred,number_of_cumulative_change_processes) + type = integer + intent = in +[dtend] + standard_name = cumulative_change_of_state_variables + long_name = diagnostic tendencies for state variables + units = mixed + dimensions = (horizontal_loop_extent,vertical_layer_dimension,cumulative_change_of_state_variables_outer_index_max) + type = real + kind = kind_phys + intent = inout +[ntk] + standard_name = index_for_turbulent_kinetic_energy_convective_transport_tracer + long_name = index for turbulent kinetic energy in the convectively transported tracer array + units = index + dimensions = () + type = integer + intent = in +[ntke] + standard_name = index_of_turbulent_kinetic_energy_in_tracer_concentration_array + long_name = tracer index for turbulent kinetic energy + units = index + dimensions = () + type = integer + intent = in +[ldiag3d] + standard_name = flag_for_diagnostics_3D + long_name = flag for 3d diagnostic fields + units = flag + dimensions = () + type = logical + intent = in +[qdiag3d] + standard_name = flag_for_tracer_diagnostics_3D + long_name = flag for 3d tracer diagnostic fields + units = flag + dimensions = () + type = logical + intent = in +[index_of_process_conv_trans] + standard_name = index_of_convective_transport_process_in_cumulative_change_index + long_name = index of convective transport process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[otsptflag] + standard_name = flag_convective_tracer_transport_interstitial + long_name = flag for interstitial tracer transport + units = flag + dimensions = (number_of_tracers) + type = logical + intent = in +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out \ No newline at end of file diff --git a/physics/GFS_suite_interstitial_5.F90 b/physics/GFS_suite_interstitial_5.F90 new file mode 100644 index 000000000..c73345ea0 --- /dev/null +++ b/physics/GFS_suite_interstitial_5.F90 @@ -0,0 +1,43 @@ +!> \file GFS_suite_interstitial_5.F90 +!! Contains code to update cloud liquid and ice in the convective transportable tracer array before RAS convection. + + module GFS_suite_interstitial_5 + + contains + +!> \section arg_table_GFS_suite_interstitial_5_run Argument Table +!! \htmlinclude GFS_suite_interstitial_5_run.html +!! + subroutine GFS_suite_interstitial_5_run (im, levs, ntrac, ntcw, ntiw, nn, gq0, clw, errmsg, errflg) + + use machine, only: kind_phys + + implicit none + + ! interface variables + integer, intent(in ) :: im, levs, ntrac, ntcw, ntiw, nn + + real(kind=kind_phys), intent(in ), dimension(:,:,:) :: gq0 + + real(kind=kind_phys), intent(out), dimension(:,:,:) :: clw + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! local variables + integer :: i,k + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + do k=1,levs + do i=1,im + clw(i,k,1) = gq0(i,k,ntiw) ! ice + clw(i,k,2) = gq0(i,k,ntcw) ! water + enddo + enddo + + end subroutine GFS_suite_interstitial_5_run + + end module GFS_suite_interstitial_5 diff --git a/physics/GFS_suite_interstitial_5.meta b/physics/GFS_suite_interstitial_5.meta new file mode 100644 index 000000000..9d32160a1 --- /dev/null +++ b/physics/GFS_suite_interstitial_5.meta @@ -0,0 +1,83 @@ +######################################################################## +[ccpp-table-properties] + name = GFS_suite_interstitial_5 + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = GFS_suite_interstitial_5_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[levs] + standard_name = vertical_layer_dimension + long_name = vertical layer dimension + units = count + dimensions = () + type = integer + intent = in +[ntrac] + standard_name = number_of_tracers + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = in +[ntcw] + standard_name = index_of_cloud_liquid_water_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for cloud condensate (or liquid water) + units = index + dimensions = () + type = integer + intent = in +[ntiw] + standard_name = index_of_cloud_ice_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for ice water + units = index + dimensions = () + type = integer + intent = in +[nn] + standard_name = number_of_tracers_for_convective_transport + long_name = number of tracers for convective transport + units = count + dimensions = () + type = integer + intent = in +[gq0] + standard_name = tracer_concentration_of_new_state + long_name = tracer concentration updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = in +[clw] + standard_name = convective_transportable_tracers + long_name = array to contain cloud water and other convective trans. tracers + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers_for_convective_transport) + type = real + kind = kind_phys + intent = inout +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out diff --git a/physics/GFS_suite_interstitial_phys_reset.F90 b/physics/GFS_suite_interstitial_phys_reset.F90 new file mode 100644 index 000000000..d74924d95 --- /dev/null +++ b/physics/GFS_suite_interstitial_phys_reset.F90 @@ -0,0 +1,32 @@ +!> \file GFS_suite_interstitial_phys_reset.f90 +!! Contains code to reset physics-related interstitial variables in the GFS physics suite. + + module GFS_suite_interstitial_phys_reset + + contains + +!> \section arg_table_GFS_suite_interstitial_phys_reset_run Argument Table +!! \htmlinclude GFS_suite_interstitial_phys_reset_run.html +!! + subroutine GFS_suite_interstitial_phys_reset_run (Interstitial, Model, errmsg, errflg) + + use machine, only: kind_phys + use GFS_typedefs, only: GFS_control_type + use CCPP_typedefs, only: GFS_interstitial_type + + implicit none + + ! interface variables + type(GFS_interstitial_type), intent(inout) :: Interstitial + type(GFS_control_type), intent(in ) :: Model + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg + + errmsg = '' + errflg = 0 + + call Interstitial%phys_reset(Model) + + end subroutine GFS_suite_interstitial_phys_reset_run + + end module GFS_suite_interstitial_phys_reset \ No newline at end of file diff --git a/physics/GFS_suite_interstitial_phys_reset.meta b/physics/GFS_suite_interstitial_phys_reset.meta new file mode 100644 index 000000000..adebbc833 --- /dev/null +++ b/physics/GFS_suite_interstitial_phys_reset.meta @@ -0,0 +1,39 @@ +######################################################################## +[ccpp-table-properties] + name = GFS_suite_interstitial_phys_reset + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = GFS_suite_interstitial_phys_reset_run + type = scheme +[Interstitial] + standard_name = GFS_interstitial_type_instance + long_name = derived type GFS_interstitial_type in FV3 + units = DDT + dimensions = () + type = GFS_interstitial_type + intent = inout +[Model] + standard_name = GFS_control_type_instance + long_name = Fortran DDT containing FV3-GFS model control parameters + units = DDT + dimensions = () + type = GFS_control_type + intent = in +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out \ No newline at end of file diff --git a/physics/GFS_suite_interstitial_rad_reset.F90 b/physics/GFS_suite_interstitial_rad_reset.F90 new file mode 100644 index 000000000..78cd23501 --- /dev/null +++ b/physics/GFS_suite_interstitial_rad_reset.F90 @@ -0,0 +1,32 @@ +!> \file GFS_suite_interstitial_rad_reset.f90 +!! Contains code to reset radiation-related interstitial variables + + module GFS_suite_interstitial_rad_reset + + contains + +!> \section arg_table_GFS_suite_interstitial_rad_reset_run Argument Table +!! \htmlinclude GFS_suite_interstitial_rad_reset_run.html +!! + subroutine GFS_suite_interstitial_rad_reset_run (Interstitial, Model, errmsg, errflg) + + use machine, only: kind_phys + use GFS_typedefs, only: GFS_control_type + use CCPP_typedefs, only: GFS_interstitial_type + + implicit none + + ! interface variables + type(GFS_interstitial_type), intent(inout) :: Interstitial + type(GFS_control_type), intent(in) :: Model + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + errmsg = '' + errflg = 0 + + call Interstitial%rad_reset(Model) + + end subroutine GFS_suite_interstitial_rad_reset_run + + end module GFS_suite_interstitial_rad_reset \ No newline at end of file diff --git a/physics/GFS_suite_interstitial_rad_reset.meta b/physics/GFS_suite_interstitial_rad_reset.meta new file mode 100644 index 000000000..91fd8cba7 --- /dev/null +++ b/physics/GFS_suite_interstitial_rad_reset.meta @@ -0,0 +1,38 @@ +[ccpp-table-properties] + name = GFS_suite_interstitial_rad_reset + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = GFS_suite_interstitial_rad_reset_run + type = scheme +[Interstitial] + standard_name = GFS_interstitial_type_instance + long_name = derived type GFS_interstitial_type in FV3 + units = DDT + dimensions = () + type = GFS_interstitial_type + intent = inout +[Model] + standard_name = GFS_control_type_instance + long_name = Fortran DDT containing FV3-GFS model control parameters + units = DDT + dimensions = () + type = GFS_control_type + intent = in +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out \ No newline at end of file diff --git a/physics/GFS_suite_stateout_reset.F90 b/physics/GFS_suite_stateout_reset.F90 new file mode 100644 index 000000000..313a0304c --- /dev/null +++ b/physics/GFS_suite_stateout_reset.F90 @@ -0,0 +1,43 @@ +!> \file GFS_suite_stateout_reset.f90 +!! Contains code to set the values of the physics-updated state to the before-physics state prior to actually being modified by physics. + + module GFS_suite_stateout_reset + + contains + +!> \section arg_table_GFS_suite_stateout_reset_run Argument Table +!! \htmlinclude GFS_suite_stateout_reset_run.html +!! + subroutine GFS_suite_stateout_reset_run (im, levs, ntrac, & + tgrs, ugrs, vgrs, qgrs, & + gt0 , gu0 , gv0 , gq0 , & + errmsg, errflg) + + use machine, only: kind_phys + + implicit none + + ! interface variables + integer, intent(in ) :: im + integer, intent(in ) :: levs + integer, intent(in ) :: ntrac + real(kind=kind_phys), intent(in ), dimension(:,:) :: tgrs, ugrs, vgrs + real(kind=kind_phys), intent(in ), dimension(:,:,:) :: qgrs + real(kind=kind_phys), intent(out), dimension(:,:) :: gt0, gu0, gv0 + real(kind=kind_phys), intent(out), dimension(:,:,:) :: gq0 + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + gt0(:,:) = tgrs(:,:) + gu0(:,:) = ugrs(:,:) + gv0(:,:) = vgrs(:,:) + gq0(:,:,:) = qgrs(:,:,:) + + end subroutine GFS_suite_stateout_reset_run + + end module GFS_suite_stateout_reset \ No newline at end of file diff --git a/physics/GFS_suite_stateout_reset.meta b/physics/GFS_suite_stateout_reset.meta new file mode 100644 index 000000000..fa4111e6b --- /dev/null +++ b/physics/GFS_suite_stateout_reset.meta @@ -0,0 +1,110 @@ +######################################################################## +[ccpp-table-properties] + name = GFS_suite_stateout_reset + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = GFS_suite_stateout_reset_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[levs] + standard_name = vertical_layer_dimension + long_name = vertical layer dimension + units = count + dimensions = () + type = integer + intent = in +[ntrac] + standard_name = number_of_tracers + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = in +[tgrs] + standard_name = air_temperature + long_name = model layer mean temperature + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[ugrs] + standard_name = x_wind + long_name = zonal wind + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[vgrs] + standard_name = y_wind + long_name = meridional wind + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[qgrs] + standard_name = tracer_concentration + long_name = model layer mean tracer concentration + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = in +[gt0] + standard_name = air_temperature_of_new_state + long_name = temperature updated by physics + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[gu0] + standard_name = x_wind_of_new_state + long_name = zonal wind updated by physics + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[gv0] + standard_name = y_wind_of_new_state + long_name = meridional wind updated by physics + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[gq0] + standard_name = tracer_concentration_of_new_state + long_name = tracer concentration updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = out +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out \ No newline at end of file diff --git a/physics/GFS_suite_stateout_update.F90 b/physics/GFS_suite_stateout_update.F90 new file mode 100644 index 000000000..2771c3e82 --- /dev/null +++ b/physics/GFS_suite_stateout_update.F90 @@ -0,0 +1,63 @@ +!> \file GFS_suite_stateout_update.f90 +!! Contains code to update the state variables due to process-split physics from accumulated tendencies during that phase. +!! Also, set bounds on the mass-weighted rime factor when using Ferrier-Aligo microphysics. + + module GFS_suite_stateout_update + + contains + +!> \section arg_table_GFS_suite_stateout_update_run Argument Table +!! \htmlinclude GFS_suite_stateout_update_run.html +!! + subroutine GFS_suite_stateout_update_run (im, levs, ntrac, dtp, & + tgrs, ugrs, vgrs, qgrs, dudt, dvdt, dtdt, dqdt, & + gt0, gu0, gv0, gq0, ntiw, nqrimef, imp_physics, & + imp_physics_fer_hires, epsq, errmsg, errflg) + + use machine, only: kind_phys + + implicit none + + ! Interface variables + integer, intent(in ) :: im + integer, intent(in ) :: levs + integer, intent(in ) :: ntrac + integer, intent(in ) :: imp_physics,imp_physics_fer_hires + integer, intent(in ) :: ntiw, nqrimef + real(kind=kind_phys), intent(in ) :: dtp, epsq + + real(kind=kind_phys), intent(in ), dimension(:,:) :: tgrs, ugrs, vgrs + real(kind=kind_phys), intent(in ), dimension(:,:,:) :: qgrs + real(kind=kind_phys), intent(in ), dimension(:,:) :: dudt, dvdt, dtdt + real(kind=kind_phys), intent(in ), dimension(:,:,:) :: dqdt + real(kind=kind_phys), intent(out), dimension(:,:) :: gt0, gu0, gv0 + real(kind=kind_phys), intent(out), dimension(:,:,:) :: gq0 + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + integer :: i, k + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + gt0(:,:) = tgrs(:,:) + dtdt(:,:) * dtp + gu0(:,:) = ugrs(:,:) + dudt(:,:) * dtp + gv0(:,:) = vgrs(:,:) + dvdt(:,:) * dtp + gq0(:,:,:) = qgrs(:,:,:) + dqdt(:,:,:) * dtp + + if (imp_physics == imp_physics_fer_hires) then + do k=1,levs + do i=1,im + if(gq0(i,k,ntiw) > epsq) then + gq0(i,k,nqrimef) = max(1., gq0(i,k,nqrimef)/gq0(i,k,ntiw)) + else + gq0(i,k,nqrimef) = 1. + end if + end do + end do + end if + + end subroutine GFS_suite_stateout_update_run + + end module GFS_suite_stateout_update \ No newline at end of file diff --git a/physics/GFS_suite_stateout_update.meta b/physics/GFS_suite_stateout_update.meta new file mode 100644 index 000000000..580482b71 --- /dev/null +++ b/physics/GFS_suite_stateout_update.meta @@ -0,0 +1,186 @@ +######################################################################## +[ccpp-table-properties] + name = GFS_suite_stateout_update + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = GFS_suite_stateout_update_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[levs] + standard_name = vertical_layer_dimension + long_name = vertical layer dimension + units = count + dimensions = () + type = integer + intent = in +[ntrac] + standard_name = number_of_tracers + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = in +[dtp] + standard_name = timestep_for_physics + long_name = physics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in +[tgrs] + standard_name = air_temperature + long_name = model layer mean temperature + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[ugrs] + standard_name = x_wind + long_name = zonal wind + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[vgrs] + standard_name = y_wind + long_name = meridional wind + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[qgrs] + standard_name = tracer_concentration + long_name = model layer mean tracer concentration + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = in +[dudt] + standard_name = process_split_cumulative_tendency_of_x_wind + long_name = updated tendency of the x wind + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[dvdt] + standard_name = process_split_cumulative_tendency_of_y_wind + long_name = updated tendency of the y wind + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[dtdt] + standard_name = process_split_cumulative_tendency_of_air_temperature + long_name = updated tendency of the temperature + units = K s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[dqdt] + standard_name = process_split_cumulative_tendency_of_tracers + long_name = updated tendency of the tracers + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = in +[gt0] + standard_name = air_temperature_of_new_state + long_name = temperature updated by physics + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[gu0] + standard_name = x_wind_of_new_state + long_name = zonal wind updated by physics + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[gv0] + standard_name = y_wind_of_new_state + long_name = meridional wind updated by physics + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[gq0] + standard_name = tracer_concentration_of_new_state + long_name = tracer concentration updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = out +[ntiw] + standard_name = index_of_cloud_ice_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for ice water + units = index + dimensions = () + type = integer + intent = in +[nqrimef] + standard_name = index_of_mass_weighted_rime_factor_in_tracer_concentration_array + long_name = tracer index for mass weighted rime factor + units = index + dimensions = () + type = integer + intent = in +[imp_physics] + standard_name = control_for_microphysics_scheme + long_name = choice of microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[imp_physics_fer_hires] + standard_name = identifier_for_fer_hires_microphysics_scheme + long_name = choice of Ferrier-Aligo microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[epsq] + standard_name = minimum_value_of_specific_humidity + long_name = floor value for specific humidity + units = kg kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out \ No newline at end of file diff --git a/physics/GFS_surface_composites_inter.F90 b/physics/GFS_surface_composites_inter.F90 new file mode 100644 index 000000000..0e288691c --- /dev/null +++ b/physics/GFS_surface_composites_inter.F90 @@ -0,0 +1,71 @@ +!> \file GFS_surface_composites_inter.F90 +!! Contains code related to generating composites for all GFS surface schemes. + +module GFS_surface_composites_inter + + use machine, only: kind_phys + + implicit none + + private + + public GFS_surface_composites_inter_run + +contains + +!> \section arg_table_GFS_surface_composites_inter_run Argument Table +!! \htmlinclude GFS_surface_composites_inter_run.html +!! + subroutine GFS_surface_composites_inter_run (im, dry, icy, wet, semis_wat, semis_lnd, semis_ice, & + adjsfcdlw, gabsbdlw_lnd, gabsbdlw_ice, gabsbdlw_wat,& + adjsfcusw, adjsfcdsw, adjsfcnsw, errmsg, errflg) + + implicit none + + ! Interface variables + integer, intent(in ) :: im + logical, dimension(:), intent(in ) :: dry, icy, wet + real(kind=kind_phys), dimension(:), intent(in ) :: semis_wat, semis_lnd, semis_ice, & + adjsfcdlw, adjsfcdsw, adjsfcnsw + real(kind=kind_phys), dimension(:), intent(inout) :: gabsbdlw_lnd, gabsbdlw_ice, gabsbdlw_wat + real(kind=kind_phys), dimension(:), intent(out) :: adjsfcusw + + ! CCPP error handling + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg +! + ! Local variables + integer :: i + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! --- convert lw fluxes for land/ocean/sea-ice models - requires dcyc2t3 to set adjsfcdlw + ! note: for sw: adjsfcdsw and adjsfcnsw are zenith angle adjusted downward/net fluxes. + ! for lw: adjsfcdlw is (sfc temp adjusted) downward fluxe with no emiss effect. + ! adjsfculw is (sfc temp adjusted) upward fluxe including emiss effect. + ! one needs to be aware that that the absorbed downward lw flux (used by land/ocean + ! models as downward flux) is not the same as adjsfcdlw but a value reduced by + ! the factor of emissivity. however, the net effects are the same when seeing + ! it either above the surface interface or below. + ! + ! - flux above the interface used by atmosphere model: + ! down: adjsfcdlw; up: adjsfculw = sfcemis*sigma*T**4 + (1-sfcemis)*adjsfcdlw + ! net = up - down = sfcemis * (sigma*T**4 - adjsfcdlw) + ! - flux below the interface used by lnd/oc/ice models: + ! down: sfcemis*adjsfcdlw; up: sfcemis*sigma*T**4 + ! net = up - down = sfcemis * (sigma*T**4 - adjsfcdlw) + ! surface upwelling shortwave flux at current time is in adjsfcusw + + ! --- ... define the downward lw flux absorbed by ground + do i=1,im + if (dry(i)) gabsbdlw_lnd(i) = semis_lnd(i) * adjsfcdlw(i) + if (icy(i)) gabsbdlw_ice(i) = semis_ice(i) * adjsfcdlw(i) + if (wet(i)) gabsbdlw_wat(i) = semis_wat(i) * adjsfcdlw(i) + adjsfcusw(i) = adjsfcdsw(i) - adjsfcnsw(i) + enddo + + end subroutine GFS_surface_composites_inter_run + +end module GFS_surface_composites_inter \ No newline at end of file diff --git a/physics/GFS_surface_composites_inter.meta b/physics/GFS_surface_composites_inter.meta new file mode 100644 index 000000000..00227a09b --- /dev/null +++ b/physics/GFS_surface_composites_inter.meta @@ -0,0 +1,133 @@ +######################################################################## +[ccpp-table-properties] + name = GFS_surface_composites_inter + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = GFS_surface_composites_inter_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[dry] + standard_name = flag_nonzero_land_surface_fraction + long_name = flag indicating presence of some land surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in +[icy] + standard_name = flag_nonzero_sea_ice_surface_fraction + long_name = flag indicating presence of some sea ice surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in +[wet] + standard_name = flag_nonzero_wet_surface_fraction + long_name = flag indicating presence of some ocean or lake surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in +[semis_wat] + standard_name = surface_longwave_emissivity_over_water + long_name = surface lw emissivity in fraction over water + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[semis_lnd] + standard_name = surface_longwave_emissivity_over_land + long_name = surface lw emissivity in fraction over land + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[semis_ice] + standard_name = surface_longwave_emissivity_over_ice + long_name = surface lw emissivity in fraction over ice + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[adjsfcdlw] + standard_name = surface_downwelling_longwave_flux + long_name = surface downwelling longwave flux at current time + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[gabsbdlw_lnd] + standard_name = surface_downwelling_longwave_flux_absorbed_by_ground_over_land + long_name = total sky surface downward longwave flux absorbed by the ground over land + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[gabsbdlw_ice] + standard_name = surface_downwelling_longwave_flux_absorbed_by_ground_over_ice + long_name = total sky surface downward longwave flux absorbed by the ground over ice + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[gabsbdlw_wat] + standard_name = surface_downwelling_longwave_flux_absorbed_by_ground_over_water + long_name = total sky surface downward longwave flux absorbed by the ground over water + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[adjsfcusw] + standard_name = surface_upwelling_shortwave_flux + long_name = surface upwelling shortwave flux at current time + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[adjsfcdsw] + standard_name = surface_downwelling_shortwave_flux + long_name = surface downwelling shortwave flux at current time + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[adjsfcnsw] + standard_name = surface_net_downwelling_shortwave_flux + long_name = surface net downwelling shortwave flux at current time + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out \ No newline at end of file diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites_post.F90 similarity index 51% rename from physics/GFS_surface_composites.F90 rename to physics/GFS_surface_composites_post.F90 index f44df5890..f39ccb77e 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites_post.F90 @@ -1,394 +1,6 @@ -!> \file GFS_surface_composites.F90 +!> \file GFS_surface_composites_post.F90 !! Contains code related to generating composites for all GFS surface schemes. -module GFS_surface_composites_pre - - use machine, only: kind_phys - use physparam, only : iemsflg - - implicit none - - private - - public GFS_surface_composites_pre_init, GFS_surface_composites_pre_finalize, GFS_surface_composites_pre_run - - real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys, epsln = 1.0e-10_kind_phys - -! real(kind=kind_phys), parameter :: huge = 9.9692099683868690E36 ! NetCDF float FillValue - -contains - - subroutine GFS_surface_composites_pre_init () - end subroutine GFS_surface_composites_pre_init - - subroutine GFS_surface_composites_pre_finalize() - end subroutine GFS_surface_composites_pre_finalize - -!> \section arg_table_GFS_surface_composites_pre_run Argument Table -!! \htmlinclude GFS_surface_composites_pre_run.html -!! - subroutine GFS_surface_composites_pre_run (im, xlat_d, xlon_d, flag_init, lsm_cold_start, lkm, frac_grid, & - flag_cice, cplflx, cplice, cplwav2atm, lsm, lsm_ruc, & - landfrac, lakefrac, lakedepth, oceanfrac, frland, & - dry, icy, lake, use_flake, wet, hice, cice, zorlo, zorll, zorli, & - snowd, snowd_lnd, snowd_ice, tprcp, tprcp_wat, & - tprcp_lnd, tprcp_ice, uustar, uustar_wat, uustar_lnd, uustar_ice, & - weasd, weasd_lnd, weasd_ice, ep1d_ice, tsfc, tsfco, tsfcl, tsfc_wat, & - tisfc, tsurf_wat, tsurf_lnd, tsurf_ice, & - gflx_ice, tgice, islmsk, islmsk_cice, slmsk, qss, qss_wat, qss_lnd, qss_ice, & - min_lakeice, min_seaice, kdt, huge, errmsg, errflg) - - implicit none - - ! Interface variables - integer, intent(in ) :: im, lkm, kdt, lsm, lsm_ruc - logical, intent(in ) :: flag_init, lsm_cold_start, frac_grid, cplflx, cplice, cplwav2atm - logical, dimension(:), intent(inout) :: flag_cice - logical, dimension(:), intent(inout) :: dry, icy, lake, use_flake, wet - real(kind=kind_phys), dimension(:), intent(in ) :: xlat_d, xlon_d - real(kind=kind_phys), dimension(:), intent(in ) :: landfrac, lakefrac, lakedepth, oceanfrac - real(kind=kind_phys), dimension(:), intent(inout) :: cice, hice - real(kind=kind_phys), dimension(:), intent( out) :: frland - real(kind=kind_phys), dimension(:), intent(in ) :: snowd, tprcp, uustar, weasd, qss - - real(kind=kind_phys), dimension(:), intent(inout) :: tsfc, tsfco, tsfcl, tisfc - real(kind=kind_phys), dimension(:), intent(inout) :: snowd_lnd, snowd_ice, tprcp_wat, & - tprcp_lnd, tprcp_ice, tsfc_wat, tsurf_wat,tsurf_lnd, tsurf_ice, & - uustar_wat, uustar_lnd, uustar_ice, weasd_lnd, weasd_ice, & - qss_wat, qss_lnd, qss_ice, ep1d_ice, gflx_ice - real(kind=kind_phys), intent(in ) :: tgice - integer, dimension(:), intent(inout) :: islmsk, islmsk_cice - real(kind=kind_phys), dimension(:), intent(inout) :: slmsk - real(kind=kind_phys), intent(in ) :: min_lakeice, min_seaice, huge - ! - real(kind=kind_phys), dimension(:), intent(inout) :: zorlo, zorll, zorli - ! - real(kind=kind_phys), parameter :: timin = 173.0_kind_phys ! minimum temperature allowed for snow/ice - - real(kind=kind_phys) :: tem - - ! CCPP error handling - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Local variables - integer :: i - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (frac_grid) then ! cice is ice fraction wrt water area - do i=1,im - frland(i) = landfrac(i) - if (frland(i) > zero) dry(i) = .true. - if (frland(i) < one) then - if (oceanfrac(i) > zero) then - if (cice(i) >= min_seaice) then - icy(i) = .true. - tisfc(i) = max(timin, min(tisfc(i), tgice)) - if (cplflx) then - islmsk_cice(i) = 4 - flag_cice(i) = .true. - else - islmsk_cice(i) = 2 - flag_cice(i) = .false. - endif - islmsk(i) = 2 - else - cice(i) = zero - hice(i) = zero - flag_cice(i) = .false. - islmsk_cice(i) = 0 - islmsk(i) = 0 - icy(i) = .false. - endif - if (cice(i) < one) then - wet(i) = .true. ! some open ocean - if (.not. cplflx .and. icy(i)) tsfco(i) = max(tisfc(i), tgice) - endif - else - if (cice(i) >= min_lakeice) then - icy(i) = .true. - islmsk(i) = 2 - tisfc(i) = max(timin, min(tisfc(i), tgice)) - else - cice(i) = zero - hice(i) = zero - islmsk(i) = 0 - icy(i) = .false. - endif - islmsk_cice(i) = islmsk(i) - flag_cice(i) = .false. - if (cice(i) < one) then - wet(i) = .true. ! some open lake - if (icy(i)) tsfco(i) = max(tisfc(i), tgice) - endif - endif - else ! all land - cice(i) = zero - hice(i) = zero - islmsk_cice(i) = 1 - islmsk(i) = 1 - wet(i) = .false. - icy(i) = .false. - flag_cice(i) = .false. - endif - enddo - - else - - do i = 1, IM - if (islmsk(i) == 1) then -! tsfcl(i) = tsfc(i) - dry(i) = .true. - frland(i) = one - cice(i) = zero - hice(i) = zero - icy(i) = .false. - else - frland(i) = zero - if (oceanfrac(i) > zero) then - if (cice(i) >= min_seaice) then - icy(i) = .true. - tisfc(i) = max(timin, min(tisfc(i), tgice)) - ! This cplice namelist option was added to deal with the - ! situation of the FV3ATM-HYCOM coupling without an active sea - ! ice (e.g., CICE6) component. By default, the cplice is true - ! when cplflx is .true. (e.g., for the S2S application). - ! Whereas, for the HAFS FV3ATM-HYCOM coupling, cplice is set as - ! .false.. In the future HAFS FV3ATM-MOM6 coupling, the cplflx - ! could be .true., while cplice being .false.. - if (cplice .and. cplflx) then - islmsk_cice(i) = 4 - flag_cice(i) = .true. - else - islmsk_cice(i) = 2 - flag_cice(i) = .false. - endif - islmsk(i) = 2 - else - cice(i) = zero - hice(i) = zero - flag_cice(i) = .false. - islmsk(i) = 0 - islmsk_cice(i) = 0 - icy(i) = .false. - endif - if (cice(i) < one) then - wet(i) = .true. ! some open ocean - if (cplice) then - if (.not. cplflx .and. icy(i)) tsfco(i) = max(tisfc(i), tgice) - else - if (icy(i)) tsfco(i) = max(tisfc(i), tgice) - endif - endif - else - if (cice(i) >= min_lakeice) then - icy(i) = .true. - tisfc(i) = max(timin, min(tisfc(i), tgice)) - islmsk(i) = 2 - else - cice(i) = zero - hice(i) = zero - islmsk(i) = 0 - icy(i) = .false. - endif - islmsk_cice(i) = islmsk(i) - flag_cice(i) = .false. - if (cice(i) < one) then - wet(i) = .true. ! some open lake - if (icy(i)) tsfco(i) = max(tisfc(i), tgice) - endif - endif - endif - enddo - endif ! frac_grid - - do i=1,im - tprcp_wat(i) = tprcp(i) - tprcp_lnd(i) = tprcp(i) - tprcp_ice(i) = tprcp(i) - - if (wet(i)) then ! Water - uustar_wat(i) = uustar(i) - tsfc_wat(i) = tsfco(i) - tsurf_wat(i) = tsfco(i) - zorlo(i) = max(1.0e-5, min(one, zorlo(i))) - ! DH* - else - zorlo(i) = huge - ! *DH - endif - if (dry(i)) then ! Land - uustar_lnd(i) = uustar(i) - if(lsm /= lsm_ruc) weasd_lnd(i) = weasd(i) - tsurf_lnd(i) = tsfcl(i) - ! DH* - else - zorll(i) = huge - ! *DH - !mjz - tsfcl(i) = huge - endif - if (icy(i)) then ! Ice - uustar_ice(i) = uustar(i) - if(lsm /= lsm_ruc) weasd_ice(i) = weasd(i) - tsurf_ice(i) = tisfc(i) - ep1d_ice(i) = zero - gflx_ice(i) = zero - zorli(i) = max(1.0e-5, min(one, zorli(i))) - ! DH* - else - zorli(i) = huge - ! *DH - endif - if (nint(slmsk(i)) /= 1) slmsk(i) = islmsk(i) - enddo - -! to prepare to separate lake from ocean under water category - do i = 1, im - if ((wet(i) .or. icy(i)) .and. lakefrac(i) > zero) then - lake(i) = .true. - if (lkm == 1 .and. lakefrac(i) >= 0.15 .and. lakedepth(i) > one) then - use_flake(i) = .true. - else - use_flake(i) = .false. - endif - else - lake(i) = .false. - use_flake(i) = .false. - endif - enddo -! - if (frac_grid) then - do i=1,im - if (dry(i)) then - if (icy(i)) then - if (kdt == 1 .or. (.not. cplflx .or. lakefrac(i) > zero)) then - tem = one / (cice(i)*(one-frland(i))) - snowd_ice(i) = max(zero, (snowd(i) - snowd_lnd(i)*frland(i)) * tem) - weasd_ice(i) = max(zero, (weasd(i) - weasd_lnd(i)*frland(i)) * tem) - endif - endif - elseif (icy(i)) then - if (kdt == 1 .or. (.not. cplflx .or. lakefrac(i) > zero)) then - tem = one / cice(i) - snowd_lnd(i) = zero - snowd_ice(i) = snowd(i) * tem - weasd_lnd(i) = zero - weasd_ice(i) = weasd(i) * tem - endif - endif - enddo - else - if(lsm /= lsm_ruc) then ! do not do snow initialization with RUC lsm - do i=1,im - !-- print ice point - !if ( (xlon_d(i) > 298.6) .and. (xlon_d(i) < 298.7) .and. & - ! (xlat_d(i) > 68.6 ) .and. (xlat_d(i) < 68.7 )) then - ! print *,'Composit weasd_ice(i),snowd_ice',kdt,i,xlat_d(i),xlon_d(i),weasd_ice(i),snowd_ice(i) - !endif - !if ( (xlon_d(i) > 284.35) .and. (xlon_d(i) < 284.6) .and. & - ! (xlat_d(i) > 41.0 ) .and. (xlat_d(i) < 41.2 )) then - ! print *,'Composit2 weasd_lnd(i),snowd_lnd',kdt,i,xlat_d(i),xlon_d(i),weasd_lnd(i),snowd_lnd(i) - !endif - if (icy(i)) then - if (kdt == 1 .or. (.not. cplflx .or. lakefrac(i) > zero)) then - snowd_lnd(i) = zero - weasd_lnd(i) = zero - tem = one / cice(i) - snowd_ice(i) = snowd(i) * tem - weasd_ice(i) = weasd(i) * tem - endif - endif - enddo - endif ! lsm/=lsm_ruc - endif - -! write(0,*)' minmax of ice snow=',minval(snowd_ice),maxval(snowd_ice) - - end subroutine GFS_surface_composites_pre_run - -end module GFS_surface_composites_pre - - -module GFS_surface_composites_inter - - use machine, only: kind_phys - - implicit none - - private - - public GFS_surface_composites_inter_init, GFS_surface_composites_inter_finalize, GFS_surface_composites_inter_run - -contains - - subroutine GFS_surface_composites_inter_init () - end subroutine GFS_surface_composites_inter_init - - subroutine GFS_surface_composites_inter_finalize() - end subroutine GFS_surface_composites_inter_finalize - -!> \section arg_table_GFS_surface_composites_inter_run Argument Table -!! \htmlinclude GFS_surface_composites_inter_run.html -!! - subroutine GFS_surface_composites_inter_run (im, dry, icy, wet, semis_wat, semis_lnd, semis_ice, & - adjsfcdlw, gabsbdlw_lnd, gabsbdlw_ice, gabsbdlw_wat,& - adjsfcusw, adjsfcdsw, adjsfcnsw, errmsg, errflg) - - implicit none - - ! Interface variables - integer, intent(in ) :: im - logical, dimension(:), intent(in ) :: dry, icy, wet - real(kind=kind_phys), dimension(:), intent(in ) :: semis_wat, semis_lnd, semis_ice, & - adjsfcdlw, adjsfcdsw, adjsfcnsw - real(kind=kind_phys), dimension(:), intent(inout) :: gabsbdlw_lnd, gabsbdlw_ice, gabsbdlw_wat - real(kind=kind_phys), dimension(:), intent(out) :: adjsfcusw - - ! CCPP error handling - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg -! - ! Local variables - integer :: i - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - ! --- convert lw fluxes for land/ocean/sea-ice models - requires dcyc2t3 to set adjsfcdlw - ! note: for sw: adjsfcdsw and adjsfcnsw are zenith angle adjusted downward/net fluxes. - ! for lw: adjsfcdlw is (sfc temp adjusted) downward fluxe with no emiss effect. - ! adjsfculw is (sfc temp adjusted) upward fluxe including emiss effect. - ! one needs to be aware that that the absorbed downward lw flux (used by land/ocean - ! models as downward flux) is not the same as adjsfcdlw but a value reduced by - ! the factor of emissivity. however, the net effects are the same when seeing - ! it either above the surface interface or below. - ! - ! - flux above the interface used by atmosphere model: - ! down: adjsfcdlw; up: adjsfculw = sfcemis*sigma*T**4 + (1-sfcemis)*adjsfcdlw - ! net = up - down = sfcemis * (sigma*T**4 - adjsfcdlw) - ! - flux below the interface used by lnd/oc/ice models: - ! down: sfcemis*adjsfcdlw; up: sfcemis*sigma*T**4 - ! net = up - down = sfcemis * (sigma*T**4 - adjsfcdlw) - ! surface upwelling shortwave flux at current time is in adjsfcusw - - ! --- ... define the downward lw flux absorbed by ground - do i=1,im - if (dry(i)) gabsbdlw_lnd(i) = semis_lnd(i) * adjsfcdlw(i) - if (icy(i)) gabsbdlw_ice(i) = semis_ice(i) * adjsfcdlw(i) - if (wet(i)) gabsbdlw_wat(i) = semis_wat(i) * adjsfcdlw(i) - adjsfcusw(i) = adjsfcdsw(i) - adjsfcnsw(i) - enddo - - end subroutine GFS_surface_composites_inter_run - -end module GFS_surface_composites_inter - - module GFS_surface_composites_post use machine, only: kind_phys @@ -400,19 +12,13 @@ module GFS_surface_composites_post private - public GFS_surface_composites_post_init, GFS_surface_composites_post_finalize, GFS_surface_composites_post_run + public GFS_surface_composites_post_run real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys, & half = 0.5_kind_phys, qmin = 1.0e-8_kind_phys contains - subroutine GFS_surface_composites_post_init () - end subroutine GFS_surface_composites_post_init - - subroutine GFS_surface_composites_post_finalize() - end subroutine GFS_surface_composites_post_finalize - !> \section arg_table_GFS_surface_composites_post_run Argument Table !! \htmlinclude GFS_surface_composites_post_run.html !! diff --git a/physics/GFS_surface_composites.meta b/physics/GFS_surface_composites_post.meta similarity index 62% rename from physics/GFS_surface_composites.meta rename to physics/GFS_surface_composites_post.meta index 40f0c940c..c7e8c6476 100644 --- a/physics/GFS_surface_composites.meta +++ b/physics/GFS_surface_composites_post.meta @@ -1,660 +1,8 @@ -[ccpp-table-properties] - name = GFS_surface_composites_pre - type = scheme - dependencies = machine.F,sfc_diff.f - -######################################################################## -[ccpp-arg-table] - name = GFS_surface_composites_pre_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in -[xlat_d] - standard_name = latitude_in_degree - long_name = latitude in degree north - units = degree_north - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[xlon_d] - standard_name = longitude_in_degree - long_name = longitude in degree east - units = degree_east - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[flag_init] - standard_name = flag_for_first_timestep - long_name = flag signaling first time step for time integration loop - units = flag - dimensions = () - type = logical - intent = in -[lsm_cold_start] - standard_name = do_lsm_cold_start - long_name = flag to signify LSM is cold-started - units = flag - dimensions = () - type = logical - intent = in -[lkm] - standard_name = control_for_lake_surface_scheme - long_name = flag for lake surface model - units = flag - dimensions = () - type = integer - intent = in -[frac_grid] - standard_name = flag_for_fractional_landmask - long_name = flag for fractional grid - units = flag - dimensions = () - type = logical - intent = in -[flag_cice] - standard_name = flag_for_cice - long_name = flag for cice - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = inout -[cplflx] - standard_name = flag_for_surface_flux_coupling - long_name = flag controlling cplflx collection (default off) - units = flag - dimensions = () - type = logical - intent = in -[cplice] - standard_name = flag_for_sea_ice_coupling - long_name = flag controlling cplice collection (default on) - units = flag - dimensions = () - type = logical - intent = in -[cplwav2atm] - standard_name = flag_for_one_way_ocean_wave_coupling_to_atmosphere - long_name = flag controlling ocean wave coupling to the atmosphere (default off) - units = flag - dimensions = () - type = logical - intent = in -[lsm] - standard_name = control_for_land_surface_scheme - long_name = flag for land surface model - units = flag - dimensions = () - type = integer - intent = in -[lsm_ruc] - standard_name = identifier_for_ruc_land_surface_scheme - long_name = flag for RUC land surface model - units = flag - dimensions = () - type = integer - intent = in -[landfrac] - standard_name = land_area_fraction - long_name = fraction of horizontal grid area occupied by land - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[lakefrac] - standard_name = lake_area_fraction - long_name = fraction of horizontal grid area occupied by lake - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[lakedepth] - standard_name = lake_depth - long_name = lake depth - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[oceanfrac] - standard_name = sea_area_fraction - long_name = fraction of horizontal grid area occupied by ocean - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[frland] - standard_name = land_area_fraction_for_microphysics - long_name = land area fraction used in microphysics schemes - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[dry] - standard_name = flag_nonzero_land_surface_fraction - long_name = flag indicating presence of some land surface area fraction - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = inout -[icy] - standard_name = flag_nonzero_sea_ice_surface_fraction - long_name = flag indicating presence of some sea ice surface area fraction - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = inout -[lake] - standard_name = flag_nonzero_lake_surface_fraction - long_name = flag indicating presence of some lake surface area fraction - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = inout -[use_flake] - standard_name = flag_for_using_flake - long_name = flag indicating lake points using flake model - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = inout -[wet] - standard_name = flag_nonzero_wet_surface_fraction - long_name = flag indicating presence of some ocean or lake surface area fraction - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = inout -[hice] - standard_name = sea_ice_thickness - long_name = sea ice thickness - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[cice] - standard_name = sea_ice_area_fraction_of_sea_area_fraction - long_name = ice fraction over open water - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[zorlo] - standard_name = surface_roughness_length_over_water - long_name = surface roughness length over water - units = cm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[zorll] - standard_name = surface_roughness_length_over_land - long_name = surface roughness length over land - units = cm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[zorli] - standard_name = surface_roughness_length_over_ice - long_name = surface roughness length over ice - units = cm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[snowd] - standard_name = lwe_surface_snow - long_name = water equivalent snow depth - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[snowd_lnd] - standard_name = surface_snow_thickness_water_equivalent_over_land - long_name = water equivalent snow depth over land - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[snowd_ice] - standard_name = surface_snow_thickness_water_equivalent_over_ice - long_name = water equivalent snow depth over ice - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[tprcp] - standard_name = nonnegative_lwe_thickness_of_precipitation_amount_on_dynamics_timestep - long_name = total precipitation amount in each time step - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[tprcp_wat] - standard_name = nonnegative_lwe_thickness_of_precipitation_amount_on_dynamics_timestep_over_water - long_name = total precipitation amount in each time step over water - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[tprcp_lnd] - standard_name = nonnegative_lwe_thickness_of_precipitation_amount_on_dynamics_timestep_over_land - long_name = total precipitation amount in each time step over land - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[tprcp_ice] - standard_name = nonnegative_lwe_thickness_of_precipitation_amount_on_dynamics_timestep_over_ice - long_name = total precipitation amount in each time step over ice - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[uustar] - standard_name = surface_friction_velocity - long_name = boundary layer parameter - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[uustar_wat] - standard_name = surface_friction_velocity_over_water - long_name = surface friction velocity over water - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[uustar_lnd] - standard_name = surface_friction_velocity_over_land - long_name = surface friction velocity over land - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[uustar_ice] - standard_name = surface_friction_velocity_over_ice - long_name = surface friction velocity over ice - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[weasd] - standard_name = lwe_thickness_of_surface_snow_amount - long_name = water equiv of acc snow depth over land and sea ice - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[weasd_lnd] - standard_name = water_equivalent_accumulated_snow_depth_over_land - long_name = water equiv of acc snow depth over land - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[weasd_ice] - standard_name = water_equivalent_accumulated_snow_depth_over_ice - long_name = water equiv of acc snow depth over ice - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[ep1d_ice] - standard_name = surface_upward_potential_latent_heat_flux_over_ice - long_name = surface upward potential latent heat flux over ice - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[tsfc] - standard_name = surface_skin_temperature - long_name = surface skin temperature - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[tsfco] - standard_name = sea_surface_temperature - long_name = sea surface temperature - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[tsfcl] - standard_name = surface_skin_temperature_over_land - long_name = surface skin temperature over land - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[tsfc_wat] - standard_name = surface_skin_temperature_over_water - long_name = surface skin temperature over water - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[tisfc] - standard_name = surface_skin_temperature_over_ice - long_name = surface skin temperature over ice - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[tsurf_wat] - standard_name = surface_skin_temperature_after_iteration_over_water - long_name = surface skin temperature after iteration over water - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[tsurf_lnd] - standard_name = surface_skin_temperature_after_iteration_over_land - long_name = surface skin temperature after iteration over land - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[tsurf_ice] - standard_name = surface_skin_temperature_after_iteration_over_ice - long_name = surface skin temperature after iteration over ice - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[gflx_ice] - standard_name = upward_heat_flux_in_soil_over_ice - long_name = soil heat flux over ice - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[tgice] - standard_name = freezing_point_temperature_of_seawater - long_name = freezing point temperature of seawater - units = K - dimensions = () - type = real - kind = kind_phys - intent = in -[islmsk] - standard_name = sea_land_ice_mask - long_name = sea/land/ice mask (=0/1/2) - units = flag - dimensions = (horizontal_loop_extent) - type = integer - intent = inout -[islmsk_cice] - standard_name = sea_land_ice_mask_cice - long_name = sea/land/ice mask cice (=0/1/2) - units = flag - dimensions = (horizontal_loop_extent) - type = integer - intent = inout -[slmsk] - standard_name = area_type - long_name = landmask: sea/land/ice=0/1/2 - units = flag - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[qss] - standard_name = surface_specific_humidity - long_name = surface air saturation specific humidity - units = kg kg-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[qss_wat] - standard_name = surface_specific_humidity_over_water - long_name = surface air saturation specific humidity over water - units = kg kg-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[qss_lnd] - standard_name = surface_specific_humidity_over_land - long_name = surface air saturation specific humidity over land - units = kg kg-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[qss_ice] - standard_name = surface_specific_humidity_over_ice - long_name = surface air saturation specific humidity over ice - units = kg kg-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[min_lakeice] - standard_name = min_lake_ice_area_fraction - long_name = minimum lake ice value - units = frac - dimensions = () - type = real - kind = kind_phys - intent = in -[min_seaice] - standard_name = min_sea_ice_area_fraction - long_name = minimum sea ice value - units = frac - dimensions = () - type = real - kind = kind_phys - intent = in -[kdt] - standard_name = index_of_timestep - long_name = current forecast iteration - units = index - dimensions = () - type = integer - intent = in -[huge] - standard_name = netcdf_float_fillvalue - long_name = definition of NetCDF float FillValue - units = none - dimensions = () - type = real - kind = kind_phys - intent = in -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out - -######################################################################## -[ccpp-table-properties] - name = GFS_surface_composites_inter - type = scheme - dependencies = machine.F - -######################################################################## -[ccpp-arg-table] - name = GFS_surface_composites_inter_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in -[dry] - standard_name = flag_nonzero_land_surface_fraction - long_name = flag indicating presence of some land surface area fraction - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = in -[icy] - standard_name = flag_nonzero_sea_ice_surface_fraction - long_name = flag indicating presence of some sea ice surface area fraction - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = in -[wet] - standard_name = flag_nonzero_wet_surface_fraction - long_name = flag indicating presence of some ocean or lake surface area fraction - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = in -[semis_wat] - standard_name = surface_longwave_emissivity_over_water - long_name = surface lw emissivity in fraction over water - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[semis_lnd] - standard_name = surface_longwave_emissivity_over_land - long_name = surface lw emissivity in fraction over land - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[semis_ice] - standard_name = surface_longwave_emissivity_over_ice - long_name = surface lw emissivity in fraction over ice - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[adjsfcdlw] - standard_name = surface_downwelling_longwave_flux - long_name = surface downwelling longwave flux at current time - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[gabsbdlw_lnd] - standard_name = surface_downwelling_longwave_flux_absorbed_by_ground_over_land - long_name = total sky surface downward longwave flux absorbed by the ground over land - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[gabsbdlw_ice] - standard_name = surface_downwelling_longwave_flux_absorbed_by_ground_over_ice - long_name = total sky surface downward longwave flux absorbed by the ground over ice - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[gabsbdlw_wat] - standard_name = surface_downwelling_longwave_flux_absorbed_by_ground_over_water - long_name = total sky surface downward longwave flux absorbed by the ground over water - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[adjsfcusw] - standard_name = surface_upwelling_shortwave_flux - long_name = surface upwelling shortwave flux at current time - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[adjsfcdsw] - standard_name = surface_downwelling_shortwave_flux - long_name = surface downwelling shortwave flux at current time - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[adjsfcnsw] - standard_name = surface_net_downwelling_shortwave_flux - long_name = surface net downwelling shortwave flux at current time - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out - ######################################################################## [ccpp-table-properties] name = GFS_surface_composites_post type = scheme - dependencies = machine.F + dependencies = machine.F,sfc_diff.f ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_surface_composites_pre.F90 b/physics/GFS_surface_composites_pre.F90 new file mode 100644 index 000000000..734f1965b --- /dev/null +++ b/physics/GFS_surface_composites_pre.F90 @@ -0,0 +1,295 @@ +!> \file GFS_surface_composites_pre.F90 +!! Contains code related to generating composites for all GFS surface schemes. + +module GFS_surface_composites_pre + + use machine, only: kind_phys + use physparam, only : iemsflg + + implicit none + + private + + public GFS_surface_composites_pre_run + + real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys, epsln = 1.0e-10_kind_phys + +! real(kind=kind_phys), parameter :: huge = 9.9692099683868690E36 ! NetCDF float FillValue + +contains + +!> \section arg_table_GFS_surface_composites_pre_run Argument Table +!! \htmlinclude GFS_surface_composites_pre_run.html +!! + subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, & + flag_cice, cplflx, cplice, cplwav2atm, lsm, lsm_ruc, & + landfrac, lakefrac, lakedepth, oceanfrac, frland, & + dry, icy, lake, use_flake, wet, hice, cice, zorlo, zorll, zorli, & + snowd, snowd_lnd, snowd_ice, tprcp, tprcp_wat, & + tprcp_lnd, tprcp_ice, uustar, uustar_wat, uustar_lnd, uustar_ice, & + weasd, weasd_lnd, weasd_ice, ep1d_ice, tsfc, tsfco, tsfcl, tsfc_wat, & + tisfc, tsurf_wat, tsurf_lnd, tsurf_ice, & + gflx_ice, tgice, islmsk, islmsk_cice, slmsk, qss, qss_wat, qss_lnd, qss_ice, & + min_lakeice, min_seaice, kdt, huge, errmsg, errflg) + + implicit none + + ! Interface variables + integer, intent(in ) :: im, lkm, kdt, lsm, lsm_ruc + logical, intent(in ) :: cplflx, cplice, cplwav2atm, frac_grid + logical, dimension(:), intent(inout) :: flag_cice + logical, dimension(:), intent(inout) :: dry, icy, lake, use_flake, wet + real(kind=kind_phys), dimension(:), intent(in ) :: landfrac, lakefrac, lakedepth, oceanfrac + real(kind=kind_phys), dimension(:), intent(inout) :: cice, hice + real(kind=kind_phys), dimension(:), intent( out) :: frland + real(kind=kind_phys), dimension(:), intent(in ) :: snowd, tprcp, uustar, weasd, qss + + real(kind=kind_phys), dimension(:), intent(inout) :: tsfc, tsfco, tsfcl, tisfc + real(kind=kind_phys), dimension(:), intent(inout) :: snowd_lnd, snowd_ice, tprcp_wat, & + tprcp_lnd, tprcp_ice, tsfc_wat, tsurf_wat,tsurf_lnd, tsurf_ice, & + uustar_wat, uustar_lnd, uustar_ice, weasd_lnd, weasd_ice, & + qss_wat, qss_lnd, qss_ice, ep1d_ice, gflx_ice + real(kind=kind_phys), intent(in ) :: tgice + integer, dimension(:), intent(inout) :: islmsk, islmsk_cice + real(kind=kind_phys), dimension(:), intent(inout) :: slmsk + real(kind=kind_phys), intent(in ) :: min_lakeice, min_seaice, huge + ! + real(kind=kind_phys), dimension(:), intent(inout) :: zorlo, zorll, zorli + ! + real(kind=kind_phys), parameter :: timin = 173.0_kind_phys ! minimum temperature allowed for snow/ice + + real(kind=kind_phys) :: tem + + ! CCPP error handling + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Local variables + integer :: i + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (frac_grid) then ! cice is ice fraction wrt water area + do i=1,im + frland(i) = landfrac(i) + if (frland(i) > zero) dry(i) = .true. + if (frland(i) < one) then + if (oceanfrac(i) > zero) then + if (cice(i) >= min_seaice) then + icy(i) = .true. + tisfc(i) = max(timin, min(tisfc(i), tgice)) + if (cplflx) then + islmsk_cice(i) = 4 + flag_cice(i) = .true. + else + islmsk_cice(i) = 2 + flag_cice(i) = .false. + endif + islmsk(i) = 2 + else + cice(i) = zero + hice(i) = zero + flag_cice(i) = .false. + islmsk_cice(i) = 0 + islmsk(i) = 0 + icy(i) = .false. + endif + if (cice(i) < one) then + wet(i) = .true. ! some open ocean + if (.not. cplflx .and. icy(i)) tsfco(i) = max(tisfc(i), tgice) + endif + else + if (cice(i) >= min_lakeice) then + icy(i) = .true. + islmsk(i) = 2 + tisfc(i) = max(timin, min(tisfc(i), tgice)) + else + cice(i) = zero + hice(i) = zero + islmsk(i) = 0 + icy(i) = .false. + endif + islmsk_cice(i) = islmsk(i) + flag_cice(i) = .false. + if (cice(i) < one) then + wet(i) = .true. ! some open lake + if (icy(i)) tsfco(i) = max(tisfc(i), tgice) + endif + endif + else ! all land + cice(i) = zero + hice(i) = zero + islmsk_cice(i) = 1 + islmsk(i) = 1 + wet(i) = .false. + icy(i) = .false. + flag_cice(i) = .false. + endif + enddo + + else + + do i = 1, IM + if (islmsk(i) == 1) then +! tsfcl(i) = tsfc(i) + dry(i) = .true. + frland(i) = one + cice(i) = zero + hice(i) = zero + icy(i) = .false. + else + frland(i) = zero + if (oceanfrac(i) > zero) then + if (cice(i) >= min_seaice) then + icy(i) = .true. + tisfc(i) = max(timin, min(tisfc(i), tgice)) + ! This cplice namelist option was added to deal with the + ! situation of the FV3ATM-HYCOM coupling without an active sea + ! ice (e.g., CICE6) component. By default, the cplice is true + ! when cplflx is .true. (e.g., for the S2S application). + ! Whereas, for the HAFS FV3ATM-HYCOM coupling, cplice is set as + ! .false.. In the future HAFS FV3ATM-MOM6 coupling, the cplflx + ! could be .true., while cplice being .false.. + if (cplice .and. cplflx) then + islmsk_cice(i) = 4 + flag_cice(i) = .true. + else + islmsk_cice(i) = 2 + flag_cice(i) = .false. + endif + islmsk(i) = 2 + else + cice(i) = zero + hice(i) = zero + flag_cice(i) = .false. + islmsk(i) = 0 + islmsk_cice(i) = 0 + icy(i) = .false. + endif + if (cice(i) < one) then + wet(i) = .true. ! some open ocean + if (cplice) then + if (.not. cplflx .and. icy(i)) tsfco(i) = max(tisfc(i), tgice) + else + if (icy(i)) tsfco(i) = max(tisfc(i), tgice) + endif + endif + else + if (cice(i) >= min_lakeice) then + icy(i) = .true. + tisfc(i) = max(timin, min(tisfc(i), tgice)) + islmsk(i) = 2 + else + cice(i) = zero + hice(i) = zero + islmsk(i) = 0 + icy(i) = .false. + endif + islmsk_cice(i) = islmsk(i) + flag_cice(i) = .false. + if (cice(i) < one) then + wet(i) = .true. ! some open lake + if (icy(i)) tsfco(i) = max(tisfc(i), tgice) + endif + endif + endif + enddo + endif ! frac_grid + + do i=1,im + tprcp_wat(i) = tprcp(i) + tprcp_lnd(i) = tprcp(i) + tprcp_ice(i) = tprcp(i) + + if (wet(i)) then ! Water + uustar_wat(i) = uustar(i) + tsfc_wat(i) = tsfco(i) + tsurf_wat(i) = tsfco(i) + zorlo(i) = max(1.0e-5, min(one, zorlo(i))) + ! DH* + else + zorlo(i) = huge + ! *DH + endif + if (dry(i)) then ! Land + uustar_lnd(i) = uustar(i) + if(lsm /= lsm_ruc) weasd_lnd(i) = weasd(i) + tsurf_lnd(i) = tsfcl(i) + ! DH* + else + zorll(i) = huge + ! *DH + !mjz + tsfcl(i) = huge + endif + if (icy(i)) then ! Ice + uustar_ice(i) = uustar(i) + if(lsm /= lsm_ruc) weasd_ice(i) = weasd(i) + tsurf_ice(i) = tisfc(i) + ep1d_ice(i) = zero + gflx_ice(i) = zero + zorli(i) = max(1.0e-5, min(one, zorli(i))) + ! DH* + else + zorli(i) = huge + ! *DH + endif + if (nint(slmsk(i)) /= 1) slmsk(i) = islmsk(i) + enddo + +! to prepare to separate lake from ocean under water category + do i = 1, im + if ((wet(i) .or. icy(i)) .and. lakefrac(i) > zero) then + lake(i) = .true. + if (lkm == 1 .and. lakefrac(i) >= 0.15 .and. lakedepth(i) > one) then + use_flake(i) = .true. + else + use_flake(i) = .false. + endif + else + lake(i) = .false. + use_flake(i) = .false. + endif + enddo +! + if (frac_grid) then + do i=1,im + if (dry(i)) then + if (icy(i)) then + if (kdt == 1 .or. (.not. cplflx .or. lakefrac(i) > zero)) then + tem = one / (cice(i)*(one-frland(i))) + snowd_ice(i) = max(zero, (snowd(i) - snowd_lnd(i)*frland(i)) * tem) + weasd_ice(i) = max(zero, (weasd(i) - weasd_lnd(i)*frland(i)) * tem) + endif + endif + elseif (icy(i)) then + if (kdt == 1 .or. (.not. cplflx .or. lakefrac(i) > zero)) then + tem = one / cice(i) + snowd_lnd(i) = zero + snowd_ice(i) = snowd(i) * tem + weasd_lnd(i) = zero + weasd_ice(i) = weasd(i) * tem + endif + endif + enddo + elseif(lsm /= lsm_ruc) then ! do not do snow initialization with RUC lsm + do i=1,im + if (icy(i)) then + if (kdt == 1 .or. (.not. cplflx .or. lakefrac(i) > zero)) then + snowd_lnd(i) = zero + weasd_lnd(i) = zero + tem = one / cice(i) + snowd_ice(i) = snowd(i) * tem + weasd_ice(i) = weasd(i) * tem + endif + endif + enddo + endif + +! write(0,*)' minmax of ice snow=',minval(snowd_ice),maxval(snowd_ice) + + end subroutine GFS_surface_composites_pre_run + +end module GFS_surface_composites_pre diff --git a/physics/GFS_surface_composites_pre.meta b/physics/GFS_surface_composites_pre.meta new file mode 100644 index 000000000..e87af3e28 --- /dev/null +++ b/physics/GFS_surface_composites_pre.meta @@ -0,0 +1,487 @@ +[ccpp-table-properties] + name = GFS_surface_composites_pre + type = scheme + dependencies = machine.F,physparam.f + +######################################################################## +[ccpp-arg-table] + name = GFS_surface_composites_pre_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[lkm] + standard_name = control_for_lake_surface_scheme + long_name = flag for lake surface model + units = flag + dimensions = () + type = integer + intent = in +[frac_grid] + standard_name = flag_for_fractional_landmask + long_name = flag for fractional grid + units = flag + dimensions = () + type = logical + intent = in +[flag_cice] + standard_name = flag_for_cice + long_name = flag for cice + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = inout +[cplflx] + standard_name = flag_for_surface_flux_coupling + long_name = flag controlling cplflx collection (default off) + units = flag + dimensions = () + type = logical + intent = in +[cplice] + standard_name = flag_for_sea_ice_coupling + long_name = flag controlling cplice collection (default on) + units = flag + dimensions = () + type = logical + intent = in +[cplwav2atm] + standard_name = flag_for_one_way_ocean_wave_coupling_to_atmosphere + long_name = flag controlling ocean wave coupling to the atmosphere (default off) + units = flag + dimensions = () + type = logical + intent = in +[lsm] + standard_name = control_for_land_surface_scheme + long_name = flag for land surface model + units = flag + dimensions = () + type = integer + intent = in +[lsm_ruc] + standard_name = identifier_for_ruc_land_surface_scheme + long_name = flag for RUC land surface model + units = flag + dimensions = () + type = integer + intent = in +[landfrac] + standard_name = land_area_fraction + long_name = fraction of horizontal grid area occupied by land + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[lakefrac] + standard_name = lake_area_fraction + long_name = fraction of horizontal grid area occupied by lake + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[lakedepth] + standard_name = lake_depth + long_name = lake depth + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[oceanfrac] + standard_name = sea_area_fraction + long_name = fraction of horizontal grid area occupied by ocean + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[frland] + standard_name = land_area_fraction_for_microphysics + long_name = land area fraction used in microphysics schemes + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[dry] + standard_name = flag_nonzero_land_surface_fraction + long_name = flag indicating presence of some land surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = inout +[icy] + standard_name = flag_nonzero_sea_ice_surface_fraction + long_name = flag indicating presence of some sea ice surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = inout +[lake] + standard_name = flag_nonzero_lake_surface_fraction + long_name = flag indicating presence of some lake surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = inout +[use_flake] + standard_name = flag_for_using_flake + long_name = flag indicating lake points using flake model + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = inout +[wet] + standard_name = flag_nonzero_wet_surface_fraction + long_name = flag indicating presence of some ocean or lake surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = inout +[hice] + standard_name = sea_ice_thickness + long_name = sea ice thickness + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[cice] + standard_name = sea_ice_area_fraction_of_sea_area_fraction + long_name = ice fraction over open water + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[zorlo] + standard_name = surface_roughness_length_over_water + long_name = surface roughness length over water + units = cm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[zorll] + standard_name = surface_roughness_length_over_land + long_name = surface roughness length over land + units = cm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[zorli] + standard_name = surface_roughness_length_over_ice + long_name = surface roughness length over ice + units = cm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[snowd] + standard_name = lwe_surface_snow + long_name = water equivalent snow depth + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[snowd_lnd] + standard_name = surface_snow_thickness_water_equivalent_over_land + long_name = water equivalent snow depth over land + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[snowd_ice] + standard_name = surface_snow_thickness_water_equivalent_over_ice + long_name = water equivalent snow depth over ice + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[tprcp] + standard_name = nonnegative_lwe_thickness_of_precipitation_amount_on_dynamics_timestep + long_name = total precipitation amount in each time step + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[tprcp_wat] + standard_name = nonnegative_lwe_thickness_of_precipitation_amount_on_dynamics_timestep_over_water + long_name = total precipitation amount in each time step over water + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[tprcp_lnd] + standard_name = nonnegative_lwe_thickness_of_precipitation_amount_on_dynamics_timestep_over_land + long_name = total precipitation amount in each time step over land + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[tprcp_ice] + standard_name = nonnegative_lwe_thickness_of_precipitation_amount_on_dynamics_timestep_over_ice + long_name = total precipitation amount in each time step over ice + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[uustar] + standard_name = surface_friction_velocity + long_name = boundary layer parameter + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[uustar_wat] + standard_name = surface_friction_velocity_over_water + long_name = surface friction velocity over water + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[uustar_lnd] + standard_name = surface_friction_velocity_over_land + long_name = surface friction velocity over land + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[uustar_ice] + standard_name = surface_friction_velocity_over_ice + long_name = surface friction velocity over ice + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[weasd] + standard_name = lwe_thickness_of_surface_snow_amount + long_name = water equiv of acc snow depth over land and sea ice + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[weasd_lnd] + standard_name = water_equivalent_accumulated_snow_depth_over_land + long_name = water equiv of acc snow depth over land + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[weasd_ice] + standard_name = water_equivalent_accumulated_snow_depth_over_ice + long_name = water equiv of acc snow depth over ice + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[ep1d_ice] + standard_name = surface_upward_potential_latent_heat_flux_over_ice + long_name = surface upward potential latent heat flux over ice + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[tsfc] + standard_name = surface_skin_temperature + long_name = surface skin temperature + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[tsfco] + standard_name = sea_surface_temperature + long_name = sea surface temperature + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[tsfcl] + standard_name = surface_skin_temperature_over_land + long_name = surface skin temperature over land + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[tsfc_wat] + standard_name = surface_skin_temperature_over_water + long_name = surface skin temperature over water + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[tisfc] + standard_name = surface_skin_temperature_over_ice + long_name = surface skin temperature over ice + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[tsurf_wat] + standard_name = surface_skin_temperature_after_iteration_over_water + long_name = surface skin temperature after iteration over water + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[tsurf_lnd] + standard_name = surface_skin_temperature_after_iteration_over_land + long_name = surface skin temperature after iteration over land + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[tsurf_ice] + standard_name = surface_skin_temperature_after_iteration_over_ice + long_name = surface skin temperature after iteration over ice + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[gflx_ice] + standard_name = upward_heat_flux_in_soil_over_ice + long_name = soil heat flux over ice + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[tgice] + standard_name = freezing_point_temperature_of_seawater + long_name = freezing point temperature of seawater + units = K + dimensions = () + type = real + kind = kind_phys + intent = in +[islmsk] + standard_name = sea_land_ice_mask + long_name = sea/land/ice mask (=0/1/2) + units = flag + dimensions = (horizontal_loop_extent) + type = integer + intent = inout +[islmsk_cice] + standard_name = sea_land_ice_mask_cice + long_name = sea/land/ice mask cice (=0/1/2) + units = flag + dimensions = (horizontal_loop_extent) + type = integer + intent = inout +[slmsk] + standard_name = area_type + long_name = landmask: sea/land/ice=0/1/2 + units = flag + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[qss] + standard_name = surface_specific_humidity + long_name = surface air saturation specific humidity + units = kg kg-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[qss_wat] + standard_name = surface_specific_humidity_over_water + long_name = surface air saturation specific humidity over water + units = kg kg-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[qss_lnd] + standard_name = surface_specific_humidity_over_land + long_name = surface air saturation specific humidity over land + units = kg kg-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[qss_ice] + standard_name = surface_specific_humidity_over_ice + long_name = surface air saturation specific humidity over ice + units = kg kg-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[min_lakeice] + standard_name = min_lake_ice_area_fraction + long_name = minimum lake ice value + units = frac + dimensions = () + type = real + kind = kind_phys + intent = in +[min_seaice] + standard_name = min_sea_ice_area_fraction + long_name = minimum sea ice value + units = frac + dimensions = () + type = real + kind = kind_phys + intent = in +[kdt] + standard_name = index_of_timestep + long_name = current forecast iteration + units = index + dimensions = () + type = integer + intent = in +[huge] + standard_name = netcdf_float_fillvalue + long_name = definition of NetCDF float FillValue + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out \ No newline at end of file diff --git a/physics/GFS_surface_generic.F90 b/physics/GFS_surface_generic_post.F90 similarity index 53% rename from physics/GFS_surface_generic.F90 rename to physics/GFS_surface_generic_post.F90 index 1b39409b3..eba164c78 100644 --- a/physics/GFS_surface_generic.F90 +++ b/physics/GFS_surface_generic_post.F90 @@ -1,235 +1,5 @@ -!> \file GFS_surface_generic.F90 -!! Contains code related to all GFS surface schemes. - -!>\defgroup mod_GFS_surface_generic_pre GFS Surface Generic Pre module - module GFS_surface_generic_pre - - use machine, only: kind_phys - - implicit none - - private - - public GFS_surface_generic_pre_init, GFS_surface_generic_pre_finalize, GFS_surface_generic_pre_run - - real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys - - contains - -!> \section arg_table_GFS_surface_generic_pre_init Argument Table -!! \htmlinclude GFS_surface_generic_pre_init.html -!! - subroutine GFS_surface_generic_pre_init (nthreads, im, slmsk, isot, ivegsrc, stype, vtype, slope, & - vtype_save, stype_save, slope_save, errmsg, errflg) - - implicit none - - ! Interface variables - integer, intent(in) :: nthreads, im, isot, ivegsrc - real(kind_phys), dimension(:), intent(in) :: slmsk - integer, dimension(:), intent(inout) :: vtype, stype, slope - integer, dimension(:), intent(out) :: vtype_save, stype_save, slope_save - - ! CCPP error handling - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Local variables - integer, dimension(1:im) :: islmsk - integer :: i - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - islmsk = nint(slmsk) - - ! Save current values of vegetation, soil and slope type - vtype_save(:) = vtype(:) - stype_save(:) = stype(:) - slope_save(:) = slope(:) - - call update_vegetation_soil_slope_type(nthreads, im, isot, ivegsrc, islmsk, vtype, stype, slope) - - end subroutine GFS_surface_generic_pre_init - - subroutine GFS_surface_generic_pre_finalize() - end subroutine GFS_surface_generic_pre_finalize - -!> \section arg_table_GFS_surface_generic_pre_run Argument Table -!! \htmlinclude GFS_surface_generic_pre_run.html -!! - subroutine GFS_surface_generic_pre_run (nthreads, im, levs, vfrac, islmsk, isot, ivegsrc, stype, vtype, slope, & - prsik_1, prslk_1, tsfc, phil, con_g, sigmaf, work3, zlvl, & - drain_cpl, dsnow_cpl, rain_cpl, snow_cpl, lndp_type, n_var_lndp, sfc_wts, & - lndp_var_list, lndp_prt_list, & - z01d, zt1d, bexp1d, xlai1d, vegf1d, lndp_vgf, & - cplflx, flag_cice, islmsk_cice, slimskin_cpl, & - wind, u1, v1, cnvwind, smcwlt2, smcref2, vtype_save, stype_save, slope_save, & - errmsg, errflg) - - use surface_perturbation, only: cdfnor - - implicit none - - ! Interface variables - integer, intent(in) :: nthreads, im, levs, isot, ivegsrc - integer, dimension(:), intent(in) :: islmsk - - real(kind=kind_phys), intent(in) :: con_g - real(kind=kind_phys), dimension(:), intent(in) :: vfrac, prsik_1, prslk_1 - integer, dimension(:), intent(inout) :: vtype, stype, slope - integer, dimension(:), intent(out) :: vtype_save(:), stype_save(:), slope_save(:) - - real(kind=kind_phys), dimension(:), intent(inout) :: tsfc - real(kind=kind_phys), dimension(:,:), intent(in) :: phil - - real(kind=kind_phys), dimension(:), intent(inout) :: sigmaf, work3, zlvl - - ! Stochastic physics / surface perturbations - real(kind=kind_phys), dimension(:), intent(out) :: drain_cpl - real(kind=kind_phys), dimension(:), intent(out) :: dsnow_cpl - real(kind=kind_phys), dimension(:), intent(in) :: rain_cpl - real(kind=kind_phys), dimension(:), intent(in) :: snow_cpl - integer, intent(in) :: lndp_type, n_var_lndp - character(len=3), dimension(:), intent(in) :: lndp_var_list - real(kind=kind_phys), dimension(:), intent(in) :: lndp_prt_list - real(kind=kind_phys), dimension(:,:), intent(in) :: sfc_wts - real(kind=kind_phys), dimension(:), intent(out) :: z01d - real(kind=kind_phys), dimension(:), intent(out) :: zt1d - real(kind=kind_phys), dimension(:), intent(out) :: bexp1d - real(kind=kind_phys), dimension(:), intent(out) :: xlai1d - real(kind=kind_phys), dimension(:), intent(out) :: vegf1d - real(kind=kind_phys), intent(out) :: lndp_vgf - - logical, intent(in) :: cplflx - real(kind=kind_phys), dimension(:), intent(in) :: slimskin_cpl - logical, dimension(:), intent(inout) :: flag_cice - integer, dimension(:), intent(out) :: islmsk_cice - - real(kind=kind_phys), dimension(:), intent(out) :: wind - real(kind=kind_phys), dimension(:), intent(in ) :: u1, v1 - ! surface wind enhancement due to convection - real(kind=kind_phys), dimension(:), intent(inout ) :: cnvwind - ! - real(kind=kind_phys), dimension(:), intent(out) :: smcwlt2, smcref2 - - ! CCPP error handling - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Local variables - integer :: i, k - real(kind=kind_phys) :: onebg, cdfz - - ! Set constants - onebg = 1.0/con_g - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - ! Scale random patterns for surface perturbations with perturbation size - ! Turn vegetation fraction pattern into percentile pattern - lndp_vgf=-999. - - if (lndp_type==1) then - do k =1,n_var_lndp - select case(lndp_var_list(k)) - case ('rz0') - z01d(:) = lndp_prt_list(k)* sfc_wts(:,k) - case ('rzt') - zt1d(:) = lndp_prt_list(k)* sfc_wts(:,k) - case ('shc') - bexp1d(:) = lndp_prt_list(k) * sfc_wts(:,k) - case ('lai') - xlai1d(:) = lndp_prt_list(k)* sfc_wts(:,k) - case ('vgf') - ! note that the pertrubed vegfrac is being used in sfc_drv, but not sfc_diff - do i=1,im - call cdfnor(sfc_wts(i,k),cdfz) - vegf1d(i) = cdfz - enddo - lndp_vgf = lndp_prt_list(k) - end select - enddo - endif - - ! End of stochastic physics / surface perturbation - - ! Save current values of vegetation, soil and slope type - vtype_save(:) = vtype(:) - stype_save(:) = stype(:) - slope_save(:) = slope(:) - - call update_vegetation_soil_slope_type(nthreads, im, isot, ivegsrc, islmsk, vtype, stype, slope) - - do i=1,im - sigmaf(i) = max(vfrac(i), 0.01_kind_phys) - islmsk_cice(i) = islmsk(i) - - work3(i) = prsik_1(i) / prslk_1(i) - - zlvl(i) = phil(i,1) * onebg - smcwlt2(i) = zero - smcref2(i) = zero - - wind(i) = max(sqrt(u1(i)*u1(i) + v1(i)*v1(i)) & - + max(zero, min(cnvwind(i), 30.0_kind_phys)), one) - !wind(i) = max(sqrt(Statein%ugrs(i,1)*Statein%ugrs(i,1) + & - ! Statein%vgrs(i,1)*Statein%vgrs(i,1)) & - ! + max(zero, min(Tbd%phy_f2d(i,Model%num_p2d), 30.0)), one) - cnvwind(i) = zero - - enddo - - if (cplflx) then - do i=1,im - islmsk_cice(i) = nint(slimskin_cpl(i)) - flag_cice(i) = (islmsk_cice(i) == 4) - enddo - endif - - end subroutine GFS_surface_generic_pre_run - - subroutine update_vegetation_soil_slope_type(nthreads, im, isot, ivegsrc, islmsk, vtype, stype, slope) - - implicit none - - integer, intent(in) :: nthreads, im, isot, ivegsrc, islmsk(:) - integer, intent(inout) :: vtype(:), stype(:), slope(:) - integer :: i - -!$OMP parallel do num_threads(nthreads) default(none) private(i) & -!$OMP shared(im, isot, ivegsrc, islmsk, vtype, stype, slope) - do i=1,im - if (islmsk(i) == 2) then - if (isot == 1) then - stype(i) = 16 - else - stype(i) = 9 - endif - if (ivegsrc == 0 .or. ivegsrc == 4) then - vtype(i) = 24 - elseif (ivegsrc == 1) then - vtype(i) = 15 - elseif (ivegsrc == 2) then - vtype(i) = 13 - elseif (ivegsrc == 3 .or. ivegsrc == 5) then - vtype(i) = 15 - endif - slope(i) = 9 - else - if (vtype(i) < 1) vtype(i) = 17 - if (slope(i) < 1) slope(i) = 1 - endif - enddo -!$OMP end parallel do - - end subroutine update_vegetation_soil_slope_type - - end module GFS_surface_generic_pre - +!> \file GFS_surface_generic_post.F90 +!! Contains code related to all GFS surface schemes to be run afterward. module GFS_surface_generic_post @@ -239,7 +9,7 @@ module GFS_surface_generic_post private - public GFS_surface_generic_post_init, GFS_surface_generic_post_finalize, GFS_surface_generic_post_run + public GFS_surface_generic_post_init, GFS_surface_generic_post_run real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys @@ -268,13 +38,10 @@ subroutine GFS_surface_generic_post_init (vtype, stype, slope, vtype_save, stype end subroutine GFS_surface_generic_post_init - subroutine GFS_surface_generic_post_finalize() - end subroutine GFS_surface_generic_post_finalize - !> \section arg_table_GFS_surface_generic_post_run Argument Table !! \htmlinclude GFS_surface_generic_post_run.html !! - subroutine GFS_surface_generic_post_run (im, cplflx, cplchm, cplwav, lssav, dry, icy, wet, & + subroutine GFS_surface_generic_post_run (im, cplflx, cplaqm, cplchm, cplwav, lssav, dry, icy, wet, & lsm, lsm_noahmp, dtf, ep1d, gflx, tgrs_1, qgrs_1, ugrs_1, vgrs_1, & adjsfcdlw, adjsfcdsw, adjnirbmd, adjnirdfd, adjvisbmd, adjvisdfd, adjsfculw, adjsfculw_wat, adjnirbmu, adjnirdfu, & adjvisbmu, adjvisdfu, t2m, q2m, u10m, v10m, tsfc, tsfc_wat, pgr, xcosz, evbs, evcw, trans, sbsno, snowc, snohf, pah, pahi, & @@ -288,7 +55,7 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplchm, cplwav, lssav, dry, implicit none integer, intent(in) :: im - logical, intent(in) :: cplflx, cplchm, cplwav, lssav + logical, intent(in) :: cplflx, cplaqm, cplchm, cplwav, lssav logical, dimension(:), intent(in) :: dry, icy, wet integer, intent(in) :: lsm, lsm_noahmp real(kind=kind_phys), intent(in) :: dtf @@ -416,6 +183,34 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplchm, cplwav, lssav, dry, enddo endif + if (cplaqm .and. .not.cplflx) then + do i=1,im + t2mi_cpl (i) = t2m(i) + q2mi_cpl (i) = q2m(i) + psurfi_cpl (i) = pgr(i) + if (wet(i)) then ! some open water +! --- compute open water albedo + xcosz_loc = max( zero, min( one, xcosz(i) )) + ocalnirdf_cpl = 0.06_kind_phys + ocalnirbm_cpl = max(albdf, 0.026_kind_phys/(xcosz_loc**1.7_kind_phys+0.065_kind_phys) & + & + 0.15_kind_phys * (xcosz_loc-0.1_kind_phys) * (xcosz_loc-0.5_kind_phys) & + & * (xcosz_loc-one)) + ocalvisdf_cpl = 0.06_kind_phys + ocalvisbm_cpl = ocalnirbm_cpl + + nswsfci_cpl(i) = adjnirbmd(i) * (one-ocalnirbm_cpl) + & + adjnirdfd(i) * (one-ocalnirdf_cpl) + & + adjvisbmd(i) * (one-ocalvisbm_cpl) + & + adjvisdfd(i) * (one-ocalvisdf_cpl) + else + nswsfci_cpl(i) = adjnirbmd(i) - adjnirbmu(i) + & + adjnirdfd(i) - adjnirdfu(i) + & + adjvisbmd(i) - adjvisbmu(i) + & + adjvisdfd(i) - adjvisdfu(i) + endif + enddo + endif + if (lssav) then do i=1,im gflux(i) = gflux(i) + gflx(i) * dtf diff --git a/physics/GFS_surface_generic.meta b/physics/GFS_surface_generic_post.meta similarity index 70% rename from physics/GFS_surface_generic.meta rename to physics/GFS_surface_generic_post.meta index 28c88c5ea..033ec1cbf 100644 --- a/physics/GFS_surface_generic.meta +++ b/physics/GFS_surface_generic_post.meta @@ -1,482 +1,8 @@ -[ccpp-table-properties] - name = GFS_surface_generic_pre - type = scheme - dependencies = machine.F,surface_perturbation.F90 - -######################################################################## -[ccpp-arg-table] - name = GFS_surface_generic_pre_init - type = scheme -[nthreads] - standard_name = number_of_openmp_threads - long_name = number of OpenMP threads available for physics schemes - units = count - dimensions = () - type = integer - intent = in -[im] - standard_name = horizontal_dimension - long_name = horizontal dimension - units = count - dimensions = () - type = integer - intent = in -[slmsk] - standard_name = area_type - long_name = landmask: sea/land/ice=0/1/2 - units = flag - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = in -[isot] - standard_name = control_for_soil_type_dataset - long_name = soil type dataset choice - units = index - dimensions = () - type = integer - intent = in -[ivegsrc] - standard_name = control_for_vegetation_dataset - long_name = land use dataset choice - units = index - dimensions = () - type = integer - intent = in -[stype] - standard_name = soil_type_classification - long_name = soil type for lsm - units = index - dimensions = (horizontal_dimension) - type = integer - intent = inout -[vtype] - standard_name = vegetation_type_classification - long_name = vegetation type for lsm - units = index - dimensions = (horizontal_dimension) - type = integer - intent = inout -[slope] - standard_name = surface_slope_classification - long_name = sfc slope type for lsm - units = index - dimensions = (horizontal_dimension) - type = integer - intent = inout -[stype_save] - standard_name = soil_type_classification_save - long_name = soil type for lsm save - units = index - dimensions = (horizontal_dimension) - type = integer - intent = out -[vtype_save] - standard_name = vegetation_type_classification_save - long_name = vegetation type for lsm save - units = index - dimensions = (horizontal_dimension) - type = integer - intent = out -[slope_save] - standard_name = surface_slope_classification_save - long_name = sfc slope type for lsm save - units = index - dimensions = (horizontal_dimension) - type = integer - intent = out -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out - -######################################################################## -[ccpp-arg-table] - name = GFS_surface_generic_pre_run - type = scheme -[nthreads] - standard_name = number_of_openmp_threads - long_name = number of OpenMP threads available for physics schemes - units = count - dimensions = () - type = integer - intent = in -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in -[levs] - standard_name = vertical_layer_dimension - long_name = number of vertical levels - units = count - dimensions = () - type = integer - intent = in -[vfrac] - standard_name = vegetation_area_fraction - long_name = areal fractional cover of green vegetation - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[islmsk] - standard_name = sea_land_ice_mask - long_name = landmask: sea/land/ice=0/1/2 - units = flag - dimensions = (horizontal_loop_extent) - type = integer - intent = in -[isot] - standard_name = control_for_soil_type_dataset - long_name = soil type dataset choice - units = index - dimensions = () - type = integer - intent = in -[ivegsrc] - standard_name = control_for_vegetation_dataset - long_name = land use dataset choice - units = index - dimensions = () - type = integer - intent = in -[stype] - standard_name = soil_type_classification - long_name = soil type for lsm - units = index - dimensions = (horizontal_loop_extent) - type = integer - intent = inout -[vtype] - standard_name = vegetation_type_classification - long_name = vegetation type for lsm - units = index - dimensions = (horizontal_loop_extent) - type = integer - intent = inout -[slope] - standard_name = surface_slope_classification - long_name = sfc slope type for lsm - units = index - dimensions = (horizontal_loop_extent) - type = integer - intent = inout -[vtype_save] - standard_name = vegetation_type_classification_save - long_name = vegetation type for lsm save - units = index - dimensions = (horizontal_loop_extent) - type = integer - intent = out -[stype_save] - standard_name = soil_type_classification_save - long_name = soil type for lsm save - units = index - dimensions = (horizontal_loop_extent) - type = integer - intent = out -[slope_save] - standard_name = surface_slope_classification_save - long_name = sfc slope type for lsm save - units = index - dimensions = (horizontal_loop_extent) - type = integer - intent = out -[prsik_1] - standard_name = surface_dimensionless_exner_function - long_name = dimensionless Exner function at lowest model interface - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[prslk_1] - standard_name = dimensionless_exner_function_at_surface_adjacent_layer - long_name = dimensionless Exner function at lowest model layer - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[tsfc] - standard_name = surface_skin_temperature - long_name = surface skin temperature - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[phil] - standard_name = geopotential - long_name = geopotential at model layer centers - units = m2 s-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[con_g] - standard_name = gravitational_acceleration - long_name = gravitational acceleration - units = m s-2 - dimensions = () - type = real - kind = kind_phys - intent = in -[sigmaf] - standard_name = bounded_vegetation_area_fraction - long_name = areal fractional cover of green vegetation bounded on the bottom - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[work3] - standard_name = ratio_of_exner_function_between_midlayer_and_interface_at_lowest_model_layer - long_name = Exner function ratio bt midlayer and interface at 1st layer - units = ratio - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[zlvl] - standard_name = height_above_ground_at_lowest_model_layer - long_name = layer 1 height above ground (not MSL) - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[drain_cpl] - standard_name = tendency_of_lwe_thickness_of_rain_amount_on_dynamics_timestep_for_coupling - long_name = change in rain_cpl (coupling_type) - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[dsnow_cpl] - standard_name = tendency_of_lwe_thickness_of_snowfall_amount_on_dynamics_timestep_for_coupling - long_name = change in show_cpl (coupling_type) - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[rain_cpl] - standard_name = cumulative_lwe_thickness_of_precipitation_amount_for_coupling - long_name = total rain precipitation - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[snow_cpl] - standard_name = cumulative_lwe_thickness_of_snow_amount_for_coupling - long_name = total snow precipitation - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[lndp_type] - standard_name = control_for_stochastic_land_surface_perturbation - long_name = index for stochastic land surface perturbations type - units = index - dimensions = () - type = integer - intent = in -[n_var_lndp] - standard_name = number_of_perturbed_land_surface_variables - long_name = number of land surface variables perturbed - units = count - dimensions = () - type = integer - intent = in -[sfc_wts] - standard_name = surface_stochastic_weights_from_coupled_process - long_name = weights for stochastic surface physics perturbation - units = 1 - dimensions = (horizontal_loop_extent,number_of_perturbed_land_surface_variables) - type = real - kind = kind_phys - intent = in -[lndp_var_list] - standard_name = land_surface_perturbation_variables - long_name = variables to be perturbed for landperts - units = none - dimensions = (number_of_perturbed_land_surface_variables) - type = character - kind = len=3 - intent = in -[lndp_prt_list] - standard_name =land_surface_perturbation_magnitudes - long_name = magnitude of perturbations for landperts - units = variable - dimensions = (number_of_perturbed_land_surface_variables) - type = real - kind = kind_phys - intent = in -[z01d] - standard_name = perturbation_of_momentum_roughness_length - long_name = perturbation of momentum roughness length - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[zt1d] - standard_name = perturbation_of_heat_to_momentum_roughness_length_ratio - long_name = perturbation of heat to momentum roughness length ratio - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[bexp1d] - standard_name = perturbation_of_soil_type_b_parameter - long_name = perturbation of soil type "b" parameter - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[xlai1d] - standard_name = perturbation_of_leaf_area_index - long_name = perturbation of leaf area index - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[vegf1d] - standard_name = perturbation_of_vegetation_fraction - long_name = perturbation of vegetation fraction - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[lndp_vgf] - standard_name = magnitude_of_perturbation_of_vegetation_fraction - long_name = magnitude of perturbation of vegetation fraction - units = frac - dimensions = () - type = real - kind = kind_phys - intent = out -[cplflx] - standard_name = flag_for_surface_flux_coupling - long_name = flag controlling cplflx collection (default off) - units = flag - dimensions = () - type = logical - intent = in -[flag_cice] - standard_name = flag_for_cice - long_name = flag for cice - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = inout -[islmsk_cice] - standard_name = sea_land_ice_mask_cice - long_name = sea/land/ice mask cice (=0/1/2) - units = flag - dimensions = (horizontal_loop_extent) - type = integer - intent = out -[slimskin_cpl] - standard_name = area_type_from_coupled_process - long_name = sea/land/ice mask input (=0/1/2) - units = flag - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[wind] - standard_name = wind_speed_at_lowest_model_layer - long_name = wind speed at lowest model level - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[u1] - standard_name = x_wind_at_surface_adjacent_layer - long_name = zonal wind at lowest model layer - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[v1] - standard_name = y_wind_at_surface_adjacent_layer - long_name = meridional wind at lowest model layer - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[cnvwind] - standard_name = enhancement_to_wind_speed_at_surface_adjacent_layer_due_to_convection - long_name = surface wind enhancement due to convection - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[smcwlt2] - standard_name = volume_fraction_of_condensed_water_in_soil_at_wilting_point - long_name = wilting point (volumetric) - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[smcref2] - standard_name = threshold_volume_fraction_of_condensed_water_in_soil - long_name = soil moisture threshold (volumetric) - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out - ######################################################################## [ccpp-table-properties] name = GFS_surface_generic_post type = scheme - dependencies = machine.F,surface_perturbation.F90 + dependencies = machine.F ######################################################################## [ccpp-arg-table] @@ -558,6 +84,13 @@ dimensions = () type = logical intent = in +[cplaqm] + standard_name = flag_for_air_quality_coupling + long_name = flag controlling cplaqm collection (default off) + units = flag + dimensions = () + type = logical + intent = in [cplchm] standard_name = flag_for_chemistry_coupling long_name = flag controlling cplchm collection (default off) diff --git a/physics/GFS_surface_generic_pre.F90 b/physics/GFS_surface_generic_pre.F90 new file mode 100644 index 000000000..c572201a4 --- /dev/null +++ b/physics/GFS_surface_generic_pre.F90 @@ -0,0 +1,228 @@ +!> \file GFS_surface_generic_pre.F90 +!! Contains code related to running prior to all GFS surface schemes. + +!>\defgroup mod_GFS_surface_generic_pre GFS Surface Generic Pre module + module GFS_surface_generic_pre + + use machine, only: kind_phys + + implicit none + + private + + public GFS_surface_generic_pre_init, GFS_surface_generic_pre_run + + real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys + + contains + +!> \section arg_table_GFS_surface_generic_pre_init Argument Table +!! \htmlinclude GFS_surface_generic_pre_init.html +!! + subroutine GFS_surface_generic_pre_init (nthreads, im, slmsk, isot, ivegsrc, stype, vtype, slope, & + vtype_save, stype_save, slope_save, errmsg, errflg) + + implicit none + + ! Interface variables + integer, intent(in) :: nthreads, im, isot, ivegsrc + real(kind_phys), dimension(:), intent(in) :: slmsk + integer, dimension(:), intent(inout) :: vtype, stype, slope + integer, dimension(:), intent(out) :: vtype_save, stype_save, slope_save + + ! CCPP error handling + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Local variables + integer, dimension(1:im) :: islmsk + integer :: i + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + islmsk = nint(slmsk) + + ! Save current values of vegetation, soil and slope type + vtype_save(:) = vtype(:) + stype_save(:) = stype(:) + slope_save(:) = slope(:) + + call update_vegetation_soil_slope_type(nthreads, im, isot, ivegsrc, islmsk, vtype, stype, slope) + + end subroutine GFS_surface_generic_pre_init + +!> \section arg_table_GFS_surface_generic_pre_run Argument Table +!! \htmlinclude GFS_surface_generic_pre_run.html +!! + subroutine GFS_surface_generic_pre_run (nthreads, im, levs, vfrac, islmsk, isot, ivegsrc, stype, vtype, slope, & + prsik_1, prslk_1, tsfc, phil, con_g, sigmaf, work3, zlvl, & + drain_cpl, dsnow_cpl, rain_cpl, snow_cpl, lndp_type, n_var_lndp, sfc_wts, & + lndp_var_list, lndp_prt_list, & + z01d, zt1d, bexp1d, xlai1d, vegf1d, lndp_vgf, & + cplflx, flag_cice, islmsk_cice, slimskin_cpl, & + wind, u1, v1, cnvwind, smcwlt2, smcref2, vtype_save, stype_save, slope_save, & + errmsg, errflg) + + use surface_perturbation, only: cdfnor + + implicit none + + ! Interface variables + integer, intent(in) :: nthreads, im, levs, isot, ivegsrc + integer, dimension(:), intent(in) :: islmsk + + real(kind=kind_phys), intent(in) :: con_g + real(kind=kind_phys), dimension(:), intent(in) :: vfrac, prsik_1, prslk_1 + integer, dimension(:), intent(inout) :: vtype, stype, slope + integer, dimension(:), intent(out) :: vtype_save(:), stype_save(:), slope_save(:) + + real(kind=kind_phys), dimension(:), intent(inout) :: tsfc + real(kind=kind_phys), dimension(:,:), intent(in) :: phil + + real(kind=kind_phys), dimension(:), intent(inout) :: sigmaf, work3, zlvl + + ! Stochastic physics / surface perturbations + real(kind=kind_phys), dimension(:), intent(out) :: drain_cpl + real(kind=kind_phys), dimension(:), intent(out) :: dsnow_cpl + real(kind=kind_phys), dimension(:), intent(in) :: rain_cpl + real(kind=kind_phys), dimension(:), intent(in) :: snow_cpl + integer, intent(in) :: lndp_type, n_var_lndp + character(len=3), dimension(:), intent(in) :: lndp_var_list + real(kind=kind_phys), dimension(:), intent(in) :: lndp_prt_list + real(kind=kind_phys), dimension(:,:), intent(in) :: sfc_wts + real(kind=kind_phys), dimension(:), intent(out) :: z01d + real(kind=kind_phys), dimension(:), intent(out) :: zt1d + real(kind=kind_phys), dimension(:), intent(out) :: bexp1d + real(kind=kind_phys), dimension(:), intent(out) :: xlai1d + real(kind=kind_phys), dimension(:), intent(out) :: vegf1d + real(kind=kind_phys), intent(out) :: lndp_vgf + + logical, intent(in) :: cplflx + real(kind=kind_phys), dimension(:), intent(in) :: slimskin_cpl + logical, dimension(:), intent(inout) :: flag_cice + integer, dimension(:), intent(out) :: islmsk_cice + + real(kind=kind_phys), dimension(:), intent(out) :: wind + real(kind=kind_phys), dimension(:), intent(in ) :: u1, v1 + ! surface wind enhancement due to convection + real(kind=kind_phys), dimension(:), intent(inout ) :: cnvwind + ! + real(kind=kind_phys), dimension(:), intent(out) :: smcwlt2, smcref2 + + ! CCPP error handling + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Local variables + integer :: i, k + real(kind=kind_phys) :: onebg, cdfz + + ! Set constants + onebg = 1.0/con_g + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! Scale random patterns for surface perturbations with perturbation size + ! Turn vegetation fraction pattern into percentile pattern + lndp_vgf=-999. + + if (lndp_type==1) then + do k =1,n_var_lndp + select case(lndp_var_list(k)) + case ('rz0') + z01d(:) = lndp_prt_list(k)* sfc_wts(:,k) + case ('rzt') + zt1d(:) = lndp_prt_list(k)* sfc_wts(:,k) + case ('shc') + bexp1d(:) = lndp_prt_list(k) * sfc_wts(:,k) + case ('lai') + xlai1d(:) = lndp_prt_list(k)* sfc_wts(:,k) + case ('vgf') + ! note that the pertrubed vegfrac is being used in sfc_drv, but not sfc_diff + do i=1,im + call cdfnor(sfc_wts(i,k),cdfz) + vegf1d(i) = cdfz + enddo + lndp_vgf = lndp_prt_list(k) + end select + enddo + endif + + ! End of stochastic physics / surface perturbation + + ! Save current values of vegetation, soil and slope type + vtype_save(:) = vtype(:) + stype_save(:) = stype(:) + slope_save(:) = slope(:) + + call update_vegetation_soil_slope_type(nthreads, im, isot, ivegsrc, islmsk, vtype, stype, slope) + + do i=1,im + sigmaf(i) = max(vfrac(i), 0.01_kind_phys) + islmsk_cice(i) = islmsk(i) + + work3(i) = prsik_1(i) / prslk_1(i) + + zlvl(i) = phil(i,1) * onebg + smcwlt2(i) = zero + smcref2(i) = zero + + wind(i) = max(sqrt(u1(i)*u1(i) + v1(i)*v1(i)) & + + max(zero, min(cnvwind(i), 30.0_kind_phys)), one) + !wind(i) = max(sqrt(Statein%ugrs(i,1)*Statein%ugrs(i,1) + & + ! Statein%vgrs(i,1)*Statein%vgrs(i,1)) & + ! + max(zero, min(Tbd%phy_f2d(i,Model%num_p2d), 30.0)), one) + cnvwind(i) = zero + + enddo + + if (cplflx) then + do i=1,im + islmsk_cice(i) = nint(slimskin_cpl(i)) + flag_cice(i) = (islmsk_cice(i) == 4) + enddo + endif + + end subroutine GFS_surface_generic_pre_run + + subroutine update_vegetation_soil_slope_type(nthreads, im, isot, ivegsrc, islmsk, vtype, stype, slope) + + implicit none + + integer, intent(in) :: nthreads, im, isot, ivegsrc, islmsk(:) + integer, intent(inout) :: vtype(:), stype(:), slope(:) + integer :: i + +!$OMP parallel do num_threads(nthreads) default(none) private(i) & +!$OMP shared(im, isot, ivegsrc, islmsk, vtype, stype, slope) + do i=1,im + if (islmsk(i) == 2) then + if (isot == 1) then + stype(i) = 16 + else + stype(i) = 9 + endif + if (ivegsrc == 0 .or. ivegsrc == 4) then + vtype(i) = 24 + elseif (ivegsrc == 1) then + vtype(i) = 15 + elseif (ivegsrc == 2) then + vtype(i) = 13 + elseif (ivegsrc == 3 .or. ivegsrc == 5) then + vtype(i) = 15 + endif + slope(i) = 9 + else + if (vtype(i) < 1) vtype(i) = 17 + if (slope(i) < 1) slope(i) = 1 + endif + enddo +!$OMP end parallel do + + end subroutine update_vegetation_soil_slope_type + + end module GFS_surface_generic_pre diff --git a/physics/GFS_surface_generic_pre.meta b/physics/GFS_surface_generic_pre.meta new file mode 100644 index 000000000..f5b7f7f27 --- /dev/null +++ b/physics/GFS_surface_generic_pre.meta @@ -0,0 +1,473 @@ +[ccpp-table-properties] + name = GFS_surface_generic_pre + type = scheme + dependencies = machine.F,surface_perturbation.F90 + +######################################################################## +[ccpp-arg-table] + name = GFS_surface_generic_pre_init + type = scheme +[nthreads] + standard_name = number_of_openmp_threads + long_name = number of OpenMP threads available for physics schemes + units = count + dimensions = () + type = integer + intent = in +[im] + standard_name = horizontal_dimension + long_name = horizontal dimension + units = count + dimensions = () + type = integer + intent = in +[slmsk] + standard_name = area_type + long_name = landmask: sea/land/ice=0/1/2 + units = flag + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in +[isot] + standard_name = control_for_soil_type_dataset + long_name = soil type dataset choice + units = index + dimensions = () + type = integer + intent = in +[ivegsrc] + standard_name = control_for_vegetation_dataset + long_name = land use dataset choice + units = index + dimensions = () + type = integer + intent = in +[stype] + standard_name = soil_type_classification + long_name = soil type for lsm + units = index + dimensions = (horizontal_dimension) + type = integer + intent = inout +[vtype] + standard_name = vegetation_type_classification + long_name = vegetation type for lsm + units = index + dimensions = (horizontal_dimension) + type = integer + intent = inout +[slope] + standard_name = surface_slope_classification + long_name = sfc slope type for lsm + units = index + dimensions = (horizontal_dimension) + type = integer + intent = inout +[stype_save] + standard_name = soil_type_classification_save + long_name = soil type for lsm save + units = index + dimensions = (horizontal_dimension) + type = integer + intent = out +[vtype_save] + standard_name = vegetation_type_classification_save + long_name = vegetation type for lsm save + units = index + dimensions = (horizontal_dimension) + type = integer + intent = out +[slope_save] + standard_name = surface_slope_classification_save + long_name = sfc slope type for lsm save + units = index + dimensions = (horizontal_dimension) + type = integer + intent = out +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out + +######################################################################## +[ccpp-arg-table] + name = GFS_surface_generic_pre_run + type = scheme +[nthreads] + standard_name = number_of_openmp_threads + long_name = number of OpenMP threads available for physics schemes + units = count + dimensions = () + type = integer + intent = in +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[levs] + standard_name = vertical_layer_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in +[vfrac] + standard_name = vegetation_area_fraction + long_name = areal fractional cover of green vegetation + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[islmsk] + standard_name = sea_land_ice_mask + long_name = landmask: sea/land/ice=0/1/2 + units = flag + dimensions = (horizontal_loop_extent) + type = integer + intent = in +[isot] + standard_name = control_for_soil_type_dataset + long_name = soil type dataset choice + units = index + dimensions = () + type = integer + intent = in +[ivegsrc] + standard_name = control_for_vegetation_dataset + long_name = land use dataset choice + units = index + dimensions = () + type = integer + intent = in +[stype] + standard_name = soil_type_classification + long_name = soil type for lsm + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = inout +[vtype] + standard_name = vegetation_type_classification + long_name = vegetation type for lsm + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = inout +[slope] + standard_name = surface_slope_classification + long_name = sfc slope type for lsm + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = inout +[vtype_save] + standard_name = vegetation_type_classification_save + long_name = vegetation type for lsm save + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = out +[stype_save] + standard_name = soil_type_classification_save + long_name = soil type for lsm save + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = out +[slope_save] + standard_name = surface_slope_classification_save + long_name = sfc slope type for lsm save + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = out +[prsik_1] + standard_name = surface_dimensionless_exner_function + long_name = dimensionless Exner function at lowest model interface + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[prslk_1] + standard_name = dimensionless_exner_function_at_surface_adjacent_layer + long_name = dimensionless Exner function at lowest model layer + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[tsfc] + standard_name = surface_skin_temperature + long_name = surface skin temperature + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[phil] + standard_name = geopotential + long_name = geopotential at model layer centers + units = m2 s-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[con_g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in +[sigmaf] + standard_name = bounded_vegetation_area_fraction + long_name = areal fractional cover of green vegetation bounded on the bottom + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[work3] + standard_name = ratio_of_exner_function_between_midlayer_and_interface_at_lowest_model_layer + long_name = Exner function ratio bt midlayer and interface at 1st layer + units = ratio + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[zlvl] + standard_name = height_above_ground_at_lowest_model_layer + long_name = layer 1 height above ground (not MSL) + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[drain_cpl] + standard_name = tendency_of_lwe_thickness_of_rain_amount_on_dynamics_timestep_for_coupling + long_name = change in rain_cpl (coupling_type) + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[dsnow_cpl] + standard_name = tendency_of_lwe_thickness_of_snowfall_amount_on_dynamics_timestep_for_coupling + long_name = change in show_cpl (coupling_type) + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[rain_cpl] + standard_name = cumulative_lwe_thickness_of_precipitation_amount_for_coupling + long_name = total rain precipitation + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[snow_cpl] + standard_name = cumulative_lwe_thickness_of_snow_amount_for_coupling + long_name = total snow precipitation + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[lndp_type] + standard_name = control_for_stochastic_land_surface_perturbation + long_name = index for stochastic land surface perturbations type + units = index + dimensions = () + type = integer + intent = in +[n_var_lndp] + standard_name = number_of_perturbed_land_surface_variables + long_name = number of land surface variables perturbed + units = count + dimensions = () + type = integer + intent = in +[sfc_wts] + standard_name = surface_stochastic_weights_from_coupled_process + long_name = weights for stochastic surface physics perturbation + units = 1 + dimensions = (horizontal_loop_extent,number_of_perturbed_land_surface_variables) + type = real + kind = kind_phys + intent = in +[lndp_var_list] + standard_name = land_surface_perturbation_variables + long_name = variables to be perturbed for landperts + units = none + dimensions = (number_of_perturbed_land_surface_variables) + type = character + kind = len=3 + intent = in +[lndp_prt_list] + standard_name =land_surface_perturbation_magnitudes + long_name = magnitude of perturbations for landperts + units = variable + dimensions = (number_of_perturbed_land_surface_variables) + type = real + kind = kind_phys + intent = in +[z01d] + standard_name = perturbation_of_momentum_roughness_length + long_name = perturbation of momentum roughness length + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[zt1d] + standard_name = perturbation_of_heat_to_momentum_roughness_length_ratio + long_name = perturbation of heat to momentum roughness length ratio + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[bexp1d] + standard_name = perturbation_of_soil_type_b_parameter + long_name = perturbation of soil type "b" parameter + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[xlai1d] + standard_name = perturbation_of_leaf_area_index + long_name = perturbation of leaf area index + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[vegf1d] + standard_name = perturbation_of_vegetation_fraction + long_name = perturbation of vegetation fraction + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[lndp_vgf] + standard_name = magnitude_of_perturbation_of_vegetation_fraction + long_name = magnitude of perturbation of vegetation fraction + units = frac + dimensions = () + type = real + kind = kind_phys + intent = out +[cplflx] + standard_name = flag_for_surface_flux_coupling + long_name = flag controlling cplflx collection (default off) + units = flag + dimensions = () + type = logical + intent = in +[flag_cice] + standard_name = flag_for_cice + long_name = flag for cice + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = inout +[islmsk_cice] + standard_name = sea_land_ice_mask_cice + long_name = sea/land/ice mask cice (=0/1/2) + units = flag + dimensions = (horizontal_loop_extent) + type = integer + intent = out +[slimskin_cpl] + standard_name = area_type_from_coupled_process + long_name = sea/land/ice mask input (=0/1/2) + units = flag + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[wind] + standard_name = wind_speed_at_lowest_model_layer + long_name = wind speed at lowest model level + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[u1] + standard_name = x_wind_at_surface_adjacent_layer + long_name = zonal wind at lowest model layer + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[v1] + standard_name = y_wind_at_surface_adjacent_layer + long_name = meridional wind at lowest model layer + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[cnvwind] + standard_name = enhancement_to_wind_speed_at_surface_adjacent_layer_due_to_convection + long_name = surface wind enhancement due to convection + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[smcwlt2] + standard_name = volume_fraction_of_condensed_water_in_soil_at_wilting_point + long_name = wilting point (volumetric) + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[smcref2] + standard_name = threshold_volume_fraction_of_condensed_water_in_soil + long_name = soil moisture threshold (volumetric) + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out \ No newline at end of file diff --git a/physics/GFS_surface_loop_control_part1.F90 b/physics/GFS_surface_loop_control_part1.F90 new file mode 100644 index 000000000..9d73608b4 --- /dev/null +++ b/physics/GFS_surface_loop_control_part1.F90 @@ -0,0 +1,51 @@ +!> \file GFS_surface_loop_control_part1.F90 +!! This file contains the GFS_surface_loop_control_part1 scheme. + +!> \defgroup GFS_surface_loop_control GFS_surface_loop_control scheme +!! @{ + + module GFS_surface_loop_control_part1 + contains + +!> \brief Brief description of the subroutine +!! +!! \section arg_table_GFS_surface_loop_control_part1_run Arguments +!! \htmlinclude GFS_surface_loop_control_part1_run.html +!! +!! \section general General Algorithm +!! \section detailed Detailed Algorithm +!! @{ + + subroutine GFS_surface_loop_control_part1_run (im, iter, & + wind, flag_guess, errmsg, errflg) + + use machine, only: kind_phys + + implicit none + + ! Interface variables + integer, intent(in) :: im + integer, intent(in) :: iter + real(kind=kind_phys), dimension(:), intent(in) :: wind + logical, dimension(:), intent(inout) :: flag_guess + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Local variables + integer :: i + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + do i=1,im + if (iter == 1 .and. wind(i) < 2.0d0) then + flag_guess(i) = .true. + endif + enddo + + end subroutine GFS_surface_loop_control_part1_run +!> @} + end module GFS_surface_loop_control_part1 +!> @} \ No newline at end of file diff --git a/physics/GFS_surface_loop_control_part1.meta b/physics/GFS_surface_loop_control_part1.meta new file mode 100644 index 000000000..f178320ee --- /dev/null +++ b/physics/GFS_surface_loop_control_part1.meta @@ -0,0 +1,53 @@ +[ccpp-table-properties] + name = GFS_surface_loop_control_part1 + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = GFS_surface_loop_control_part1_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[iter] + standard_name = ccpp_loop_counter + long_name = loop counter for subcycling loops in CCPP + units = index + dimensions = () + type = integer + intent = in +[wind] + standard_name = wind_speed_at_lowest_model_layer + long_name = wind speed at lowest model level + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[flag_guess] + standard_name = flag_for_guess_run + long_name = flag for guess run + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = inout +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out \ No newline at end of file diff --git a/physics/GFS_surface_loop_control.F90 b/physics/GFS_surface_loop_control_part2.F90 similarity index 51% rename from physics/GFS_surface_loop_control.F90 rename to physics/GFS_surface_loop_control_part2.F90 index 0de1c8ee5..80b25ca1e 100644 --- a/physics/GFS_surface_loop_control.F90 +++ b/physics/GFS_surface_loop_control_part2.F90 @@ -1,60 +1,5 @@ -!> \file GFS_surface_loop_control.F90 -!! This file contains the GFS_surface_loop_control scheme. - -!> \defgroup GFS_surface_loop_control GFS_surface_loop_control scheme -!! @{ - - module GFS_surface_loop_control_part1 - contains - - subroutine GFS_surface_loop_control_part1_init - end subroutine GFS_surface_loop_control_part1_init - - subroutine GFS_surface_loop_control_part1_finalize - end subroutine GFS_surface_loop_control_part1_finalize - -!> \brief Brief description of the subroutine -!! -!! \section arg_table_GFS_surface_loop_control_part1_run Arguments -!! \htmlinclude GFS_surface_loop_control_part1_run.html -!! -!! \section general General Algorithm -!! \section detailed Detailed Algorithm -!! @{ - - subroutine GFS_surface_loop_control_part1_run (im, iter, & - wind, flag_guess, errmsg, errflg) - - use machine, only: kind_phys - - implicit none - - ! Interface variables - integer, intent(in) :: im - integer, intent(in) :: iter - real(kind=kind_phys), dimension(:), intent(in) :: wind - logical, dimension(:), intent(inout) :: flag_guess - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Local variables - integer :: i - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - do i=1,im - if (iter == 1 .and. wind(i) < 2.0d0) then - flag_guess(i) = .true. - endif - enddo - - end subroutine GFS_surface_loop_control_part1_run -!> @} - end module GFS_surface_loop_control_part1 -!> @} +!> \file GFS_surface_loop_control_part2.F90 +!! This file contains the GFS_surface_loop_control_part2 scheme. !> \defgroup GFS_surface_loop_control GFS_surface_loop_control scheme !! @{ @@ -62,12 +7,6 @@ end module GFS_surface_loop_control_part1 module GFS_surface_loop_control_part2 contains - subroutine GFS_surface_loop_control_part2_init - end subroutine GFS_surface_loop_control_part2_init - - subroutine GFS_surface_loop_control_part2_finalize - end subroutine GFS_surface_loop_control_part2_finalize - !> \brief Brief description of the subroutine !! #if 0 diff --git a/physics/GFS_surface_loop_control.meta b/physics/GFS_surface_loop_control_part2.meta similarity index 67% rename from physics/GFS_surface_loop_control.meta rename to physics/GFS_surface_loop_control_part2.meta index 4a522ff43..7c9bc7408 100644 --- a/physics/GFS_surface_loop_control.meta +++ b/physics/GFS_surface_loop_control_part2.meta @@ -1,57 +1,3 @@ -[ccpp-table-properties] - name = GFS_surface_loop_control_part1 - type = scheme - dependencies = machine.F - -######################################################################## -[ccpp-arg-table] - name = GFS_surface_loop_control_part1_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in -[iter] - standard_name = ccpp_loop_counter - long_name = loop counter for subcycling loops in CCPP - units = index - dimensions = () - type = integer - intent = in -[wind] - standard_name = wind_speed_at_lowest_model_layer - long_name = wind speed at lowest model level - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[flag_guess] - standard_name = flag_for_guess_run - long_name = flag for guess run - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = inout -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out - ######################################################################## [ccpp-table-properties] name = GFS_surface_loop_control_part2 diff --git a/physics/bl_mynn_common.f90 b/physics/bl_mynn_common.f90 new file mode 100644 index 000000000..7923bbf8b --- /dev/null +++ b/physics/bl_mynn_common.f90 @@ -0,0 +1,67 @@ +!>\file bl_mynn_common.f90 +!! Define Model-specific constants/parameters. +!! This module will be used at the initialization stage +!! where all model-specific constants are read and saved into +!! memory. This module is then used again in the MYNN-EDMF. All +!! MYNN-specific constants are declared globally in the main +!! module (module_bl_mynn) further below: + module bl_mynn_common + +!------------------------------------------ +! +!------------------------------------------ + +! The following 5-6 lines are the only lines in this file that are not +! universal for all dycores... Any ideas how to universalize it? +! For MPAS: +! use mpas_kind_types,only: kind_phys => RKIND +! For CCPP: + use machine, only : kind_phys + + implicit none + save + +! To be specified from dycore + real(kind=kind_phys):: cp != 7.*r_d/2. (J/kg/K) + real(kind=kind_phys):: cpv != 4.*r_v (J/kg/K) Spec heat H2O gas + real(kind=kind_phys):: cice != 2106. (J/kg/K) Spec heat H2O ice + real(kind=kind_phys):: cliq != 4190. (J/kg/K) Spec heat H2O liq + real(kind=kind_phys):: p608 != R_v/R_d-1. + real(kind=kind_phys):: ep_2 != R_d/R_v + real(kind=kind_phys):: grav != accel due to gravity + real(kind=kind_phys):: karman != von Karman constant + real(kind=kind_phys):: t0c != temperature of water at freezing, 273.15 K + real(kind=kind_phys):: rcp != r_d/cp + real(kind=kind_phys):: r_d != 287. (J/kg/K) gas const dry air + real(kind=kind_phys):: r_v != 461.6 (J/kg/K) gas const water + real(kind=kind_phys):: xlf != 0.35E6 (J/kg) fusion at 0 C + real(kind=kind_phys):: xlv != 2.50E6 (J/kg) vaporization at 0 C + real(kind=kind_phys):: xls != 2.85E6 (J/kg) sublimation + real(kind=kind_phys):: rvovrd != r_v/r_d != 1.608 + +! Specified locally + real(kind=kind_phys),parameter:: zero = 0.0 + real(kind=kind_phys),parameter:: half = 0.5 + real(kind=kind_phys),parameter:: one = 1.0 + real(kind=kind_phys),parameter:: two = 2.0 + real(kind=kind_phys),parameter:: onethird = 1./3. + real(kind=kind_phys),parameter:: twothirds = 2./3. + real(kind=kind_phys),parameter:: tref = 300.0 ! reference temperature (K) + real(kind=kind_phys),parameter:: TKmin = 253.0 ! for total water conversion, Tripoli and Cotton (1981) + real(kind=kind_phys),parameter:: p1000mb=100000.0 + real(kind=kind_phys),parameter:: svp1 = 0.6112 !(kPa) + real(kind=kind_phys),parameter:: svp2 = 17.67 !(dimensionless) + real(kind=kind_phys),parameter:: svp3 = 29.65 !(K) + real(kind=kind_phys),parameter:: tice = 240.0 !-33 (C), temp at saturation w.r.t. ice + +! To be derived in the init routine + real(kind=kind_phys):: ep_3 != 1.-ep_2 != 0.378 + real(kind=kind_phys):: gtr != grav/tref + real(kind=kind_phys):: rk != cp/r_d + real(kind=kind_phys):: tv0 != p608*tref + real(kind=kind_phys):: tv1 != (1.+p608)*tref + real(kind=kind_phys):: xlscp != (xlv+xlf)/cp + real(kind=kind_phys):: xlvcp != xlv/cp + real(kind=kind_phys):: g_inv != 1./grav + + end module bl_mynn_common diff --git a/physics/cs_conv.F90 b/physics/cs_conv.F90 index 8ed33f0d3..ebadf5b34 100644 --- a/physics/cs_conv.F90 +++ b/physics/cs_conv.F90 @@ -1,124 +1,6 @@ !> \file cs_conv.F90 !! This file contains the Chikira-Sugiyama Convection scheme. -module cs_conv_pre - contains - - subroutine cs_conv_pre_init() - end subroutine cs_conv_pre_init - - subroutine cs_conv_pre_finalize() - end subroutine cs_conv_pre_finalize - -!! \section arg_table_cs_conv_pre_run Argument Table -!! \htmlinclude cs_conv_pre_run.html -!! - subroutine cs_conv_pre_run(im, levs, ntrac, q, clw1, clw2, & - & work1, work2, cs_parm1, cs_parm2, wcbmax, & - & fswtr, fscav, save_q1, save_q2, save_q3, & - & errmsg, errflg) - - - use machine , only : kind_phys - - implicit none - -! --- inputs - integer, intent(in) :: im, levs, ntrac - real(kind_phys), dimension(:,:), intent(in) :: q - real(kind_phys), dimension(:,:), intent(in) :: clw1,clw2 - real(kind_phys), dimension(:), intent(in) :: work1, work2 - real(kind_phys), intent(in) :: cs_parm1, cs_parm2 - -! --- input/output - real(kind_phys), dimension(:), intent(out) :: fswtr, fscav - real(kind_phys), dimension(:), intent(out) :: wcbmax - real(kind_phys), dimension(:,:), intent(out) :: save_q1,save_q2 - ! save_q3 is not allocated for Zhao-Carr MP - real(kind_phys), dimension(:,:), intent(out) :: save_q3 - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - -! --- locals - integer :: i, k - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - do i =1,im - wcbmax(i) = cs_parm1 * work1(i) + cs_parm2 * work2(i) - enddo - - fswtr(:) = 0.0 - fscav(:) = 0.0 - do k=1,levs - do i=1,im - ! DH* note - save_q1 assignment may be redundant, - ! because already done in GFS_DCNV_generic_pre? - ! Keep for using cs_conv w/o GFS_DCNV_generic_pre? - save_q1(i,k) = q(i,k) - save_q2(i,k) = max(0.0,clw2(i,k)) - save_q3(i,k) = max(0.0,clw1(i,k)) - enddo - enddo - - return - end subroutine cs_conv_pre_run - -end module cs_conv_pre - -module cs_conv_post - contains - - subroutine cs_conv_post_init() - end subroutine cs_conv_post_init - - subroutine cs_conv_post_finalize() - end subroutine cs_conv_post_finalize - -!> \section arg_table_cs_conv_post_run Argument Table -!! \htmlinclude cs_conv_post_run.html -!! - subroutine cs_conv_post_run(im, kmax, do_aw, sigmatot, sigmafrac, errmsg, errflg) - - use machine , only : kind_phys - - implicit none - -! --- inputs - integer, intent(in) :: im, kmax - logical, intent(in) :: do_aw - real(kind_phys), dimension(:,:), intent(in) :: sigmatot - -! --- input/output - real(kind_phys), dimension(:,:), intent(out) :: sigmafrac - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - -! --- locals - integer :: i, k, kk - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (do_aw) then - do k=1,kmax - kk = min(k+1,kmax) ! assuming no cloud top reaches the model top - do i=1,im !DD - sigmafrac(i,k) = 0.5 * (sigmatot(i,k)+sigmatot(i,kk)) - enddo - enddo - endif - - return - end subroutine cs_conv_post_run - -end module cs_conv_post - module cs_conv !--------------------------------------------------------------------------------- ! Purpose: diff --git a/physics/cs_conv.meta b/physics/cs_conv.meta index 90a411031..fae1c91fe 100644 --- a/physics/cs_conv.meta +++ b/physics/cs_conv.meta @@ -1,216 +1,3 @@ -[ccpp-table-properties] - name = cs_conv_pre - type = scheme - dependencies = funcphys.f90,machine.F,physcons.F90 - -######################################################################## -[ccpp-arg-table] - name = cs_conv_pre_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal dimension - units = count - dimensions = () - type = integer - intent = in -[levs] - standard_name = vertical_layer_dimension - long_name = number of veritcal levels - units = count - dimensions = () - type = integer - intent = in -[ntrac] - standard_name = number_of_tracers - long_name = number of tracers - units = count - dimensions = () - type = integer - intent = in -[q] - standard_name = specific_humidity_of_new_state - long_name = water vapor specific humidity updated by physics - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[clw1] - standard_name = ice_water_mixing_ratio_convective_transport_tracer - long_name = ratio of mass of ice water to mass of dry air plus vapor (without condensates) in the convectively transported tracer array - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[clw2] - standard_name = cloud_condensed_water_mixing_ratio_convective_transport_tracer - long_name = ratio of mass of cloud water to mass of dry air plus vapor (without condensates) in the convectively transported tracer array - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[work1] - standard_name = grid_size_related_coefficient_used_in_scale_sensitive_schemes - long_name = grid size related coefficient used in scale-sensitive schemes - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[work2] - standard_name = grid_size_related_coefficient_used_in_scale_sensitive_schemes_complement - long_name = complement to work1 - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[cs_parm1] - standard_name = updraft_velocity_tunable_parameter_1_CS - long_name = tunable parameter 1 for Chikira-Sugiyama convection - units = m s-1 - dimensions = () - type = real - kind = kind_phys - intent = in -[cs_parm2] - standard_name = updraft_velocity_tunable_parameter_2_CS - long_name = tunable parameter 2 for Chikira-Sugiyama convection - units = m s-1 - dimensions = () - type = real - kind = kind_phys - intent = in -[wcbmax] - standard_name = maximum_updraft_velocity_at_cloud_base - long_name = maximum updraft velocity at cloud base - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[fswtr] - standard_name = fraction_of_cloud_top_water_scavenged - long_name = fraction of the tracer (cloud top water) that is scavenged by convection - units = km-1 - dimensions = (number_of_tracers_scavenged) - type = real - kind = kind_phys - intent = out -[fscav] - standard_name = fraction_of_tracer_scavenged - long_name = fraction of the tracer (aerosols) that is scavenged by convection - units = km-1 - dimensions = (number_of_tracers_scavenged) - type = real - kind = kind_phys - intent = out -[save_q1] - standard_name = water_vapor_specific_humidity_save - long_name = water vapor specific humidity before entering a physics scheme - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[save_q2] - standard_name = cloud_condensed_water_mixing_ratio_save - long_name = ratio of mass of cloud water to mass of dry air plus vapor (without condensates) before entering a physics scheme - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[save_q3] - standard_name = ice_water_mixing_ratio_save - long_name = cloud ice water mixing ratio before entering a physics scheme - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out - -######################################################################## -[ccpp-table-properties] - name = cs_conv_post - type = scheme - dependencies = funcphys.f90,machine.F,physcons.F90 - -######################################################################## -[ccpp-arg-table] - name = cs_conv_post_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal dimension - units = count - dimensions = () - type = integer - intent = in -[kmax] - standard_name = vertical_layer_dimension - long_name = number of veritcal levels - units = count - dimensions = () - type = integer - intent = in -[do_aw] - standard_name = flag_for_Arakawa_Wu_adjustment - long_name = flag for Arakawa Wu scale-aware adjustment - units = flag - dimensions = () - type = logical - intent = in -[sigmatot] - standard_name = convective_updraft_area_fraction_at_model_interfaces - long_name = convective updraft area fraction at model interfaces - units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[sigmafrac] - standard_name = convective_updraft_area_fraction - long_name = convective updraft area fraction - units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out - ######################################################################## [ccpp-table-properties] name = cs_conv diff --git a/physics/cs_conv_post.F90 b/physics/cs_conv_post.F90 new file mode 100644 index 000000000..403b4d204 --- /dev/null +++ b/physics/cs_conv_post.F90 @@ -0,0 +1,46 @@ +!> \file cs_conv_post.F90 +!! This file contains code to execute after the Chikira-Sugiyama Convection scheme. + +module cs_conv_post + contains + +!> \section arg_table_cs_conv_post_run Argument Table +!! \htmlinclude cs_conv_post_run.html +!! + subroutine cs_conv_post_run(im, kmax, do_aw, sigmatot, sigmafrac, errmsg, errflg) + + use machine , only : kind_phys + + implicit none + +! --- inputs + integer, intent(in) :: im, kmax + logical, intent(in) :: do_aw + real(kind_phys), dimension(:,:), intent(in) :: sigmatot + +! --- input/output + real(kind_phys), dimension(:,:), intent(out) :: sigmafrac + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + +! --- locals + integer :: i, k, kk + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (do_aw) then + do k=1,kmax + kk = min(k+1,kmax) ! assuming no cloud top reaches the model top + do i=1,im !DD + sigmafrac(i,k) = 0.5 * (sigmatot(i,k)+sigmatot(i,kk)) + enddo + enddo + endif + + return + end subroutine cs_conv_post_run + +end module cs_conv_post \ No newline at end of file diff --git a/physics/cs_conv_post.meta b/physics/cs_conv_post.meta new file mode 100644 index 000000000..116ffbef4 --- /dev/null +++ b/physics/cs_conv_post.meta @@ -0,0 +1,62 @@ +######################################################################## +[ccpp-table-properties] + name = cs_conv_post + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = cs_conv_post_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal dimension + units = count + dimensions = () + type = integer + intent = in +[kmax] + standard_name = vertical_layer_dimension + long_name = number of veritcal levels + units = count + dimensions = () + type = integer + intent = in +[do_aw] + standard_name = flag_for_Arakawa_Wu_adjustment + long_name = flag for Arakawa Wu scale-aware adjustment + units = flag + dimensions = () + type = logical + intent = in +[sigmatot] + standard_name = convective_updraft_area_fraction_at_model_interfaces + long_name = convective updraft area fraction at model interfaces + units = frac + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[sigmafrac] + standard_name = convective_updraft_area_fraction + long_name = convective updraft area fraction + units = frac + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out \ No newline at end of file diff --git a/physics/cs_conv_pre.F90 b/physics/cs_conv_pre.F90 new file mode 100644 index 000000000..8cc1020d4 --- /dev/null +++ b/physics/cs_conv_pre.F90 @@ -0,0 +1,64 @@ +!> \file cs_conv_pre.F90 +!! This file contains preparation for the Chikira-Sugiyama Convection scheme. + +module cs_conv_pre + contains + +!! \section arg_table_cs_conv_pre_run Argument Table +!! \htmlinclude cs_conv_pre_run.html +!! + subroutine cs_conv_pre_run(im, levs, ntrac, q, clw1, clw2, & + & work1, work2, cs_parm1, cs_parm2, wcbmax, & + & fswtr, fscav, save_q1, save_q2, save_q3, & + & errmsg, errflg) + + + use machine , only : kind_phys + + implicit none + +! --- inputs + integer, intent(in) :: im, levs, ntrac + real(kind_phys), dimension(:,:), intent(in) :: q + real(kind_phys), dimension(:,:), intent(in) :: clw1,clw2 + real(kind_phys), dimension(:), intent(in) :: work1, work2 + real(kind_phys), intent(in) :: cs_parm1, cs_parm2 + +! --- input/output + real(kind_phys), dimension(:), intent(out) :: fswtr, fscav + real(kind_phys), dimension(:), intent(out) :: wcbmax + real(kind_phys), dimension(:,:), intent(out) :: save_q1,save_q2 + ! save_q3 is not allocated for Zhao-Carr MP + real(kind_phys), dimension(:,:), intent(out) :: save_q3 + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + +! --- locals + integer :: i, k + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + do i =1,im + wcbmax(i) = cs_parm1 * work1(i) + cs_parm2 * work2(i) + enddo + + fswtr(:) = 0.0 + fscav(:) = 0.0 + do k=1,levs + do i=1,im + ! DH* note - save_q1 assignment may be redundant, + ! because already done in GFS_DCNV_generic_pre? + ! Keep for using cs_conv w/o GFS_DCNV_generic_pre? + save_q1(i,k) = q(i,k) + save_q2(i,k) = max(0.0,clw2(i,k)) + save_q3(i,k) = max(0.0,clw1(i,k)) + enddo + enddo + + return + end subroutine cs_conv_pre_run + +end module cs_conv_pre \ No newline at end of file diff --git a/physics/cs_conv_pre.meta b/physics/cs_conv_pre.meta new file mode 100644 index 000000000..2decd5f8b --- /dev/null +++ b/physics/cs_conv_pre.meta @@ -0,0 +1,149 @@ +[ccpp-table-properties] + name = cs_conv_pre + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = cs_conv_pre_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal dimension + units = count + dimensions = () + type = integer + intent = in +[levs] + standard_name = vertical_layer_dimension + long_name = number of veritcal levels + units = count + dimensions = () + type = integer + intent = in +[ntrac] + standard_name = number_of_tracers + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = in +[q] + standard_name = specific_humidity_of_new_state + long_name = water vapor specific humidity updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[clw1] + standard_name = ice_water_mixing_ratio_convective_transport_tracer + long_name = ratio of mass of ice water to mass of dry air plus vapor (without condensates) in the convectively transported tracer array + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[clw2] + standard_name = cloud_condensed_water_mixing_ratio_convective_transport_tracer + long_name = ratio of mass of cloud water to mass of dry air plus vapor (without condensates) in the convectively transported tracer array + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[work1] + standard_name = grid_size_related_coefficient_used_in_scale_sensitive_schemes + long_name = grid size related coefficient used in scale-sensitive schemes + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[work2] + standard_name = grid_size_related_coefficient_used_in_scale_sensitive_schemes_complement + long_name = complement to work1 + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[cs_parm1] + standard_name = updraft_velocity_tunable_parameter_1_CS + long_name = tunable parameter 1 for Chikira-Sugiyama convection + units = m s-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[cs_parm2] + standard_name = updraft_velocity_tunable_parameter_2_CS + long_name = tunable parameter 2 for Chikira-Sugiyama convection + units = m s-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[wcbmax] + standard_name = maximum_updraft_velocity_at_cloud_base + long_name = maximum updraft velocity at cloud base + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[fswtr] + standard_name = fraction_of_cloud_top_water_scavenged + long_name = fraction of the tracer (cloud top water) that is scavenged by convection + units = km-1 + dimensions = (number_of_tracers_scavenged) + type = real + kind = kind_phys + intent = out +[fscav] + standard_name = fraction_of_tracer_scavenged + long_name = fraction of the tracer (aerosols) that is scavenged by convection + units = km-1 + dimensions = (number_of_tracers_scavenged) + type = real + kind = kind_phys + intent = out +[save_q1] + standard_name = water_vapor_specific_humidity_save + long_name = water vapor specific humidity before entering a physics scheme + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[save_q2] + standard_name = cloud_condensed_water_mixing_ratio_save + long_name = ratio of mass of cloud water to mass of dry air plus vapor (without condensates) before entering a physics scheme + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[save_q3] + standard_name = ice_water_mixing_ratio_save + long_name = cloud ice water mixing ratio before entering a physics scheme + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out \ No newline at end of file diff --git a/physics/cu_gf_deep.F90 b/physics/cu_gf_deep.F90 index f59a985cd..0702009dc 100644 --- a/physics/cu_gf_deep.F90 +++ b/physics/cu_gf_deep.F90 @@ -27,7 +27,7 @@ module cu_gf_deep !> flag to turn off or modify mom transport by downdrafts real(kind=kind_phys), parameter :: pgcd = 0.1 ! -!> aerosol awareness, do not user yet! +!> aerosol awareness, do not use yet! integer, parameter :: autoconv=2 integer, parameter :: aeroevap=3 real(kind=kind_phys), parameter :: scav_factor = 0.5 @@ -47,11 +47,11 @@ module cu_gf_deep contains - integer function my_maxloc1d(A,N,dir) + integer function my_maxloc1d(A,N) !$acc routine vector implicit none real(kind_phys), intent(in) :: A(:) - integer, intent(in) :: N,dir + integer, intent(in) :: N real(kind_phys) :: imaxval integer :: i @@ -71,7 +71,7 @@ end function my_maxloc1d !>\ingroup cu_gf_deep_group !> \section general_gf_deep GF Deep Convection General Algorithm !> @{ - subroutine cu_gf_deep_run( & + subroutine cu_gf_deep_run( & itf,ktf,its,ite, kts,kte & ,dicycle & ! diurnal cycle flag ,ichoice & ! choice of closure, use "0" for ensemble average @@ -337,7 +337,7 @@ subroutine cu_gf_deep_run( & real(kind=kind_phys), dimension (its:ite) :: & axx,edtmax,edtmin,entr_rate integer, dimension (its:ite) :: & - kzdown,kdet,k22,jmin,kstabi,kstabm,k22x,xland1, & + kzdown,kdet,k22,jmin,kstabi,kstabm,k22x,xland1, & ktopdby,kbconx,ierr2,ierr3,kbmax !$acc declare create(edt,edto,edtm,aa1,aa0,xaa0,hkb, & !$acc hkbo,xhkb, & @@ -345,7 +345,7 @@ subroutine cu_gf_deep_run( & !$acc pwevo,bu,bud,cap_max, & !$acc cap_max_increment,closure_n,psum,psumh,sig,sigd, & !$acc axx,edtmax,edtmin,entr_rate, & -!$acc kzdown,kdet,k22,jmin,kstabi,kstabm,k22x,xland1, & +!$acc kzdown,kdet,k22,jmin,kstabi,kstabm,k22x,xland1, & !$acc ktopdby,kbconx,ierr2,ierr3,kbmax) integer, dimension (its:ite), intent(inout) :: ierr @@ -353,11 +353,12 @@ subroutine cu_gf_deep_run( & !$acc declare copy(ierr) copyin(csum) integer :: & iloop,nens3,ki,kk,i,k - real(kind=kind_phys) :: & - dz,dzo,mbdt,radius,pefc, & + real(kind=kind_phys) :: & + dz,dzo,mbdt,radius, & zcutdown,depth_min,zkbmax,z_detr,zktop, & dh,cap_maxs,trash,trash2,frh,sig_thresh - real(kind=kind_phys) entdo,dp,subin,detdo,entup, & + real(kind=kind_phys), dimension (its:ite) :: pefc + real(kind=kind_phys) entdo,dp,subin,detdo,entup, & detup,subdown,entdoj,entupk,detupk,totmas real(kind=kind_phys), dimension (its:ite) :: lambau,flux_tun,zws,ztexec,zqexec @@ -2269,7 +2270,7 @@ subroutine cu_gf_deep_run( & if(ierr(i).eq.0) then if(aeroevap.gt.1)then ! aerosol scavagening - ccnloss(i)=ccn(i)*pefc*xmb(i) ! HCB + ccnloss(i)=ccn(i)*pefc(i)*xmb(i) ! HCB ccn(i) = ccn(i) - ccnloss(i)*scav_factor endif endif @@ -2605,7 +2606,8 @@ subroutine cup_dd_edt(ierr,us,vs,z,ktop,kbcon,edt,p,pwav, & real(kind=kind_phys), dimension (its:ite,1) & ,intent (out ) :: & edtc - real(kind=kind_phys), intent (out ) :: & + real(kind=kind_phys), dimension (its:ite) & + ,intent(out) :: & pefc real(kind=kind_phys), dimension (its:ite) & ,intent (out ) :: & @@ -2639,7 +2641,7 @@ subroutine cup_dd_edt(ierr,us,vs,z,ktop,kbcon,edt,p,pwav, & prop_c=0. !10.386 alpha3 = 0.75 beta3 = -0.15 - pefc=0. + pefc(:)=0. pefb=0. pef=0. @@ -2702,12 +2704,12 @@ subroutine cup_dd_edt(ierr,us,vs,z,ktop,kbcon,edt,p,pwav, & prop_c=.5*(pefb+pef)/aeroadd aeroadd=((1.e-2*ccn(i))**beta3)*(psum2(i)**(alpha3-1)) aeroadd=prop_c*aeroadd - pefc=aeroadd + pefc(i)=aeroadd - if(pefc.gt.0.9)pefc=0.9 - if(pefc.lt.0.1)pefc=0.1 - edt(i)=1.-pefc - if(aeroevap.eq.2)edt(i)=1.-.25*(pefb+pef+2.*pefc) + if(pefc(i).gt.0.9)pefc(i)=0.9 + if(pefc(i).lt.0.1)pefc(i)=0.1 + edt(i)=1.-pefc(i) + if(aeroevap.eq.2)edt(i)=1.-.25*(pefb+pef+2.*pefc(i)) endif endif @@ -4905,7 +4907,7 @@ subroutine get_zu_zd_pdf_fim(kklev,p,rand_vmas,zubeg,ipr,xland,zuh2,draft,ierr,k if(zu(kpbli).gt.0.) & zu(kts:min(ktf,kt-1))= zu(kts:min(ktf,kt-1))/zu(kpbli) - do k=my_maxloc1d(zu(:),kte,1),1,-1 + do k=my_maxloc1d(zu(:),kte),1,-1 if(zu(k).lt.1.e-6)then kb_adj=k+1 exit @@ -4964,7 +4966,7 @@ subroutine get_zu_zd_pdf_fim(kklev,p,rand_vmas,zubeg,ipr,xland,zuh2,draft,ierr,k ! zu(kts:min(ktf,kt+1))= zu(kts:min(ktf,kt+1))/maxval(zu(kts:min(ktf,kt+1))) if(zu(kpbli).gt.0.) & zu(kts:min(ktf,kt-1))= zu(kts:min(ktf,kt-1))/zu(kpbli) - do k=my_maxloc1d(zu(:),kte,1),1,-1 + do k=my_maxloc1d(zu(:),kte),1,-1 if(zu(k).lt.1.e-6)then kb_adj=k+1 exit @@ -5013,7 +5015,7 @@ subroutine get_zu_zd_pdf_fim(kklev,p,rand_vmas,zubeg,ipr,xland,zuh2,draft,ierr,k if(zu(kpbli).gt.0.) & zu(kts:min(ktf,kt-1))= zu(kts:min(ktf,kt-1))/zu(kpbli) - do k=my_maxloc1d(zu(:),kte,1),1,-1 + do k=my_maxloc1d(zu(:),kte),1,-1 if(zu(k).lt.1.e-6)then kb_adj=k+1 exit @@ -5254,91 +5256,93 @@ subroutine get_inversion_layers(ierr,p_cup,t_cup,z_cup,qo_cup,qeso_cup,k_inv_lay !$acc end parallel end subroutine get_inversion_layers -!----------------------------------------------------------------------------------- -!>\ingroup cu_gf_deep_group -!> This function calcualtes - function deriv3(xx, xi, yi, ni, m) -!$acc routine vector - !============================================================================*/ - ! evaluate first- or second-order derivatives - ! using three-point lagrange interpolation - ! written by: alex godunov (october 2009) - ! input ... - ! xx - the abscissa at which the interpolation is to be evaluated - ! xi() - the arrays of data abscissas - ! yi() - the arrays of data ordinates - ! ni - size of the arrays xi() and yi() - ! m - order of a derivative (1 or 2) - ! output ... - ! deriv3 - interpolated value - !============================================================================*/ - - implicit none - integer, parameter :: n=3 - integer ni, m,i, j, k, ix - real(kind=kind_phys):: deriv3, xx - real(kind=kind_phys):: xi(ni), yi(ni), x(n), f(n) - - ! exit if too high-order derivative was needed, - if (m > 2) then - deriv3 = 0.0 - return - end if - - ! if x is ouside the xi(1)-xi(ni) interval set deriv3=0.0 - if (xx < xi(1) .or. xx > xi(ni)) then - deriv3 = 0.0 -#ifndef _OPENACC - stop "problems with finding the 2nd derivative" -#else - return -#endif - end if - - ! a binary (bisectional) search to find i so that xi(i-1) < x < xi(i) - i = 1 - j = ni - do while (j > i+1) - k = (i+j)/2 - if (xx < xi(k)) then - j = k - else - i = k - end if - end do - - ! shift i that will correspond to n-th order of interpolation - ! the search point will be in the middle in x_i, x_i+1, x_i+2 ... - i = i + 1 - n/2 - - ! check boundaries: if i is ouside of the range [1, ... n] -> shift i - if (i < 1) i=1 - if (i + n > ni) i=ni-n+1 - - ! old output to test i - ! write(*,100) xx, i - ! 100 format (f10.5, i5) - - ! just wanted to use index i - ix = i - ! initialization of f(n) and x(n) - do i=1,n - f(i) = yi(ix+i-1) - x(i) = xi(ix+i-1) - end do - - ! calculate the first-order derivative using lagrange interpolation - if (m == 1) then - deriv3 = (2.0*xx - (x(2)+x(3)))*f(1)/((x(1)-x(2))*(x(1)-x(3))) - deriv3 = deriv3 + (2.0*xx - (x(1)+x(3)))*f(2)/((x(2)-x(1))*(x(2)-x(3))) - deriv3 = deriv3 + (2.0*xx - (x(1)+x(2)))*f(3)/((x(3)-x(1))*(x(3)-x(2))) - ! calculate the second-order derivative using lagrange interpolation - else - deriv3 = 2.0*f(1)/((x(1)-x(2))*(x(1)-x(3))) - deriv3 = deriv3 + 2.0*f(2)/((x(2)-x(1))*(x(2)-x(3))) - deriv3 = deriv3 + 2.0*f(3)/((x(3)-x(1))*(x(3)-x(2))) - end if - end function deriv3 +! DH* 20220604 - this isn't used at all +!!!!----------------------------------------------------------------------------------- +!!!!>\ingroup cu_gf_deep_group +!!!!> This function calcualtes +!!! function deriv3(xx, xi, yi, ni, m) +!!!!$acc routine vector +!!! !============================================================================*/ +!!! ! evaluate first- or second-order derivatives +!!! ! using three-point lagrange interpolation +!!! ! written by: alex godunov (october 2009) +!!! ! input ... +!!! ! xx - the abscissa at which the interpolation is to be evaluated +!!! ! xi() - the arrays of data abscissas +!!! ! yi() - the arrays of data ordinates +!!! ! ni - size of the arrays xi() and yi() +!!! ! m - order of a derivative (1 or 2) +!!! ! output ... +!!! ! deriv3 - interpolated value +!!! !============================================================================*/ +!!! +!!! implicit none +!!! integer, parameter :: n=3 +!!! integer ni, m,i, j, k, ix +!!! real(kind=kind_phys):: deriv3, xx +!!! real(kind=kind_phys):: xi(ni), yi(ni), x(n), f(n) +!!! +!!! ! exit if too high-order derivative was needed, +!!! if (m > 2) then +!!! deriv3 = 0.0 +!!! return +!!! end if +!!! +!!! ! if x is ouside the xi(1)-xi(ni) interval set deriv3=0.0 +!!! if (xx < xi(1) .or. xx > xi(ni)) then +!!! deriv3 = 0.0 +!!!#ifndef _OPENACC +!!! stop "problems with finding the 2nd derivative" +!!!#else +!!! return +!!!#endif +!!! end if +!!! +!!! ! a binary (bisectional) search to find i so that xi(i-1) < x < xi(i) +!!! i = 1 +!!! j = ni +!!! do while (j > i+1) +!!! k = (i+j)/2 +!!! if (xx < xi(k)) then +!!! j = k +!!! else +!!! i = k +!!! end if +!!! end do +!!! +!!! ! shift i that will correspond to n-th order of interpolation +!!! ! the search point will be in the middle in x_i, x_i+1, x_i+2 ... +!!! i = i + 1 - n/2 +!!! +!!! ! check boundaries: if i is ouside of the range [1, ... n] -> shift i +!!! if (i < 1) i=1 +!!! if (i + n > ni) i=ni-n+1 +!!! +!!! ! old output to test i +!!! ! write(*,100) xx, i +!!! ! 100 format (f10.5, i5) +!!! +!!! ! just wanted to use index i +!!! ix = i +!!! ! initialization of f(n) and x(n) +!!! do i=1,n +!!! f(i) = yi(ix+i-1) +!!! x(i) = xi(ix+i-1) +!!! end do +!!! +!!! ! calculate the first-order derivative using lagrange interpolation +!!! if (m == 1) then +!!! deriv3 = (2.0*xx - (x(2)+x(3)))*f(1)/((x(1)-x(2))*(x(1)-x(3))) +!!! deriv3 = deriv3 + (2.0*xx - (x(1)+x(3)))*f(2)/((x(2)-x(1))*(x(2)-x(3))) +!!! deriv3 = deriv3 + (2.0*xx - (x(1)+x(2)))*f(3)/((x(3)-x(1))*(x(3)-x(2))) +!!! ! calculate the second-order derivative using lagrange interpolation +!!! else +!!! deriv3 = 2.0*f(1)/((x(1)-x(2))*(x(1)-x(3))) +!!! deriv3 = deriv3 + 2.0*f(2)/((x(2)-x(1))*(x(2)-x(3))) +!!! deriv3 = deriv3 + 2.0*f(3)/((x(3)-x(1))*(x(3)-x(2))) +!!! end if +!!! end function deriv3 +! *DH 20220604 !============================================================================================= !>\ingroup cu_gf_deep_group subroutine get_lateral_massflux(itf,ktf, its,ite, kts,kte & diff --git a/physics/cu_gf_driver.F90 b/physics/cu_gf_driver.F90 index 79bede1a3..8f2c82052 100644 --- a/physics/cu_gf_driver.F90 +++ b/physics/cu_gf_driver.F90 @@ -7,7 +7,7 @@ module cu_gf_driver ! DH* TODO: replace constants with arguments to cu_gf_driver_run !use physcons , g => con_g, cp => con_cp, xlv => con_hvap, r_v => con_rv use machine , only: kind_phys - use cu_gf_deep, only: cu_gf_deep_run,neg_check,autoconv,aeroevap,fct1d3 + use cu_gf_deep, only: cu_gf_deep_run,neg_check,fct1d3 use cu_gf_sh , only: cu_gf_sh_run implicit none @@ -39,26 +39,6 @@ subroutine cu_gf_driver_init(imfshalcnv, imfshalcnv_gf, imfdeepcnv, & errmsg = '' errflg = 0 - ! DH* temporary - ! if (mpirank==mpiroot) then - ! write(0,*) ' ----------------------------------------------------------'//& - ! '-------------------------------------------------------------------' - ! write(0,*) ' --- WARNING --- the CCPP Grell Freitas convection scheme is'//& - ! ' currently under development, use at your own risk --- WARNING ---' - ! write(0,*) ' --------------------------------------------------------------------'//& - ! '---------------------------------------------------------' - ! end if - ! *DH temporary - - ! ! Consistency checks - ! if (.not. (imfshalcnv == imfshalcnv_gf .or. & - ! & imfdeepcnv == imfdeepcnv_gf)) then - ! write(errmsg,'(*(a))') 'Logic error: namelist choice of', & - ! & ' convection is different from Grell-Freitas scheme' - ! errflg = 1 - ! return - ! end if - end subroutine cu_gf_driver_init subroutine cu_gf_driver_finalize() diff --git a/physics/dcyc2.f b/physics/dcyc2t3.f similarity index 99% rename from physics/dcyc2.f rename to physics/dcyc2t3.f index 780d72efb..21ab5da2a 100644 --- a/physics/dcyc2.f +++ b/physics/dcyc2t3.f @@ -1,4 +1,4 @@ -!>\file dcyc2.f +!>\file dcyc2t3.f !! This file contains the CCPP-compliant dcyc2t3 codes that fits !! radiative fluxes and heating rates from a coarse radiation !! calculation time interval into model's more frequent time steps. diff --git a/physics/dcyc2.meta b/physics/dcyc2t3.meta similarity index 100% rename from physics/dcyc2.meta rename to physics/dcyc2t3.meta 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/drag_suite.F90 b/physics/drag_suite.F90 index fe9095210..09ee621bd 100644 --- a/physics/drag_suite.F90 +++ b/physics/drag_suite.F90 @@ -531,7 +531,8 @@ subroutine drag_suite_run( & ! non-dim sub grid mtn drag Amp (*j*) ! cdmb = 1.0/float(IMX/192) ! cdmb = 192.0/float(IMX) - cdmb = 4.0 * 192.0/float(IMX) + ! New cdmbgwd addition for GSL blocking drag + cdmb = 1.0 if (cdmbgwd(1) >= 0.0) cdmb = cdmb * cdmbgwd(1) !>-# Orographic Gravity Wave Drag Section @@ -1225,7 +1226,8 @@ subroutine drag_suite_run( & !--------- compute flow-blocking stress ! cd = max(2.0-1.0/od(i),0.0) - taufb(i,kts) = 0.5 * roll(i) * coefm(i) / & + ! New cdmbgwd addition for GSL blocking drag + taufb(i,kts) = cdmb * 0.5 * roll(i) * coefm(i) / & max(dxmax_ls,dxy(i))**2 * cd * dxyp(i) * & olp(i) * zblk * ulow(i)**2 tautem = taufb(i,kts)/float(kblk-kts) diff --git a/physics/gfdl_fv_sat_adj.F90 b/physics/fv_sat_adj.F90 similarity index 99% rename from physics/gfdl_fv_sat_adj.F90 rename to physics/fv_sat_adj.F90 index 816488f7a..53543485b 100644 --- a/physics/gfdl_fv_sat_adj.F90 +++ b/physics/fv_sat_adj.F90 @@ -1,4 +1,4 @@ -!>\file gfdl_fv_sat_adj.F90 +!>\file fv_sat_adj.F90 !! This file contains the GFDL in-core fast saturation adjustment. !! and it is an "intermediate physics" implemented in the remapping Lagrangian to !! Eulerian loop of FV3 solver. diff --git a/physics/gfdl_fv_sat_adj.meta b/physics/fv_sat_adj.meta similarity index 100% rename from physics/gfdl_fv_sat_adj.meta rename to physics/fv_sat_adj.meta diff --git a/physics/get_phi_fv3.F90 b/physics/get_phi_fv3.F90 new file mode 100644 index 000000000..d111d3ae0 --- /dev/null +++ b/physics/get_phi_fv3.F90 @@ -0,0 +1,59 @@ +!>\file get_phi_fv3.F90 +!! This file contains a subroutine to calculate geopotential from within physics. + +module get_phi_fv3 + + use machine, only: kind_phys + use physcons, only: con_fvirt + +!--- public declarations + public get_phi_fv3_run + +!--- local variables + real(kind=kind_phys), parameter :: zero = 0.0_kind_phys + real(kind=kind_phys), parameter :: half = 0.5_kind_phys + real(kind=kind_phys), parameter :: one = 1.0_kind_phys + +contains + +!! \section arg_table_get_phi_fv3_run Argument Table +!! \htmlinclude get_phi_fv3_run.html +!! + subroutine get_phi_fv3_run(ix, levs, con_fvirt, gt0, gq01, del_gz, phii, phil, errmsg, errflg) + + implicit none + + ! Interface variables + integer, intent(in) :: ix, levs + real(kind=kind_phys), intent(in) :: con_fvirt + real(kind=kind_phys), dimension(:,:), intent(in) :: gt0 + real(kind=kind_phys), dimension(:,:), intent(in) :: gq01 + real(kind=kind_phys), dimension(:,:), intent(inout) :: del_gz + real(kind=kind_phys), dimension(:,:), intent(out) :: phii + real(kind=kind_phys), dimension(:,:), intent(out) :: phil + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Local variables + integer :: i, k + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + +! SJL: Adjust the height hydrostatically in a way consistent with FV3 discretization + do i=1,ix + phii(i,1) = zero + enddo + do k=1,levs + do i=1,ix + del_gz(i,k) = del_gz(i,k)*gt0(i,k) * & + & (one + con_fvirt*max(zero,gq01(i,k))) + phii(i,k+1) = phii(i,k) + del_gz(i,k) + phil(i,k) = half*(phii(i,k) + phii(i,k+1)) + enddo + enddo + + end subroutine get_phi_fv3_run + +end module get_phi_fv3 \ No newline at end of file diff --git a/physics/get_phi_fv3.meta b/physics/get_phi_fv3.meta new file mode 100644 index 000000000..cbca14080 --- /dev/null +++ b/physics/get_phi_fv3.meta @@ -0,0 +1,87 @@ +######################################################################## +[ccpp-table-properties] + name = get_phi_fv3 + type = scheme + dependencies = machine.F,physcons.F90 + +######################################################################## +[ccpp-arg-table] + name = get_phi_fv3_run + type = scheme +[ix] + standard_name = horizontal_loop_extent + long_name = horizontal dimension + units = count + dimensions = () + type = integer + intent = in +[levs] + standard_name = vertical_layer_dimension + long_name = number of vertical layers + units = count + dimensions = () + type = integer + intent = in +[con_fvirt] + standard_name = ratio_of_vapor_to_dry_air_gas_constants_minus_one + long_name = rv/rd - 1 (rv = ideal gas constant for water vapor) + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[gt0] + standard_name = air_temperature_of_new_state + long_name = updated air temperature + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[gq01] + standard_name = specific_humidity_of_new_state + long_name = mid-layer specific humidity of water vapor + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[del_gz] + standard_name = geopotential_difference_between_midlayers_divided_by_midlayer_virtual_temperature + long_name = difference between mid-layer geopotentials divided by mid-layer virtual temperature + units = m2 s-2 K-1 + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = inout +[phii] + standard_name = geopotential_at_interface + long_name = interface geopotential + units = m2 s-2 + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = out +[phil] + standard_name = geopotential + long_name = mid-layer geopotential + units = m2 s-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out \ No newline at end of file diff --git a/physics/get_prs_fv3.F90 b/physics/get_prs_fv3.F90 index 35bdc35ca..0234f26c9 100644 --- a/physics/get_prs_fv3.F90 +++ b/physics/get_prs_fv3.F90 @@ -1,10 +1,13 @@ +!>\file get_prs_fv3.F90 +!! This file contains a subroutine to "adjust the geopotential height hydrostatically in a way consistent with FV3 discretization," +!! according to SJ Lin. + module get_prs_fv3 use machine, only: kind_phys -! use physcons, only: con_fvirt !--- public declarations - public get_prs_fv3_init, get_prs_fv3_run, get_prs_fv3_finalize + public get_prs_fv3_run !--- local variables real(kind=kind_phys), parameter :: zero = 0.0_kind_phys @@ -12,9 +15,6 @@ module get_prs_fv3 contains - subroutine get_prs_fv3_init() - end subroutine get_prs_fv3_init - !! \section arg_table_get_prs_fv3_run Argument Table !! \htmlinclude get_prs_fv3_run.html !! @@ -53,73 +53,4 @@ subroutine get_prs_fv3_run(ix, levs, con_fvirt, phii, prsi, tgrs, qgrs1, del, de end subroutine get_prs_fv3_run - subroutine get_prs_fv3_finalize() - end subroutine get_prs_fv3_finalize - -end module get_prs_fv3 - - -module get_phi_fv3 - - use machine, only: kind_phys - use physcons, only: con_fvirt - -!--- public declarations - public get_phi_fv3_init, get_phi_fv3_run, get_phi_fv3_finalize - -!--- local variables - real(kind=kind_phys), parameter :: zero = 0.0_kind_phys - real(kind=kind_phys), parameter :: half = 0.5_kind_phys - real(kind=kind_phys), parameter :: one = 1.0_kind_phys - -contains - - subroutine get_phi_fv3_init() - end subroutine get_phi_fv3_init - -!! \section arg_table_get_phi_fv3_run Argument Table -!! \htmlinclude get_phi_fv3_run.html -!! - subroutine get_phi_fv3_run(ix, levs, con_fvirt, gt0, gq01, del_gz, phii, phil, errmsg, errflg) - - implicit none - - ! Interface variables - integer, intent(in) :: ix, levs - real(kind=kind_phys), intent(in) :: con_fvirt - real(kind=kind_phys), dimension(:,:), intent(in) :: gt0 - real(kind=kind_phys), dimension(:,:), intent(in) :: gq01 - real(kind=kind_phys), dimension(:,:), intent(inout) :: del_gz - real(kind=kind_phys), dimension(:,:), intent(out) :: phii - real(kind=kind_phys), dimension(:,:), intent(out) :: phil - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Local variables - integer :: i, k - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - -! SJL: Adjust the height hydrostatically in a way consistent with FV3 discretization - do i=1,ix - phii(i,1) = zero - enddo - do k=1,levs - do i=1,ix - del_gz(i,k) = del_gz(i,k)*gt0(i,k) * & - & (one + con_fvirt*max(zero,gq01(i,k))) - phii(i,k+1) = phii(i,k) + del_gz(i,k) - phil(i,k) = half*(phii(i,k) + phii(i,k+1)) - enddo - enddo - - end subroutine get_phi_fv3_run - - subroutine get_phi_fv3_finalize() - end subroutine get_phi_fv3_finalize - -end module get_phi_fv3 - - +end module get_prs_fv3 \ No newline at end of file diff --git a/physics/get_prs_fv3.meta b/physics/get_prs_fv3.meta index 4e893b45c..c26f5c308 100644 --- a/physics/get_prs_fv3.meta +++ b/physics/get_prs_fv3.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = get_prs_fv3 type = scheme - dependencies = machine.F,physcons.F90 + dependencies = machine.F ######################################################################## [ccpp-arg-table] @@ -91,93 +91,4 @@ units = 1 dimensions = () type = integer - intent = out - -######################################################################## -[ccpp-table-properties] - name = get_phi_fv3 - type = scheme - dependencies = machine.F,physcons.F90 - -######################################################################## -[ccpp-arg-table] - name = get_phi_fv3_run - type = scheme -[ix] - standard_name = horizontal_loop_extent - long_name = horizontal dimension - units = count - dimensions = () - type = integer - intent = in -[levs] - standard_name = vertical_layer_dimension - long_name = number of vertical layers - units = count - dimensions = () - type = integer - intent = in -[con_fvirt] - standard_name = ratio_of_vapor_to_dry_air_gas_constants_minus_one - long_name = rv/rd - 1 (rv = ideal gas constant for water vapor) - units = none - dimensions = () - type = real - kind = kind_phys - intent = in -[gt0] - standard_name = air_temperature_of_new_state - long_name = updated air temperature - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[gq01] - standard_name = specific_humidity_of_new_state - long_name = mid-layer specific humidity of water vapor - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[del_gz] - standard_name = geopotential_difference_between_midlayers_divided_by_midlayer_virtual_temperature - long_name = difference between mid-layer geopotentials divided by mid-layer virtual temperature - units = m2 s-2 K-1 - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = inout -[phii] - standard_name = geopotential_at_interface - long_name = interface geopotential - units = m2 s-2 - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = out -[phil] - standard_name = geopotential - long_name = mid-layer geopotential - units = m2 s-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out - + intent = out \ No newline at end of file diff --git a/physics/gwdc.f b/physics/gwdc.f index 086662e73..8ece20aea 100644 --- a/physics/gwdc.f +++ b/physics/gwdc.f @@ -2,83 +2,6 @@ !! stationary convection forced gravity wave drag based on !! Chun and Baik (1998) \cite chun_and_baik_1998. -!> This module contains the CCPP-compliant convective gravity -!! wave drag pre interstitial codes. - module gwdc_pre - contains - - subroutine gwdc_pre_init() - end subroutine gwdc_pre_init - -! \brief Brief description of the subroutine -!! -!! \section arg_table_gwdc_pre_run Argument Table -!! \htmlinclude gwdc_pre_run.html -!! - subroutine gwdc_pre_run ( & - & im, cgwf, dx, work1, work2, dlength, cldf, & - & levs, kbot, ktop, dtp, gt0, gt0_init, del, cumabs, & - & errmsg, errflg ) - - use machine, only : kind_phys - implicit none - - integer, intent(in) :: im, levs - integer, intent(in) :: kbot(:), ktop(:) - real(kind=kind_phys), intent(in) :: dtp - real(kind=kind_phys), intent(in) :: cgwf(:) - real(kind=kind_phys), intent(in) :: dx(:), work1(:), work2(:) - real(kind=kind_phys), intent(in) :: & - & gt0(:,:), gt0_init(:,:), del(:,:) - - real(kind=kind_phys), intent(out) :: & - & dlength(:), cldf(:), cumabs(:) - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - integer :: i, k - real(kind=kind_phys) :: tem1, tem2 - real(kind=kind_phys) :: work3(im) - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - do i = 1, im - tem1 = dx(i) - tem2 = tem1 - dlength(i) = sqrt( tem1*tem1+tem2*tem2 ) - cldf(i) = cgwf(1)*work1(i) + cgwf(2)*work2(i) - enddo - -! --- ... calculate maximum convective heating rate -! cuhr = temperature change due to deep convection - - cumabs(:) = 0.0 - work3(:) = 0.0 - do k = 1, levs - do i = 1, im - if (k >= kbot(i) .and. k <= ktop(i)) then - cumabs(i) & - & = cumabs(i) + (gt0(i,k) - gt0_init(i,k)) * del(i,k) - work3(i) = work3(i) + del(i,k) - endif - enddo - enddo - do i=1,im - if (work3(i) > 0.0) cumabs(i) = cumabs(i) / (dtp*work3(i)) - enddo - - end subroutine gwdc_pre_run - - subroutine gwdc_pre_finalize () - end subroutine gwdc_pre_finalize - - end module gwdc_pre - -!> This module contains the CCPP-compliant -!! convective gravity wave drag scheme. module gwdc contains @@ -1437,97 +1360,4 @@ subroutine gwdc_run (im,km,lat,u1,v1,t1,q1,deltim, & end subroutine gwdc_run !> @} - subroutine gwdc_finalize() - end subroutine gwdc_finalize - - end module gwdc - -!> This module contains the CCPP-compliant convective gravity wave -!! drag post intersititial codes. - module gwdc_post - - contains - - subroutine gwdc_post_init() - end subroutine gwdc_post_init - -! \brief Brief description of the subroutine -!! -!> \section arg_table_gwdc_post_run Argument Table -!! \htmlinclude gwdc_post_run.html -!! - subroutine gwdc_post_run( & - & im, levs, lssav, ldiag3d, dtf, dtp, con_cp, & - & tauctx, taucty, gwdcu, gwdcv, & - & dugwd, dvgwd, dtend, dtidx, index_of_x_wind, index_of_y_wind, & - & index_of_process_nonorographic_gwd, gu0, gv0, gt0, & - & errmsg, errflg) - - use machine, only : kind_phys - implicit none - - integer, intent(in) :: im, levs - logical, intent(in) :: lssav, ldiag3d - real(kind=kind_phys), intent(in) :: dtf, dtp, con_cp - real(kind=kind_phys), intent(in) :: & - & tauctx(:), taucty(:), gwdcu(:,:), gwdcv(:,:) - - real(kind=kind_phys), intent(inout) :: dugwd(:), dvgwd(:), & - & gu0(:,:), gv0(:,:), gt0(:,:) - real(kind=kind_phys), intent(inout), optional :: dtend(:,:,:) - integer, intent(in) :: dtidx(:,:) - integer, intent(in) :: index_of_process_nonorographic_gwd - integer, intent(in) :: index_of_x_wind, index_of_y_wind - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - integer :: i, k, idtend - real(kind=kind_phys) :: eng0, eng1 - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - -! --- ... write out cloud top stress and wind tendencies - - if (lssav) then - dugwd(:) = dugwd(:) + tauctx(:)*dtf - dvgwd(:) = dvgwd(:) + taucty(:)*dtf - endif ! end if_lssav - - if (ldiag3d) then - idtend = dtidx(index_of_x_wind,index_of_process_nonorographic_g& - & wd) - if(idtend>=1) then - dtend(:,:,idtend) = dtend(:,:,idtend) + gwdcu(:,:) * dtf - endif - idtend = dtidx(index_of_y_wind,index_of_process_nonorographic_g& - & wd) - if(idtend>=1) then - dtend(:,:,idtend) = dtend(:,:,idtend) + gwdcv(:,:) * dtf - endif - endif - -! --- ... update the wind components with gwdc tendencies - - do k = 1, levs - do i = 1, im - eng0 = 0.5*(gu0(i,k)*gu0(i,k) + gv0(i,k)*gv0(i,k)) - gu0(i,k) = gu0(i,k) + gwdcu(i,k) * dtp - gv0(i,k) = gv0(i,k) + gwdcv(i,k) * dtp - eng1 = 0.5*(gu0(i,k)*gu0(i,k) + gv0(i,k)*gv0(i,k)) - gt0(i,k) = gt0(i,k) + (eng0-eng1)/(dtp*con_cp) - enddo -! if (lprnt) write(7000,*)' gu0=',gu0(ipr,k),' gwdcu=', -! &gwdcu(ipr,k), ' gv0=', gv0(ipr,k),' gwdcv=',gwdcv(ipr,k) -! &,' k=',k - enddo - - end subroutine gwdc_post_run - - subroutine gwdc_post_finalize() - end subroutine gwdc_post_finalize - - end module gwdc_post - + end module gwdc \ No newline at end of file diff --git a/physics/gwdc.meta b/physics/gwdc.meta index e61559e92..341879b0b 100644 --- a/physics/gwdc.meta +++ b/physics/gwdc.meta @@ -1,144 +1,3 @@ -[ccpp-table-properties] - name = gwdc_pre - type = scheme - dependencies = machine.F - -######################################################################## -[ccpp-arg-table] - name = gwdc_pre_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in -[cgwf] - standard_name = tunable_parameters_for_convective_gravity_wave_drag - long_name = multiplication factors for convective gravity wave drag - units = none - dimensions = (2) - type = real - kind = kind_phys - intent = in -[dx] - standard_name = characteristic_grid_lengthscale - long_name = grid size in zonal direction - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[work1] - standard_name = grid_size_related_coefficient_used_in_scale_sensitive_schemes - long_name = grid size related coefficient used in scale-sensitive schemes - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[work2] - standard_name = grid_size_related_coefficient_used_in_scale_sensitive_schemes_complement - long_name = complement to work1 - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[dlength] - standard_name = characteristic_grid_length_scale - long_name = representative horizontal length scale of grid box - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[cldf] - standard_name = cloud_area_fraction - long_name = fraction of grid box area in which updrafts occur - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[levs] - standard_name = vertical_layer_dimension - long_name = number of vertical layers - units = count - dimensions = () - type = integer - intent = in -[kbot] - standard_name = vertical_index_at_cloud_base - long_name = vertical index at cloud base - units = index - dimensions = (horizontal_loop_extent) - type = integer - intent = in -[ktop] - standard_name = vertical_index_at_cloud_top - long_name = vertical index at cloud top - units = index - dimensions = (horizontal_loop_extent) - type = integer - intent = in -[dtp] - standard_name = timestep_for_physics - long_name = physics time step - units = s - dimensions = () - type = real - kind = kind_phys - intent = in -[gt0] - standard_name = air_temperature_of_new_state - long_name = updated air temperature - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[gt0_init] - standard_name = air_temperature_save - long_name = air temperature before entering convection scheme - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[del] - standard_name = air_pressure_difference_between_midlayers - long_name = difference between mid-layer pressures - units = Pa - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cumabs] - standard_name = maximum_column_heating_rate - long_name = maximum heating rate in column - units = K s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out - ######################################################################## [ccpp-table-properties] name = gwdc @@ -414,191 +273,4 @@ units = 1 dimensions = () type = integer - intent = out - -######################################################################## -[ccpp-table-properties] - name = gwdc_post - type = scheme - dependencies = machine.F - -######################################################################## -[ccpp-arg-table] - name = gwdc_post_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in -[levs] - standard_name = vertical_layer_dimension - long_name = number of vertical layers - units = count - dimensions = () - type = integer - intent = in -[lssav] - standard_name = flag_for_diagnostics - long_name = flag for calculating diagnostic fields - units = flag - dimensions = () - type = logical - intent = in -[ldiag3d] - standard_name = flag_for_diagnostics_3D - long_name = flag for calculating 3-D diagnostic fields - units = flag - dimensions = () - type = logical - intent = in -[dtf] - standard_name = timestep_for_dynamics - long_name = dynamics time step - units = s - dimensions = () - type = real - kind = kind_phys - intent = in -[dtp] - standard_name = timestep_for_physics - long_name = physics time step - units = s - dimensions = () - type = real - kind = kind_phys - intent = in -[con_cp] - standard_name = specific_heat_of_dry_air_at_constant_pressure - long_name = specific heat of dry air at constant pressure - units = J kg-1 K-1 - dimensions = () - type = real - kind = kind_phys - intent = in -[tauctx] - standard_name = instantaneous_x_stress_due_to_gravity_wave_drag - long_name = zonal stress at cloud top due to convective gravity wave drag - units = Pa - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[taucty] - standard_name = instantaneous_y_stress_due_to_gravity_wave_drag - long_name = meridional stress at cloud top due to convective gravity wave drag - units = Pa - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[gwdcu] - standard_name = tendency_of_x_wind_due_to_convective_gravity_wave_drag - long_name = zonal wind tendency due to convective gravity wave drag - units = m s-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[gwdcv] - standard_name = tendency_of_y_wind_due_to_convective_gravity_wave_drag - long_name = meridional wind tendency due to convective gravity wave drag - units = m s-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[dugwd] - standard_name = time_integral_of_x_stress_due_to_gravity_wave_drag - long_name = integral over time of zonal stress due to gravity wave drag - units = Pa s - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[dvgwd] - standard_name = time_integral_of_y_stress_due_to_gravity_wave_drag - long_name = integral over time of meridional stress due to gravity wave drag - units = Pa s - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[dtend] - standard_name = cumulative_change_of_state_variables - long_name = diagnostic tendencies for state variables - units = mixed - dimensions = (horizontal_loop_extent,vertical_layer_dimension,cumulative_change_of_state_variables_outer_index_max) - type = real - kind = kind_phys - active = (flag_for_diagnostics_3D) - intent = inout -[dtidx] - standard_name = cumulative_change_of_state_variables_outer_index - long_name = index of state-variable and process in last dimension of diagnostic tendencies array AKA cumulative_change_index - units = index - dimensions = (number_of_tracers_plus_one_hundred,number_of_cumulative_change_processes) - type = integer - intent = in -[index_of_x_wind] - standard_name = index_of_x_wind_in_cumulative_change_index - long_name = index of x-wind in first dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[index_of_y_wind] - standard_name = index_of_y_wind_in_cumulative_change_index - long_name = index of x-wind in first dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[index_of_process_nonorographic_gwd] - standard_name = index_of_nonorographic_gravity_wave_drag_process_in_cumulative_change_index - long_name = index of nonorographic gravity wave drag process in second dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[gu0] - standard_name = x_wind_of_new_state - long_name = updated zonal wind - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[gv0] - standard_name = y_wind_of_new_state - long_name = updated meridional wind - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[gt0] - standard_name = air_temperature_of_new_state - long_name = updated air temperature - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out + intent = out \ No newline at end of file diff --git a/physics/gwdc_post.f b/physics/gwdc_post.f new file mode 100644 index 000000000..62891ffd4 --- /dev/null +++ b/physics/gwdc_post.f @@ -0,0 +1,82 @@ +!> \file gwdc_post.f This file contains code to execute after the original code for parameterization of +!! stationary convection forced gravity wave drag based on +!! Chun and Baik (1998) \cite chun_and_baik_1998. + + module gwdc_post + + contains + +!> \section arg_table_gwdc_post_run Argument Table +!! \htmlinclude gwdc_post_run.html +!! + subroutine gwdc_post_run( & + & im, levs, lssav, ldiag3d, dtf, dtp, con_cp, & + & tauctx, taucty, gwdcu, gwdcv, & + & dugwd, dvgwd, dtend, dtidx, index_of_x_wind, index_of_y_wind, & + & index_of_process_nonorographic_gwd, gu0, gv0, gt0, & + & errmsg, errflg) + + use machine, only : kind_phys + implicit none + + integer, intent(in) :: im, levs + logical, intent(in) :: lssav, ldiag3d + real(kind=kind_phys), intent(in) :: dtf, dtp, con_cp + real(kind=kind_phys), intent(in) :: & + & tauctx(:), taucty(:), gwdcu(:,:), gwdcv(:,:) + + real(kind=kind_phys), intent(inout) :: dugwd(:), dvgwd(:), & + & gu0(:,:), gv0(:,:), gt0(:,:) + real(kind=kind_phys), intent(inout), optional :: dtend(:,:,:) + integer, intent(in) :: dtidx(:,:) + integer, intent(in) :: index_of_process_nonorographic_gwd + integer, intent(in) :: index_of_x_wind, index_of_y_wind + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + integer :: i, k, idtend + real(kind=kind_phys) :: eng0, eng1 + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + +! --- ... write out cloud top stress and wind tendencies + + if (lssav) then + dugwd(:) = dugwd(:) + tauctx(:)*dtf + dvgwd(:) = dvgwd(:) + taucty(:)*dtf + endif ! end if_lssav + + if (ldiag3d) then + idtend = dtidx(index_of_x_wind,index_of_process_nonorographic_g& + & wd) + if(idtend>=1) then + dtend(:,:,idtend) = dtend(:,:,idtend) + gwdcu(:,:) * dtf + endif + idtend = dtidx(index_of_y_wind,index_of_process_nonorographic_g& + & wd) + if(idtend>=1) then + dtend(:,:,idtend) = dtend(:,:,idtend) + gwdcv(:,:) * dtf + endif + endif + +! --- ... update the wind components with gwdc tendencies + + do k = 1, levs + do i = 1, im + eng0 = 0.5*(gu0(i,k)*gu0(i,k) + gv0(i,k)*gv0(i,k)) + gu0(i,k) = gu0(i,k) + gwdcu(i,k) * dtp + gv0(i,k) = gv0(i,k) + gwdcv(i,k) * dtp + eng1 = 0.5*(gu0(i,k)*gu0(i,k) + gv0(i,k)*gv0(i,k)) + gt0(i,k) = gt0(i,k) + (eng0-eng1)/(dtp*con_cp) + enddo +! if (lprnt) write(7000,*)' gu0=',gu0(ipr,k),' gwdcu=', +! &gwdcu(ipr,k), ' gv0=', gv0(ipr,k),' gwdcv=',gwdcv(ipr,k) +! &,' k=',k + enddo + + end subroutine gwdc_post_run + + end module gwdc_post \ No newline at end of file diff --git a/physics/gwdc_post.meta b/physics/gwdc_post.meta new file mode 100644 index 000000000..25415b888 --- /dev/null +++ b/physics/gwdc_post.meta @@ -0,0 +1,186 @@ +######################################################################## +[ccpp-table-properties] + name = gwdc_post + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = gwdc_post_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[levs] + standard_name = vertical_layer_dimension + long_name = number of vertical layers + units = count + dimensions = () + type = integer + intent = in +[lssav] + standard_name = flag_for_diagnostics + long_name = flag for calculating diagnostic fields + units = flag + dimensions = () + type = logical + intent = in +[ldiag3d] + standard_name = flag_for_diagnostics_3D + long_name = flag for calculating 3-D diagnostic fields + units = flag + dimensions = () + type = logical + intent = in +[dtf] + standard_name = timestep_for_dynamics + long_name = dynamics time step + units = s + dimensions = () + type = real + kind = kind_phys + intent = in +[dtp] + standard_name = timestep_for_physics + long_name = physics time step + units = s + dimensions = () + type = real + kind = kind_phys + intent = in +[con_cp] + standard_name = specific_heat_of_dry_air_at_constant_pressure + long_name = specific heat of dry air at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[tauctx] + standard_name = instantaneous_x_stress_due_to_gravity_wave_drag + long_name = zonal stress at cloud top due to convective gravity wave drag + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[taucty] + standard_name = instantaneous_y_stress_due_to_gravity_wave_drag + long_name = meridional stress at cloud top due to convective gravity wave drag + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[gwdcu] + standard_name = tendency_of_x_wind_due_to_convective_gravity_wave_drag + long_name = zonal wind tendency due to convective gravity wave drag + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[gwdcv] + standard_name = tendency_of_y_wind_due_to_convective_gravity_wave_drag + long_name = meridional wind tendency due to convective gravity wave drag + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[dugwd] + standard_name = time_integral_of_x_stress_due_to_gravity_wave_drag + long_name = integral over time of zonal stress due to gravity wave drag + units = Pa s + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[dvgwd] + standard_name = time_integral_of_y_stress_due_to_gravity_wave_drag + long_name = integral over time of meridional stress due to gravity wave drag + units = Pa s + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[dtend] + standard_name = cumulative_change_of_state_variables + long_name = diagnostic tendencies for state variables + units = mixed + dimensions = (horizontal_loop_extent,vertical_layer_dimension,cumulative_change_of_state_variables_outer_index_max) + type = real + kind = kind_phys + active = (flag_for_diagnostics_3D) + intent = inout +[dtidx] + standard_name = cumulative_change_of_state_variables_outer_index + long_name = index of state-variable and process in last dimension of diagnostic tendencies array AKA cumulative_change_index + units = index + dimensions = (number_of_tracers_plus_one_hundred,number_of_cumulative_change_processes) + type = integer + intent = in +[index_of_x_wind] + standard_name = index_of_x_wind_in_cumulative_change_index + long_name = index of x-wind in first dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[index_of_y_wind] + standard_name = index_of_y_wind_in_cumulative_change_index + long_name = index of x-wind in first dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[index_of_process_nonorographic_gwd] + standard_name = index_of_nonorographic_gravity_wave_drag_process_in_cumulative_change_index + long_name = index of nonorographic gravity wave drag process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[gu0] + standard_name = x_wind_of_new_state + long_name = updated zonal wind + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[gv0] + standard_name = y_wind_of_new_state + long_name = updated meridional wind + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[gt0] + standard_name = air_temperature_of_new_state + long_name = updated air temperature + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out diff --git a/physics/gwdc_pre.f b/physics/gwdc_pre.f new file mode 100644 index 000000000..e2dce0a61 --- /dev/null +++ b/physics/gwdc_pre.f @@ -0,0 +1,68 @@ +!> \file gwdc_pre.f This file is preparation for the original code for parameterization of +!! stationary convection forced gravity wave drag based on +!! Chun and Baik (1998) \cite chun_and_baik_1998. + + module gwdc_pre + contains + +!! \section arg_table_gwdc_pre_run Argument Table +!! \htmlinclude gwdc_pre_run.html +!! + subroutine gwdc_pre_run ( & + & im, cgwf, dx, work1, work2, dlength, cldf, & + & levs, kbot, ktop, dtp, gt0, gt0_init, del, cumabs, & + & errmsg, errflg ) + + use machine, only : kind_phys + implicit none + + integer, intent(in) :: im, levs + integer, intent(in) :: kbot(:), ktop(:) + real(kind=kind_phys), intent(in) :: dtp + real(kind=kind_phys), intent(in) :: cgwf(:) + real(kind=kind_phys), intent(in) :: dx(:), work1(:), work2(:) + real(kind=kind_phys), intent(in) :: & + & gt0(:,:), gt0_init(:,:), del(:,:) + + real(kind=kind_phys), intent(out) :: & + & dlength(:), cldf(:), cumabs(:) + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + integer :: i, k + real(kind=kind_phys) :: tem1, tem2 + real(kind=kind_phys) :: work3(im) + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + do i = 1, im + tem1 = dx(i) + tem2 = tem1 + dlength(i) = sqrt( tem1*tem1+tem2*tem2 ) + cldf(i) = cgwf(1)*work1(i) + cgwf(2)*work2(i) + enddo + +! --- ... calculate maximum convective heating rate +! cuhr = temperature change due to deep convection + + cumabs(:) = 0.0 + work3(:) = 0.0 + do k = 1, levs + do i = 1, im + if (k >= kbot(i) .and. k <= ktop(i)) then + cumabs(i) & + & = cumabs(i) + (gt0(i,k) - gt0_init(i,k)) * del(i,k) + work3(i) = work3(i) + del(i,k) + endif + enddo + enddo + do i=1,im + if (work3(i) > 0.0) cumabs(i) = cumabs(i) / (dtp*work3(i)) + enddo + + end subroutine gwdc_pre_run + + end module gwdc_pre \ No newline at end of file diff --git a/physics/gwdc_pre.meta b/physics/gwdc_pre.meta new file mode 100644 index 000000000..63df59cfa --- /dev/null +++ b/physics/gwdc_pre.meta @@ -0,0 +1,140 @@ +[ccpp-table-properties] + name = gwdc_pre + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = gwdc_pre_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[cgwf] + standard_name = tunable_parameters_for_convective_gravity_wave_drag + long_name = multiplication factors for convective gravity wave drag + units = none + dimensions = (2) + type = real + kind = kind_phys + intent = in +[dx] + standard_name = characteristic_grid_lengthscale + long_name = grid size in zonal direction + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[work1] + standard_name = grid_size_related_coefficient_used_in_scale_sensitive_schemes + long_name = grid size related coefficient used in scale-sensitive schemes + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[work2] + standard_name = grid_size_related_coefficient_used_in_scale_sensitive_schemes_complement + long_name = complement to work1 + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[dlength] + standard_name = characteristic_grid_length_scale + long_name = representative horizontal length scale of grid box + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[cldf] + standard_name = cloud_area_fraction + long_name = fraction of grid box area in which updrafts occur + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[levs] + standard_name = vertical_layer_dimension + long_name = number of vertical layers + units = count + dimensions = () + type = integer + intent = in +[kbot] + standard_name = vertical_index_at_cloud_base + long_name = vertical index at cloud base + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = in +[ktop] + standard_name = vertical_index_at_cloud_top + long_name = vertical index at cloud top + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = in +[dtp] + standard_name = timestep_for_physics + long_name = physics time step + units = s + dimensions = () + type = real + kind = kind_phys + intent = in +[gt0] + standard_name = air_temperature_of_new_state + long_name = updated air temperature + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[gt0_init] + standard_name = air_temperature_save + long_name = air temperature before entering convection scheme + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[del] + standard_name = air_pressure_difference_between_midlayers + long_name = difference between mid-layer pressures + units = Pa + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cumabs] + standard_name = maximum_column_heating_rate + long_name = maximum heating rate in column + units = K s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out \ No newline at end of file diff --git a/physics/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/moninedmf.f b/physics/hedmf.f similarity index 99% rename from physics/moninedmf.f rename to physics/hedmf.f index 19e055da4..83d0fe1b0 100644 --- a/physics/moninedmf.f +++ b/physics/hedmf.f @@ -1,4 +1,4 @@ -!> \file moninedmf.f +!> \file hedmf.f !! Contains most of the hybrid eddy-diffusivity mass-flux scheme except for the !! subroutine that calculates the mass flux and updraft properties. diff --git a/physics/moninedmf.meta b/physics/hedmf.meta similarity index 100% rename from physics/moninedmf.meta rename to physics/hedmf.meta diff --git a/physics/sfc_drv.f b/physics/lsm_noah.f similarity index 98% rename from physics/sfc_drv.f rename to physics/lsm_noah.f index 817897fe7..d519dcda5 100644 --- a/physics/sfc_drv.f +++ b/physics/lsm_noah.f @@ -1,4 +1,4 @@ -!> \file sfc_drv.f +!> \file lsm_noah.f !! This file contains the Noah land surface scheme driver. !> This module contains the CCPP-compliant Noah land surface scheme driver. @@ -196,6 +196,8 @@ end subroutine lsm_noah_finalize ! smcwlt2 - real, dry soil moisture threshold im ! ! smcref2 - real, soil moisture threshold im ! ! wet1 - real, normalized soil wetness im ! +! lai - real, leaf area index (dimensionless) im ! +! rca - real, canopy resistance (s/m) im ! ! ! ! ==================== end of description ===================== ! @@ -225,7 +227,7 @@ subroutine lsm_noah_run & ! --- outputs: & sncovr1, qsurf, gflux, drain, evap, hflx, ep, runoff, & & cmm, chh, evbs, evcw, sbsno, snowc, stm, snohf, & - & smcwlt2, smcref2, wet1, errmsg, errflg & + & smcwlt2, smcref2, wet1, lai, rca, errmsg, errflg & & ) ! !use machine , only : kind_phys @@ -282,7 +284,7 @@ subroutine lsm_noah_run & real (kind=kind_phys), dimension(:), intent(inout) :: sncovr1, & & qsurf, gflux, drain, evap, hflx, ep, runoff, cmm, chh, & & evbs, evcw, sbsno, snowc, stm, snohf, smcwlt2, smcref2, & - & wet1 + & wet1, lai, rca character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -552,6 +554,8 @@ subroutine lsm_noah_run & !!\n ssoil - soil heat flux (\f$W m^{-2}\f$: negative if downward from surface) !!\n runoff1 - surface runoff (\f$m s^{-1}\f$), not infiltrating the surface !!\n runoff2 - subsurface runoff (\f$m s^{-1}\f$), drainage out bottom +!!\n xlai - leaf area index (dimensionless) +!!\n rca - canopy resistance (s/m) evap(i) = eta hflx(i) = sheat @@ -590,6 +594,9 @@ subroutine lsm_noah_run & ! ---- ... outside sflx, roughness uses cm as unit (update after snow's effect) zorl(i) = z0*100.0_kind_phys + lai(i) = xlai + rca(i) = rc + !> - Do not return the following output fields to parent model: !!\n ec - canopy water evaporation (m s-1) !!\n edir - direct soil evaporation (m s-1) @@ -610,7 +617,6 @@ subroutine lsm_noah_run & !!\n rc - canopy resistance (s m-1) !!\n pc - plant coefficient (unitless fraction, 0-1) where pc*etp !! = actual transp -!!\n xlai - leaf area index (dimensionless) !!\n rsmin - minimum canopy resistance (s m-1) !!\n rcs - incoming solar rc factor (dimensionless) !!\n rct - air temperature rc factor (dimensionless) diff --git a/physics/sfc_drv.meta b/physics/lsm_noah.meta similarity index 98% rename from physics/sfc_drv.meta rename to physics/lsm_noah.meta index a3aa9044e..2ce7c3e6c 100644 --- a/physics/sfc_drv.meta +++ b/physics/lsm_noah.meta @@ -734,6 +734,22 @@ type = real kind = kind_phys intent = inout +[lai] + standard_name = leaf_area_index + long_name = leaf area index + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[rca] + standard_name = aerodynamic_resistance_in_canopy + long_name = canopy resistance + units = s m-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/sfc_drv_ruc.F90 b/physics/lsm_ruc.F90 similarity index 99% rename from physics/sfc_drv_ruc.F90 rename to physics/lsm_ruc.F90 index d2e893e17..d206308cb 100644 --- a/physics/sfc_drv_ruc.F90 +++ b/physics/lsm_ruc.F90 @@ -1,4 +1,4 @@ -!>\file sfc_drv_ruc.F90 +!>\file lsm_ruc.F90 !! This file contains the RUC land surface scheme driver. module lsm_ruc @@ -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, & & oro, sigma, 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) :: oro, sigma @@ -786,7 +788,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/lsm_ruc.meta similarity index 99% rename from physics/sfc_drv_ruc.meta rename to physics/lsm_ruc.meta index addfd940f..e8290de54 100644 --- a/physics/sfc_drv_ruc.meta +++ b/physics/lsm_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 diff --git a/physics/m_micro_interstitial.F90 b/physics/m_micro_interstitial.F90 deleted file mode 100644 index 8d0132cf1..000000000 --- a/physics/m_micro_interstitial.F90 +++ /dev/null @@ -1,277 +0,0 @@ -!> \file m_micro_interstitial.F90 -!! This file contains subroutines that prepare data for and from the Morrison-Gettelman microphysics scheme -!! as part of the GFS physics suite. - module m_micro_pre - - implicit none - - contains - - subroutine m_micro_pre_init() - end subroutine m_micro_pre_init - -! \brief Brief description of the subroutine -!! -!! \section arg_table_m_micro_pre_run Argument Table -!! \htmlinclude m_micro_pre_run.html -!! - subroutine m_micro_pre_run (im, levs, do_shoc, skip_macro, fprcp, mg3_as_mg2, gq0_ice, gq0_water, gq0_rain, & - gq0_snow, gq0_graupel, gq0_rain_nc, gq0_snow_nc, gq0_graupel_nc, cld_shoc, cnvc, cnvw, tcr, tcrf, gt0, & - qrn, qsnw, qgl, ncpr, ncps, ncgl, cld_frc_MG, clw_water, clw_ice, clcn, errmsg, errflg ) - - use machine, only : kind_phys - implicit none - - integer, intent(in) :: im, levs, fprcp - logical, intent(in) :: do_shoc, mg3_as_mg2 - logical, intent(inout) :: skip_macro - real(kind=kind_phys), intent(in) :: tcr, tcrf - - real(kind=kind_phys), intent(in) :: & - gq0_ice(:,:), gq0_water(:,:), gq0_rain(:,:), gq0_snow(:,:), & - gq0_graupel(:,:), gq0_rain_nc(:,:), gq0_snow_nc(:,:), & - gq0_graupel_nc(:,:), cld_shoc(:,:), cnvc(:,:), cnvw(:,:), & - gt0(:,:) - - real(kind=kind_phys), intent(inout) :: & - qrn(:,:), qsnw(:,:), qgl(:,:), ncpr(:,:), ncps(:,:), ncgl(:,:), & - cld_frc_MG(:,:) - - real(kind=kind_phys), intent(out) :: clw_ice(:,:), clw_water(:,:) - - real(kind=kind_phys), intent(in) :: clcn(:,:) - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - integer :: i, k - real(kind=kind_phys) :: tem - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - ! Acheng used clw here for other code to run smoothly and minimum change - ! to make the code work. However, the nc and clw should be treated - ! in other procceses too. August 28/2015; Hope that can be done next - ! year. I believe this will make the physical interaction more reasonable - ! Anning 12/5/2015 changed ntcw hold liquid only - skip_macro = do_shoc - if (do_shoc) then - if (fprcp == 0) then - do k=1,levs - do i=1,im - clw_ice(i,k) = gq0_ice(i,k) - clw_water(i,k) = gq0_water(i,k) - cld_frc_MG(i,k) = cld_shoc(i,k) - enddo - enddo - else if ((abs(fprcp) == 1) .or. mg3_as_mg2) then - do k=1,levs - do i=1,im - clw_ice(i,k) = gq0_ice(i,k) - clw_water(i,k) = gq0_water(i,k) - qrn(i,k) = gq0_rain(i,k) - qsnw(i,k) = gq0_snow(i,k) - ncpr(i,k) = gq0_rain_nc(i,k) - ncps(i,k) = gq0_snow_nc(i,k) - cld_frc_MG(i,k) = cld_shoc(i,k) - enddo - enddo - else - do k=1,levs - do i=1,im - clw_ice(i,k) = gq0_ice(i,k) - clw_water(i,k) = gq0_water(i,k) - qrn(i,k) = gq0_rain(i,k) - qsnw(i,k) = gq0_snow(i,k) - qgl(i,k) = gq0_graupel(i,k) - ncpr(i,k) = gq0_rain_nc(i,k) - ncps(i,k) = gq0_snow_nc(i,k) - ncgl(i,k) = gq0_graupel_nc(i,k) - cld_frc_MG(i,k) = cld_shoc(i,k) - enddo - enddo - end if - else - if (fprcp == 0 ) then - do k=1,levs - do i=1,im - clw_ice(i,k) = gq0_ice(i,k) - clw_water(i,k) = gq0_water(i,k) - enddo - enddo - elseif (abs(fprcp) == 1 .or. mg3_as_mg2) then - do k=1,levs - do i=1,im - clw_ice(i,k) = gq0_ice(i,k) - clw_water(i,k) = gq0_water(i,k) - qrn(i,k) = gq0_rain(i,k) - qsnw(i,k) = gq0_snow(i,k) - ncpr(i,k) = gq0_rain_nc(i,k) - ncps(i,k) = gq0_snow_nc(i,k) - enddo - enddo - else - do k=1,levs - do i=1,im - clw_ice(i,k) = gq0_ice(i,k) - clw_water(i,k) = gq0_water(i,k) - qrn(i,k) = gq0_rain(i,k) - qsnw(i,k) = gq0_snow(i,k) - qgl(i,k) = gq0_graupel(i,k) - ncpr(i,k) = gq0_rain_nc(i,k) - ncps(i,k) = gq0_snow_nc(i,k) - ncgl(i,k) = gq0_graupel_nc(i,k) - enddo - enddo - endif - end if - - ! add convective cloud fraction - do k = 1,levs - do i = 1,im - cld_frc_MG(i,k) = min(1.0, cld_frc_MG(i,k) + clcn(i,k)) - enddo - enddo - - end subroutine m_micro_pre_run - - subroutine m_micro_pre_finalize () - end subroutine m_micro_pre_finalize - - end module m_micro_pre - -!> This module contains the CCPP-compliant MG microphysics -!! post intersititial codes. - module m_micro_post - - implicit none - - contains - - subroutine m_micro_post_init() - end subroutine m_micro_post_init - -! \brief Brief description of the subroutine -!! -!! \section arg_table_m_micro_post_run Argument Table -!! \htmlinclude m_micro_post_run.html -!! - subroutine m_micro_post_run( & - im, levs, fprcp, mg3_as_mg2, ncpr, ncps, ncgl, qrn, qsnw, qgl, & - gq0_ice, gq0_rain, gq0_snow, gq0_graupel, gq0_rain_nc, gq0_snow_nc, & - gq0_graupel_nc, ice, snow, graupel, dtp, errmsg, errflg) - - use machine, only : kind_phys - implicit none - - integer, intent(in) :: im, levs, fprcp - logical, intent(in) :: mg3_as_mg2 - - real(kind=kind_phys), intent(in ) :: ncpr(:,:) - real(kind=kind_phys), intent(in ) :: ncps(:,:) - real(kind=kind_phys), intent(in ) :: ncgl(:,:) - real(kind=kind_phys), intent(inout) :: qrn(:,:) - real(kind=kind_phys), intent(inout) :: qsnw(:,:) - real(kind=kind_phys), intent(inout) :: qgl(:,:) - real(kind=kind_phys), intent(in ) :: gq0_ice(:,:) - real(kind=kind_phys), intent(out ) :: gq0_rain(:,:) - real(kind=kind_phys), intent(out ) :: gq0_snow(:,:) - real(kind=kind_phys), intent(out ) :: gq0_graupel(:,:) - real(kind=kind_phys), intent(out ) :: gq0_rain_nc(:,:) - real(kind=kind_phys), intent(out ) :: gq0_snow_nc(:,:) - real(kind=kind_phys), intent(out ) :: gq0_graupel_nc(:,:) - real(kind=kind_phys), intent( out) :: ice(:) - real(kind=kind_phys), intent( out) :: snow(:) - real(kind=kind_phys), intent( out) :: graupel(:) - real(kind=kind_phys), intent(in ) :: dtp - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Local variables - real(kind=kind_phys), parameter :: qsmall = 1.0d-20 - real(kind=kind_phys), parameter :: con_p001 = 0.001d0 - real(kind=kind_phys), parameter :: con_day = 86400.0d0 - integer :: i, k - real(kind=kind_phys) :: tem - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 -! do k=1,levs -! write(1000+me,*)' maxwatnca=',maxval(Stateout%gq0(1:im,k,ntlnc)),' k=',k,' kdt=',kdt -! enddo -! write(1000+me,*)' at latitude = ',lat -! tx1 = 1000.0 -! call moist_bud(im,ix,ix,levs,me,kdt,con_g,tx1,del,rain1 -! &, txa, clw(1,1,2), clw(1,1,1) -! &, gq0(1,1,1),gq0(1,1,ntcw),gq0(1,1,ntcw+1),' m_micro ') - -! if (lprnt) write(0,*) ' rain1=',rain1(ipr)*86400.0, & -! &' rainc=',diag%rainc(ipr)*86400.0 -! &,' cn_prc=',cn_prc(ipr),' cn_snr=',cn_snr(ipr) -! if(lprnt) write(0,*) ' aftgt0=',Stateout%gt0(ipr,:),' kdt=',kdt -! if (lprnt) write(0,*) ' aftlsgq0=',stateout%gq0(ipr,:,1),' kdt=',kdt -! if (lprnt) write(0,*)' clw1aft=',stateout%gq0(ipr,:,ntiw),' kdt=',kdt -! if (ntgl > 0 .and. lprnt) & -! write(0,*)' cgw1aft=',stateout%gq0(ipr,:,ntgl),' kdt=',kdt -! if (lprnt) write(0,*)' cloudsm=',tbd%phy_f3d(ipr,:,1)*100,' kdt=',kdt -! if (lprnt) write(0,*)' clw2aft=',stateout%gq0(ipr,:,ntcw),' kdt=',kdt -! if (lprnt) write(0,*)' qrna=',qrn(ipr,:),' kdt=',kdt -! if (lprnt) write(0,*)' qsnwa=',qsnw(ipr,:),' kdt=',kdt -! if (lprnt) write(0,*)' qglba',qgl(ipr,:),' kdt=',kdt - - tem = dtp * con_p001 / con_day - if (abs(fprcp) == 1 .or. mg3_as_mg2) then - do k=1,levs - do i=1,im - if (abs(qrn(i,k)) < qsmall) qrn(i,k) = 0.0 - if (abs(qsnw(i,k)) < qsmall) qsnw(i,k) = 0.0 - gq0_rain(i,k) = qrn(i,k) - gq0_snow(i,k) = qsnw(i,k) - gq0_rain_nc(i,k) = ncpr(i,k) - gq0_snow_nc(i,k) = ncps(i,k) - enddo - enddo - do i=1,im - ice(i) = tem * gq0_ice(i,1) - snow(i) = tem * qsnw(i,1) - enddo - elseif (fprcp > 1) then - do k=1,levs - do i=1,im - if (abs(qrn(i,k)) < qsmall) qrn(i,k) = 0.0 - if (abs(qsnw(i,k)) < qsmall) qsnw(i,k) = 0.0 - if (abs(qgl(i,k)) < qsmall) qgl(i,k) = 0.0 - gq0_rain(i,k) = qrn(i,k) - gq0_snow(i,k) = qsnw(i,k) - gq0_graupel(i,k) = qgl(i,k) - gq0_rain_nc(i,k) = ncpr(i,k) - gq0_snow_nc(i,k) = ncps(i,k) - gq0_graupel_nc(i,k) = ncgl(i,k) - enddo - enddo - do i=1,im - ice(i) = tem * gq0_ice(i,1) - snow(i) = tem * qsnw(i,1) - graupel(i) = tem * qgl(i,1) - enddo - - endif - -! if (lprnt) write(0,*)' cloudsm=',tbd%phy_f3d(ipr,:,1)*100,' kdt=',kdt -! if (lprnt) write(0,*)' clw2aft=',stateout%gq0(ipr,:,ntcw),' kdt=',kdt -! if (lprnt) write(0,*)' qrna=',qrn(ipr,:),' kdt=',kdt -! if (lprnt) write(0,*)' qsnwa=',qsnw(ipr,:),' kdt=',kdt -! if (lprnt) write(0,*)' qglba',qgl(ipr,:),' kdt=',kdt -! - - - end subroutine m_micro_post_run - - subroutine m_micro_post_finalize() - end subroutine m_micro_post_finalize - - end module m_micro_post diff --git a/physics/m_micro_post.F90 b/physics/m_micro_post.F90 new file mode 100644 index 000000000..a61ee4874 --- /dev/null +++ b/physics/m_micro_post.F90 @@ -0,0 +1,127 @@ +!> \file m_micro_post.F90 +!! This file contains subroutines that prepare data from the Morrison-Gettelman microphysics scheme +!! as part of the GFS physics suite. + + module m_micro_post + + implicit none + + contains + +!! \section arg_table_m_micro_post_run Argument Table +!! \htmlinclude m_micro_post_run.html +!! + subroutine m_micro_post_run( & + im, levs, fprcp, mg3_as_mg2, ncpr, ncps, ncgl, qrn, qsnw, qgl, & + gq0_ice, gq0_rain, gq0_snow, gq0_graupel, gq0_rain_nc, gq0_snow_nc, & + gq0_graupel_nc, ice, snow, graupel, dtp, errmsg, errflg) + + use machine, only : kind_phys + implicit none + + integer, intent(in) :: im, levs, fprcp + logical, intent(in) :: mg3_as_mg2 + + real(kind=kind_phys), intent(in ) :: ncpr(:,:) + real(kind=kind_phys), intent(in ) :: ncps(:,:) + real(kind=kind_phys), intent(in ) :: ncgl(:,:) + real(kind=kind_phys), intent(inout) :: qrn(:,:) + real(kind=kind_phys), intent(inout) :: qsnw(:,:) + real(kind=kind_phys), intent(inout) :: qgl(:,:) + real(kind=kind_phys), intent(in ) :: gq0_ice(:,:) + real(kind=kind_phys), intent(out ) :: gq0_rain(:,:) + real(kind=kind_phys), intent(out ) :: gq0_snow(:,:) + real(kind=kind_phys), intent(out ) :: gq0_graupel(:,:) + real(kind=kind_phys), intent(out ) :: gq0_rain_nc(:,:) + real(kind=kind_phys), intent(out ) :: gq0_snow_nc(:,:) + real(kind=kind_phys), intent(out ) :: gq0_graupel_nc(:,:) + real(kind=kind_phys), intent( out) :: ice(:) + real(kind=kind_phys), intent( out) :: snow(:) + real(kind=kind_phys), intent( out) :: graupel(:) + real(kind=kind_phys), intent(in ) :: dtp + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Local variables + real(kind=kind_phys), parameter :: qsmall = 1.0d-20 + real(kind=kind_phys), parameter :: con_p001 = 0.001d0 + real(kind=kind_phys), parameter :: con_day = 86400.0d0 + integer :: i, k + real(kind=kind_phys) :: tem + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 +! do k=1,levs +! write(1000+me,*)' maxwatnca=',maxval(Stateout%gq0(1:im,k,ntlnc)),' k=',k,' kdt=',kdt +! enddo +! write(1000+me,*)' at latitude = ',lat +! tx1 = 1000.0 +! call moist_bud(im,ix,ix,levs,me,kdt,con_g,tx1,del,rain1 +! &, txa, clw(1,1,2), clw(1,1,1) +! &, gq0(1,1,1),gq0(1,1,ntcw),gq0(1,1,ntcw+1),' m_micro ') + +! if (lprnt) write(0,*) ' rain1=',rain1(ipr)*86400.0, & +! &' rainc=',diag%rainc(ipr)*86400.0 +! &,' cn_prc=',cn_prc(ipr),' cn_snr=',cn_snr(ipr) +! if(lprnt) write(0,*) ' aftgt0=',Stateout%gt0(ipr,:),' kdt=',kdt +! if (lprnt) write(0,*) ' aftlsgq0=',stateout%gq0(ipr,:,1),' kdt=',kdt +! if (lprnt) write(0,*)' clw1aft=',stateout%gq0(ipr,:,ntiw),' kdt=',kdt +! if (ntgl > 0 .and. lprnt) & +! write(0,*)' cgw1aft=',stateout%gq0(ipr,:,ntgl),' kdt=',kdt +! if (lprnt) write(0,*)' cloudsm=',tbd%phy_f3d(ipr,:,1)*100,' kdt=',kdt +! if (lprnt) write(0,*)' clw2aft=',stateout%gq0(ipr,:,ntcw),' kdt=',kdt +! if (lprnt) write(0,*)' qrna=',qrn(ipr,:),' kdt=',kdt +! if (lprnt) write(0,*)' qsnwa=',qsnw(ipr,:),' kdt=',kdt +! if (lprnt) write(0,*)' qglba',qgl(ipr,:),' kdt=',kdt + + tem = dtp * con_p001 / con_day + if (abs(fprcp) == 1 .or. mg3_as_mg2) then + do k=1,levs + do i=1,im + if (abs(qrn(i,k)) < qsmall) qrn(i,k) = 0.0 + if (abs(qsnw(i,k)) < qsmall) qsnw(i,k) = 0.0 + gq0_rain(i,k) = qrn(i,k) + gq0_snow(i,k) = qsnw(i,k) + gq0_rain_nc(i,k) = ncpr(i,k) + gq0_snow_nc(i,k) = ncps(i,k) + enddo + enddo + do i=1,im + ice(i) = tem * gq0_ice(i,1) + snow(i) = tem * qsnw(i,1) + enddo + elseif (fprcp > 1) then + do k=1,levs + do i=1,im + if (abs(qrn(i,k)) < qsmall) qrn(i,k) = 0.0 + if (abs(qsnw(i,k)) < qsmall) qsnw(i,k) = 0.0 + if (abs(qgl(i,k)) < qsmall) qgl(i,k) = 0.0 + gq0_rain(i,k) = qrn(i,k) + gq0_snow(i,k) = qsnw(i,k) + gq0_graupel(i,k) = qgl(i,k) + gq0_rain_nc(i,k) = ncpr(i,k) + gq0_snow_nc(i,k) = ncps(i,k) + gq0_graupel_nc(i,k) = ncgl(i,k) + enddo + enddo + do i=1,im + ice(i) = tem * gq0_ice(i,1) + snow(i) = tem * qsnw(i,1) + graupel(i) = tem * qgl(i,1) + enddo + + endif + +! if (lprnt) write(0,*)' cloudsm=',tbd%phy_f3d(ipr,:,1)*100,' kdt=',kdt +! if (lprnt) write(0,*)' clw2aft=',stateout%gq0(ipr,:,ntcw),' kdt=',kdt +! if (lprnt) write(0,*)' qrna=',qrn(ipr,:),' kdt=',kdt +! if (lprnt) write(0,*)' qsnwa=',qsnw(ipr,:),' kdt=',kdt +! if (lprnt) write(0,*)' qglba',qgl(ipr,:),' kdt=',kdt +! + + + end subroutine m_micro_post_run + + end module m_micro_post diff --git a/physics/m_micro_post.meta b/physics/m_micro_post.meta new file mode 100644 index 000000000..684ac3f21 --- /dev/null +++ b/physics/m_micro_post.meta @@ -0,0 +1,190 @@ +######################################################################## +[ccpp-table-properties] + name = m_micro_post + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = m_micro_post_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[levs] + standard_name = vertical_layer_dimension + long_name = number of vertical layers + units = count + dimensions = () + type = integer + intent = in +[fprcp] + standard_name = number_of_frozen_precipitation_species + long_name = number of frozen precipitation species + units = count + dimensions = () + type = integer + intent = in +[mg3_as_mg2] + standard_name = flag_mg3_as_mg2 + long_name = flag for controlling prep for Morrison-Gettelman microphysics + units = flag + dimensions = () + type = logical + intent = in +[ncpr] + standard_name = local_rain_number_concentration + long_name = number concentration of rain local to physics + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[ncps] + standard_name = local_snow_number_concentration + long_name = number concentration of snow local to physics + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[ncgl] + standard_name = local_graupel_number_concentration + long_name = number concentration of graupel local to physics + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[qrn] + standard_name = local_rain_water_mixing_ratio + long_name = ratio of mass of rain water to mass of dry air plus vapor (without condensates) local to physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[qsnw] + standard_name = local_snow_water_mixing_ratio + long_name = ratio of mass of snow water to mass of dry air plus vapor (without condensates) local to physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[qgl] + standard_name = local_graupel_mixing_ratio + long_name = ratio of mass of graupel to mass of dry air plus vapor (without condensates) local to physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[gq0_ice] + standard_name = cloud_ice_mixing_ratio_of_new_state + long_name = ratio of mass of ice water to mass of dry air plus vapor (without condensates) updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[gq0_rain] + standard_name = rain_mixing_ratio_of_new_state + long_name = ratio of mass of rain water to mass of dry air plus vapor (without condensates) updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[gq0_snow] + standard_name = snow_mixing_ratio_of_new_state + long_name = ratio of mass of snow water to mass of dry air plus vapor (without condensates) updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[gq0_graupel] + standard_name = graupel_mixing_ratio_of_new_state + long_name = ratio of mass of graupel to mass of dry air plus vapor (without condensates) updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[gq0_rain_nc] + standard_name = mass_number_concentration_of_rain_of_new_state + long_name = number concentration of rain updated by physics + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[gq0_snow_nc] + standard_name = mass_number_concentration_of_snow_of_new_state + long_name = number concentration of snow updated by physics + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[gq0_graupel_nc] + standard_name = mass_number_concentration_of_graupel_of_new_state + long_name = number concentration of graupel updated by physics + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[ice] + standard_name = lwe_thickness_of_ice_amount_on_dynamics_timestep + long_name = ice fall at this time step + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[snow] + standard_name = lwe_thickness_of_snow_amount_on_dynamics_timestep + long_name = snow fall at this time step + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[graupel] + standard_name = lwe_thickness_of_graupel_amount_on_dynamics_timestep + long_name = graupel fall at this time step + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[dtp] + standard_name = timestep_for_physics + long_name = physics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out + diff --git a/physics/m_micro_pre.F90 b/physics/m_micro_pre.F90 new file mode 100644 index 000000000..9893e0db1 --- /dev/null +++ b/physics/m_micro_pre.F90 @@ -0,0 +1,135 @@ +!> \file m_micro_pre.F90 +!! This file contains subroutines that prepare data for the Morrison-Gettelman microphysics scheme +!! as part of the GFS physics suite. + module m_micro_pre + + implicit none + + contains + +!! \section arg_table_m_micro_pre_run Argument Table +!! \htmlinclude m_micro_pre_run.html +!! + subroutine m_micro_pre_run (im, levs, do_shoc, skip_macro, fprcp, mg3_as_mg2, gq0_ice, gq0_water, gq0_rain, & + gq0_snow, gq0_graupel, gq0_rain_nc, gq0_snow_nc, gq0_graupel_nc, cld_shoc, cnvc, cnvw, tcr, tcrf, gt0, & + qrn, qsnw, qgl, ncpr, ncps, ncgl, cld_frc_MG, clw_water, clw_ice, clcn, errmsg, errflg ) + + use machine, only : kind_phys + implicit none + + integer, intent(in) :: im, levs, fprcp + logical, intent(in) :: do_shoc, mg3_as_mg2 + logical, intent(inout) :: skip_macro + real(kind=kind_phys), intent(in) :: tcr, tcrf + + real(kind=kind_phys), intent(in) :: & + gq0_ice(:,:), gq0_water(:,:), gq0_rain(:,:), gq0_snow(:,:), & + gq0_graupel(:,:), gq0_rain_nc(:,:), gq0_snow_nc(:,:), & + gq0_graupel_nc(:,:), cld_shoc(:,:), cnvc(:,:), cnvw(:,:), & + gt0(:,:) + + real(kind=kind_phys), intent(inout) :: & + qrn(:,:), qsnw(:,:), qgl(:,:), ncpr(:,:), ncps(:,:), ncgl(:,:), & + cld_frc_MG(:,:) + + real(kind=kind_phys), intent(out) :: clw_ice(:,:), clw_water(:,:) + + real(kind=kind_phys), intent(in) :: clcn(:,:) + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + integer :: i, k + real(kind=kind_phys) :: tem + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! Acheng used clw here for other code to run smoothly and minimum change + ! to make the code work. However, the nc and clw should be treated + ! in other procceses too. August 28/2015; Hope that can be done next + ! year. I believe this will make the physical interaction more reasonable + ! Anning 12/5/2015 changed ntcw hold liquid only + skip_macro = do_shoc + if (do_shoc) then + if (fprcp == 0) then + do k=1,levs + do i=1,im + clw_ice(i,k) = gq0_ice(i,k) + clw_water(i,k) = gq0_water(i,k) + cld_frc_MG(i,k) = cld_shoc(i,k) + enddo + enddo + else if ((abs(fprcp) == 1) .or. mg3_as_mg2) then + do k=1,levs + do i=1,im + clw_ice(i,k) = gq0_ice(i,k) + clw_water(i,k) = gq0_water(i,k) + qrn(i,k) = gq0_rain(i,k) + qsnw(i,k) = gq0_snow(i,k) + ncpr(i,k) = gq0_rain_nc(i,k) + ncps(i,k) = gq0_snow_nc(i,k) + cld_frc_MG(i,k) = cld_shoc(i,k) + enddo + enddo + else + do k=1,levs + do i=1,im + clw_ice(i,k) = gq0_ice(i,k) + clw_water(i,k) = gq0_water(i,k) + qrn(i,k) = gq0_rain(i,k) + qsnw(i,k) = gq0_snow(i,k) + qgl(i,k) = gq0_graupel(i,k) + ncpr(i,k) = gq0_rain_nc(i,k) + ncps(i,k) = gq0_snow_nc(i,k) + ncgl(i,k) = gq0_graupel_nc(i,k) + cld_frc_MG(i,k) = cld_shoc(i,k) + enddo + enddo + end if + else + if (fprcp == 0 ) then + do k=1,levs + do i=1,im + clw_ice(i,k) = gq0_ice(i,k) + clw_water(i,k) = gq0_water(i,k) + enddo + enddo + elseif (abs(fprcp) == 1 .or. mg3_as_mg2) then + do k=1,levs + do i=1,im + clw_ice(i,k) = gq0_ice(i,k) + clw_water(i,k) = gq0_water(i,k) + qrn(i,k) = gq0_rain(i,k) + qsnw(i,k) = gq0_snow(i,k) + ncpr(i,k) = gq0_rain_nc(i,k) + ncps(i,k) = gq0_snow_nc(i,k) + enddo + enddo + else + do k=1,levs + do i=1,im + clw_ice(i,k) = gq0_ice(i,k) + clw_water(i,k) = gq0_water(i,k) + qrn(i,k) = gq0_rain(i,k) + qsnw(i,k) = gq0_snow(i,k) + qgl(i,k) = gq0_graupel(i,k) + ncpr(i,k) = gq0_rain_nc(i,k) + ncps(i,k) = gq0_snow_nc(i,k) + ncgl(i,k) = gq0_graupel_nc(i,k) + enddo + enddo + endif + end if + + ! add convective cloud fraction + do k = 1,levs + do i = 1,im + cld_frc_MG(i,k) = min(1.0, cld_frc_MG(i,k) + clcn(i,k)) + enddo + enddo + + end subroutine m_micro_pre_run + + end module m_micro_pre \ No newline at end of file diff --git a/physics/m_micro_interstitial.meta b/physics/m_micro_pre.meta similarity index 58% rename from physics/m_micro_interstitial.meta rename to physics/m_micro_pre.meta index c7c8a23fd..7ac592833 100644 --- a/physics/m_micro_interstitial.meta +++ b/physics/m_micro_pre.meta @@ -255,195 +255,4 @@ units = 1 dimensions = () type = integer - intent = out - -######################################################################## -[ccpp-table-properties] - name = m_micro_post - type = scheme - dependencies = machine.F - -######################################################################## -[ccpp-arg-table] - name = m_micro_post_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in -[levs] - standard_name = vertical_layer_dimension - long_name = number of vertical layers - units = count - dimensions = () - type = integer - intent = in -[fprcp] - standard_name = number_of_frozen_precipitation_species - long_name = number of frozen precipitation species - units = count - dimensions = () - type = integer - intent = in -[mg3_as_mg2] - standard_name = flag_mg3_as_mg2 - long_name = flag for controlling prep for Morrison-Gettelman microphysics - units = flag - dimensions = () - type = logical - intent = in -[ncpr] - standard_name = local_rain_number_concentration - long_name = number concentration of rain local to physics - units = kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[ncps] - standard_name = local_snow_number_concentration - long_name = number concentration of snow local to physics - units = kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[ncgl] - standard_name = local_graupel_number_concentration - long_name = number concentration of graupel local to physics - units = kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[qrn] - standard_name = local_rain_water_mixing_ratio - long_name = ratio of mass of rain water to mass of dry air plus vapor (without condensates) local to physics - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[qsnw] - standard_name = local_snow_water_mixing_ratio - long_name = ratio of mass of snow water to mass of dry air plus vapor (without condensates) local to physics - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[qgl] - standard_name = local_graupel_mixing_ratio - long_name = ratio of mass of graupel to mass of dry air plus vapor (without condensates) local to physics - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[gq0_ice] - standard_name = cloud_ice_mixing_ratio_of_new_state - long_name = ratio of mass of ice water to mass of dry air plus vapor (without condensates) updated by physics - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[gq0_rain] - standard_name = rain_mixing_ratio_of_new_state - long_name = ratio of mass of rain water to mass of dry air plus vapor (without condensates) updated by physics - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[gq0_snow] - standard_name = snow_mixing_ratio_of_new_state - long_name = ratio of mass of snow water to mass of dry air plus vapor (without condensates) updated by physics - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[gq0_graupel] - standard_name = graupel_mixing_ratio_of_new_state - long_name = ratio of mass of graupel to mass of dry air plus vapor (without condensates) updated by physics - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[gq0_rain_nc] - standard_name = mass_number_concentration_of_rain_of_new_state - long_name = number concentration of rain updated by physics - units = kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[gq0_snow_nc] - standard_name = mass_number_concentration_of_snow_of_new_state - long_name = number concentration of snow updated by physics - units = kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[gq0_graupel_nc] - standard_name = mass_number_concentration_of_graupel_of_new_state - long_name = number concentration of graupel updated by physics - units = kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[ice] - standard_name = lwe_thickness_of_ice_amount_on_dynamics_timestep - long_name = ice fall at this time step - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[snow] - standard_name = lwe_thickness_of_snow_amount_on_dynamics_timestep - long_name = snow fall at this time step - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[graupel] - standard_name = lwe_thickness_of_graupel_amount_on_dynamics_timestep - long_name = graupel fall at this time step - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[dtp] - standard_name = timestep_for_physics - long_name = physics timestep - units = s - dimensions = () - type = real - kind = kind_phys - intent = in -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out - + intent = out \ No newline at end of file diff --git a/physics/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/mfpbltq.f b/physics/mfpbltq.f index b906052cd..c4333290b 100644 --- a/physics/mfpbltq.f +++ b/physics/mfpbltq.f @@ -11,7 +11,7 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, & cnvflg,zl,zm,q1,t1,u1,v1,plyr,pix,thlx,thvx, & gdx,hpbl,kpbl,vpert,buo,xmf, - & tcko,qcko,ucko,vcko,xlamue,a1) + & tcko,qcko,ucko,vcko,xlamueq,a1) ! use machine , only : kind_phys use funcphys , only : fpvs @@ -35,14 +35,15 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, & buo(im,km), xmf(im,km), & tcko(im,km),qcko(im,km,ntrac1), & ucko(im,km),vcko(im,km), - & xlamue(im,km-1) + & xlamueq(im,km-1) ! c local variables and arrays ! integer i, j, k, n, ndc integer kpblx(im), kpbly(im) ! - real(kind=kind_phys) dt2, dz, ce0, cm, + real(kind=kind_phys) dt2, dz, ce0, + & cm, cq, & factor, gocp, & g, b1, f1, & bb1, bb2, @@ -56,7 +57,7 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, & thup, thvu, dq ! real(kind=kind_phys) rbdn(im), rbup(im), hpblx(im), - & xlamuem(im,km-1) + & xlamue(im,km-1), xlamuem(im,km-1) real(kind=kind_phys) delz(im), xlamax(im) ! real(kind=kind_phys) wu2(im,km), thlu(im,km), @@ -71,7 +72,7 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, parameter(g=grav) parameter(gocp=g/cp) parameter(elocp=hvap/cp,el2orc=hvap*hvap/(rv*cp)) - parameter(ce0=0.4,cm=1.0) + parameter(ce0=0.4,cm=1.0,cq=1.3) parameter(qmin=1.e-8,qlmin=1.e-12) parameter(alp=1.5,vpertmax=3.0,pgcon=0.55) parameter(b1=0.5,f1=0.15) @@ -132,6 +133,7 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, xlamue(i,k) = xlamax(i) endif ! + xlamueq(i,k) = cq * xlamue(i,k) xlamuem(i,k) = cm * xlamue(i,k) endif enddo @@ -148,6 +150,9 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, ! thlu(i,k) = ((1.-tem)*thlu(i,k-1)+tem* & (thlx(i,k-1)+thlx(i,k)))/factor +! + tem = 0.5 * xlamueq(i,k-1) * dz + factor = 1. + tem qtu(i,k) = ((1.-tem)*qtu(i,k-1)+tem* & (qtx(i,k-1)+qtx(i,k)))/factor ! @@ -282,6 +287,7 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, xlamue(i,k) = xlamax(i) endif ! + xlamueq(i,k) = cq * xlamue(i,k) xlamuem(i,k) = cm * xlamue(i,k) endif enddo @@ -384,6 +390,9 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, ! thlu(i,k) = ((1.-tem)*thlu(i,k-1)+tem* & (thlx(i,k-1)+thlx(i,k)))/factor +! + tem = 0.5 * xlamueq(i,k-1) * dz + factor = 1. + tem qtu(i,k) = ((1.-tem)*qtu(i,k-1)+tem* & (qtx(i,k-1)+qtx(i,k)))/factor ! @@ -432,7 +441,7 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, do i = 1, im if (cnvflg(i) .and. k <= kpbl(i)) then dz = zl(i,k) - zl(i,k-1) - tem = 0.5 * xlamue(i,k-1) * dz + tem = 0.5 * xlamueq(i,k-1) * dz factor = 1. + tem ! qcko(i,k,n) = ((1.-tem)*qcko(i,k-1,n)+tem* @@ -453,7 +462,7 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, do i = 1, im if (cnvflg(i) .and. k <= kpbl(i)) then dz = zl(i,k) - zl(i,k-1) - tem = 0.5 * xlamue(i,k-1) * dz + tem = 0.5 * xlamueq(i,k-1) * dz factor = 1. + tem ! qcko(i,k,n) = ((1.-tem)*qcko(i,k-1,n)+tem* diff --git a/physics/mfscuq.f b/physics/mfscuq.f index 3390c3e58..3c54b0bda 100644 --- a/physics/mfscuq.f +++ b/physics/mfscuq.f @@ -11,7 +11,7 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt, & cnvflg,zl,zm,q1,t1,u1,v1,plyr,pix, & thlx,thvx,thlvx,gdx,thetae, & krad,mrad,radmin,buo,xmfd, - & tcdo,qcdo,ucdo,vcdo,xlamde,a1) + & tcdo,qcdo,ucdo,vcdo,xlamdeq,a1) ! use machine , only : kind_phys use funcphys , only : fpvs @@ -39,7 +39,7 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt, & buo(im,km), xmfd(im,km), & tcdo(im,km), qcdo(im,km,ntrac1), & ucdo(im,km), vcdo(im,km), - & xlamde(im,km-1) + & xlamdeq(im,km-1) ! ! local variables and arrays ! @@ -47,7 +47,8 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt, integer i,j,indx, k, n, kk, ndc integer krad1(im) ! - real(kind=kind_phys) dt2, dz, ce0, cm, + real(kind=kind_phys) dt2, dz, ce0, + & cm, cq, & gocp, factor, g, tau, & b1, f1, bb1, bb2, & a1, a2, @@ -62,7 +63,7 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt, ! real(kind=kind_phys) wd2(im,km), thld(im,km), & qtx(im,km), qtd(im,km), - & thlvd(im), hrad(im), + & thlvd(im), hrad(im), xlamde(im,km-1), & xlamdem(im,km-1), ra1(im) real(kind=kind_phys) delz(im), xlamax(im) ! @@ -77,7 +78,7 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt, parameter(g=grav) parameter(gocp=g/cp) parameter(elocp=hvap/cp,el2orc=hvap*hvap/(rv*cp)) - parameter(ce0=0.4,cm=1.0,pgcon=0.55) + parameter(ce0=0.4,cm=1.0,cq=1.3,pgcon=0.55) parameter(qmin=1.e-8,qlmin=1.e-12) parameter(b1=0.45,f1=0.15) parameter(a2=0.5) @@ -208,6 +209,7 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt, xlamde(i,k) = xlamax(i) endif ! + xlamdeq(i,k) = cq * xlamde(i,k) xlamdem(i,k) = cm * xlamde(i,k) endif enddo @@ -224,6 +226,9 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt, ! thld(i,k) = ((1.-tem)*thld(i,k+1)+tem* & (thlx(i,k)+thlx(i,k+1)))/factor +! + tem = 0.5 * xlamdeq(i,k) * dz + factor = 1. + tem qtd(i,k) = ((1.-tem)*qtd(i,k+1)+tem* & (qtx(i,k)+qtx(i,k+1)))/factor ! @@ -347,6 +352,7 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt, xlamde(i,k) = xlamax(i) endif ! + xlamdeq(i,k) = cq * xlamde(i,k) xlamdem(i,k) = cm * xlamde(i,k) endif enddo @@ -457,6 +463,9 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt, ! thld(i,k) = ((1.-tem)*thld(i,k+1)+tem* & (thlx(i,k)+thlx(i,k+1)))/factor +! + tem = 0.5 * xlamdeq(i,k) * dz + factor = 1. + tem qtd(i,k) = ((1.-tem)*qtd(i,k+1)+tem* & (qtx(i,k)+qtx(i,k+1)))/factor ! @@ -509,7 +518,7 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt, if (cnvflg(i) .and. k < krad(i)) then if(k >= mrad(i)) then dz = zl(i,k+1) - zl(i,k) - tem = 0.5 * xlamde(i,k) * dz + tem = 0.5 * xlamdeq(i,k) * dz factor = 1. + tem ! qcdo(i,k,n) = ((1.-tem)*qcdo(i,k+1,n)+tem* @@ -532,7 +541,7 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt, if (cnvflg(i) .and. k < krad(i)) then if(k >= mrad(i)) then dz = zl(i,k+1) - zl(i,k) - tem = 0.5 * xlamde(i,k) * dz + tem = 0.5 * xlamdeq(i,k) * dz factor = 1. + tem ! qcdo(i,k,n) = ((1.-tem)*qcdo(i,k+1,n)+tem* diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index 292d5aa18..8ffd8040c 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -236,74 +236,6 @@ ! Many of these changes are now documented in references listed above. !==================================================================== - module bl_mynn_common - -!------------------------------------------ -!Define Model-specific constants/parameters. -!This module will be used at the initialization stage -!where all model-specific constants are read and saved into -!memory. This module is then used again in the MYNN-EDMF. All -!MYNN-specific constants are declared globally in the main -!module (module_bl_mynn) further below: -!------------------------------------------ - -! The following 5-6 lines are the only lines in this file that are not -! universal for all dycores... Any ideas how to universalize it? -! For MPAS: -! use mpas_kind_types,only: kind_phys => RKIND -! For CCPP: - use machine, only : kind_phys - - implicit none - save - -! To be specified from dycore - real(kind=kind_phys):: cp != 7.*r_d/2. (J/kg/K) - real(kind=kind_phys):: cpv != 4.*r_v (J/kg/K) Spec heat H2O gas - real(kind=kind_phys):: cice != 2106. (J/kg/K) Spec heat H2O ice - real(kind=kind_phys):: cliq != 4190. (J/kg/K) Spec heat H2O liq - real(kind=kind_phys):: p608 != R_v/R_d-1. - real(kind=kind_phys):: ep_2 != R_d/R_v - real(kind=kind_phys):: grav != accel due to gravity - real(kind=kind_phys):: karman != von Karman constant - real(kind=kind_phys):: t0c != temperature of water at freezing, 273.15 K - real(kind=kind_phys):: rcp != r_d/cp - real(kind=kind_phys):: r_d != 287. (J/kg/K) gas const dry air - real(kind=kind_phys):: r_v != 461.6 (J/kg/K) gas const water - real(kind=kind_phys):: xlf != 0.35E6 (J/kg) fusion at 0 C - real(kind=kind_phys):: xlv != 2.50E6 (J/kg) vaporization at 0 C - real(kind=kind_phys):: xls != 2.85E6 (J/kg) sublimation - real(kind=kind_phys):: rvovrd != r_v/r_d != 1.608 - -! Specified locally - real(kind=kind_phys),parameter:: zero = 0.0 - real(kind=kind_phys),parameter:: half = 0.5 - real(kind=kind_phys),parameter:: one = 1.0 - real(kind=kind_phys),parameter:: two = 2.0 - real(kind=kind_phys),parameter:: onethird = 1./3. - real(kind=kind_phys),parameter:: twothirds = 2./3. - real(kind=kind_phys),parameter:: tref = 300.0 ! reference temperature (K) - real(kind=kind_phys),parameter:: TKmin = 253.0 ! for total water conversion, Tripoli and Cotton (1981) - real(kind=kind_phys),parameter:: p1000mb=100000.0 - real(kind=kind_phys),parameter:: svp1 = 0.6112 !(kPa) - real(kind=kind_phys),parameter:: svp2 = 17.67 !(dimensionless) - real(kind=kind_phys),parameter:: svp3 = 29.65 !(K) - real(kind=kind_phys),parameter:: tice = 240.0 !-33 (C), temp at saturation w.r.t. ice - -! To be derived in the init routine - real(kind=kind_phys):: ep_3 != 1.-ep_2 != 0.378 - real(kind=kind_phys):: gtr != grav/tref - real(kind=kind_phys):: rk != cp/r_d - real(kind=kind_phys):: tv0 != p608*tref - real(kind=kind_phys):: tv1 != (1.+p608)*tref - real(kind=kind_phys):: xlscp != (xlv+xlf)/cp - real(kind=kind_phys):: xlvcp != xlv/cp - real(kind=kind_phys):: g_inv != 1./grav - - end module bl_mynn_common - -!================================================================== - MODULE module_bl_mynn use bl_mynn_common,only: & @@ -465,7 +397,7 @@ SUBROUTINE mynn_bl_driver( & &nchem,kdvel,ndvel, & !Smoke/Chem variables &chem3d, vdep, & &frp,EMIS_ANT_NO, & ! JLS/RAR to adjust exchange coeffs - &mix_chem,fire_turb, & ! end smoke/chem variables + &mix_chem,fire_turb,rrfs_smoke, & ! end smoke/chem variables &Tsq,Qsq,Cov, & &RUBLTEN,RVBLTEN,RTHBLTEN, & @@ -498,7 +430,8 @@ SUBROUTINE mynn_bl_driver( & &spp_pbl,pattern_spp_pbl, & &RTHRATEN, & &FLAG_QC,FLAG_QI,FLAG_QNC, & - &FLAG_QNI,FLAG_QNWFA,FLAG_QNIFA & + &FLAG_QNI,FLAG_QNWFA,FLAG_QNIFA, & + &FLAG_OZONE & &,IDS,IDE,JDS,JDE,KDS,KDE & &,IMS,IME,JMS,JME,KMS,KME & &,ITS,ITE,JTS,JTE,KTS,KTE) @@ -523,9 +456,9 @@ SUBROUTINE mynn_bl_driver( & REAL, INTENT(in) :: closure LOGICAL, INTENT(in) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC,& - FLAG_QNWFA,FLAG_QNIFA + FLAG_QNWFA,FLAG_QNIFA,FLAG_OZONE - LOGICAL, INTENT(IN) :: mix_chem,fire_turb + LOGICAL, INTENT(IN) :: mix_chem,fire_turb,rrfs_smoke INTEGER, INTENT(in) :: & & IDS,IDE,JDS,JDE,KDS,KDE & @@ -542,61 +475,65 @@ SUBROUTINE mynn_bl_driver( & ! closure : <= 2.5; Level 2.5 ! 2.5< and <3; Level 2.6 ! = 3; Level 3 + +! SGT: Changed this to use assumed shape arrays (dimension(:,:,:)) with no "optional" arguments +! to prevent a crash on Cheyenne. Do not change it back without testing if the code runs +! on Cheyenne with the GNU compiler. REAL, INTENT(in) :: delt - REAL, DIMENSION(IMS:IME), INTENT(in) :: dx - REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(in) :: dz, & + REAL, DIMENSION(:), INTENT(in) :: dx + REAL, DIMENSION(:,:), INTENT(in) :: dz, & &u,v,w,th,sqv3D,p,exner,rho,T3D - REAL, DIMENSION(IMS:IME,KMS:KME), OPTIONAL, INTENT(in):: & + REAL, DIMENSION(:,:), INTENT(in):: & &sqc3D,sqi3D,qni,qnc,qnwfa,qnifa - REAL, DIMENSION(IMS:IME,KMS:KME), OPTIONAL, INTENT(in):: ozone - REAL, DIMENSION(IMS:IME), INTENT(in) :: xland,ust, & + REAL, DIMENSION(:,:), INTENT(in):: ozone + REAL, DIMENSION(:), INTENT(in) :: xland,ust, & &ch,ts,qsfc,ps,hfx,qfx,wspd,uoce,voce,vdfg,znt - REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: & + REAL, DIMENSION(:,:), INTENT(inout) :: & &Qke,Tsq,Qsq,Cov,qke_adv - REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: & + REAL, DIMENSION(:,:), INTENT(inout) :: & &RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN,RQCBLTEN, & &RQIBLTEN,RQNIBLTEN,RQNCBLTEN, & &RQNWFABLTEN,RQNIFABLTEN - REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: DOZONE + REAL, DIMENSION(:,:), INTENT(inout) :: DOZONE - REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(in) :: RTHRATEN + REAL, DIMENSION(:,:), INTENT(in) :: RTHRATEN - REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(out) :: & + REAL, DIMENSION(:,:), INTENT(out) :: & &exch_h,exch_m !These 10 arrays are only allocated when bl_mynn_output > 0 - REAL, DIMENSION(IMS:IME,KMS:KME), OPTIONAL, INTENT(inout) :: & + REAL, DIMENSION(:,:), INTENT(inout) :: & & edmf_a,edmf_w,edmf_qt,edmf_thl,edmf_ent,edmf_qc, & & sub_thl3D,sub_sqv3D,det_thl3D,det_sqv3D ! REAL, DIMENSION(IMS:IME,KMS:KME) :: & ! & edmf_a_dd,edmf_w_dd,edmf_qt_dd,edmf_thl_dd,edmf_ent_dd,edmf_qc_dd - REAL, DIMENSION(IMS:IME), INTENT(inout) :: Pblh,rmol + REAL, DIMENSION(:), INTENT(inout) :: Pblh,rmol REAL, DIMENSION(IMS:IME) :: Psig_bl,Psig_shcu - INTEGER,DIMENSION(IMS:IME),INTENT(INOUT) :: & + INTEGER,DIMENSION(:),INTENT(INOUT) :: & &KPBL,nupdraft,ktop_plume - REAL, DIMENSION(IMS:IME), INTENT(OUT) :: & + REAL, DIMENSION(:), INTENT(OUT) :: & &maxmf - REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: & + REAL, DIMENSION(:,:), INTENT(inout) :: & &el_pbl - REAL, DIMENSION(IMS:IME,KMS:KME), optional, INTENT(out) :: & + REAL, DIMENSION(:,:), INTENT(out) :: & &qWT,qSHEAR,qBUOY,qDISS,dqke ! 3D budget arrays are not allocated when bl_mynn_tkebudget == .false. ! 1D (local) budget arrays are used for passing between subroutines. REAL, DIMENSION(kts:kte) :: qWT1,qSHEAR1,qBUOY1,qDISS1,dqke1,diss_heat - REAL, DIMENSION(IMS:IME,KMS:KME), intent(out) :: Sh3D,Sm3D + REAL, DIMENSION(:,:), intent(out) :: Sh3D,Sm3D - REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: & + REAL, DIMENSION(:,:), INTENT(inout) :: & &qc_bl,qi_bl,cldfra_bl REAL, DIMENSION(KTS:KTE) :: qc_bl1D,qi_bl1D,cldfra_bl1D,& qc_bl1D_old,qi_bl1D_old,cldfra_bl1D_old @@ -605,9 +542,9 @@ SUBROUTINE mynn_bl_driver( & INTEGER, INTENT(IN ) :: nchem, kdvel, ndvel ! REAL, DIMENSION( ims:ime, kms:kme, nchem ), INTENT(INOUT), optional :: chem3d ! REAL, DIMENSION( ims:ime, kdvel, ndvel ), INTENT(IN), optional :: vdep - REAL, DIMENSION(ims:ime, kms:kme, nchem), INTENT(INOUT), optional :: chem3d - REAL, DIMENSION(ims:ime, ndvel), INTENT(IN), optional :: vdep - REAL, DIMENSION(ims:ime), INTENT(IN), optional :: frp,EMIS_ANT_NO + REAL, DIMENSION(:, :, :), INTENT(INOUT) :: chem3d + REAL, DIMENSION(:, :), INTENT(IN) :: vdep + REAL, DIMENSION(:), INTENT(IN) :: frp,EMIS_ANT_NO !local REAL, DIMENSION(kts:kte ,nchem) :: chem1 REAL, DIMENSION(kts:kte+1,nchem) :: s_awchem1 @@ -654,7 +591,7 @@ SUBROUTINE mynn_bl_driver( & ! Stochastic fields INTEGER, INTENT(IN) ::spp_pbl - REAL, DIMENSION( ims:ime, kms:kme), INTENT(IN),OPTIONAL ::pattern_spp_pbl + REAL, DIMENSION( :, :), INTENT(IN) ::pattern_spp_pbl REAL, DIMENSION(KTS:KTE) ::rstoch_col ! Substepping TKE @@ -804,7 +741,7 @@ SUBROUTINE mynn_bl_driver( & QC_BL1D(k)=QC_BL(i,k) QI_BL1D(k)=QI_BL(i,k) ENDIF - IF (PRESENT(sqi3D) .AND. FLAG_QI ) THEN + IF (FLAG_QI ) THEN sqi(k)=sqi3D(i,k) !/(1.+qv(i,k)) sqw(k)=sqv(k)+sqc(k)+sqi(k) thl(k)=th1(k) - xlvcp/ex1(k)*sqc(k) & @@ -988,7 +925,7 @@ SUBROUTINE mynn_bl_driver( & dqnwfa1(k)=0.0 dqnifa1(k)=0.0 dozone1(k)=0.0 - IF(PRESENT(sqi3D) .AND. FLAG_QI)THEN + IF(FLAG_QI)THEN sqi(k)= sqi3D(i,k) !/(1.+qv(i,k)) qi1(k)= sqi(k)/(1.-sqv(k)) sqw(k)= sqv(k)+sqc(k)+sqi(k) @@ -1031,27 +968,27 @@ SUBROUTINE mynn_bl_driver( & thetav(k)=th1(k)*(1.+0.608*sqv(k)) thvl(k) =thlsg(k) *(1.+0.608*sqv(k)) - IF (PRESENT(qni) .AND. FLAG_QNI ) THEN + IF (FLAG_QNI ) THEN qni1(k)=qni(i,k) ELSE qni1(k)=0.0 ENDIF - IF (PRESENT(qnc) .AND. FLAG_QNC ) THEN + IF (FLAG_QNC ) THEN qnc1(k)=qnc(i,k) ELSE qnc1(k)=0.0 ENDIF - IF (PRESENT(qnwfa) .AND. FLAG_QNWFA ) THEN + IF (FLAG_QNWFA ) THEN qnwfa1(k)=qnwfa(i,k) ELSE qnwfa1(k)=0.0 ENDIF - IF (PRESENT(qnifa) .AND. FLAG_QNIFA ) THEN + IF (FLAG_QNIFA ) THEN qnifa1(k)=qnifa(i,k) ELSE qnifa1(k)=0.0 ENDIF - IF (PRESENT(ozone)) THEN + IF (FLAG_OZONE) THEN ozone1(k)=ozone(i,k) ELSE ozone1(k)=0.0 @@ -1115,7 +1052,7 @@ SUBROUTINE mynn_bl_driver( & ENDDO ! end k !initialize smoke/chem arrays (if used): - IF (mix_chem ) then + IF ( rrfs_smoke .and. mix_chem ) then do ic = 1,ndvel vd1(ic) = vdep(i,ic) !is this correct???? chem1(kts,ic) = chem3d(i,kts,ic) @@ -1412,7 +1349,7 @@ SUBROUTINE mynn_bl_driver( & &bl_mynn_mixscalars ) - IF ( mix_chem ) THEN + IF ( rrfs_smoke .and. mix_chem ) THEN CALL mynn_mix_chem(kts,kte,i, & &delt, dz1, pblh(i), & &nchem, kdvel, ndvel, & @@ -1425,13 +1362,11 @@ SUBROUTINE mynn_bl_driver( & &frp(i), & &fire_turb ) - IF ( PRESENT(chem3d) ) THEN - DO ic = 1,nchem - DO k = kts,kte - chem3d(i,k,ic) = chem1(k,ic) - ENDDO + DO ic = 1,nchem + DO k = kts,kte + chem3d(i,k,ic) = chem1(k,ic) ENDDO - ENDIF + ENDDO ENDIF CALL retrieve_exchange_coeffs(kts,kte,& @@ -1446,22 +1381,22 @@ SUBROUTINE mynn_bl_driver( & RTHBLTEN(i,k)=dth1(k) RQVBLTEN(i,k)=dqv1(k) IF(bl_mynn_cloudmix > 0)THEN - IF (PRESENT(sqc3D) .AND. FLAG_QC) RQCBLTEN(i,k)=dqc1(k) - IF (PRESENT(sqi3D) .AND. FLAG_QI) RQIBLTEN(i,k)=dqi1(k) + IF (FLAG_QC) RQCBLTEN(i,k)=dqc1(k) + IF (FLAG_QI) RQIBLTEN(i,k)=dqi1(k) ELSE - IF (PRESENT(sqc3D) .AND. FLAG_QC) RQCBLTEN(i,k)=0. - IF (PRESENT(sqi3D) .AND. FLAG_QI) RQIBLTEN(i,k)=0. + IF (FLAG_QC) RQCBLTEN(i,k)=0. + IF (FLAG_QI) RQIBLTEN(i,k)=0. ENDIF IF(bl_mynn_cloudmix > 0 .AND. bl_mynn_mixscalars > 0)THEN - IF (PRESENT(qnc) .AND. FLAG_QNC) RQNCBLTEN(i,k)=dqnc1(k) - IF (PRESENT(qni) .AND. FLAG_QNI) RQNIBLTEN(i,k)=dqni1(k) - IF (PRESENT(qnwfa) .AND. FLAG_QNWFA) RQNWFABLTEN(i,k)=dqnwfa1(k) - IF (PRESENT(qnifa) .AND. FLAG_QNIFA) RQNIFABLTEN(i,k)=dqnifa1(k) + IF (FLAG_QNC) RQNCBLTEN(i,k)=dqnc1(k) + IF (FLAG_QNI) RQNIBLTEN(i,k)=dqni1(k) + IF (FLAG_QNWFA) RQNWFABLTEN(i,k)=dqnwfa1(k) + IF (FLAG_QNIFA) RQNIFABLTEN(i,k)=dqnifa1(k) ELSE - IF (PRESENT(qnc) .AND. FLAG_QNC) RQNCBLTEN(i,k)=0. - IF (PRESENT(qni) .AND. FLAG_QNI) RQNIBLTEN(i,k)=0. - IF (PRESENT(qnwfa) .AND. FLAG_QNWFA) RQNWFABLTEN(i,k)=0. - IF (PRESENT(qnifa) .AND. FLAG_QNIFA) RQNIFABLTEN(i,k)=0. + IF (FLAG_QNC) RQNCBLTEN(i,k)=0. + IF (FLAG_QNI) RQNIBLTEN(i,k)=0. + IF (FLAG_QNWFA) RQNWFABLTEN(i,k)=0. + IF (FLAG_QNIFA) RQNIFABLTEN(i,k)=0. ENDIF DOZONE(i,k)=DOZONE1(k) @@ -5348,7 +5283,7 @@ SUBROUTINE mynn_mix_chem(kts,kte,i, & REAL, DIMENSION(kts:kte) :: rhoinv REAL, DIMENSION(kts:kte+1) :: rhoz,khdz REAL, PARAMETER :: no_threshold = 0.1 - REAL, PARAMETER :: frp_threshold = 1.0 ! JLS 12/21/21 + REAL, PARAMETER :: frp_threshold = 10.0 ! RAR 02/11/22: I increased the frp threshold to enhance mixing REAL, PARAMETER :: pblh_threshold = 250.0 dztop=.5*(dz(kte)+dz(kte-1)) @@ -5362,6 +5297,7 @@ SUBROUTINE mynn_mix_chem(kts,kte,i, & rhoz(kts) =rho(kts) rhoinv(kts)=1./rho(kts) khdz(kts) =rhoz(kts)*dfh(kts) + DO k=kts+1,kte rhoz(k) =(rho(k)*dz(k-1) + rho(k-1)*dz(k))/(dz(k-1)+dz(k)) rhoz(k) = MAX(rhoz(k),1E-4) diff --git a/physics/module_mp_nssl_2mom.F90 b/physics/module_mp_nssl_2mom.F90 new file mode 100644 index 000000000..b34fa755e --- /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 ) .and. f_cnatmp ) ) 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/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index d36fd2090..6624e0dbb 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -968,7 +968,7 @@ END SUBROUTINE thompson_init !> @{ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & nwfa, nifa, nwfa2d, nifa2d, & - tt, th, pii, & + aero_ind_fdb, tt, th, pii, & p, w, dz, dt_in, dt_inner, & sedi_semi, decfl, & RAINNC, RAINNCV, & @@ -984,7 +984,8 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & has_reqc, has_reqi, has_reqs, & rand_perturb_on, & kme_stoch, & - rand_pert, & + rand_pert, spp_prt_list, spp_var_list, & + spp_stddev_cutoff, n_var_spp, & ids,ide, jds,jde, kds,kde, & ! domain dims ims,ime, jms,jme, kms,kme, & ! memory dims its,ite, jts,jte, kts,kte, & ! tile dims @@ -1023,12 +1024,13 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT):: & nc, nwfa, nifa REAL, DIMENSION(ims:ime, jms:jme), OPTIONAL, INTENT(IN):: nwfa2d, nifa2d + LOGICAL, OPTIONAL, INTENT(IN):: aero_ind_fdb REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT):: & re_cloud, re_ice, re_snow - INTEGER, INTENT(IN) :: rand_perturb_on, kme_stoch - REAL, DIMENSION(:,:), INTENT(IN) :: & - rand_pert - + INTEGER, INTENT(IN) :: rand_perturb_on, kme_stoch, n_var_spp + REAL, DIMENSION(:,:), INTENT(IN) :: rand_pert + REAL, DIMENSION(:), INTENT(IN) :: spp_prt_list, spp_stddev_cutoff + CHARACTER(len=3), DIMENSION(:), INTENT(IN) :: spp_var_list INTEGER, INTENT(IN):: has_reqc, has_reqi, has_reqs #if ( WRF_CHEM == 1 ) REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: & @@ -1101,7 +1103,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & REAL, DIMENSION(its:ite, jts:jte):: pcp_ra, pcp_sn, pcp_gr, pcp_ic REAL:: dt, pptrain, pptsnow, pptgraul, pptice REAL:: qc_max, qr_max, qs_max, qi_max, qg_max, ni_max, nr_max - REAL:: rand1, rand2, rand3, min_rand + REAL:: rand1, rand2, rand3, rand_pert_max INTEGER:: i, j, k, m INTEGER:: imax_qc,imax_qr,imax_qi,imax_qs,imax_qg,imax_ni,imax_nr INTEGER:: jmax_qc,jmax_qr,jmax_qi,jmax_qs,jmax_qg,jmax_ni,jmax_nr @@ -1233,10 +1235,23 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & pcp_sn(:,:) = 0.0 pcp_gr(:,:) = 0.0 pcp_ic(:,:) = 0.0 + rand_pert_max = 0.0 ndt = max(nint(dt_in/dt_inner),1) dt = dt_in/ndt if(dt_in .le. dt_inner) dt= dt_in + !Get the Thompson MP SPP magnitude and standard deviation cutoff, + !then compute rand_pert_max + + if (rand_perturb_on .ne. 0) then + do k =1,n_var_spp + select case (spp_var_list(k)) + case('mp') + rand_pert_max = spp_prt_list(k)*spp_stddev_cutoff(k) + end select + enddo + endif + do it = 1, ndt qc_max = 0. @@ -1292,7 +1307,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & m = RSHIFT(ABS(rand_perturb_on),1) if (MOD(m,2) .ne. 0) rand2 = rand_pert(i,1)*2. m = RSHIFT(ABS(rand_perturb_on),2) - if (MOD(m,2) .ne. 0) rand3 = 0.25*(rand_pert(i,1)+ABS(min_rand)) + if (MOD(m,2) .ne. 0) rand3 = 0.25*(rand_pert(i,1)+rand_pert_max) m = RSHIFT(ABS(rand_perturb_on),3) endif !+---+-----------------------------------------------------------------+ @@ -1446,8 +1461,10 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & !.. Changed 13 May 2013 to fake emissions in which nwfa2d is aerosol !.. number tendency (number per kg per second). if (is_aerosol_aware) then + if ( .not. aero_ind_fdb) then nwfa1d(kts) = nwfa1d(kts) + nwfa2d(i,j)*dt nifa1d(kts) = nifa1d(kts) + nifa2d(i,j)*dt + endif do k = kts, kte nc(i,k,j) = nc1d(k) @@ -4109,7 +4126,14 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & do k = kte, kts, -1 vtg = 0. if (rg(k).gt. R1) then - vtg = rhof(k)*av_g*cgg(6)*ogg3 * ilamg(k)**bv_g + ygra1 = alog10(max(1.E-9, rg(k))) + zans1 = 3.0 + 2./7.*(ygra1+8.) + rand1 + N0_exp = 10.**(zans1) + N0_exp = MAX(DBLE(gonv_min), MIN(N0_exp, DBLE(gonv_max))) + lam_exp = (N0_exp*am_g*cgg(1)/rg(k))**oge1 + lamg = lam_exp * (cgg(3)*ogg2*ogg1)**obmg + + vtg = rhof(k)*av_g*cgg(6)*ogg3 * (1./lamg)**bv_g if (temp(k).gt. T_0) then vtgk(k) = MAX(vtg, vtrk(k)) else diff --git a/physics/module_sf_mynn.F90 b/physics/module_sf_mynn.F90 index 65e83c93d..0d81e145a 100644 --- a/physics/module_sf_mynn.F90 +++ b/physics/module_sf_mynn.F90 @@ -111,10 +111,6 @@ MODULE module_sf_mynn INTEGER, PARAMETER :: debug_code = 0 !0: no extra ouput !1: check input !2: everything - heavy I/O - LOGICAL, PARAMETER :: compute_diag = .false. - LOGICAL, PARAMETER :: compute_flux = .true. !shouldn't need compute - ! these in FV3. They will be written over anyway. - ! Computing the fluxes here is leftover from the WRF world. REAL, DIMENSION(0:1000 ),SAVE :: psim_stab,psim_unstab, & psih_stab,psih_unstab @@ -132,10 +128,11 @@ SUBROUTINE SFCLAY_mynn( & CP,G,ROVCP,R,XLV, & !in SVP1,SVP2,SVP3,SVPT0,EP1,EP2,KARMAN, & !in ISFFLX,isftcflx,lsm,lsm_ruc, & !in + compute_flux,compute_diag, & !in iz0tlnd,psi_opt, & !in - & sigmaf,vegtype,shdmax,ivegsrc, & !intent(in) - & z0pert,ztpert, & !intent(in) - & redrag,sfc_z0_type, & !intent(in) + sigmaf,vegtype,shdmax,ivegsrc, & !intent(in) + z0pert,ztpert, & !intent(in) + redrag,sfc_z0_type, & !intent(in) itimestep,iter,flag_iter, & !in wet, dry, icy, & !intent(in) tskin_wat, tskin_lnd, tskin_ice, & !intent(in) @@ -273,8 +270,9 @@ SUBROUTINE SFCLAY_mynn( & REAL, INTENT(IN) :: CP,G,ROVCP,R,XLV !,DX !NAMELIST/CONFIGURATION OPTIONS: INTEGER, INTENT(IN) :: ISFFLX, LSM, LSM_RUC - INTEGER, OPTIONAL, INTENT(IN) :: ISFTCFLX, IZ0TLND - INTEGER, OPTIONAL, INTENT(IN) :: spp_sfc, psi_opt + INTEGER, OPTIONAL, INTENT(IN) :: ISFTCFLX, IZ0TLND + INTEGER, OPTIONAL, INTENT(IN) :: spp_sfc, psi_opt + logical, intent(in) :: compute_flux,compute_diag integer, intent(in) :: ivegsrc integer, intent(in) :: sfc_z0_type ! option for calculating surface roughness length over ocean logical, intent(in) :: redrag ! reduced drag coeff. flag for high wind over sea (j.han) @@ -441,6 +439,7 @@ SUBROUTINE SFCLAY_mynn( & CP,G,ROVCP,R,XLV,SVP1,SVP2,SVP3,SVPT0, & EP1,EP2,KARMAN, & ISFFLX,isftcflx,iz0tlnd,psi_opt, & + compute_flux,compute_diag, & sigmaf,vegtype,shdmax,ivegsrc, & !intent(in) z0pert,ztpert, & !intent(in) redrag,sfc_z0_type, & !intent(in) @@ -488,6 +487,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & CP,G,ROVCP,R,XLV,SVP1,SVP2,SVP3,SVPT0, & EP1,EP2,KARMAN, & ISFFLX,isftcflx,iz0tlnd,psi_opt, & + compute_flux,compute_diag, & sigmaf,vegtype,shdmax,ivegsrc, & !intent(in) z0pert,ztpert, & !intent(in) redrag,sfc_z0_type, & !intent(in) @@ -543,6 +543,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !----------------------------- INTEGER, INTENT(IN) :: ISFFLX INTEGER, OPTIONAL, INTENT(IN ) :: ISFTCFLX, IZ0TLND + logical, intent(in) :: compute_flux,compute_diag INTEGER, INTENT(IN) :: spp_sfc, psi_opt integer, intent(in) :: ivegsrc integer, intent(in) :: sfc_z0_type ! option for calculating surface roughness length over ocean @@ -847,8 +848,8 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & DO I=its,ite ! CONVERT LOWEST LAYER TEMPERATURE TO POTENTIAL TEMPERATURE: - TH1D(I)=T1D(I)*THCON(I) !(Theta, K) - TC1D(I)=T1D(I)-273.15 !(T, Celsius) + TH1D(I)=T1D(I)*(100000./P1D(I))**ROVCP !(Theta, K) + TC1D(I)=T1D(I)-273.15 !(T, Celsius) ENDDO DO I=its,ite @@ -858,7 +859,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ENDDO DO I=its,ite - RHO1D(I)=PSFCPA(I)/(R*TV1D(I)) !now using value calculated in sfc driver + RHO1D(I)=P1D(I)/(R*TV1D(I)) !now using value calculated in sfc driver ZA(I)=0.5*dz8w1d(I) !height of first half-sigma level ZA2(I)=dz8w1d(I) + 0.5*dz2w1d(I) !height of 2nd half-sigma level GOVRTH(I)=G/TH1D(I) @@ -921,7 +922,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & DO I=its,ite if( flag_iter(i) ) then ! DH* 20200401 - note. A weird bug in Intel 18 on hera prevents using the - ! normal -O2 optimization in REPRO and PROD mode for this file. Not reproducible + ! normal -O2 optimization in Release mode for this file. Not reproducible ! by every user, the bug manifests itself in the resulting wind speed WSPD(I) ! being -99.0 despite the assignments in lines 932 and 933. *DH WSPD(I)=SQRT(U1D(I)*U1D(I)+V1D(I)*V1D(I)) @@ -1723,9 +1724,9 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & IF (wet(I)) THEN ! TO PREVENT OSCILLATIONS AVERAGE WITH OLD VALUE OLDUST = UST_wat(I) - UST_wat(I)=0.5*UST_wat(I)+0.5*KARMAN*WSPD(I)/PSIX_wat(I) + !UST_wat(I)=0.5*UST_wat(I)+0.5*KARMAN*WSPD(I)/PSIX_wat(I) !NON-AVERAGED: - !UST_wat(I)=KARMAN*WSPD(I)/PSIX_wat(I) + UST_wat(I)=KARMAN*WSPD(I)/PSIX_wat(I) stress_wat(i)=ust_wat(i)**2 ! Compute u* without vconv for use in HFX calc when isftcflx > 0 @@ -1890,7 +1891,8 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !---------------------------------- ! COMPUTE SURFACE HEAT FLUX: !---------------------------------- - HFX(I)=FLHC(I)*(THSK_lnd(I)-TH1D(I)) + !HFX(I)=FLHC(I)*(THSK_lnd(I)-TH1D(I)) + HFX(I)=RHO1D(I)*CPM(I)*KARMAN*WSPD(i)/PSIX_lnd(I)*KARMAN/PSIT_lnd(I)*(THSK_lnd(I)-TH1D(i)) HFX(I)=MAX(HFX(I),-250.) ! BWG, 2020-06-17: Mod next 2 lines for fractional HFLX_lnd(I)=HFX(I)/(RHO1D(I)*cpm(I)) @@ -1934,7 +1936,8 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !---------------------------------- ! COMPUTE SURFACE HEAT FLUX: !---------------------------------- - HFX(I)=FLHC(I)*(THSK_wat(I)-TH1D(I)) + !HFX(I)=FLHC(I)*(THSK_wat(I)-TH1D(I)) + HFX(I)=RHO1D(I)*CPM(I)*KARMAN*WSPD(i)/PSIX_wat(I)*KARMAN/PSIT_wat(I)*(THSK_wat(I)-TH1D(i)) IF ( PRESENT(ISFTCFLX) ) THEN IF ( ISFTCFLX.NE.0 ) THEN ! AHW: add dissipative heating term @@ -1981,7 +1984,8 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !---------------------------------- ! COMPUTE SURFACE HEAT FLUX: !---------------------------------- - HFX(I)=FLHC(I)*(THSK_ice(I)-TH1D(I)) + !HFX(I)=FLHC(I)*(THSK_ice(I)-TH1D(I)) + HFX(I)=RHO1D(I)*CPM(I)*KARMAN*WSPD(i)/PSIX_ice(I)*KARMAN/PSIT_ice(I)*(THSK_ice(I)-TH1D(i)) HFX(I)=MAX(HFX(I),-250.) ! BWG, 2020-06-17: Mod next 2 lines for fractional HFLX_ice(I)=HFX(I)/(RHO1D(I)*cpm(I)) @@ -2418,7 +2422,7 @@ SUBROUTINE edson_etal_2013(Z_0,ustar,wsp10,visc,zu) REAL, INTENT(IN) :: ustar, visc, wsp10, zu REAL, INTENT(OUT) :: Z_0 REAL, PARAMETER :: G=9.81 - REAL, PARAMETER :: m=0.017, b=-0.005 + REAL, PARAMETER :: m=0.0017, b=-0.005 REAL :: CZC ! variable charnock "constant" REAL :: wsp10m ! logarithmically calculated 10 m diff --git a/physics/module_sf_noahmp_glacier.f90 b/physics/module_sf_noahmp_glacier.f90 index 4c3a53c88..c4c03aaf8 100644 --- a/physics/module_sf_noahmp_glacier.f90 +++ b/physics/module_sf_noahmp_glacier.f90 @@ -62,6 +62,7 @@ module noahmp_glacier_globals INTEGER :: OPT_GLA != 1 !(suggested 1) INTEGER :: OPT_SFC != 1 !(suggested 1) + INTEGER :: OPT_TRS != 1 !(suggested 2) ! adjustable parameters for snow processes @@ -1129,8 +1130,10 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso real (kind=kind_phys) :: b !< temporary calculation real (kind=kind_phys) :: t, tdc !< kelvin to degree celsius with limit -50 to +50 real (kind=kind_phys), dimension( 1:nsoil) :: sice !< soil ice + real (kind=kind_phys) :: czil !< calculate roughness length of heat tdc(t) = min( 50., max(-50.,(t-tfrz)) ) + czil=0.1 ! ----------------------------------------------------------------- ! initialization variables that do not depend on stability iteration @@ -1155,10 +1158,18 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso fv = ur*vkc/log(zlvli/z0m) reyni = fv*z0m/(1.5e-05) !introduction of fv dependent z0h for the iter - if (reyni .gt. 2.0) then - z0h = z0m/exp(2.46*(reyni)**0.25 - log(7.4)) !Brutsaert 1982 - else - z0h = z0m/exp(-log(0.397)) !Brusaert 1982, table 4 + if (opt_trs == 1) then + z0h = z0m + elseif (opt_trs == 2) then + z0h = z0m*exp(-czil*0.4*258.2*sqrt(fv*z0m)) + elseif (opt_trs == 3) then + z0h = z0m*0.1 + elseif (opt_trs == 4) then + if (reyni .gt. 2.0) then + z0h = z0m/exp(2.46*(reyni)**0.25 - log(7.4)) !Brutsaert 1982 + else + z0h = z0m/exp(-log(0.397)) !Brusaert 1982, table 4 + endif endif z0h_total = z0h @@ -3328,7 +3339,8 @@ end subroutine error_glacier ! ================================================================================================== !>\ingroup NoahMP_LSM - subroutine noahmp_options_glacier(iopt_alb ,iopt_snf ,iopt_tbot, iopt_stc, iopt_gla, iopt_sfc) + subroutine noahmp_options_glacier(iopt_alb ,iopt_snf ,iopt_tbot, iopt_stc, iopt_gla,& + iopt_sfc, iopt_trs) implicit none @@ -3339,6 +3351,7 @@ subroutine noahmp_options_glacier(iopt_alb ,iopt_snf ,iopt_tbot, iopt_stc, iop !! 1 -> semi-implicit; 2 -> full implicit (original noah) integer, intent(in) :: iopt_gla !< glacier option (1->phase change; 2->simple) integer, intent(in) :: iopt_sfc !< sfc scheme option + integer, intent(in) :: iopt_trs !< thermal roughness option ! ------------------------------------------------------------------------------------------------- @@ -3348,6 +3361,7 @@ subroutine noahmp_options_glacier(iopt_alb ,iopt_snf ,iopt_tbot, iopt_stc, iop opt_stc = iopt_stc opt_gla = iopt_gla opt_sfc = iopt_sfc + opt_trs = iopt_trs end subroutine noahmp_options_glacier diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index 944446085..1c899e4bd 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -159,6 +159,11 @@ module module_sf_noahmplsm ! **0 -> no crop model, will run default dynamic vegetation ! 1 -> liu, et al. 2016 + integer :: opt_trs !< options for thermal roughness scheme + ! **1 -> z0h=z0 + ! 2 -> czil + ! 3 -> ec style + ! 4 -> kb inversed !------------------------------------------------------------------------------------------! ! physical constants: ! !------------------------------------------------------------------------------------------! @@ -673,18 +678,23 @@ subroutine noahmp_sflx (parameters, & real (kind=kind_phys) :: latheag !< latent heat vap./sublimation (j/kg) logical :: frozen_ground !< used to define latent heat pathway logical :: frozen_canopy !< used to define latent heat pathway - LOGICAL :: dveg_active !< flag to run dynamic vegetation - LOGICAL :: crop_active !< flag to run crop model + logical :: dveg_active !< flag to run dynamic vegetation + logical :: crop_active !< flag to run crop model +! add canopy heat storage (C.He added based on GY Niu's communication) + real :: canhs ! canopy heat storage change w/m2 +! maximum lai/sai used for some parameterizations based on plant growthi + ! intent (out) variables need to be assigned a value. these normally get assigned values ! only if dveg == 2. nee = 0.0 npp = 0.0 gpp = 0.0 - pahv = 0. - pahg = 0. - pahb = 0. - pah = 0. + pahv = 0. + pahg = 0. + pahb = 0. + pah = 0. + canhs = 0. ! -------------------------------------------------------------------------------------------------- ! re-process atmospheric forcing @@ -724,7 +734,7 @@ subroutine noahmp_sflx (parameters, & ! vegetation phenology call phenology (parameters,vegtyp ,croptype, snowh , tv , lat , yearlen , julian , & !in - lai , sai , troot , elai , esai ,igs, pgs) + lai , sai , troot , elai , esai ,igs, pgs) !input gvf should be consistent with lai if(dveg == 1 .or. dveg == 6 .or. dveg == 7) then @@ -768,8 +778,8 @@ subroutine noahmp_sflx (parameters, & sfctmp ,thair ,lwdn ,uu ,vv ,zlvl , & !in co2air ,o2air ,solad ,solai ,cosz ,igs , & !in eair ,tbot ,zsnso ,zsoil , & !in - elai ,esai ,fwet ,foln , & !in - fveg ,pahv ,pahg ,pahb , & !in + elai ,esai ,fwet ,foln , & !in + fveg ,shdfac, pahv ,pahg ,pahb , & !in qsnow ,dzsnso ,lat ,canliq ,canice ,iloc, jloc , & !in thsfc_loc, prslkix,prsik1x,prslk1x,garea1, & !in z0wrf ,z0hwrf , & !out @@ -792,7 +802,7 @@ subroutine noahmp_sflx (parameters, & t2mv ,t2mb ,fsrv , & fsrg ,rssun ,rssha ,albd ,albi ,albsnd,albsni, bgap ,wgap, tgv,tgb,& q1 ,q2v ,q2b ,q2e ,chv ,chb , & !out - emissi ,pah , & + emissi ,pah ,canhs, & shg,shc,shb,evg,evb,ghv,ghb,irg,irc,irb,tr,evc,chleaf,chuc,chv2,chb2 ) !out qsfc = q1 ! @@ -863,9 +873,9 @@ subroutine noahmp_sflx (parameters, & nsnow ,ist ,errwat ,iloc , jloc ,fveg , & sav ,sag ,fsrv ,fsrg ,zwt ,pah , & #ifdef CCPP - pahv ,pahg ,pahb ,errmsg, errflg) !in ( except errwat [out] and errmsg, errflg [inout] ) + pahv ,pahg ,pahb ,canhs,errmsg, errflg) !in ( except errwat [out] and errmsg, errflg [inout] ) #else - pahv ,pahg ,pahb ) !in ( except errwat, which is out ) + pahv ,pahg ,pahb, canhs ) !in ( except errwat, which is out ) #endif #ifdef CCPP @@ -1047,7 +1057,7 @@ end subroutine atm !!vegetation phenology considering vegetation canopy being buried by snow and !!evolution in time. subroutine phenology (parameters,vegtyp ,croptype, snowh , tv , lat , yearlen , julian , & !in - lai , sai , troot , elai , esai , igs, pgs) + lai , sai , troot , elai , esai , igs, pgs) ! -------------------------------------------------------------------------------------------------- ! vegetation phenology considering vegeation canopy being buries by snow and evolution in time @@ -1400,9 +1410,9 @@ subroutine error (parameters,swdown ,fsa ,fsr ,fira ,fsh ,fcev , & nsnow ,ist ,errwat, iloc ,jloc ,fveg , & sav ,sag ,fsrv ,fsrg ,zwt ,pah , & #ifdef CCPP - pahv ,pahg ,pahb ,errmsg, errflg) + pahv ,pahg ,pahb ,canhs,errmsg, errflg) #else - pahv ,pahg ,pahb ) + pahv ,pahg ,pahb ,canhs) #endif ! -------------------------------------------------------------------------------------------------- ! check surface energy balance and water balance @@ -1451,6 +1461,7 @@ subroutine error (parameters,swdown ,fsa ,fsr ,fira ,fsh ,fcev , & real (kind=kind_phys), intent(in) :: pahv !precipitation advected heat - total (w/m2) real (kind=kind_phys), intent(in) :: pahg !precipitation advected heat - total (w/m2) real (kind=kind_phys), intent(in) :: pahb !precipitation advected heat - total (w/m2) + real (kind=kind_phys), intent(in) :: canhs !canopy heat storage change (w/m2) C.He added based on GY Niu's communication #ifdef CCPP character(len=*) , intent(inout) :: errmsg @@ -1496,7 +1507,7 @@ subroutine error (parameters,swdown ,fsa ,fsr ,fira ,fsh ,fcev , & #endif end if - erreng = sav+sag-(fira+fsh+fcev+fgev+fctr+ssoil) +pah + erreng = sav+sag-(fira+fsh+fcev+fgev+fctr+ssoil+canhs) +pah ! erreng = fveg*sav+sag-(fira+fsh+fcev+fgev+fctr+ssoil) if(abs(erreng) > 0.01) then write(message,*) 'erreng =',erreng,' at i,j: ',iloc,jloc @@ -1546,6 +1557,12 @@ subroutine error (parameters,swdown ,fsa ,fsr ,fira ,fsh ,fcev , & errmsg = trim(errmsg)//NEW_LINE('A')//trim(message) #else call wrf_message(trim(message)) +#endif + write(message,'(a17,f10.4)') "canopy heat storage: ",canhs +#ifdef CCPP + errmsg = trim(errmsg)//NEW_LINE('A')//trim(message) +#else + call wrf_message(trim(message)) #endif write(message,'(a17,4f10.4)') "precip advected: ",pah,pahv,pahg,pahb #ifdef CCPP @@ -1599,8 +1616,8 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in sfctmp ,thair ,lwdn ,uu ,vv ,zref , & !in co2air ,o2air ,solad ,solai ,cosz ,igs , & !in eair ,tbot ,zsnso ,zsoil , & !in - elai ,esai ,fwet ,foln , & !in - fveg ,pahv ,pahg ,pahb , & !in + elai ,esai ,fwet ,foln , & !in + fveg ,shdfac, pahv ,pahg ,pahb , & !in qsnow ,dzsnso ,lat ,canliq ,canice ,iloc , jloc, & !in thsfc_loc, prslkix,prsik1x,prslk1x,garea1, & !in z0wrf ,z0hwrf , & !out @@ -1622,7 +1639,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in qc ,qsfc ,psfc , & !in t2mv ,t2mb ,fsrv , & fsrg ,rssun ,rssha ,albd ,albi,albsnd ,albsni,bgap ,wgap,tgv,tgb,& - q1 ,q2v ,q2b ,q2e ,chv ,chb, emissi,pah ,& + q1 ,q2v ,q2b ,q2e ,chv ,chb, emissi,pah,canhs,& shg,shc,shb,evg,evb,ghv,ghb,irg,irc,irb,tr,evc,chleaf,chuc,chv2,chb2 ) !out !jref:end @@ -1696,6 +1713,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in real (kind=kind_phys) , intent(in) :: esai !lai adjusted for burying by snow real (kind=kind_phys) , intent(in) :: fwet !fraction of canopy that is wet [-] real (kind=kind_phys) , intent(in) :: fveg !greeness vegetation fraction (-) + real (kind=kind_phys) , intent(in) :: shdfac !< green vegetation fraction [0.0-1.0] real (kind=kind_phys) , intent(in) :: lat !latitude (radians) real (kind=kind_phys) , intent(in) :: canliq !canopy-intercepted liquid water (mm) real (kind=kind_phys) , intent(in) :: canice !canopy-intercepted ice mass (mm) @@ -1769,6 +1787,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in real (kind=kind_phys) , intent(out) :: t2mb !2-m air temperature over bare ground part [k] real (kind=kind_phys) , intent(out) :: bgap real (kind=kind_phys) , intent(out) :: wgap + real (kind=kind_phys) , intent(out) :: canhs !canopy heat storage change (w/m2) real (kind=kind_phys), dimension(1:2) , intent(out) :: albd !albedo (direct) real (kind=kind_phys), dimension(1:2) , intent(out) :: albi !albedo (diffuse) real (kind=kind_phys), dimension(1:2) , intent(out) :: albsnd !snow albedo (direct) @@ -1890,6 +1909,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in real (kind=kind_phys) :: csigmaf0 real (kind=kind_phys) :: csigmaf1 real (kind=kind_phys) :: csigmafveg + real (kind=kind_phys) :: czil1 real (kind=kind_phys) :: cdmnv real (kind=kind_phys) :: ezpdv @@ -1934,26 +1954,21 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in chv2 = 0. rb = 0. -! - cdmnv = 0. - ezpdv = 0. - - cdmng = 0. - ezpdg = 0. - - cdmn = 0. - ezpd = 0. - - gsigma = 0. - - z0hwrf = 0. - csigmaf1 = 0. - csigmaf0 = 0. - csigmafveg= 0. - kbsigmafveg = 0. - aone = 0. - coeffa = 0. - coeffb = 0. + cdmnv = 0.0 + ezpdv = 0.0 + cdmng = 0.0 + ezpdg = 0.0 + cdmn = 0.0 + ezpd = 0.0 + gsigma = 0.0 + z0hwrf = 0.0 + csigmaf1 = 0.0 + csigmaf0 = 0.0 + csigmafveg= 0.0 + kbsigmafveg = 0.0 + aone = 0.0 + coeffa = 0.0 + coeffb = 0.0 ! @@ -2026,7 +2041,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in call thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , & !in dt ,snowh ,snice ,snliq , & !in smc ,sh2o ,tg ,stc ,ur , & !in - lat ,z0m ,zlvl ,vegtyp , & !in + lat ,z0m ,zlvl ,vegtyp , & !in df ,hcpct ,snicev ,snliqv ,epore , & !out fact ) !out @@ -2151,7 +2166,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in uu ,vv ,sfctmp ,thair ,qair , & !in eair ,rhoair ,snowh ,vai ,gammav ,gammag , & !in fwet ,laisun ,laisha ,cwp ,dzsnso , & !in - zlvl ,zpd ,z0m ,fveg , & !in + zlvl ,zpd ,z0m ,fveg ,shdfac, & !in z0mg ,emv ,emg ,canliq ,fsno, & !in canice ,stc ,df ,rssun ,rssha , & !in rsurf ,latheav ,latheag ,parsun ,parsha ,igs , & !in @@ -2166,14 +2181,17 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in #endif tauxv ,tauyv ,irg ,irc ,shg , & !out shc ,evg ,evc ,tr ,ghv , & !out - t2mv ,psnsun ,psnsha ,csigmaf1, & !out + t2mv ,psnsun ,psnsha ,canhs , & !out + csigmaf1, & !out !jref:start qc ,qsfc ,psfc , & !in q2v ,chv2, chleaf, chuc) !inout - cdmnv = 0.4*0.4/log((zlvl-zpd)/z0m)**2 - aone = 2.6*(10.0*parameters%hvt/(zlvl-zpd))**0.355 - ezpdv = zpd*fveg !for the grid +! new coupling code + + cdmnv = 0.4*0.4/log((zlvl-zpd)/z0m)**2 + aone = 2.6*(10.0*parameters%hvt/(zlvl-zpd))**0.355 + ezpdv = zpd*fveg !for the grid !jref:end #ifdef CCPP @@ -2190,7 +2208,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in dzsnso ,zlvl ,zpdg ,z0mg ,fsno, & !in emg ,stc ,df ,rsurf ,latheag , & !in gammag ,rhsur ,iloc ,jloc ,q2 ,pahb , & !in - thsfc_loc, prslkix,prsik1x,prslk1x,fveg,garea1, & !in + thsfc_loc, prslkix,prsik1x,prslk1x,fveg,shdfac,garea1, & !in #ifdef CCPP tgb ,cmb ,chb, ustarx,errmsg ,errflg , & !inout #else @@ -2202,18 +2220,20 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in qc ,qsfc ,psfc , & !in sfcprs ,q2b, chb2) !in - cdmng = 0.4*0.4/log((zlvl-zpdg)/z0mg)**2 - ezpdg = zpdg +! new coupling code + + cdmng = 0.4*0.4/log((zlvl-zpdg)/z0mg)**2 + ezpdg = zpdg ! ! vegetation is optional; use the larger one ! - if (ezpdv .ge. ezpdg ) then - ezpd = ezpdv - elseif (ezpdv .gt. 0.0 .and. ezpdv .lt. ezpdg) then - ezpd = (1.0 -fveg)*ezpdg - else - ezpd = ezpdg - endif + if (ezpdv .ge. ezpdg ) then + ezpd = ezpdv + elseif (ezpdv .gt. 0.0 .and. ezpdv .lt. ezpdg) then + ezpd = (1.0 -fveg)*ezpdg + else + ezpd = ezpdg + endif !jref:end #ifdef CCPP @@ -2241,6 +2261,26 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in q1 = fveg * (eah*0.622/(sfcprs - 0.378*eah)) + (1.0 - fveg)*qsfc q2e = fveg * q2v + (1.0 - fveg) * q2b +! new coupling code + + if (opt_trs == 1) then + z0wrf = fveg * z0m + (1.0 - fveg) * z0mg + z0hwrf = z0wrf + elseif (opt_trs == 2) then + z0wrf = fveg * z0m + (1.0 - fveg) * z0mg +! z0hwrf = fveg * z0m*exp(-parameters%czil*0.4*258.2*sqrt(ustarx*z0m)) & +! +(1.0 - fveg) * z0mg*exp(-parameters%czil*0.4*258.2*sqrt(ustarx*z0mg)) + czil1=10.0 ** (- (0.40/0.07) * parameters%hvt) + z0hwrf = fveg * z0m*exp(-czil1*0.4*258.2*sqrt(ustarx*z0m)) & + +(1.0 - fveg) * z0mg*exp(-czil1*0.4*258.2*sqrt(ustarx*z0mg)) + elseif (opt_trs == 3) then + z0wrf = fveg * z0m + (1.0 - fveg) * z0mg + if (vegtyp.le.5) then + z0hwrf = fveg * z0m + (1.0 - fveg) * z0mg*0.1 + else + z0hwrf = fveg * z0m*0.01 + (1.0 - fveg) * z0mg*0.1 + endif + elseif (opt_trs == 4) then coeffa = (csigmaf0 - csigmaf1)/(1.0 - exp(-1.0*aone)) coeffb = csigmaf0 - coeffa csigmafveg = coeffa * exp(-1.0*aone*fveg) + coeffb @@ -2259,6 +2299,9 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in kbsigmafveg = csigmafveg/log((zlvl-ezpd)/z0wrf) - log((zlvl-ezpd)/z0wrf) z0hwrf = z0wrf/exp(kbsigmafveg) +! place holder doe other roughness scheme +! elseif (opt_trs == x) then + endif else taux = tauxb @@ -2283,7 +2326,21 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in chv = chb z0wrf = z0mg + if (opt_trs == 1) then + z0hwrf = z0wrf + elseif (opt_trs == 2) then +! z0hwrf = z0wrf*exp(-parameters%czil*0.4*258.2*sqrt(ustarx*z0wrf)) + czil1=10.0 ** (- (0.40/0.07) * parameters%hvt) + z0hwrf = z0wrf*exp(-czil1*0.4*258.2*sqrt(ustarx*z0wrf)) + elseif (opt_trs == 3) then + if (vegtyp.le.5) then + z0hwrf = z0wrf + else + z0hwrf = z0wrf*0.01 + endif + elseif (opt_trs == 4) then z0hwrf =z0wrf/exp( csigmaf0/log((zlvl-ezpd)/z0wrf) - log((zlvl-ezpd)/z0wrf) ) + endif end if @@ -2399,7 +2456,7 @@ subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , real (kind=kind_phys), intent(in) :: lat !latitude (radians) real (kind=kind_phys), intent(in) :: z0m !roughness length (m) real (kind=kind_phys), intent(in) :: zlvl !reference height (m) - integer , intent(in) :: vegtyp !vegtyp type + integer , intent(in) :: vegtyp !vegtyp type ! outputs real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(out) :: df !thermal conductivity [w/m/k] @@ -2415,6 +2472,7 @@ subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , real (kind=kind_phys), dimension(-nsnow+1: 0) :: cvsno !volumetric specific heat (j/m3/k) real (kind=kind_phys), dimension(-nsnow+1: 0) :: tksno !snow thermal conductivity (j/m3/k) real (kind=kind_phys), dimension( 1:nsoil) :: sice !soil ice content + real (kind=kind_phys), parameter :: sbeta = -2.0 ! -------------------------------------------------------------------------------------------------- ! compute snow thermal conductivity and heat capacity @@ -3592,8 +3650,8 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & dt ,sav ,sag ,lwdn ,ur , & !in uu ,vv ,sfctmp ,thair ,qair , & !in eair ,rhoair ,snowh ,vai ,gammav ,gammag, & !in - fwet ,laisun ,laisha ,cwp ,dzsnso , & !in - zlvl ,zpd ,z0m ,fveg, & !in + fwet ,laisun ,laisha ,cwp ,dzsnso , & !in + zlvl ,zpd ,z0m ,fveg ,shdfac, & !in z0mg ,emv ,emg ,canliq ,fsno, & !in canice ,stc ,df ,rssun ,rssha , & !in rsurf ,latheav ,latheag ,parsun ,parsha ,igs , & !in @@ -3608,7 +3666,8 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & #endif tauxv ,tauyv ,irg ,irc ,shg , & !out shc ,evg ,evc ,tr ,gh , & !out - t2mv ,psnsun ,psnsha ,csigmaf1, & !out + t2mv ,psnsun ,psnsha ,canhs , & !out + csigmaf1, & !out qc ,qsfc ,psfc , & !in q2v ,cah2 ,chleaf ,chuc ) !inout @@ -3617,7 +3676,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & ! ground (tg) temperatures that balance the surface energy budgets ! vegetated: -! -sav + irc[tv] + shc[tv] + evc[tv] + tr[tv] = 0 +! -sav + irc[tv] + shc[tv] + evc[tv] + tr[tv] + canhs[tv] = 0 ! -sag + irg[tg] + shg[tg] + evg[tg] + gh[tg] = 0 ! -------------------------------------------------------------------------------------------------- implicit none @@ -3646,12 +3705,6 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & real (kind=kind_phys), intent(in) :: dt !time step (s) real (kind=kind_phys), intent(in) :: fsno !snow fraction - logical , intent(in) :: thsfc_loc - real (kind=kind_phys) , intent(in) :: prslkix ! in exner function - real (kind=kind_phys) , intent(in) :: prsik1x ! in exner function - real (kind=kind_phys) , intent(in) :: prslk1x ! in exner function - real (kind=kind_phys) , intent(in) :: garea1 ! - real (kind=kind_phys), intent(in) :: snowh !actual snow depth [m] real (kind=kind_phys), intent(in) :: fwet !wetted fraction of canopy real (kind=kind_phys), intent(in) :: cwp !canopy wind parameter @@ -3704,7 +3757,6 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & real (kind=kind_phys), intent(inout) :: tg !ground temperature (k) real (kind=kind_phys), intent(inout) :: cm !momentum drag coefficient real (kind=kind_phys), intent(inout) :: ch !sensible heat exchange coefficient - real (kind=kind_phys), intent(inout) :: ustarx !< friction velocity #ifdef CCPP character(len=*), intent(inout) :: errmsg @@ -3712,7 +3764,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & #endif ! output -! -fsa + fira + fsh + (fcev + fctr + fgev) + fcst + ssoil = 0 +! -fsa + fira + fsh + (fcev + fctr + fgev) + fcst + ssoil + canhs = 0 real (kind=kind_phys), intent(out) :: tauxv !wind stress: e-w (n/m2) real (kind=kind_phys), intent(out) :: tauyv !wind stress: n-s (n/m2) real (kind=kind_phys), intent(out) :: irc !net longwave radiation (w/m2) [+= to atm] @@ -3726,10 +3778,9 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & real (kind=kind_phys), intent(out) :: t2mv !2 m height air temperature (k) real (kind=kind_phys), intent(out) :: psnsun !sunlit leaf photosynthesis (umolco2/m2/s) real (kind=kind_phys), intent(out) :: psnsha !shaded leaf photosynthesis (umolco2/m2/s) - real (kind=kind_phys), intent(out) :: csigmaf1 real (kind=kind_phys), intent(out) :: chleaf !leaf exchange coefficient real (kind=kind_phys), intent(out) :: chuc !under canopy exchange coefficient - + real (kind=kind_phys), intent(out) :: canhs !canopy heat storage change (w/m2) real (kind=kind_phys), intent(out) :: q2v real (kind=kind_phys) :: cah !sensible heat conductance, canopy air to zlvl air (m/s) real (kind=kind_phys) :: u10v !10 m wind speed in eastward dir (m/s) @@ -3777,6 +3828,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & real (kind=kind_phys) :: fm !momentum stability correction, weighted by prior iters real (kind=kind_phys) :: fh !sen heat stability correction, weighted by prior iters real (kind=kind_phys) :: fhg !sen heat stability correction, ground + real (kind=kind_phys) :: fhgh !sen heat stability correction, canopy real (kind=kind_phys) :: hcan !canopy height (m) [note: hcan >= z0mg] real (kind=kind_phys) :: a !temporary calculation @@ -3799,22 +3851,6 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & real (kind=kind_phys) :: ch2 !surface exchange at 2m real (kind=kind_phys) :: thstar !surface exchange at 2m - real (kind=kind_phys) :: dlf ! leaf dimension - real(kind=kind_phys) :: sigmaa ! momentum partition parameter - real(kind=kind_phys) :: kbsigmaf1 ! kb^-1 for fully convered by vegetation - real(kind=kind_phys) :: kbsigmafc ! kb^-1 under canopy ground - - real (kind=kind_phys) :: fm10 !monin-obukhov momentum adjustment at 10m - real (kind=kind_phys) :: rb1v !Bulk Richardson # over vegetation - real (kind=kind_phys) :: stress1v !Stress over vegetation - real (kind=kind_phys) :: snwd - real (kind=kind_phys) :: virtfacv - real (kind=kind_phys) :: thv1v - real (kind=kind_phys) :: tvsv - real (kind=kind_phys) :: tv1v - real (kind=kind_phys) :: zlvlv - - real (kind=kind_phys) :: thvair real (kind=kind_phys) :: thah real (kind=kind_phys) :: rahc2 !aerodynamic resistance for sensible heat (s/m) @@ -3823,17 +3859,14 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & real (kind=kind_phys) :: ch2v !exchange coefficient for 2m over vegetation. real (kind=kind_phys) :: cq2v !exchange coefficient for 2m over vegetation. real (kind=kind_phys) :: eah2 !2m vapor pressure over canopy - real (kind=kind_phys) :: qfx !moisture flux + real (kind=kind_phys) :: qfx !moisture flux real (kind=kind_phys) :: e1 - + real (kind=kind_phys) :: hcv !canopy heat capacity j/m2/k, C.He added real (kind=kind_phys) :: vaie !total leaf area index + stem area index,effective real (kind=kind_phys) :: laisune !sunlit leaf area index, one-sided (m2/m2),effective real (kind=kind_phys) :: laishae !shaded leaf area index, one-sided (m2/m2),effective - real(kind=kind_phys) :: tem1,tem2,zvfun1,gdx - real(kind=kind_phys), parameter :: z0lo=0.1, z0up=1.0 - integer :: k !index integer :: iter !iteration index @@ -3846,8 +3879,17 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & integer :: liter !last iteration - integer :: niter !for sfcdiff3 +! New variables for sfcdif3 + logical , intent(in ) :: thsfc_loc + real (kind=kind_phys), intent(in ) :: prslkix ! in exner function + real (kind=kind_phys), intent(in ) :: prsik1x ! in exner function + real (kind=kind_phys), intent(in ) :: prslk1x ! in exner function + real (kind=kind_phys), intent(in ) :: garea1 + real (kind=kind_phys), intent(in ) :: shdfac ! greeness vegetation fraction (-) + real (kind=kind_phys), intent(inout) :: ustarx ! friction velocity + real (kind=kind_phys), intent( out) :: csigmaf1 ! + real (kind=kind_phys) :: czil1 ! canopy based czil real (kind=kind_phys) :: t, tdc !kelvin to degree celsius with limit -50 to +50 @@ -3860,10 +3902,6 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & liter = 0 fv = ustarx - - niter = 1 - if (ur < 2.0) niter = 2 - ! --------------------------------------------------------------------------------------------- ! initialization variables that do not depend on stability iteration ! --------------------------------------------------------------------------------------------- @@ -3877,30 +3915,12 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & h = 0. qfx = 0. - csigmaf1 = 0. - ! limit lai vaie = min(6.,vai ) laisune = min(6.,laisun) laishae = min(6.,laisha) -! for sfcdiff3 - - snwd = snowh*1000.0 - zlvlv = zlvl - zpd - - virtfacv = 1.0 + 0.61 * max(qair, 1.e-8) - tv1v = sfctmp * virtfacv - - if(thsfc_loc) then ! Use local potential temperature - thv1v = sfctmp * prslkix * virtfacv - else ! Use potential temperature reference to 1000 hPa - thv1v = sfctmp / prslk1x * virtfacv - endif -! - - ! saturation vapor pressure at ground temperature t = tdc(tg) @@ -3915,8 +3935,6 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & qsfc = 0.622*eair/(psfc-0.378*eair) - dlf = parameters%dleaf !leaf dimension - ! canopy height hcan = parameters%hvt @@ -3964,30 +3982,27 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & air = -emv*(1.+(1.-emv)*(1.-emg))*lwdn - emv*emg*sb*tg**4 cir = (2.-emv*(1.-emg))*emv*sb ! --------------------------------------------------------------------------------------------- - - sigmaa = 1.0 - (0.5/(0.5+vaie))*exp(-vaie**2/8.0) - kbsigmaf1 = 16.4*(sigmaa*vaie**3)**(-0.25)*sqrt(dlf*ur/log((zlvl-zpd)/z0m)) - z0h = z0m/exp(kbsigmaf1) - csigmaf1 = log((zlvl-zpd)/z0m)*(log((zlvl-zpd)/z0m)+kbsigmaf1) ! for output for interpolation - -! -- - tem1 = (z0m - z0lo) / (z0up - z0lo) - tem1 = min(max(tem1, 0.0_kind_phys), 1.0_kind_phys) - tem2 = max(fveg, 0.1_kind_phys) - zvfun1= sqrt(tem1 * tem2) - gdx=sqrt(garea1) - if(opt_sfc == 1 .or. opt_sfc == 2) then - loop1: do iter = 1, niterc ! begin stability iteration -! use newly derived z0m/z0h - if(iter == 1) then z0hg = z0mg else z0hg = z0mg !* exp(-czil*0.4*258.2*sqrt(fv*z0mg)) end if + if (opt_trs == 1) then + z0h = z0m + elseif (opt_trs == 2) then + czil1= 10.0 ** (- (0.40/0.07) * parameters%hvt) + z0h = z0m*exp(-czil1*0.4*258.2*sqrt(fv*z0m)) + elseif (opt_trs == 3) then + if (vegtyp.le.5) then + z0h = z0m + else + z0h = z0m*0.01 + endif + endif + ! aerodyn resistances between heights zlvl and d+z0v if(opt_sfc == 1) then @@ -4016,6 +4031,15 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & cm = cm / ur endif + if(opt_sfc == 3) then + call sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in + zlvl ,tah ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in + zpd ,snowh ,shdfac ,garea1 ,.true. ,vaie ,vegtyp, & !in + ustarx ,fm ,fh ,fm2 ,fh2 , & !inout + z0h ,fv ,csigmaf1,cm ,ch ) !out + + endif + ramc = max(1.,1./(cm*ur)) rahc = max(1.,1./(ch*ur)) rawc = rahc @@ -4026,7 +4050,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & call ragrb(parameters,iter ,vaie ,rhoair ,hg ,tah , & !in zpd ,z0mg ,z0hg ,hcan ,uc , & !in z0h ,fv ,cwp ,vegtyp ,mpe , & !in - tv ,mozg ,fhg ,iloc ,jloc , & !inout + tv ,mozg ,fhg ,fhgh ,iloc ,jloc , & !inout ramg ,rahg ,rawg ,rb ) !out ! es and d(es)/dt evaluated at tv @@ -4102,14 +4126,19 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & evc = min(canice*latheav/dt,evc) end if +! canopy heat capacity + hcv = 0.02*vaie*cwat + canliq*cwat/denh2o + canice*cice/denice !j/m2/k + b = sav-irc-shc-evc-tr+pahv !additional w/m2 - a = fveg*(4.*cir*tv**3 + csh + (cev+ctr)*destv) !volumetric heat capacity +! a = fveg*(4.*cir*tv**3 + csh + (cev+ctr)*destv) !volumetric heat capacity + a = fveg*(4.*cir*tv**3 + csh + (cev+ctr)*destv) + hcv/dt !volumetric heat capacity dtv = b/a irc = irc + fveg*4.*cir*tv**3*dtv shc = shc + fveg*csh*dtv evc = evc + fveg*cev*destv*dtv tr = tr + fveg*ctr*destv*dtv + canhs = dtv*hcv/dt ! update vegetation surface temperature tv = tv + dtv @@ -4131,135 +4160,6 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & end do loop1 ! end stability iteration - endif !opt_sfc 1 or 2 -! -! sfcdiff3 -! - if (opt_sfc == 3) then - - z0hg = z0mg - - do iter = 1, niter !1 or 2; depending on ur - - if(thsfc_loc) then ! Use local potential temperature - tvsv = tah * virtfacv - else ! Use potential temperature referenced to 1000 hPa - tvsv = tah/prsik1x * virtfacv - endif - - call stability & - (zlvlv, zvfun1, gdx,tv1v,thv1v, ur, z0m, z0h, tvsv, grav,thsfc_loc, & - rb1v, fm,fh,fm10,fh2,cm,ch,stress1v,fv) - - ramc = max(1.,1./(cm*ur)) - rahc = max(1.,1./(ch*ur)) - rawc = rahc - -! aerodyn resistance between heights z0g and d+z0v, rag, and leaf -! boundary layer resistance, rb - - call ragrb(parameters,iter ,vaie ,rhoair ,hg ,tah , & !in - zpd ,z0mg ,z0hg ,hcan ,uc , & !in - z0h ,fv ,cwp ,vegtyp ,mpe , & !in - tv ,mozg ,fhg ,iloc ,jloc , & !inout - ramg ,rahg ,rawg ,rb ) !out - -! es and d(es)/dt evaluated at tv - - t = tdc(tv) - call esat(t, esatw, esati, dsatw, dsati) - if (t .gt. 0.) then - estv = esatw - destv = dsatw - else - estv = esati - destv = dsati - end if - -! stomatal resistance - - if(iter == 1) then - if (opt_crs == 1) then ! ball-berry - call stomata (parameters,vegtyp,mpe ,parsun ,foln ,iloc , jloc , & !in - tv ,estv ,eah ,sfctmp,sfcprs, & !in - o2air ,co2air,igs ,btran ,rb , & !in - rssun ,psnsun) !out - - call stomata (parameters,vegtyp,mpe ,parsha ,foln ,iloc , jloc , & !in - tv ,estv ,eah ,sfctmp,sfcprs, & !in - o2air ,co2air,igs ,btran ,rb , & !in - rssha ,psnsha) !out - end if - - if (opt_crs == 2) then ! jarvis - call canres (parameters,parsun,tv ,btran ,eah ,sfcprs, & !in - rssun ,psnsun,iloc ,jloc ) !out - - call canres (parameters,parsha,tv ,btran ,eah ,sfcprs, & !in - rssha ,psnsha,iloc ,jloc ) !out - end if - end if - -! prepare for sensible heat flux above veg. - - cah = 1./rahc - cvh = 2.*vaie/rb - cgh = 1./rahg - cond = cah + cvh + cgh - ata = (sfctmp*cah + tg*cgh) / cond - bta = cvh/cond - csh = (1.-bta)*rhoair*cpair*cvh - -! prepare for latent heat flux above veg. - - caw = 1./rawc - cew = fwet*vaie/rb - ctw = (1.-fwet)*(laisune/(rb+rssun) + laishae/(rb+rssha)) - cgw = 1./(rawg+rsurf) - cond = caw + cew + ctw + cgw - aea = (eair*caw + estg*cgw) / cond - bea = (cew+ctw)/cond - cev = (1.-bea)*cew*rhoair*cpair/gammav ! barlage: change to vegetation v3.6 - ctr = (1.-bea)*ctw*rhoair*cpair/gammav - -! evaluate surface fluxes with current temperature and solve for dts - - tah = ata + bta*tv ! canopy air t. - eah = aea + bea*estv ! canopy air e - - irc = fveg*(air + cir*tv**4) - shc = fveg*rhoair*cpair*cvh * ( tv-tah) - evc = fveg*rhoair*cpair*cew * (estv-eah) / gammav ! barlage: change to v in v3.6 - tr = fveg*rhoair*cpair*ctw * (estv-eah) / gammav - if (tv > tfrz) then - evc = min(canliq*latheav/dt,evc) ! barlage: add if block for canice in v3.6 - else - evc = min(canice*latheav/dt,evc) - end if - - b = sav-irc-shc-evc-tr+pahv !additional w/m2 - a = fveg*(4.*cir*tv**3 + csh + (cev+ctr)*destv) !volumetric heat capacity - dtv = b/a - - irc = irc + fveg*4.*cir*tv**3*dtv - shc = shc + fveg*csh*dtv - evc = evc + fveg*cev*destv*dtv - tr = tr + fveg*ctr*destv*dtv - -! update vegetation surface temperature - tv = tv + dtv -! tah = ata + bta*tv ! canopy air t; update here for consistency - -! for computing m-o length in the next iteration - h = rhoair*cpair*(tah - sfctmp) /rahc - hg = rhoair*cpair*(tg - tah) /rahg - -! consistent specific humidity from canopy air vapor pressure - qsfc = (0.622*eah)/(sfcprs-0.378*eah) - - enddo ! iteration - endif ! sfcdiff3 - ! under-canopy fluxes and tg air = - emg*(1.-emv)*lwdn - emg*emv*sb*tv**4 @@ -4359,13 +4259,14 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & dzsnso ,zlvl ,zpd ,z0m ,fsno , & !in emg ,stc ,df ,rsurf ,lathea , & !in gamma ,rhsur ,iloc ,jloc ,q2 ,pahb , & !in - thsfc_loc, prslkix,prsik1x,prslk1x,fveg,garea1, & !in + thsfc_loc, prslkix,prsik1x,prslk1x,fveg,shdfac,garea1, & !in #ifdef CCPP tgb ,cm ,ch,ustarx,errmsg ,errflg , & !inout #else tgb ,cm ,ch,ustarx, & !inout #endif - tauxb ,tauyb ,irb ,shb ,evb,csigmaf0,& !out + tauxb ,tauyb ,irb ,shb ,evb , & !out + csigmaf0, & !out ghb ,t2mb ,dx ,dz8w ,ivgtyp , & !out qc ,qsfc ,psfc , & !in sfcprs ,q2b ,ehb2 ) !in @@ -4411,13 +4312,6 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & real (kind=kind_phys), intent(in) :: rhsur !raltive humidity in surface soil/snow air space (-) real (kind=kind_phys), intent(in) :: fsno !snow fraction - logical , intent(in) :: thsfc_loc - real (kind=kind_phys) , intent(in) :: prslkix ! in exner function - real (kind=kind_phys) , intent(in) :: prsik1x ! in exner function - real (kind=kind_phys) , intent(in) :: prslk1x ! in exner function - real (kind=kind_phys) , intent(in) :: fveg - real (kind=kind_phys) , intent(in) :: garea1 - !jref:start; in integer , intent(in) :: ivgtyp real (kind=kind_phys) , intent(in) :: qc !cloud water mixing ratio @@ -4434,7 +4328,6 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & real (kind=kind_phys), intent(inout) :: tgb !ground temperature (k) real (kind=kind_phys), intent(inout) :: cm !momentum drag coefficient real (kind=kind_phys), intent(inout) :: ch !sensible heat exchange coefficient - real (kind=kind_phys), intent(inout) :: ustarx !friction velocity #ifdef CCPP character(len=*), intent(inout) :: errmsg integer, intent(inout) :: errflg @@ -4450,7 +4343,6 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & real (kind=kind_phys), intent(out) :: evb !latent heat flux (w/m2) [+ to atm] real (kind=kind_phys), intent(out) :: ghb !ground heat flux (w/m2) [+ to soil] real (kind=kind_phys), intent(out) :: t2mb !2 m height air temperature (k) - real (kind=kind_phys), intent(out) :: csigmaf0 ! !jref:start real (kind=kind_phys), intent(out) :: q2b !bare ground heat conductance real (kind=kind_phys) :: ehb !bare ground heat conductance @@ -4461,17 +4353,6 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & ! local variables - real (kind=kind_phys) :: rb1b !Bulk Richardson # over bare soil - real (kind=kind_phys) :: stress1b !Stress over bare soil - real (kind=kind_phys) :: snwd - real (kind=kind_phys) :: virtfacb - real (kind=kind_phys) :: thv1b - real (kind=kind_phys) :: tvsb - real (kind=kind_phys) :: tv1b - real (kind=kind_phys) :: zlvlb - - real (kind=kind_phys) :: fm10 - real (kind=kind_phys) :: taux !wind stress: e-w (n/m2) real (kind=kind_phys) :: tauy !wind stress: n-s (n/m2) real (kind=kind_phys) :: fira !total net longwave rad (w/m2) [+ to atm] @@ -4498,9 +4379,6 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & real (kind=kind_phys) :: cev !coefficients for ev as function of esat[ts] real (kind=kind_phys) :: cgh !coefficients for st as function of ts - real(kind=kind_phys) :: kbsigmaf0 - real(kind=kind_phys) :: reynb - !jref:start real (kind=kind_phys) :: rahb2 !aerodynamic resistance for sensible heat 2m (s/m) real (kind=kind_phys) :: rawb2 !aerodynamic resistance for water vapor 2m (s/m) @@ -4535,18 +4413,26 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & real (kind=kind_phys) :: fh2 !monin-obukhov heat adjustment at 2m real (kind=kind_phys) :: ch2 !surface exchange at 2m - real(kind=kind_phys) :: tem1,tem2,zvfun1,gdx - real(kind=kind_phys), parameter :: z0lo=0.1, z0up=1.0 - integer :: iter !iteration index integer :: niterb !number of iterations for surface temperature - integer :: niter - real (kind=kind_phys) :: mpe !prevents overflow error if division by zero !jref:start ! data niterb /3/ data niterb /5/ save niterb + +! New variables for sfcdif3 + + logical , intent(in ) :: thsfc_loc + real (kind=kind_phys), intent(in ) :: prslkix ! in exner function + real (kind=kind_phys), intent(in ) :: prsik1x ! in exner function + real (kind=kind_phys), intent(in ) :: prslk1x ! in exner function + real (kind=kind_phys), intent(in ) :: fveg + real (kind=kind_phys), intent(in ) :: shdfac + real (kind=kind_phys), intent(in ) :: garea1 + real (kind=kind_phys), intent(inout) :: ustarx !friction velocity + real (kind=kind_phys), intent( out) :: csigmaf0 ! + real (kind=kind_phys) :: t, tdc !kelvin to degree celsius with limit -50 to +50 tdc(t) = min( 50., max(-50.,(t-tfrz)) ) @@ -4562,54 +4448,10 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & h = 0. qfx = 0. - csigmaf0 = 0. - kbsigmaf0 = 0. - - niter = 1 - if (ur < 2.0) niter = 2 - - fv = ustarx - -! fv = ur*vkc/log((zlvl-zpd)/z0m) - - reynb = fv*z0m/(1.5e-05) - - if (reynb .gt. 2.0) then - kbsigmaf0 = 2.46*reynb**0.25 - log(7.4) - else - kbsigmaf0 = - log(0.397) - endif - - csigmaf0 = log((zlvl-zpd)/z0m)*(log((zlvl-zpd)/z0m) + kbsigmaf0) - - z0h = max(z0m/exp(kbsigmaf0),1.0e-6) -! -! for sfcdiff3; maybe should move to inside the option -! - snwd = snowh*1000.0 - zlvlb = zlvl - zpd - - virtfacb = 1.0 + 0.61 * max(qair, 1.e-8) - tv1b = sfctmp * virtfacb - - if(thsfc_loc) then ! Use local potential temperature - thv1b = sfctmp * prslkix * virtfacb - else ! Use potential temperature reference to 1000 hPa - thv1b = sfctmp / prslk1x * virtfacb - endif - cir = emg*sb cgh = 2.*df(isnow+1)/dzsnso(isnow+1) ! ----------------------------------------------------------------- - tem1 = (z0m - z0lo) / (z0up - z0lo) - tem1 = min(max(tem1, 0.0_kind_phys), 1.0_kind_phys) - tem2 = max(fveg, 0.1_kind_phys) - zvfun1= sqrt(tem1 * tem2) - gdx=sqrt(garea1) - - if (opt_sfc == 1 .or. opt_sfc == 2) then - loop3: do iter = 1, niterb ! begin stability iteration ! if(iter == 1) then @@ -4649,6 +4491,15 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & endif + if(opt_sfc == 3) then + call sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in + zlvl ,tgb ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in + zpd ,snowh,shdfac ,garea1 ,.false. ,0.0,ivgtyp , & !in + ustarx ,fm ,fh ,fm2 ,fh2 , & !inout + z0h ,fv ,csigmaf0,cm ,ch ) !out + + endif + ramb = max(1.,1./(cm*ur)) rahb = max(1.,1./(ch*ur)) rawb = rahb @@ -4706,83 +4557,8 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & qfx = (qsfc-qair)*cev*gamma/cpair end do loop3 ! end stability iteration - endif ! opt_sfc 1/2 ! ----------------------------------------------------------------- - if (opt_sfc == 3) then - - do iter = 1, niter !1 or 2; depending on ur - - if(thsfc_loc) then ! Use local potential temperature - tvsb = tgb * virtfacb - else ! Use potential temperature referenced to 1000 hPa - tvsb = tgb/prsik1x * virtfacb - endif - - call stability & - (zlvlb, zvfun1, gdx,tv1b,thv1b, ur, z0m, z0h, tvsb, grav,thsfc_loc, & - rb1b, fm,fh,fm10,fh2,cm,ch,stress1b,fv) - - - ramb = max(1.,1./(cm*ur)) - rahb = max(1.,1./(ch*ur)) - rawb = rahb - -!jref - variables for diagnostics - emb = 1./ramb - ehb = 1./rahb - -! es and d(es)/dt evaluated at tg - - t = tdc(tgb) - call esat(t, esatw, esati, dsatw, dsati) - if (t .gt. 0.) then - estg = esatw - destg = dsatw - else - estg = esati - destg = dsati - end if - - csh = rhoair*cpair/rahb - cev = rhoair*cpair/gamma/(rsurf+rawb) - -! surface fluxes and dtg - - irb = cir * tgb**4 - emg*lwdn - shb = csh * (tgb - sfctmp ) - evb = cev * (estg*rhsur - eair ) - ghb = cgh * (tgb - stc(isnow+1)) - - b = sag-irb-shb-evb-ghb+pahb - a = 4.*cir*tgb**3 + csh + cev*destg + cgh - dtg = b/a - - irb = irb + 4.*cir*tgb**3*dtg - shb = shb + csh*dtg - evb = evb + cev*destg*dtg - ghb = ghb + cgh*dtg - -! update ground surface temperature - tgb = tgb + dtg - -! for m-o length -! h = csh * (tgb - sfctmp) - - t = tdc(tgb) - call esat(t, esatw, esati, dsatw, dsati) - if (t .gt. 0.) then - estg = esatw - else - estg = esati - end if - qsfc = 0.622*(estg*rhsur)/(psfc-0.378*(estg*rhsur)) - - qfx = (qsfc-qair)*cev*gamma/cpair - - end do ! end stability iteration - endif ! sfcdiff3 - ! if snow on ground and tg > tfrz: reset tg = tfrz. reevaluate ground fluxes. if(opt_stc == 1 .or. opt_stc == 3) then @@ -4830,7 +4606,7 @@ end subroutine bare_flux subroutine ragrb(parameters,iter ,vai ,rhoair ,hg ,tah , & !in zpd ,z0mg ,z0hg ,hcan ,uc , & !in z0h ,fv ,cwp ,vegtyp ,mpe , & !in - tv ,mozg ,fhg ,iloc ,jloc , & !inout + tv ,mozg ,fhg ,fhgh ,iloc ,jloc , & !inout ramg ,rahg ,rawg ,rb ) !out ! -------------------------------------------------------------------------------------------------- ! compute under-canopy aerodynamic resistance rag and leaf boundary layer @@ -4864,6 +4640,7 @@ subroutine ragrb(parameters,iter ,vai ,rhoair ,hg ,tah , & !in real (kind=kind_phys), intent(inout) :: mozg !monin-obukhov stability parameter real (kind=kind_phys), intent(inout) :: fhg !stability correction + real (kind=kind_phys), intent(inout) :: fhgh !stability correction, canopy ! outputs real (kind=kind_phys) :: ramg !aerodynamic resistance for momentum (s/m) @@ -4878,33 +4655,41 @@ subroutine ragrb(parameters,iter ,vai ,rhoair ,hg ,tah , & !in real (kind=kind_phys) :: tmprah2 !temporary calculation for aerodynamic resistances real (kind=kind_phys) :: tmprb !temporary calculation for rb real (kind=kind_phys) :: molg,fhgnew,cwpc + real (kind=kind_phys) :: mozgh, fhgnewh ! -------------------------------------------------------------------------------------------------- ! stability correction to below canopy resistance mozg = 0. molg = 0. + mozgh = 0. if(iter > 1) then tmp1 = vkc * (grav/tah) * hg/(rhoair*cpair) if (abs(tmp1) .le. mpe) tmp1 = mpe molg = -1. * fv**3 / tmp1 mozg = min( (zpd-z0mg)/molg, 1.) + mozgh = min( (hcan - zpd)/molg, 1.) end if if (mozg < 0.) then fhgnew = (1. - 15.*mozg)**(-0.25) + fhgnewh = 0.74 * (1. - 9.*mozg)**(-0.5) ! PHIh else fhgnew = 1.+ 4.7*mozg + fhgnewh = 0.74 + 4.7*mozgh ! PHIh endif if (iter == 1) then fhg = fhgnew + fhgh = fhgnewh else fhg = 0.5 * (fhg+fhgnew) + fhgh = 0.5 * (fhgh+fhgnewh) endif cwpc = (cwp * vai * hcan * fhg)**0.5 ! cwpc = (cwp*fhg)**0.5 + cwpc = max(min(cwpc,5.0),1.0) tmp1 = exp( -cwpc*z0hg/hcan ) tmp2 = exp( -cwpc*(z0h+zpd)/hcan ) @@ -4912,7 +4697,7 @@ subroutine ragrb(parameters,iter ,vai ,rhoair ,hg ,tah , & !in ! aerodynamic resistances raw and rah between heights zpd+z0h and z0hg. - kh = max ( vkc*fv*(hcan-zpd), mpe ) + kh = max ( vkc*fv*(hcan-zpd)/(max(fhgh,0.1)), mpe ) ramg = 0. rahg = tmprah2 / kh rawg = rahg @@ -5315,6 +5100,139 @@ subroutine sfcdif2(parameters,iter ,z0 ,thz0 ,thlm ,sfcspd , & !in ! ---------------------------------------------------------------------- end subroutine sfcdif2 +!== begin sfcdif3 ================================================================================== + +!>\ingroup NoahMP_LSM +!! compute surface drag coefficient cm for momentum and ch for heat. + subroutine sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in + zlvl ,tgb ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in + zpd ,snowh ,fveg ,garea1 ,vegetated,vaie,vegtyp , & !in + ustarx ,fm ,fh ,fm2 ,fh2 , & !inout + z0h ,fv ,csigmaf ,cm ,ch ) !out + +! ------------------------------------------------------------------------------------------------- +! computing surface drag coefficient cm for momentum and ch for heat +! ------------------------------------------------------------------------------------------------- + implicit none +! ------------------------------------------------------------------------------------------------- +! inputs + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in ) :: iloc ! grid index + integer, intent(in ) :: jloc ! grid index + integer, intent(in ) :: iter ! iteration index + real (kind=kind_phys), intent(in ) :: sfctmp ! temperature at reference height [K] + real (kind=kind_phys), intent(in ) :: qair ! specific humidity at reference height [kg/kg] + real (kind=kind_phys), intent(in ) :: ur ! wind speed [m/s] + real (kind=kind_phys), intent(in ) :: zlvl ! reference height [m] + real (kind=kind_phys), intent(in ) :: tgb ! ground temperature [K] + logical, intent(in ) :: thsfc_loc ! flag for using sfc-based theta + real (kind=kind_phys), intent(in ) :: prslkix ! in exner function + real (kind=kind_phys), intent(in ) :: prsik1x ! in exner function + real (kind=kind_phys), intent(in ) :: prslk1x ! in exner function + real (kind=kind_phys), intent(in ) :: z0m ! roughness length, momentum, ground [m] + real (kind=kind_phys), intent(in ) :: zpd ! zero plane displacement [m] + real (kind=kind_phys), intent(in ) :: snowh ! snow depth [m] + real (kind=kind_phys), intent(in ) :: fveg ! fractional vegetation cover + real (kind=kind_phys), intent(in ) :: garea1 ! grid area [km2] + logical, intent(in ) :: vegetated ! .true. if vegetated + real (kind=kind_phys), intent(in ) :: vaie ! vegetation area index [m2/m2] + integer , intent(in ) :: vegtyp ! vegetation category + real (kind=kind_phys), intent(inout) :: ustarx ! friction velocity [m/s] + real (kind=kind_phys), intent(inout) :: fm ! momentum stability correction, weighted by prior iters + real (kind=kind_phys), intent(inout) :: fh ! sen heat stability correction, weighted by prior iters + real (kind=kind_phys), intent(inout) :: fm2 ! sen heat stability correction, weighted by prior iters + real (kind=kind_phys), intent(inout) :: fh2 ! sen heat stability correction, weighted by prior iters + real (kind=kind_phys), intent( out) :: z0h ! roughness length, sensible heat, ground [m] + real (kind=kind_phys), intent( out) :: fv ! friction velocity (m/s) + real (kind=kind_phys), intent( out) :: csigmaf ! + real (kind=kind_phys), intent( out) :: cm ! drag coefficient for momentum + real (kind=kind_phys), intent( out) :: ch ! drag coefficient for heat + + real (kind=kind_phys) :: reyn ! reynolds number + real (kind=kind_phys) :: kbsigmaf ! kb factor + real (kind=kind_phys) :: snwd ! snow depth [mm] + real (kind=kind_phys) :: zlvlb ! reference height - zpd [m] + real (kind=kind_phys) :: virtfac ! virtual temperature factor [-] + real (kind=kind_phys) :: tv1 ! virtual temperature at reference [K] + real (kind=kind_phys) :: thv1 ! virtual theta at reference [K] + real (kind=kind_phys) :: tvs ! virtural surface temperature [K] + real (kind=kind_phys) :: rb1 ! bulk Richardson - stability output + real (kind=kind_phys) :: stress1 ! stress - stability output + real (kind=kind_phys) :: czil1 ! canopy based czil + real (kind=kind_phys) :: fm10 ! 10-m stability adjustment - stability output + real (kind=kind_phys) :: sigmaa ! momentum partition parameter + real (kind=kind_phys) :: tem1,tem2,zvfun1,gdx + real (kind=kind_phys), parameter :: z0lo=0.1, z0up=1.0 + +! ------------------------------------------------------------------------------------------------- + + fv = ustarx +! fv = ur*vkc/log((zlvl-zpd)/z0m) + + if(vegetated) then + + if (opt_trs == 1) then + z0h = z0m + elseif (opt_trs == 2) then + czil1= 10.0 ** (- (0.40/0.07) * parameters%hvt) + z0h = z0m*exp(-czil1*0.4*258.2*sqrt(fv*z0m)) + elseif (opt_trs == 3) then + if (vegtyp.le.5) then + z0h = z0m + else + z0h = z0m*0.01 + endif + elseif (opt_trs == 4) then + sigmaa = 1.0 - (0.5/(0.5+vaie))*exp(-vaie**2/8.0) + kbsigmaf = 16.4*(sigmaa*vaie**3)**(-0.25)*sqrt(parameters%dleaf*ur/log((zlvl-zpd)/z0m)) + z0h = z0m/exp(kbsigmaf) + csigmaf = log((zlvl-zpd)/z0m)*(log((zlvl-zpd)/z0m)+kbsigmaf) ! for output for interpolation + endif + + else + + reyn = fv*z0m/(1.5e-05) + if (reyn .gt. 2.0) then + kbsigmaf = 2.46*reyn**0.25 - log(7.4) + else + kbsigmaf = - log(0.397) + endif + + z0h = max(z0m/exp(kbsigmaf),1.0e-6) + csigmaf = log((zlvl-zpd)/z0m)*(log((zlvl-zpd)/z0m) + kbsigmaf) + + end if + + snwd = snowh*1000.0 + zlvlb = zlvl - zpd + + virtfac = 1.0 + 0.61 * max(qair, 1.0e-8) + tv1 = sfctmp * virtfac + + if(thsfc_loc) then ! Use local potential temperature + thv1 = sfctmp * prslkix * virtfac + else ! Use potential temperature reference to 1000 hPa + thv1 = sfctmp / prslk1x * virtfac + endif + + tem1 = (z0m - z0lo) / (z0up - z0lo) + tem1 = min(max(tem1, 0.0_kind_phys), 1.0_kind_phys) + tem2 = max(fveg, 0.1_kind_phys) + zvfun1 = sqrt(tem1 * tem2) + gdx = sqrt(garea1) + + if(thsfc_loc) then ! Use local potential temperature + tvs = tgb * virtfac + else ! Use potential temperature referenced to 1000 hPa + tvs = tgb/prsik1x * virtfac + endif + + call stability (zlvlb, zvfun1, gdx, tv1, thv1, ur, z0m, z0h, tvs, grav, thsfc_loc, & + rb1, fm,fh,fm10,fh2,cm,ch,stress1,fv) + + end subroutine sfcdif3 + !== begin esat ===================================================================================== !>\ingroup NoahMP_LSM @@ -7714,8 +7632,10 @@ subroutine soilwater (parameters,nsoil ,nsnow ,dt ,zsoil ,dzsnso , & !in if ( parameters%urban_flag ) fcr(1)= 0.95 if(opt_run == 1) then - fff = 6.0 - fsat = parameters%fsatmx*exp(-0.5*fff*(zwt-2.0)) +! fff = 6.0 + fff = parameters%bexp(1) / 3.0 ! calibratable, c.he changed based on gy niu's update +! fsat = parameters%fsatmx*exp(-0.5*fff*(zwt-2.0)) + fsat = parameters%fsatmx*exp(-0.5*fff*zwt) ! c.he changed based on gy niu's update if(qinsur > 0.) then runsrf = qinsur * ( (1.0-fcr(1))*fsat + fcr(1) ) pddum = qinsur - runsrf ! m/s @@ -8430,8 +8350,9 @@ subroutine groundwater(parameters,nsnow ,nsoil ,dt ,sice ,zsoil , & !in real (kind=kind_phys) :: watmin!minimum soil vol soil moisture [m3/m3] real (kind=kind_phys) :: xs !excessive water above saturation [mm] real (kind=kind_phys), parameter :: rous = 0.2 !specific yield [-] - real (kind=kind_phys), parameter :: cmic = 0.20 !microprore content (0.0-1.0) +! real (kind=kind_phys), parameter :: cmic = 0.20 !microprore content (0.0-1.0) !0.0-close to free drainage + real (kind=kind_phys), parameter :: cmic = 0.80 ! calibratable, c.he changed based on gy niu's update ! ------------------------------------------------------------- qdis = 0.0 qin = 0.0 @@ -8473,8 +8394,10 @@ subroutine groundwater(parameters,nsnow ,nsoil ,dt ,sice ,zsoil , & !in ! groundwater discharge [mm/s] - fff = 6.0 - rsbmx = 5.0 +! fff = 6.0 +! rsbmx = 5.0 + fff = parameters%bexp(iwt) / 3.0 ! calibratable, c.he changed based on gy niu's update + rsbmx = hk(iwt) * 1.0e3 * exp(3.0) ! mm/s, calibratable, c.he changed based on gy niu's update qdis = (1.0-fcrmax)*rsbmx*exp(-parameters%timean)*exp(-fff*(zwt-2.0)) @@ -9782,7 +9705,7 @@ end subroutine psn_crop !>\ingroup NoahMP_LSM subroutine noahmp_options(idveg ,iopt_crs ,iopt_btr ,iopt_run ,iopt_sfc ,iopt_frz , & iopt_inf ,iopt_rad ,iopt_alb ,iopt_snf ,iopt_tbot, iopt_stc, & - iopt_rsf , iopt_soil, iopt_pedo, iopt_crop ) + iopt_rsf , iopt_soil, iopt_pedo, iopt_crop ,iopt_trs ) implicit none @@ -9804,6 +9727,7 @@ subroutine noahmp_options(idveg ,iopt_crs ,iopt_btr ,iopt_run ,iopt_sfc integer, intent(in) :: iopt_soil !soil parameters set-up option integer, intent(in) :: iopt_pedo !pedo-transfer function (1->saxton and rawls) integer, intent(in) :: iopt_crop !crop model option (0->none; 1->liu et al.) + integer, intent(in) :: iopt_trs !thermal roughness scheme option (1->z0h=z0; 2->rb reversed) ! ------------------------------------------------------------------------------------------------- @@ -9824,6 +9748,7 @@ subroutine noahmp_options(idveg ,iopt_crs ,iopt_btr ,iopt_run ,iopt_sfc opt_soil = iopt_soil opt_pedo = iopt_pedo opt_crop = iopt_crop + opt_trs = iopt_trs end subroutine noahmp_options diff --git a/physics/mp_nssl.F90 b/physics/mp_nssl.F90 new file mode 100644 index 000000000..c442d204c --- /dev/null +++ b/physics/mp_nssl.F90 @@ -0,0 +1,821 @@ +!>\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) + + ! For restart runs, the init is done here + if (restart) then + is_initialized = .true. + return + end if + +! Other initialization operation here.... + + 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, restart, & + 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 + logical, intent(in) :: restart + ! 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 .and. .not. restart ) 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_mp)) + ! Flip CCN concentrations from 'activated' to 'unactivated' (allows BC condition to be zero) + cn_mp = nssl_qccn - cccn_mp + cn_mp = Max(0.0_kind_phys, cn_mp) + + ELSE + cn_mp = cccn_mp + ENDIF + IF ( ntccna > 0 ) THEN + ! not in use yet +! 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_mp = Max(0.0_kind_phys, nssl_qccn - cn_mp ) +! cccn_mp = nssl_qccn - cn_mp + ELSE + cccn_mp = cn_mp + ENDIF +! cccna = cna_mp ! cna not in use yet for ccpp + 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..82b5ff739 --- /dev/null +++ b/physics/mp_nssl.meta @@ -0,0 +1,641 @@ +[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 +[restart] + standard_name = flag_for_restart + long_name = flag for restart (warmstart) or coldstart + 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/mp_thompson.F90 b/physics/mp_thompson.F90 index 7c76ea933..712239864 100644 --- a/physics/mp_thompson.F90 +++ b/physics/mp_thompson.F90 @@ -300,7 +300,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & con_eps, convert_dry_rho, & spechum, qc, qr, qi, qs, qg, ni, nr, & is_aerosol_aware, nc, nwfa, nifa, & - nwfa2d, nifa2d, & + nwfa2d, nifa2d, aero_ind_fdb, & tgrs, prsl, phii, omega, & sedi_semi, decfl, dtp, dt_inner, & first_time_step, istep, nsteps, & @@ -308,7 +308,9 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & refl_10cm, reset_dBZ, do_radar_ref, & mpicomm, mpirank, mpiroot, blkno, & ext_diag, diag3d, reset_diag3d, & - spp_wts_mp, spp_mp, & + spp_wts_mp, spp_mp, n_var_spp, & + spp_prt_list, spp_var_list, & + spp_stddev_cutoff, & errmsg, errflg) implicit none @@ -339,6 +341,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & real(kind_phys), optional, intent(inout) :: nifa(:,:) real(kind_phys), optional, intent(in ) :: nwfa2d(:) real(kind_phys), optional, intent(in ) :: nifa2d(:) + logical, optional, intent(in ) :: aero_ind_fdb ! State variables and timestep information real(kind_phys), intent(inout) :: tgrs(:,:) real(kind_phys), intent(in ) :: prsl(:,:) @@ -376,7 +379,11 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & ! SPP integer, intent(in) :: spp_mp + integer, intent(in) :: n_var_spp real(kind_phys), intent(in) :: spp_wts_mp(:,:) + real(kind_phys), intent(in) :: spp_prt_list(:) + character(len=3), intent(in) :: spp_var_list(:) + real(kind_phys), intent(in) :: spp_stddev_cutoff(:) ! Local variables @@ -634,6 +641,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & if (is_aerosol_aware) then call mp_gt_driver(qv=qv, qc=qc, qr=qr, qi=qi, qs=qs, qg=qg, ni=ni, nr=nr, & nc=nc, nwfa=nwfa, nifa=nifa, nwfa2d=nwfa2d, nifa2d=nifa2d, & + aero_ind_fdb=aero_ind_fdb, & tt=tgrs, p=prsl, w=w, dz=dz, dt_in=dtstep, dt_inner=dt_inner, & sedi_semi=sedi_semi, decfl=decfl, & rainnc=rain_mp, rainncv=delta_rain_mp, & @@ -644,7 +652,9 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & diagflag=diagflag, do_radar_ref=do_radar_ref_mp, & has_reqc=has_reqc, has_reqi=has_reqi, has_reqs=has_reqs, & rand_perturb_on=spp_mp_opt, kme_stoch=kme_stoch, & - rand_pert=spp_wts_mp, & + rand_pert=spp_wts_mp, spp_var_list=spp_var_list, & + spp_prt_list=spp_prt_list, n_var_spp=n_var_spp, & + spp_stddev_cutoff=spp_stddev_cutoff, & ids=ids, ide=ide, jds=jds, jde=jde, kds=kds, kde=kde, & ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, & its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte, & @@ -681,7 +691,9 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & diagflag=diagflag, do_radar_ref=do_radar_ref_mp, & has_reqc=has_reqc, has_reqi=has_reqi, has_reqs=has_reqs, & rand_perturb_on=spp_mp_opt, kme_stoch=kme_stoch, & - rand_pert=spp_wts_mp, & + rand_pert=spp_wts_mp, spp_var_list=spp_var_list, & + spp_prt_list=spp_prt_list, n_var_spp=n_var_spp, & + spp_stddev_cutoff=spp_stddev_cutoff, & ids=ids, ide=ide, jds=jds, jde=jde, kds=kds, kde=kde, & ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, & its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte, & diff --git a/physics/mp_thompson.meta b/physics/mp_thompson.meta index a3bc20615..9981b119d 100644 --- a/physics/mp_thompson.meta +++ b/physics/mp_thompson.meta @@ -435,6 +435,13 @@ type = real kind = kind_phys intent = in +[aero_ind_fdb] + standard_name = do_smoke_aerosol_indirect_feedback + long_name = flag for wfa ifa emission indirect feedback + units = flag + dimensions = () + type = logical + intent = in [tgrs] standard_name = air_temperature_of_new_state long_name = model layer mean temperature @@ -644,7 +651,6 @@ units = 1 dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real - kind = kind_phys intent = in [spp_mp] standard_name = control_for_microphysics_spp_perturbations @@ -653,6 +659,37 @@ dimensions = () type = integer intent = in +[n_var_spp] + standard_name = number_of_perturbed_spp_schemes + long_name = number of perturbed spp schemes + units = count + dimensions = () + type = integer + intent = in +[spp_prt_list] + standard_name = magnitude_of_spp_perturbations + long_name = magnitude of spp perturbations + units = 1 + dimensions = (number_of_perturbed_spp_schemes) + type = real + kind = kind_phys + intent = in +[spp_stddev_cutoff] + standard_name = magnitude_of_spp_standard_deviation_cutoff + long_name = magnitude of spp standard deviation cutoff + units = 1 + dimensions = (number_of_perturbed_spp_schemes) + type = real + kind = kind_phys + intent = in +[spp_var_list] + standard_name = perturbed_spp_schemes + long_name = perturbed spp schemes + units = none + dimensions = (number_of_perturbed_spp_schemes) + type = character + kind = len=3 + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/module_MYJPBL_wrapper.F90 b/physics/myjpbl_wrapper.F90 similarity index 99% rename from physics/module_MYJPBL_wrapper.F90 rename to physics/myjpbl_wrapper.F90 index 9010b4cdb..5c47d7168 100644 --- a/physics/module_MYJPBL_wrapper.F90 +++ b/physics/myjpbl_wrapper.F90 @@ -1,4 +1,4 @@ -!> \file module_myjpbl_wrapper.F90 +!> \file myjpbl_wrapper.F90 !! Contains all of the code related to running the MYJ PBL scheme MODULE myjpbl_wrapper diff --git a/physics/module_MYJPBL_wrapper.meta b/physics/myjpbl_wrapper.meta similarity index 100% rename from physics/module_MYJPBL_wrapper.meta rename to physics/myjpbl_wrapper.meta diff --git a/physics/module_MYJSFC_wrapper.F90 b/physics/myjsfc_wrapper.F90 similarity index 99% rename from physics/module_MYJSFC_wrapper.F90 rename to physics/myjsfc_wrapper.F90 index 3d2b2e017..d7737e911 100644 --- a/physics/module_MYJSFC_wrapper.F90 +++ b/physics/myjsfc_wrapper.F90 @@ -1,4 +1,4 @@ -!> \file module_myjsfc_wrapper.F90 +!> \file myjsfc_wrapper.F90 !! Contains all of the code related to running the MYJ surface layer scheme MODULE myjsfc_wrapper diff --git a/physics/module_MYJSFC_wrapper.meta b/physics/myjsfc_wrapper.meta similarity index 100% rename from physics/module_MYJSFC_wrapper.meta rename to physics/myjsfc_wrapper.meta diff --git a/physics/module_MYNNPBL_wrapper.F90 b/physics/mynnedmf_wrapper.F90 similarity index 94% rename from physics/module_MYNNPBL_wrapper.F90 rename to physics/mynnedmf_wrapper.F90 index d9e53f9d3..5917145fe 100644 --- a/physics/module_MYNNPBL_wrapper.F90 +++ b/physics/mynnedmf_wrapper.F90 @@ -1,4 +1,4 @@ -!> \file module_MYNNPBL_wrapper.F90 +!> \file mynnedmf_wrapper.F90 !! This file contains all of the code related to running the MYNN !! eddy-diffusivity mass-flux scheme. @@ -113,6 +113,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, & @@ -145,6 +146,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, & @@ -159,6 +161,8 @@ SUBROUTINE mynnedmf_wrapper_run( & & icloud_bl, do_mynnsfclay, & & imp_physics, imp_physics_gfdl, & & imp_physics_thompson, imp_physics_wsm6, & + & chem3d, frp, mix_chem, rrfs_smoke, fire_turb, nchem, ndvel, & + & imp_physics_nssl, nssl_ccn_on, & & ltaerosol, spp_wts_pbl, spp_pbl, lprnt, huge, errmsg, errflg ) ! should be moved to inside the mynn: @@ -179,11 +183,8 @@ SUBROUTINE mynnedmf_wrapper_run( & logical, intent(in) :: cplflx !smoke/chem - !logical, intent(in) :: mix_chem, fire_turb - !integer, intent(in) :: nchem, ndvel, kdvel - !for testing only: - logical, parameter :: mix_chem=.false., fire_turb=.false. - integer, parameter :: nchem=2, ndvel=2, kdvel=1 + integer, intent(in) :: nchem, ndvel + integer, parameter :: kdvel=1 ! NAMELIST OPTIONS (INPUT): logical, intent(in) :: & @@ -192,7 +193,8 @@ SUBROUTINE mynnedmf_wrapper_run( & & 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, & @@ -205,6 +207,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & bl_mynn_output, & & imp_physics, imp_physics_wsm6, & & imp_physics_thompson, imp_physics_gfdl, & + & imp_physics_nssl, & & spp_pbl real, intent(in) :: & & bl_mynn_closure @@ -222,7 +225,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & bl_mynn_mixscalars=1 LOGICAL :: & & FLAG_QI, FLAG_QNI, FLAG_QC, FLAG_QNC, & - & FLAG_QNWFA, FLAG_QNIFA + & FLAG_QNWFA, FLAG_QNIFA, FLAG_OZONE ! Define locally until needed from CCPP LOGICAL, PARAMETER :: cycling = .false. INTEGER, PARAMETER :: param_first_scalar = 1 @@ -247,6 +250,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, Sm3D, & & qc_bl, qi_bl, cldfra_bl @@ -259,7 +263,6 @@ SUBROUTINE mynnedmf_wrapper_run( & & dqke,qWT,qSHEAR,qBUOY,qDISS real(kind=kind_phys), dimension(:,:), intent(inout) :: & & t3d,qgrs_water_vapor,qgrs_liquid_cloud,qgrs_ice_cloud - real(kind=kind_phys), dimension(:,:), intent(in) :: & & u,v,omega, & & exner,prsl, & @@ -268,6 +271,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 @@ -285,17 +289,11 @@ SUBROUTINE mynnedmf_wrapper_run( & real(kind=kind_phys), allocatable :: old_ozone(:,:) !smoke/chem arrays - ! real(kind=kind_phys), dimension(:,:), intent(inout), optional :: & - ! & qgrs_smoke_conc, qgrs_dust_conc - ! real(kind=kind_phys), allocatable, dimension(:,:,:) :: chem3d - ! real(kind=kind_phys), dimension(:,:), intent(in), optional :: vdep - ! real(kind=kind_phys), dimension(:), intent(in), optional :: frp, emis_ant_no -!for testing only - real(kind=kind_phys), dimension(im,levs) :: & - & qgrs_smoke_conc, qgrs_dust_conc - real(kind=kind_phys), allocatable, dimension(:,:,:) :: chem3d - real(kind=kind_phys), dimension(im,ndvel) :: vdep !not passed in yet??? - real(kind=kind_phys), dimension(im) :: frp, emis_ant_no + real(kind_phys), dimension(:), intent(inout) :: frp + logical, intent(in) :: mix_chem, fire_turb, rrfs_smoke + real(kind=kind_phys), dimension(:,:,:), intent(inout) :: chem3d + real(kind=kind_phys), dimension(im) :: emis_ant_no + real(kind=kind_phys), dimension(im,ndvel) :: vdep !MYNN-2D real(kind=kind_phys), dimension(:), intent(in) :: & @@ -361,20 +359,8 @@ SUBROUTINE mynnedmf_wrapper_run( & endif !initialize arrays for test - qgrs_smoke_conc = 1.0 - qgrs_dust_conc = 1.0 - FRP = 0. EMIS_ANT_NO = 0. vdep = 0. ! hli for chem dry deposition, 0 temporarily - if (mix_chem) then - allocate ( chem3d(im,levs,nchem) ) - do k=1,levs - do i=1,im - chem3d(i,k,1)=qgrs_smoke_conc(i,k) - chem3d(i,k,2)=qgrs_dust_conc (i,k) - enddo - enddo - endif ! Check incoming moist species to ensure non-negative values ! First, create height (dz) and pressure differences (delp) @@ -403,6 +389,8 @@ SUBROUTINE mynnedmf_wrapper_run( & t3d(i,:) ) enddo + FLAG_OZONE = ntoz>0 + ! Assign variables for each microphysics scheme if (imp_physics == imp_physics_wsm6) then ! WSM6 @@ -431,6 +419,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 @@ -703,6 +722,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & Chem3d=chem3d,Vdep=vdep, & & FRP=frp,EMIS_ANT_NO=emis_ant_no, & & mix_chem=mix_chem,fire_turb=fire_turb, & + & rrfs_smoke=rrfs_smoke, & !----- & Tsq=tsq,Qsq=qsq,Cov=cov, & !output & RUBLTEN=RUBLTEN,RVBLTEN=RVBLTEN,RTHBLTEN=RTHBLTEN, & !output @@ -739,6 +759,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & FLAG_QI=flag_qi,FLAG_QNI=flag_qni, & !input & FLAG_QC=flag_qc,FLAG_QNC=flag_qnc, & !input & FLAG_QNWFA=FLAG_QNWFA,FLAG_QNIFA=FLAG_QNIFA, & !input + & FLAG_OZONE=FLAG_OZONE, & !input & IDS=1,IDE=im,JDS=1,JDE=1,KDS=1,KDE=levs, & !input & IMS=1,IME=im,JMS=1,JME=1,KMS=1,KME=levs, & !input & ITS=1,ITE=im,JTS=1,JTE=1,KTS=1,KTE=levs) !input @@ -869,6 +890,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 @@ -966,10 +1002,6 @@ SUBROUTINE mynnedmf_wrapper_run( & deallocate(save_qke_adv) endif - if(allocated(chem3d))then - deallocate(chem3d) - endif - CONTAINS SUBROUTINE dtend_helper(itracer,field,mult) diff --git a/physics/module_MYNNPBL_wrapper.meta b/physics/mynnedmf_wrapper.meta similarity index 94% rename from physics/module_MYNNPBL_wrapper.meta rename to physics/mynnedmf_wrapper.meta index 658c80100..33f97113f 100644 --- a/physics/module_MYNNPBL_wrapper.meta +++ b/physics/mynnedmf_wrapper.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = mynnedmf_wrapper type = scheme - dependencies = machine.F,module_bl_mynn.F90,physcons.F90 + dependencies = machine.F,module_bl_mynn.F90,physcons.F90,bl_mynn_common.f90 ######################################################################## [ccpp-arg-table] @@ -351,6 +351,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 @@ -773,7 +781,7 @@ kind = kind_phys intent = inout [exch_h] - standard_name = atmosphere_heat_diffusivity_for_mynnpbl + standard_name = atmosphere_heat_diffusivity_for_mynnedmf long_name = diffusivity for heat for MYNN PBL (defined for all mass levels) units = m2 s-1 dimensions = (horizontal_loop_extent,vertical_layer_dimension) @@ -781,7 +789,7 @@ kind = kind_phys intent = out [exch_m] - standard_name = atmosphere_momentum_diffusivity_for_mynnpbl + standard_name = atmosphere_momentum_diffusivity_for_mynnedmf long_name = diffusivity for momentum for MYNN PBL (defined for all mass levels) units = m2 s-1 dimensions = (horizontal_loop_extent,vertical_layer_dimension) @@ -1057,6 +1065,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 @@ -1267,7 +1283,7 @@ [bl_mynn_closure] standard_name = control_for_closure_level_in_mellor_yamada_nakanishi_niino_pbl_scheme long_name = flag to determine the closure level for the mynn - units = flag + units = 1 dimensions = () type = real intent = in @@ -1313,6 +1329,71 @@ 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 +[chem3d] + standard_name = chem3d_mynn_pbl_transport + long_name = mynn pbl transport of smoke and dust + units = various + dimensions = (horizontal_loop_extent,vertical_layer_dimension,2) + type = real + kind = kind_phys + intent = inout +[frp] + standard_name = frp_hourly + long_name = hourly fire radiative power + units = MW + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[rrfs_smoke] + standard_name = do_smoke_coupling + long_name = flag controlling rrfs_smoke collection (default off) + units = flag + dimensions = () + type = logical + intent = in +[mix_chem] + standard_name = do_planetary_boundary_layer_smoke_mixing + long_name = flag for rrfs smoke mynn tracer mixing + units = flag + dimensions = () + type = logical + intent = in +[fire_turb] + standard_name = do_planetary_boundary_layer_fire_enhancement + long_name = flag for rrfs smoke mynn enh vermix + units = flag + dimensions = () + type = logical + intent = in +[nchem] + standard_name = number_of_chemical_species_vertically_mixed + long_name = number of chemical vertically mixed + units = count + dimensions = () + type = integer + intent = in +[ndvel] + standard_name = number_of_chemical_species_deposited + long_name = number of chemical pbl deposited + units = count + dimensions = () + type = integer + intent = in [ltaerosol] standard_name = flag_for_aerosol_physics long_name = flag for aerosol physics diff --git a/physics/module_MYNNSFC_wrapper.F90 b/physics/mynnsfc_wrapper.F90 similarity index 94% rename from physics/module_MYNNSFC_wrapper.F90 rename to physics/mynnsfc_wrapper.F90 index 150a66472..c4da027f1 100644 --- a/physics/module_MYNNSFC_wrapper.F90 +++ b/physics/mynnsfc_wrapper.F90 @@ -1,4 +1,4 @@ -!> \file module_mynnsfc_wrapper.F90 +!> \file mynnsfc_wrapper.F90 !! Contains all of the code related to running the MYNN surface layer scheme MODULE mynnsfc_wrapper @@ -62,6 +62,9 @@ SUBROUTINE mynnsfc_wrapper_run( & & sigmaf,vegtype,shdmax,ivegsrc, & !intent(in) & z0pert,ztpert, & !intent(in) & redrag,sfc_z0_type, & !intent(in) + & isftcflx,iz0tlnd, & !intent(in) + & sfclay_compute_flux, & !intent(in) + & sfclay_compute_diag, & !intent(in) & delt,dx, & & u, v, t3d, qvsh, qc, prsl, phii, & & exner, ps, PBLH, slmsk, & @@ -98,19 +101,6 @@ SUBROUTINE mynnsfc_wrapper_run( & ! should be moved to inside the mynn: use machine , only : kind_phys -! use physcons, only : cp => con_cp, & -! & g => con_g, & -! & r_d => con_rd, & -! & r_v => con_rv, & -! & cpv => con_cvap, & -! & cliq => con_cliq, & -! & Cice => con_csol, & -! & rcp => con_rocp, & -! & XLV => con_hvap, & -! & XLF => con_hfus, & -! & EP_1 => con_fvirt, & -! & EP_2 => con_eps - ! USE module_sf_mynn, only : SFCLAY_mynn !tgs - info on iterations: ! flag_iter- logical, execution or not (im) @@ -143,11 +133,9 @@ SUBROUTINE mynnsfc_wrapper_run( & integer, intent(out) :: errflg !MISC CONFIGURATION OPTIONS - INTEGER, PARAMETER :: & - & isftcflx = 0, & !control: 0 - & iz0tlnd = 0, & !control: 0 - & isfflx = 1 - + INTEGER, PARAMETER :: isfflx = 1 + logical, intent(in) :: sfclay_compute_flux,sfclay_compute_diag + integer, intent(in) :: isftcflx,iz0tlnd integer, intent(in) :: im, levs integer, intent(in) :: iter, itimestep, lsm, lsm_ruc logical, dimension(:), intent(in) :: flag_iter @@ -311,9 +299,10 @@ SUBROUTINE mynnsfc_wrapper_run( & EP1=ep_1,EP2=ep_2,KARMAN=karman, & ISFFLX=isfflx,isftcflx=isftcflx,LSM=lsm,LSM_RUC=lsm_ruc, & iz0tlnd=iz0tlnd,psi_opt=psi_opt, & - & sigmaf=sigmaf,vegtype=vegtype,shdmax=shdmax,ivegsrc=ivegsrc, & !intent(in) - & z0pert=z0pert,ztpert=ztpert, & !intent(in) - & redrag=redrag,sfc_z0_type=sfc_z0_type, & !intent(in) + compute_flux=sfclay_compute_flux,compute_diag=sfclay_compute_diag,& + sigmaf=sigmaf,vegtype=vegtype,shdmax=shdmax,ivegsrc=ivegsrc, & !intent(in) + z0pert=z0pert,ztpert=ztpert, & !intent(in) + redrag=redrag,sfc_z0_type=sfc_z0_type, & !intent(in) itimestep=itimestep,iter=iter,flag_iter=flag_iter, & wet=wet, dry=dry, icy=icy, & !intent(in) tskin_wat=tskin_wat, tskin_lnd=tskin_lnd, tskin_ice=tskin_ice, & !intent(in) diff --git a/physics/module_MYNNSFC_wrapper.meta b/physics/mynnsfc_wrapper.meta similarity index 96% rename from physics/module_MYNNSFC_wrapper.meta rename to physics/mynnsfc_wrapper.meta index 4e73504d7..d89cc5d35 100644 --- a/physics/module_MYNNSFC_wrapper.meta +++ b/physics/mynnsfc_wrapper.meta @@ -157,6 +157,34 @@ dimensions = () type = integer intent = in +[isftcflx] + standard_name = control_for_thermal_roughness_lengths_over_water + long_name = flag for thermal roughness lengths over water in mynnsfclay + units = 1 + dimensions = () + type = integer + intent = in +[iz0tlnd] + standard_name = control_for_thermal_roughness_lengths_over_land + long_name = flag for thermal roughness lengths over land in mynnsfclay + units = 1 + dimensions = () + type = integer + intent = in +[sfclay_compute_flux] + standard_name = do_compute_surface_scalar_fluxes + long_name = flag for computing surface scalar fluxes in mynnsfclay + units = flag + dimensions = () + type = logical + intent = in +[sfclay_compute_diag] + standard_name = do_compute_surface_diagnostics + long_name = flag for computing surface diagnostics in mynnsfclay + units = flag + dimensions = () + type = logical + intent = in [delt] standard_name = timestep_for_physics long_name = time step for physics diff --git a/physics/noahmp_tables.f90 b/physics/noahmp_tables.f90 index 9cb25b3f3..2e3e2920e 100644 --- a/physics/noahmp_tables.f90 +++ b/physics/noahmp_tables.f90 @@ -510,11 +510,11 @@ module noahmp_tables ! real :: cwpvt_table(mvt) !< empirical canopy wind parameter - data ( cwpvt_table (i),i=1,mvt) / 0.18, 0.67, 0.18, 0.67, 0.29, 1.00, & - & 2.00, 1.30, 1.00, 5.00, 1.17, 1.67, & - & 1.67, 1.67, 0.18, 0.18, 0.18, 0.67, & - & 1.00, 0.18, 0.00, 0.00, 0.00, 0.00, & - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + data ( cwpvt_table (i),i=1,mvt) / 0.09, 0.335, 0.09, 0.335, 0.145, 0.50, & + & 1.00, 0.65, 0.50, 2.50, 0.585, 0.835, & + & 0.835, 0.835, 0.09, 0.09, 0.09, 0.335, & + & 0.50, 0.09, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / real :: wrrat_table(mvt) !< wood to non-wood ratio diff --git a/physics/sfc_noahmp_drv.F90 b/physics/noahmpdrv.F90 similarity index 99% rename from physics/sfc_noahmp_drv.F90 rename to physics/noahmpdrv.F90 index 1fd9773ff..14f26b28f 100644 --- a/physics/sfc_noahmp_drv.F90 +++ b/physics/noahmpdrv.F90 @@ -1,5 +1,5 @@ #define CCPP -!> \file sfc_noahmp_drv.F90 +!> \file noahmpdrv.F90 !! This file contains the NoahMP land surface scheme driver. !>\defgroup NoahMP_LSM NoahMP LSM Model @@ -111,7 +111,7 @@ subroutine noahmpdrv_run & shdmin, shdmax, snoalb, sfalb, flag_iter,con_g, & idveg, iopt_crs, iopt_btr, iopt_run, iopt_sfc, iopt_frz, & iopt_inf, iopt_rad, iopt_alb, iopt_snf, iopt_tbot, & - iopt_stc, xlatin, xcoszin, iyrlen, julian, garea, & + iopt_stc, iopt_trs,xlatin, xcoszin, iyrlen, julian, garea, & rainn_mp, rainc_mp, snow_mp, graupel_mp, ice_mp, & con_hvap, con_cp, con_jcal, rhoh2o, con_eps, con_epsm1, & con_fvirt, con_rd, con_hfus, thsfc_loc, & @@ -213,6 +213,7 @@ subroutine noahmpdrv_run & integer , intent(in) :: iopt_snf ! option for partitioning precipitation into rainfall & snowfall integer , intent(in) :: iopt_tbot ! option for lower boundary condition of soil temperature integer , intent(in) :: iopt_stc ! option for snow/soil temperature time scheme (only layer 1) + integer , intent(in) :: iopt_trs ! option for thermal roughness scheme real(kind=kind_phys), dimension(:) , intent(in) :: xlatin ! latitude real(kind=kind_phys), dimension(:) , intent(in) :: xcoszin ! cosine of zenith angle integer , intent(in) :: iyrlen ! year length [days] @@ -700,8 +701,8 @@ subroutine noahmpdrv_run & call noahmp_options(idveg ,iopt_crs, iopt_btr , iopt_run, iopt_sfc, & iopt_frz, iopt_inf , iopt_rad, iopt_alb, & - iopt_snf, iopt_tbot, iopt_stc, & - iopt_rsf, iopt_soil, iopt_pedo, iopt_crop ) + iopt_snf, iopt_tbot, iopt_stc, iopt_rsf, & + iopt_soil,iopt_pedo, iopt_crop,iopt_trs ) if ( vegetation_category == isice_table ) then @@ -714,7 +715,8 @@ subroutine noahmpdrv_run & ice_flag = -1 temperature_soil_bot = min(temperature_soil_bot,263.15) - call noahmp_options_glacier(iopt_alb, iopt_snf, iopt_tbot, iopt_stc, iopt_gla, iopt_sfc ) + call noahmp_options_glacier(iopt_alb, iopt_snf, iopt_tbot, iopt_stc, iopt_gla, & + iopt_sfc ,iopt_trs) call noahmp_glacier ( & i_location ,1 ,cosine_zenith ,nsnow , & @@ -921,7 +923,7 @@ subroutine noahmpdrv_run & snowc (i) = snow_cover_fraction sncovr1 (i) = snow_cover_fraction -! qsurf (i) = spec_humidity_surface + qsurf (i) = spec_humidity_surface tsurf (i) = tskin(i) tvxy (i) = temperature_leaf @@ -996,7 +998,7 @@ subroutine noahmpdrv_run & cmm (i) = cmxy(i) * wind(i) snwdph (i) = snow_depth * 1000.0 ! convert from m to mm; wait after the stability call - qsurf (i) = q1(i) + evap(i)/(con_hvap*density*ch(i)*wind(i)) +! qsurf (i) = q1(i) + evap(i)/(con_hvap*density*ch(i)*wind(i)) ! ! --- change units for output diff --git a/physics/sfc_noahmp_drv.meta b/physics/noahmpdrv.meta similarity index 99% rename from physics/sfc_noahmp_drv.meta rename to physics/noahmpdrv.meta index ea08e6bf7..1246fa1b0 100644 --- a/physics/sfc_noahmp_drv.meta +++ b/physics/noahmpdrv.meta @@ -424,6 +424,13 @@ dimensions = () type = integer intent = in +[iopt_trs] + standard_name = control_for_land_surface_scheme_surface_thermal_roughness + long_name = choice for surface thermal roughness option (see noahmp module for definition) + units = index + dimensions = () + type = integer + intent = in [xlatin] standard_name = latitude long_name = latitude 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/rad_sw_pre.F90 b/physics/rad_sw_pre.F90 new file mode 100644 index 000000000..8c33c17b8 --- /dev/null +++ b/physics/rad_sw_pre.F90 @@ -0,0 +1,59 @@ +! ###################################################################################### +!>\file rad_sw_pre.f90 +!! +!! This file gathers the sunlit points for the shortwave radiation schemes. +!! +!> \defgroup rad_sw_pre GFS radiation pre routine. +!! @{ +!! +! ###################################################################################### +module rad_sw_pre +contains + + ! ################################################################################### +!> \section arg_table_rad_sw_pre_run Argument Table +!! \htmlinclude rad_sw_pre_run.html +!! +!! \section rad_sw_pre_run +!! @{ + ! ################################################################################### + subroutine rad_sw_pre_run (im, lsswr, coszen, nday, idxday, errmsg, errflg) + use machine, only: kind_phys + implicit none + + ! Inputs + integer, intent(in) :: im + logical, intent(in) :: lsswr + real(kind_phys), dimension(:), intent(in) :: coszen + + ! Outputs + integer, intent(out) :: nday + integer, dimension(:), intent(out) :: idxday + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Local variables + integer :: i + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (lsswr) then + ! Check for daytime points for SW radiation. + nday = 0 + idxday = 0 + do i = 1, IM + if (coszen(i) >= 0.0001) then + nday = nday + 1 + idxday(nday) = i + endif + enddo + else + nday = 0 + idxday = 0 + endif + + end subroutine rad_sw_pre_run +!! @} +end module rad_sw_pre diff --git a/physics/rrtmg_sw_pre.meta b/physics/rad_sw_pre.meta similarity index 96% rename from physics/rrtmg_sw_pre.meta rename to physics/rad_sw_pre.meta index 6a3a4e0a4..ccbdbf74b 100644 --- a/physics/rrtmg_sw_pre.meta +++ b/physics/rad_sw_pre.meta @@ -1,11 +1,11 @@ [ccpp-table-properties] - name = rrtmg_sw_pre + name = rad_sw_pre type = scheme dependencies = iounitdef.f,machine.F ######################################################################## [ccpp-arg-table] - name = rrtmg_sw_pre_run + name = rad_sw_pre_run type = scheme [im] standard_name = horizontal_loop_extent diff --git a/physics/radiation_cloud_overlap.F90 b/physics/radiation_cloud_overlap.F90 index a94923ba5..7fa44ec07 100644 --- a/physics/radiation_cloud_overlap.F90 +++ b/physics/radiation_cloud_overlap.F90 @@ -21,10 +21,10 @@ subroutine cmp_dcorr_lgth_hogan(nCol, lat, con_pi, dcorr_lgth) nCol ! Number of horizontal grid-points real(kind_phys), intent(in) :: & con_pi ! Physical constant: Pi - real(kind_phys), dimension(nCol), intent(in) :: & + real(kind_phys), dimension(:), intent(in) :: & lat ! Latitude ! Outputs - real(kind_phys), dimension(nCol),intent(out) :: & + real(kind_phys), dimension(:),intent(out) :: & dcorr_lgth ! Decorrelation length ! Local variables @@ -52,11 +52,11 @@ subroutine cmp_dcorr_lgth_oreopoulos(nCol, lat, juldat, yearlength, dcorr_lgth) real(kind_phys), intent(in) :: & juldat ! Julian date - real(kind_phys), dimension(nCol), intent(in) :: & + real(kind_phys), dimension(:), intent(in) :: & lat ! Latitude ! Outputs - real(kind_phys), dimension(nCol),intent(out) :: & + real(kind_phys), dimension(:),intent(out) :: & dcorr_lgth ! Decorrelation length (km) ! Parameters for the Gaussian fits per Eqs. (10) and (11) (See Table 1) @@ -84,19 +84,25 @@ end subroutine cmp_dcorr_lgth_oreopoulos ! ###################################################################################### ! ! ###################################################################################### - subroutine get_alpha_exp(nCol, nLay, dzlay, dcorr_lgth, alpha) + subroutine get_alpha_exper(nCol, nLay, iovr, iovr_exprand, dzlay, & + dcorr_lgth, cld_frac, alpha) ! Inputs integer, intent(in) :: & nCol, & ! Number of horizontal grid points nLay ! Number of vertical grid points - real(kind_phys), dimension(nCol), intent(in) :: & + integer, intent(in) :: & + iovr, & + iovr_exprand + real(kind_phys), dimension(:), intent(in) :: & dcorr_lgth ! Decorrelation length (km) - real(kind_phys), dimension(nCol,nLay), intent(in) :: & + real(kind_phys), dimension(:,:), intent(in) :: & dzlay ! + real(kind_phys), dimension(:,:), intent(in) :: & + cld_frac ! Outputs - real(kind_phys), dimension(nCol,nLay) :: & + real(kind_phys), dimension(:,:) :: & alpha ! Cloud overlap parameter ! Local variables @@ -108,9 +114,22 @@ subroutine get_alpha_exp(nCol, nLay, dzlay, dcorr_lgth, alpha) alpha(iCol,iLay) = exp( -(dzlay(iCol,iLay)) / dcorr_lgth(iCol)) enddo enddo - + + ! Revise alpha for exponential-random cloud overlap + ! Decorrelate layers when a clear layer follows a cloudy layer to enforce + ! random correlation between non-adjacent blocks of cloudy layers + if (iovr == iovr_exprand) then + do iLay = 2, nLay + do iCol = 1, nCol + if (cld_frac(iCol,iLay) == 0.0 .and. cld_frac(iCol,iLay-1) > 0.0) then + alpha(iCol,iLay) = 0.0 + endif + enddo + enddo + endif + return - end subroutine get_alpha_exp + end subroutine get_alpha_exper end module module_radiation_cloud_overlap diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index c3e0b1293..16ea93d26 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -18,82 +18,53 @@ ! outputs: ! ! ( none ) ! ! ! -! 'progcld1' --- zhao/moorthi prognostic cloud scheme ! +! 'radiation_clouds_prop' --- radiation cloud properties ! +! obtained from various cloud schemes ! ! inputs: ! -! (plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw, ! -! xlat,xlon,slmsk,dz,delp, ! -! IX, NLAY, NLP1, ! -! uni_cld, lmfshal, lmfdeep2, cldcov, ! -! effrl,effri,effrr,effrs,effr_in, ! -! dzlay, latdeg, julian, yearlen, ! +! (plyr,plvl,tlyr,tvly,qlyr,qstl,rhly, ! +! ccnd, ncndl, cnvw, cnvc, tracer1, ! +! xlat,xlon,slmsk,dz,delp, IX, LM, NLAY, NLP1, ! +! deltaq, sup, me, icloud, kdt, ! +! ntrac, ntcw, ntiw, ntrw, ntsw, ntgl, ntclamt, ! +! imp_physics, imp_physics_nssl, imp_physics_fer_hires, ! +! imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, ! +! imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, ! +! imp_physics_mg, iovr_rand, iovr_maxrand, iovr_max, ! +! iovr_dcorr, iovr_exp, iovr_exprand, idcor_con, ! +! idcor_hogan, idcor_oreopoulos, ! +! imfdeepcnv, imfdeepcnv_gf, do_mynnedmf, lgfdlmprad, ! +! uni_cld, lmfshal, lmfdeep2, cldcov, clouds1, ! +! effrl, effri, effrr, effrs, effr_in, ! +! effrl_inout, effri_inout, effrs_inout, ! +! lwp_ex, iwp_ex, lwp_fc, iwp_fc, ! +! dzlay, latdeg, julian, yearlen, gridkm, ! ! outputs: ! -! clouds,clds,mtop,mbot,de_lgth,alpha) ! +! cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, ! +! cld_rwp, cld_rerain, cld_swp, cld_resnow, ! +! clds,mtop,mbot,de_lgth,alpha) ! ! ! -! 'progcld2' --- ferrier prognostic cloud microphysics ! -! inputs: ! -! (plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw, ! -! xlat,xlon,slmsk,dz,delp, f_ice,f_rain,r_rime,flgmin, ! -! IX, NLAY, NLP1, lmfshal, lmfdeep2, ! -! dzlay, latdeg, julian, yearlen, ! -! outputs: ! -! clouds,clds,mtop,mbot,de_lgth,alpha) ! -! ! -! 'progcld3' --- zhao/moorthi prognostic cloud + pdfcld! -! inputs: ! -! (plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw,cnvw,cnvc, ! -! xlat,xlon,slmsk, dz, delp, ! -! ix, nlay, nlp1, ! -! deltaq,sup,kdt,me, ! -! dzlay, latdeg, julian, yearlen, ! -! outputs: ! -! clouds,clds,mtop,mbot,de_lgth,alpha) ! -! ! -! 'progcld4' --- gfdl-lin cloud microphysics ! -! inputs: ! -! (plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw,cnvw,cnvc, ! -! xlat,xlon,slmsk, dz, delp, ! -! ix, nlay, nlp1, ! -! dzlay, latdeg, julian, yearlen, ! -! outputs: ! -! clouds,clds,mtop,mbot,de_lgth,alpha) ! -! ! -! 'progcld4o' --- inactive ! -! ! -! 'progcld5' --- wsm6 cloud microphysics ! -! inputs: ! -! (plyr,plvl,tlyr,qlyr,qstl,rhly,clw, ! -! xlat,xlon,slmsk, dz, delp, ! -! ntrac,ntcw,ntiw,ntrw,ntsw,ntgl, ! -! ix, nlay, nlp1, ! -! uni_cld, lmfshal, lmfdeep2, cldcov, ! -! re_cloud,re_ice,re_snow, ! -! dzlay, latdeg, julian, yearlen, ! -! outputs: ! -! clouds,clds,mtop,mbot,de_lgth,alpha) ! -! ! -! 'progclduni' --- for unified clouds with MG microphys! -! inputs: ! -! (plyr,plvl,tlyr,tvly,ccnd,ncnd, ! -! xlat,xlon,slmsk,dz,delp, IX, NLAY, NLP1, cldtot, ! -! effrl,effri,effrr,effrs,effr_in, ! -! dzlay, latdeg, julian, yearlen, ! -! outputs: ! -! clouds,clds,mtop,mbot,de_lgth,alpha) ! -! ! -! internal accessable only subroutines: ! -! 'gethml' --- get diagnostic hi, mid, low clouds ! +! internal/external accessable subroutines: ! +! 'progcld_zhao_carr' --- zhao/moorthi prognostic cloud scheme ! +! 'progcld_zhao_carr_pdf' --- zhao/moorthi prognostic cloud + pdfcld ! +! 'progcld_gfdl_lin' --- GFDL-Lin cloud microphysics ! +! 'progcld_fer_hires' --- Ferrier-Aligo cloud microphysics ! +! 'progcld_thompson_wsm6' --- Thompson/wsm6 cloud microphysics (EMC) ! +! 'progclduni' --- MG2/3 cloud microphysics ! +! (with/without SHOC) (EMC) ! +! also used by GFDL MP (EMC) ! +! 'progcld_thompson' --- Thompson MP (added by G. Thompson) ! +! 'gethml' --- get diagnostic hi, mid, low clouds ! ! ! -! ! -! cloud array description: ! -! clouds(:,:,1) - layer total cloud fraction ! -! clouds(:,:,2) - layer cloud liq water path ! -! clouds(:,:,3) - mean effective radius for liquid cloud ! -! clouds(:,:,4) - layer cloud ice water path ! -! clouds(:,:,5) - mean effective radius for ice cloud ! -! clouds(:,:,6) - layer rain drop water path ! -! clouds(:,:,7) - mean effective radius for rain drop ! -! ** clouds(:,:,8) - layer snow flake water path ! -! clouds(:,:,9) - mean effective radius for snow flake ! +! cloud property array description: ! +! cld_frac (:,:) - layer total cloud fraction ! +! cld_lwp (:,:) - layer cloud liq water path ! +! cld_reliq (:,:) - mean effective radius for liquid cloud ! +! cld_iwp (:,:) - layer cloud ice water path ! +! cld_reice (:,:) - mean effective radius for ice cloud ! +! cld_rwp (:,:) - layer rain drop water path ! +! cld_rerain(:,:) - mean effective radius for rain drop ! +! ** cld_swp (:,:) - layer snow flake water path ! +! cld_resnow(:,:) - mean effective radius for snow flake ! ! ** fu's scheme need to be normalized by snow density (g/m**3/1.0e6)! ! ! ! external modules referenced: ! @@ -131,8 +102,6 @@ ! apr 2004, yu-tai hou - separated calculation of the ! ! averaged h,m,l,bl cloud amounts from each of the cld schemes ! ! to become an shared individule subprogram 'gethml'. ! -! may 2004, yu-tai hou - rewritten ferrier's scheme as a ! -! separated program 'progcld2' in the cloud module. ! ! apr 2005, yu-tai hou - modified cloud array and module ! ! structures. ! ! dec 2008, yu-tai hou - changed low-cld calculation, ! @@ -141,7 +110,7 @@ ! adjusted for better agreement with observations. ! ! jan 2011, yu-tai hou - changed virtual temperature ! ! as input variable instead of originally computed inside the ! -! two prognostic cld schemes 'progcld1' and 'progcld2'. ! +! two prognostic cld schemes 'progcld_zhao_carr' ! ! aug 2012, yu-tai hou - modified subroutine cld_init ! ! to pass all fixed control variables at the start. and set ! ! their correponding internal module variables to be used by ! @@ -165,6 +134,9 @@ ! either a constant or a latitude-varying and day-of-year ! ! varying decorrelation length selected with parameter "idcor". ! ! ! +! Jan 2022, Q.Liu - add subroutine radiation_clouds_prop, and ! +! move all the subroutine call "progcld*" from ! +! GFS_rrtmg_pre.F90 to this new subroutine ! !!!!! ========================================================== !!!!! !!!!! end descriptions !!!!! !!!!! ========================================================== !!!!! @@ -217,7 +189,7 @@ module module_radiation_clouds use module_microphysics, only : rsipath2 use module_iounitdef, only : NICLTUN use module_radiation_cloud_overlap, only: cmp_dcorr_lgth, & - & get_alpha_exp + & get_alpha_exper use machine, only : kind_phys ! implicit none @@ -277,9 +249,10 @@ module module_radiation_clouds & 161.503, 168.262, 175.248, 182.473, 189.952, 197.699, & & 205.728, 214.055, 222.694, 231.661, 240.971, 250.639/) - public progcld1, progcld2, progcld3, progcld4, progclduni, & - & cld_init, progcld5, progcld4o, & - & progcld6, progcld_thompson, cal_cldfra3, & + public progcld_zhao_carr, progcld_zhao_carr_pdf, & + & progcld_gfdl_lin, progclduni, progcld_fer_hires, & + & cld_init, radiation_clouds_prop, & + & progcld_thompson_wsm6, progcld_thompson, cal_cldfra3, & & find_cloudLayers, adjust_cloudIce, adjust_cloudH2O, & & adjust_cloudFinal, gethml @@ -300,8 +273,9 @@ 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 +!>\section cld_init General Algorithm !! @{ subroutine cld_init & & ( si, NLAY, imp_physics, me ) ! --- inputs @@ -390,6 +364,8 @@ subroutine cld_init & print *,' --- MG cloud microphysics' elseif (imp_physics == 15) then print *,' --- Ferrier-Aligo cloud microphysics' + elseif (imp_physics == 17) then + print *,' --- NSSL cloud microphysics' else print *,' !!! ERROR in cloud microphysc specification!!!', & & ' imp_physics (NP3D) =',imp_physics @@ -426,67 +402,36 @@ end subroutine cld_init !----------------------------------- !> \ingroup module_radiation_clouds -!> This subroutine computes cloud related quantities using -!! zhao/moorthi's prognostic cloud microphysics scheme. -!!\param plyr (IX,NLAY), model layer mean pressure in mb (100Pa) -!!\param plvl (IX,NLP1), model level pressure in mb (100Pa) -!!\param tlyr (IX,NLAY), model layer mean temperature in K -!!\param tvly (IX,NLAY), model layer virtual temperature in K -!!\param qlyr (IX,NLAY), layer specific humidity in gm/gm -!!\param qstl (IX,NLAY), layer saturate humidity in gm/gm -!!\param rhly (IX,NLAY), layer relative humidity \f$ (=qlyr/qstl) \f$ -!!\param clw (IX,NLAY), layer cloud condensate amount -!!\param xlat (IX), grid latitude in radians, default to pi/2 -> -!! -pi/2 range, otherwise see in-line comment -!!\param xlon (IX), grid longitude in radians (not used) -!!\param slmsk (IX), sea/land mask array (sea:0,land:1,sea-ice:2) -!!\param dz (IX,NLAY), layer thickness (km) -!!\param delp (IX,NLAY), model layer pressure thickness in mb (100Pa) -!!\param IX horizontal dimention -!!\param NLAY vertical layer -!!\param NLP1 level dimensions -!!\param uni_cld logical, true for cloud fraction from shoc -!!\param lmfshal logical, mass-flux shallow convection scheme flag -!!\param lmfdeep2 logical, scale-aware mass-flux deep convection scheme flag -!!\param cldcov layer cloud fraction (used when uni_cld=.true.) -!!\param effrl effective radius for liquid water -!!\param effri effective radius for ice water -!!\param effrr effective radius for rain water -!!\param effrs effective radius for snow water -!!\param effr_in logical, if .true. use input effective radii -!!\param dzlay(ix,nlay) distance between model layer centers -!!\param latdeg(ix) latitude (in degrees 90 -> -90) -!!\param julian day of the year (fractional julian day) -!!\param yearlen current length of the year (365/366 days) -!!\param clouds (IX,NLAY,NF_CLDS), cloud profiles -!!\n (:,:,1) - layer total cloud fraction -!!\n (:,:,2) - layer cloud liq water path \f$(g/m^2)\f$ -!!\n (:,:,3) - mean eff radius for liq cloud (micron) -!!\n (:,:,4) - layer cloud ice water path \f$(g/m^2)\f$ -!!\n (:,:,5) - mean eff radius for ice cloud (micron) -!!\n (:,:,6) - layer rain drop water path (not assigned) -!!\n (:,:,7) - mean eff radius for rain drop (micron) -!!\n (:,:,8) - layer snow flake water path (not assigned) -!!\n (:,:,9) - mean eff radius for snow flake (micron) -!!\param clds (IX,5), fraction of clouds for low, mid, hi, tot, bl -!!\param mtop (IX,3), vertical indices for low, mid, hi cloud tops -!!\param mbot (IX,3), vertical indices for low, mid, hi cloud bases -!!\param de_lgth (IX), clouds decorrelation length (km) -!!\param alpha (IX,NLAY), alpha decorrelation parameter -!>\section gen_progcld1 progcld1 General Algorithm +!> Subroutine radiation_clouds_prop computes cloud related quantities +!! for different cloud microphysics schemes. +!>\section radiation_clouds_prop General Algorithm !> @{ - subroutine progcld1 & - & ( plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw, & ! --- inputs: - & xlat,xlon,slmsk,dz,delp, IX, NLAY, NLP1, & - & uni_cld, lmfshal, lmfdeep2, cldcov, & - & effrl,effri,effrr,effrs,effr_in, & - & dzlay, latdeg, julian, yearlen, & - & clouds,clds,mtop,mbot,de_lgth,alpha & ! --- outputs: + subroutine radiation_clouds_prop & + & ( plyr, plvl, tlyr, tvly, qlyr, qstl, rhly, & ! --- inputs: + & ccnd, ncndl, cnvw, cnvc, tracer1, & + & xlat, xlon, slmsk, dz, delp, IX, LM, NLAY, NLP1, & + & deltaq, sup, me, icloud, kdt, & + & ntrac, ntcw, ntiw, ntrw, ntsw, ntgl, ntclamt, & + & imp_physics, imp_physics_nssl, imp_physics_fer_hires, & + & imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, & + & imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, & + & imp_physics_mg, iovr_rand, iovr_maxrand, iovr_max, & + & iovr_dcorr, iovr_exp, iovr_exprand, idcor_con, & + & idcor_hogan, idcor_oreopoulos, & + & imfdeepcnv, imfdeepcnv_gf, do_mynnedmf, lgfdlmprad, & + & uni_cld, lmfshal, lmfdeep2, cldcov, clouds1, & + & effrl, effri, effrr, effrs, effr_in, & + & effrl_inout, effri_inout, effrs_inout, & + & lwp_ex, iwp_ex, lwp_fc, iwp_fc, & + & dzlay, latdeg, julian, yearlen, gridkm, & + & cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, & ! --- outputs: + & cld_rwp, cld_rerain, cld_swp, cld_resnow, & + & clds, mtop, mbot, de_lgth, alpha & & ) ! ================= subprogram documentation block ================ ! ! ! -! subprogram: progcld1 computes cloud related quantities using ! +! subprogram: radiation_clouds_prop computes cloud related quantities using ! ! zhao/moorthi's prognostic cloud microphysics scheme. ! ! ! ! abstract: this program computes cloud fractions from cloud ! @@ -494,11 +439,22 @@ subroutine progcld1 & ! and computes the low, mid, high, total and boundary layer cloud ! ! fractions and the vertical indices of low, mid, and high cloud ! ! top and base. the three vertical cloud domains are set up in the ! -! initial subroutine "cld_init". ! +! initial subroutine "cld_init". ! ! ! -! usage: call progcld1 ! +! usage: call radiation_clouds_prop ! ! ! -! subprograms called: gethml ! +! subprograms called: ! +! ! +! 'progcld_zhao_carr' --- zhao/moorthi prognostic cloud scheme ! +! 'progcld_zhao_carr_pdf' --- zhao/moorthi prognostic cloud + pdfcld ! +! 'progcld_gfdl_lin' --- GFDL-Lin cloud microphysics ! +! 'progcld_fer_hires' --- Ferrier-Aligo cloud microphysics ! +! 'progcld_thompson_wsm6' --- Thompson/wsm6 cloud microphysics (EMC) ! +! 'progclduni' --- MG cloud microphysics ! +! --- GFDL cloud microphysics (EMC) ! +! --- Thompson + MYNN PBL (or GF convection) ! +! 'progcld_thompson' --- Thompson MP (added by G. Thompson) ! +! 'gethml' --- get diagnostic hi, mid, low clouds ! ! ! ! attributes: ! ! language: fortran 90 ! @@ -515,7 +471,12 @@ subroutine progcld1 & ! qlyr (IX,NLAY) : layer specific humidity in gm/gm ! ! qstl (IX,NLAY) : layer saturate humidity in gm/gm ! ! rhly (IX,NLAY) : layer relative humidity (=qlyr/qstl) ! -! clw (IX,NLAY) : layer cloud condensate amount ! +! ccnd (IX,NLAY,ncndl) : layer cloud condensate amount ! +! water, ice, rain, snow (+ graupel) ! +! ncndl : number of layer cloud condensate types (max of 4) ! +! cnvw (IX,NLAY) : layer convective cloud condensate ! +! cnvc (IX,NLAY) : layer convective cloud cover ! +! tracer1 (IX,NLAY,1:ntrac-1) : all tracers (except sphum) ! ! xlat (IX) : grid latitude in radians, default to pi/2 -> -pi/2! ! range, otherwise see in-line comment ! ! xlon (IX) : grid longitude in radians (not used) ! @@ -523,27 +484,75 @@ subroutine progcld1 & ! dz (ix,nlay) : layer thickness (km) ! ! delp (ix,nlay) : model layer pressure thickness in mb (100Pa) ! ! IX : horizontal dimention ! -! NLAY,NLP1 : vertical layer/level dimensions ! +! LM,NLAY,NLP1 : vertical layer/level dimensions ! +! deltaq (ix,nlay), half total water distribution width ! +! sup supersaturation ! +! me print control flag ! +! icloud : cloud effect to the optical depth in radiation ! +! kdt : current time step index ! +! ntrac number of tracers (Model%ntrac) ! +! ntcw tracer index for cloud liquid water (Model%ntcw) ! +! ntiw tracer index for cloud ice water (Model%ntiw) ! +! ntrw tracer index for rain water (Model%ntrw) ! +! ntsw tracer index for snow water (Model%ntsw) ! +! ntgl tracer index for graupel (Model%ntgl) ! +! ntclamt tracer index for cloud amount (Model%ntclamt) ! +! imp_physics : cloud microphysics scheme control flag ! +! imp_physics_nssl : NSSL microphysics ! +! imp_physics_fer_hires : Ferrier-Aligo microphysics scheme ! +! imp_physics_gfdl : GFDL microphysics scheme ! +! imp_physics_thompson : Thompson microphysics scheme ! +! imp_physics_wsm6 : WSMG microphysics scheme ! +! imp_physics_zhao_carr : Zhao-Carr microphysics scheme ! +! imp_physics_zhao_carr_pdf : Zhao-Carr microphysics scheme with PDF clouds +! imp_physics_mg : Morrison-Gettelman microphysics scheme ! +! iovr_rand : choice of cloud-overlap: random (=0) +! iovr_maxrand : choice of cloud-overlap: maximum random (=1) +! iovr_max : choice of cloud-overlap: maximum (=2) +! iovr_dcorr : choice of cloud-overlap: decorrelation length (=3) +! iovr_exp : choice of cloud-overlap: exponential (=4) +! iovr_exprand : choice of cloud-overlap: exponential random (=5) +! idcor_con : choice for decorrelation-length: Use constant value (=0) +! idcor_hogan : choice for decorrelation-length: (=1) +! idcor_oreopoulos: choice for decorrelation-length: (=2) +! imfdeepcnv : flag for mass-flux deep convection scheme ! +! imfdeepcnv_gf : flag for scale- & aerosol-aware Grell-Freitas scheme (GSD) +! do_mynnedmf : flag for MYNN-EDMF ! +! lgfdlmprad : flag for GFDLMP radiation interaction ! ! uni_cld : logical - true for cloud fraction from shoc ! ! lmfshal : logical - true for mass flux shallow convection ! ! lmfdeep2 : logical - true for mass flux deep convection ! ! cldcov : layer cloud fraction (used when uni_cld=.true. ! +! clouds1 : layer total cloud fraction +! effrl, : effective radius for liquid water +! effri, : effective radius for ice water +! effrr, : effective radius for rain water +! effrs, : effective radius for snow water +! effr_in, : flag to use effective radii of cloud species in radiation +! effrl_inout, : eff. radius of cloud liquid water particle +! effri_inout, : eff. radius of cloud ice water particle +! effrs_inout : effective radius of cloud snow particle +! lwp_ex : total liquid water path from explicit microphysics +! iwp_ex : total ice water path from explicit microphysics +! lwp_fc : total liquid water path from cloud fraction scheme +! iwp_fc : total ice water path from cloud fraction scheme ! dzlay(ix,nlay) : thickness between model layer centers (km) ! ! latdeg(ix) : latitude (in degrees 90 -> -90) ! ! julian : day of the year (fractional julian day) ! ! yearlen : current length of the year (365/366 days) ! +! gridkm : grid length in km ! ! ! output variables: ! -! clouds(IX,NLAY,NF_CLDS) : cloud profiles ! -! clouds(:,:,1) - layer total cloud fraction ! -! clouds(:,:,2) - layer cloud liq water path (g/m**2) ! -! clouds(:,:,3) - mean eff radius for liq cloud (micron) ! -! clouds(:,:,4) - layer cloud ice water path (g/m**2) ! -! clouds(:,:,5) - mean eff radius for ice cloud (micron) ! -! clouds(:,:,6) - layer rain drop water path not assigned ! -! clouds(:,:,7) - mean eff radius for rain drop (micron) ! -! *** clouds(:,:,8) - layer snow flake water path not assigned ! -! clouds(:,:,9) - mean eff radius for snow flake (micron) ! +! cloud profiles: ! +! cld_frac (:,:) - layer total cloud fraction ! +! cld_lwp (:,:) - layer cloud liq water path (g/m**2) ! +! cld_reliq (:,:) - mean eff radius for liq cloud (micron) ! +! cld_iwp (:,:) - layer cloud ice water path (g/m**2) ! +! cld_reice (:,:) - mean eff radius for ice cloud (micron) ! +! cld_rwp (:,:) - layer rain drop water path not assigned ! +! cld_rerain(:,:) - mean eff radius for rain drop (micron) ! +! *** cld_swp (:,:) - layer snow flake water path not assigned ! +! cld_resnow(:,:) - mean eff radius for snow flake (micron) ! ! *** fu's scheme need to be normalized by snow density (g/m**3/1.0e6) ! ! clds (IX,5) : fraction of clouds for low, mid, hi, tot, bl ! ! mtop (IX,3) : vertical indices for low, mid, hi cloud tops ! @@ -565,28 +574,65 @@ subroutine progcld1 & ! =f: not normalize cloud condensate ! ! ! ! ==================== end of description ===================== ! -! implicit none ! --- inputs - integer, intent(in) :: IX, NLAY, NLP1 + integer, intent(in) :: IX, LM, NLAY, NLP1, me, ncndl, icloud + integer, intent(in) :: ntrac, ntcw, ntiw, ntrw, ntsw, ntgl, & + & ntclamt + integer, intent(in) :: kdt, imfdeepcnv, imfdeepcnv_gf + integer, intent(in) :: & + & imp_physics, ! Flag for MP scheme + & imp_physics_nssl, ! Flag for NSSL scheme + & imp_physics_fer_hires, ! Flag for fer-hires scheme + & imp_physics_gfdl, ! Flag for gfdl scheme + & imp_physics_thompson, ! Flag for thompsonscheme + & imp_physics_wsm6, ! Flag for wsm6 scheme + & imp_physics_zhao_carr, ! Flag for zhao-carr scheme + & imp_physics_zhao_carr_pdf, ! Flag for zhao-carr+PDF scheme + & imp_physics_mg ! Flag for MG scheme + + integer, intent(in) :: & + & iovr_rand, ! Flag for random cloud overlap method + & iovr_maxrand, ! Flag for maximum-random cloud overlap method + & iovr_max, ! Flag for maximum cloud overlap method + & iovr_dcorr, ! Flag for decorrelation-length cloud overlap method + & iovr_exp, ! Flag for exponential cloud overlap method + & iovr_exprand, ! Flag for exponential-random cloud overlap method + & idcor_con, + & idcor_hogan, + & idcor_oreopoulos + logical, intent(in) :: uni_cld, lmfshal, lmfdeep2, effr_in + logical, intent(in) :: do_mynnedmf, lgfdlmprad + real (kind=kind_phys), dimension(:,:,:), intent(in) :: ccnd, & + & tracer1 real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & - & tlyr, tvly, qlyr, qstl, rhly, clw, cldcov, delp, dz, & - & effrl, effri, effrr, effrs, dzlay + & tlyr, tvly, qlyr, qstl, rhly, cnvw, cnvc, cldcov, & + & delp, dz, effrl, effri, effrr, effrs, dzlay, clouds1 + real (kind=kind_phys), intent(in) :: sup real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & & slmsk - real(kind=kind_phys), dimension(:), intent(in) :: latdeg + real(kind=kind_phys), dimension(:), intent(in) :: latdeg, gridkm real(kind=kind_phys), intent(in) :: julian integer, intent(in) :: yearlen +! --- inout + real(kind=kind_phys),dimension(:,:) :: deltaq + real(kind=kind_phys),dimension(:,:),intent(inout) :: & + & effrl_inout, effri_inout, effrs_inout + real(kind=kind_phys), dimension(:), intent(inout) :: & + & lwp_ex, iwp_ex, lwp_fc, iwp_fc + ! --- outputs - real (kind=kind_phys), dimension(:,:,:), intent(out) :: clouds + real (kind=kind_phys), dimension(:,:), intent(out) :: & + & cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, & + & cld_rwp, cld_rerain, cld_swp, cld_resnow real (kind=kind_phys), dimension(:,:), intent(out) :: clds real (kind=kind_phys), dimension(:), intent(out) :: de_lgth real (kind=kind_phys), dimension(:,:), intent(out) :: alpha @@ -611,15 +657,418 @@ subroutine progcld1 & ! !===> ... begin here ! - do nf=1,nf_clds - do k=1,nlay - do i=1,ix - clouds(i,k,nf) = 0.0 - enddo + if (me == 0 .and. kdt == 1) then & + print*, 'in radiation_clouds_prop=', imp_physics, uni_cld, & + & ncndl, lgfdlmprad, do_mynnedmf, imfdeepcnv, kdt + end if + + do k = 1, NLAY + do i = 1, IX + cld_frac(i,k) = 0.0 + cld_lwp(i,k) = 0.0 + cld_reliq(i,k) = 0.0 + cld_iwp(i,k) = 0.0 + cld_reice(i,k) = 0.0 + cld_rwp(i,k) = 0.0 + cld_rerain(i,k) = 0.0 + cld_swp(i,k) = 0.0 + cld_resnow(i,k) = 0.0 + enddo + enddo + + do k = 1, NLAY + do i = 1, IX + cldtot(i,k) = 0.0 + cldcnv(i,k) = 0.0 + end do + end do + + if (imp_physics == imp_physics_zhao_carr .or. & + & imp_physics == imp_physics_mg) then ! zhao/moorthi's p + ! or unified cloud and/or with MG microphysics + + if (uni_cld .and. ncndl >= 2) then + call progclduni (plyr, plvl, tlyr, tvly, ccnd, ncndl, & ! --- inputs + & xlat, xlon, slmsk, dz, delp, & + & IX, NLAY, NLP1, cldcov, & + & effrl, effri, effrr, effrs, effr_in, & + & dzlay, & + & cldtot, cldcnv, & ! inout + & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs + & cld_reice,cld_rwp, cld_rerain,cld_swp, & + & cld_resnow) + else + call progcld_zhao_carr (plyr ,plvl, tlyr, tvly, qlyr, & ! --- inputs + & qstl, rhly, ccnd(1:IX,1:NLAY,1), xlat, xlon, & + & slmsk, dz, delp, IX, NLAY, NLP1, uni_cld, & + & lmfshal, lmfdeep2, & + & cldcov, effrl, effri, effrr, effrs, effr_in, & + & dzlay, & + & cldtot, cldcnv, & ! inout + & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs + & cld_reice,cld_rwp, cld_rerain,cld_swp, & + & cld_resnow) + endif + + elseif(imp_physics == imp_physics_zhao_carr_pdf) then ! zhao/moorthi's prognostic cloud+pdfcld + + call progcld_zhao_carr_pdf (plyr, plvl, tlyr, tvly, qlyr, & ! --- inputs + & qstl, rhly, ccnd(1:IX,1:NLAY,1), cnvw, cnvc, & + & xlat, xlon, slmsk, dz, delp, IX, NLAY, NLP1, & + & deltaq, sup, kdt, me, dzlay, & + & cldtot, cldcnv, & ! inout + & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs + & cld_reice,cld_rwp, cld_rerain,cld_swp, & + & cld_resnow) + + elseif (imp_physics == imp_physics_gfdl) then ! GFDL cloud scheme + + if (.not. lgfdlmprad) then + call progcld_gfdl_lin (plyr, plvl, tlyr, tvly, qlyr, & ! --- inputs + & qstl, rhly, ccnd(1:IX,1:NLAY,1), cnvw, cnvc, & + & xlat, xlon, slmsk, cldcov, dz, delp, & + & IX, NLAY, NLP1, dzlay, & + & cldtot, cldcnv, & ! inout + & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs + & cld_reice,cld_rwp, cld_rerain,cld_swp, & + & cld_resnow) + else + + call progclduni (plyr, plvl, tlyr, tvly, ccnd, ncndl, xlat, & ! --- inputs + & xlon, slmsk, dz,delp, IX, NLAY, NLP1, cldcov, & + & effrl, effri, effrr, effrs, effr_in, & + & dzlay, & + & cldtot, cldcnv, & ! inout + & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs + & cld_reice,cld_rwp, cld_rerain,cld_swp, & + & cld_resnow) + endif + + + elseif(imp_physics == imp_physics_fer_hires) then + if (kdt == 1) then + effrl_inout(:,:) = 10. + effri_inout(:,:) = 50. + effrs_inout(:,:) = 250. + endif + + call progcld_fer_hires (plyr,plvl,tlyr,tvly,qlyr,qstl,rhly, & ! --- inputs + & tracer1,xlat,xlon,slmsk,dz,delp, & + & ntrac-1, ntcw-1,ntiw-1,ntrw-1, & + & IX,NLAY,NLP1, icloud, uni_cld, & + & lmfshal, lmfdeep2, & + & cldcov(:,1:NLAY),effrl_inout(:,:), & + & effri_inout(:,:), effrs_inout(:,:), & + & dzlay, & + & cldtot, cldcnv, & ! inout + & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs + & cld_reice,cld_rwp, cld_rerain,cld_swp, & + & cld_resnow) + + elseif ( imp_physics == imp_physics_nssl ) then ! NSSL MP + + if(do_mynnedmf .or. imfdeepcnv == imfdeepcnv_gf ) then ! MYNN PBL or GF conv + !-- MYNN PBL or convective GF + !-- use cloud fractions with SGS clouds + do k=1,NLAY + do i=1,IX + cld_frac(i,k) = clouds1(i,k) + enddo + enddo + + ! --- use clduni with the NSSL microphysics. + ! --- make sure that effr_in=.true. in the input.nml! + call progclduni (plyr, plvl, tlyr, tvly, ccnd, ncndl, & ! --- inputs + & xlat, xlon, slmsk, dz, delp, IX, NLAY, NLP1, & + & cld_frac, & + & effrl, effri, effrr, effrs, effr_in , & + & dzlay, & + & cldtot, cldcnv, & ! inout + & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs + & cld_reice,cld_rwp, cld_rerain,cld_swp, & + & cld_resnow) + else + ! MYNN PBL or GF convective are not used + call progcld_thompson_wsm6 (plyr,plvl,tlyr,qlyr,qstl, & ! --- inputs + & rhly,tracer1,xlat,xlon,slmsk,dz,delp, & + & ntrac-1, ntcw-1,ntiw-1,ntrw-1, & + & ntsw-1,ntgl-1, & + & IX, NLAY, NLP1, uni_cld, lmfshal, lmfdeep2, & + & cldcov(:,1:NLAY), cnvw, effrl_inout, & + & effri_inout, effrs_inout, & + & lwp_ex, iwp_ex, lwp_fc, iwp_fc, & + & dzlay, & + & cldtot, cldcnv, & ! inout + & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs + & cld_reice,cld_rwp, cld_rerain,cld_swp, & + & cld_resnow) + endif ! MYNN PBL or GF + + elseif(imp_physics == imp_physics_thompson) then ! Thompson MP + + if(do_mynnedmf .or. imfdeepcnv == imfdeepcnv_gf ) then ! MYNN PBL or GF conv + + if (icloud == 3) then + call progcld_thompson (plyr,plvl,tlyr,qlyr,qstl,rhly, & ! --- inputs + & tracer1,xlat,xlon,slmsk,dz,delp, & + & ntrac-1, ntcw-1,ntiw-1,ntrw-1, & + & ntsw-1,ntgl-1, & + & IX, LM, NLP1, uni_cld, lmfshal, lmfdeep2, & + & cldcov(:,1:LM), effrl, effri, effrs, & + & lwp_ex, iwp_ex, lwp_fc, iwp_fc, & + & dzlay, gridkm, & + & cldtot, cldcnv, & ! inout + & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs + & cld_reice,cld_rwp, cld_rerain,cld_swp, & + & cld_resnow) + else + + !-- MYNN PBL or convective GF + !-- use cloud fractions with SGS clouds + do k=1,NLAY + do i=1,IX + cld_frac(i,k) = clouds1(i,k) + enddo + enddo + + ! --- use clduni as with the GFDL microphysics. + ! --- make sure that effr_in=.true. in the input.nml! + call progclduni (plyr, plvl, tlyr, tvly, ccnd, ncndl, & ! --- inputs + & xlat, xlon, slmsk, dz, delp, IX, NLAY, NLP1, & + & cld_frac, & + & effrl, effri, effrr, effrs, effr_in , & + & dzlay, & + & cldtot, cldcnv, & ! inout + & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs + & cld_reice,cld_rwp, cld_rerain,cld_swp, & + & cld_resnow) + endif + + else + ! MYNN PBL or GF convective are not used + + if (icloud == 3) then + call progcld_thompson (plyr,plvl,tlyr,qlyr,qstl,rhly, & ! --- inputs + & tracer1,xlat,xlon,slmsk,dz,delp, & + & ntrac-1, ntcw-1,ntiw-1,ntrw-1, & + & ntsw-1,ntgl-1, & + & IX, LM, NLP1, uni_cld, lmfshal, lmfdeep2, & + & cldcov(:,1:LM), effrl, effri, effrs, & + & lwp_ex, iwp_ex, lwp_fc, iwp_fc, & + & dzlay, gridkm, & + & cldtot, cldcnv, & ! inout + & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs + & cld_reice,cld_rwp, cld_rerain,cld_swp, & + & cld_resnow) + + else + call progcld_thompson_wsm6 (plyr,plvl,tlyr,qlyr,qstl, & ! --- inputs + & rhly,tracer1,xlat,xlon,slmsk,dz,delp, & + & ntrac-1, ntcw-1,ntiw-1,ntrw-1, & + & ntsw-1,ntgl-1, & + & IX, NLAY, NLP1, uni_cld, lmfshal, lmfdeep2, & + & cldcov(:,1:NLAY), cnvw, effrl, effri, effrs, & + & lwp_ex, iwp_ex, lwp_fc, iwp_fc, & + & dzlay, & + & cldtot, cldcnv, & ! inout + & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs + & cld_reice,cld_rwp, cld_rerain,cld_swp, & + & cld_resnow) + endif + endif ! MYNN PBL or GF + + endif ! end if_imp_physics + +!> - Compute SFC/low/middle/high cloud top pressure for each cloud +!! domain for given latitude. +! ptopc(k,i): top presure of each cld domain (k=1-4 are sfc,L,m,h; +! --- i=1,2 are low-lat (<45 degree) and pole regions) + + do i =1, IX + rxlat(i) = abs( xlat(i) / con_pi ) ! if xlat in pi/2 -> -pi/2 range +! rxlat(i) = abs(0.5 - xlat(i)/con_pi) ! if xlat in 0 -> pi range + enddo + + do id = 1, 4 + tem1 = ptopc(id,2) - ptopc(id,1) + + do i =1, IX + ptop1(i,id) = ptopc(id,1) + tem1*max( 0.0, 4.0*rxlat(i)-1.0 ) enddo enddo -! clouds(:,:,:) = 0.0 + + ! Compute cloud decorrelation length + if (idcor == idcor_hogan) then + call cmp_dcorr_lgth(ix, xlat, con_pi, de_lgth) + endif + if (idcor == idcor_oreopoulos) then + call cmp_dcorr_lgth(ix, latdeg, julian, yearlen, de_lgth) + endif + if (idcor == idcor_con) then + de_lgth(:) = decorr_con + endif + + ! Call subroutine get_alpha_exper to define alpha parameter for exponential cloud overlap options + if ( iovr == iovr_dcorr .or. iovr == iovr_exp & + & .or. iovr == iovr_exprand) then + call get_alpha_exper(ix, nLay, iovr, iovr_exprand, dzlay, & + & de_lgth, cld_frac, alpha) + else + de_lgth(:) = 0. + alpha(:,:) = 0. + endif + +!> - Call gethml() to compute low,mid,high,total, and boundary layer +!! cloud fractions and clouds top/bottom layer indices for low, mid, +!! and high clouds. +! --- compute low, mid, high, total, and boundary layer cloud fractions +! and clouds top/bottom layer indices for low, mid, and high clouds. +! The three cloud domain boundaries are defined by ptopc. The cloud +! overlapping method is defined by control flag 'iovr', which may +! be different for lw and sw radiation programs. + + call gethml & +! --- inputs: + & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, alpha, & + & IX, NLAY, iovr_rand, iovr_maxrand, iovr_max, & + & iovr_dcorr, iovr_exp, iovr_exprand, & +! --- outputs: + & clds, mtop, mbot & + & ) + + return +!................................... + end subroutine radiation_clouds_prop + +!> \ingroup module_radiation_clouds +!> This subroutine computes cloud related quantities using +!! zhao/moorthi's prognostic cloud microphysics scheme. +!>\section progcld_zhao_carr General Algorithm +!> @{ + subroutine progcld_zhao_carr & + & ( plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw, & ! --- inputs: + & xlat,xlon,slmsk,dz,delp, IX, NLAY, NLP1, & + & uni_cld, lmfshal, lmfdeep2, cldcov, & + & effrl,effri,effrr,effrs,effr_in, & + & dzlay, cldtot, cldcnv, & + & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs + & cld_reice,cld_rwp, cld_rerain,cld_swp, cld_resnow & + & ) + +! ================= subprogram documentation block ================ ! +! ! +! subprogram: progcld_zhao_carr computes cloud related quantities using ! +! zhao/moorthi's prognostic cloud microphysics scheme. ! +! ! +! abstract: this program computes cloud fractions from cloud ! +! condensates, calculates liquid/ice cloud droplet effective radius, ! +! and computes the low, mid, high, total and boundary layer cloud ! +! fractions and the vertical indices of low, mid, and high cloud ! +! top and base. the three vertical cloud domains are set up in the ! +! initial subroutine "cld_init". ! +! ! +! usage: call progcld_zhao_carr ! +! ! +! subprograms called: gethml ! +! ! +! attributes: ! +! language: fortran 90 ! +! machine: ibm-sp, sgi ! +! ! +! ! +! ==================== definition of variables ==================== ! +! ! +! input variables: ! +! plyr (IX,NLAY) : model layer mean pressure in mb (100Pa) ! +! plvl (IX,NLP1) : model level pressure in mb (100Pa) ! +! tlyr (IX,NLAY) : model layer mean temperature in k ! +! tvly (IX,NLAY) : model layer virtual temperature in k ! +! qlyr (IX,NLAY) : layer specific humidity in gm/gm ! +! qstl (IX,NLAY) : layer saturate humidity in gm/gm ! +! rhly (IX,NLAY) : layer relative humidity (=qlyr/qstl) ! +! clw (IX,NLAY) : layer cloud condensate amount ! +! xlat (IX) : grid latitude in radians, default to pi/2 -> -pi/2! +! range, otherwise see in-line comment ! +! xlon (IX) : grid longitude in radians (not used) ! +! slmsk (IX) : sea/land mask array (sea:0,land:1,sea-ice:2) ! +! dz (ix,nlay) : layer thickness (km) ! +! delp (ix,nlay) : model layer pressure thickness in mb (100Pa) ! +! IX : horizontal dimention ! +! NLAY,NLP1 : vertical layer/level dimensions ! +! uni_cld : logical - true for cloud fraction from shoc ! +! lmfshal : logical - true for mass flux shallow convection ! +! lmfdeep2 : logical - true for mass flux deep convection ! +! cldcov : layer cloud fraction (used when uni_cld=.true. ! +! effrl : effective radius for liquid water +! effri : effective radius for ice water +! effrr : effective radius for rain water +! effrs : effective radius for snow water +! effr_in : logical, if .true. use input effective radii +! dzlay(ix,nlay) : thickness between model layer centers (km) ! +! ! +! output variables: ! +! cloud profiles: ! +! cld_frac (:,:) - layer total cloud fraction ! +! cld_lwp (:,:) - layer cloud liq water path (g/m**2) ! +! cld_reliq (:,:) - mean eff radius for liq cloud (micron) ! +! cld_iwp (:,:) - layer cloud ice water path (g/m**2) ! +! cld_reice (:,:) - mean eff radius for ice cloud (micron) ! +! cld_rwp (:,:) - layer rain drop water path not assigned ! +! cld_rerain(:,:) - mean eff radius for rain drop (micron) ! +! *** cld_swp (:,:) - layer snow flake water path not assigned ! +! cld_resnow(:,:) - mean eff radius for snow flake (micron) ! +! ! +! module variables: ! +! ivflip : control flag of vertical index direction ! +! =0: index from toa to surface ! +! =1: index from surface to toa ! +! lmfshal : mass-flux shallow conv scheme flag ! +! lmfdeep2 : scale-aware mass-flux deep conv scheme flag ! +! lcrick : control flag for eliminating CRICK ! +! =t: apply layer smoothing to eliminate CRICK ! +! =f: do not apply layer smoothing ! +! lcnorm : control flag for in-cld condensate ! +! =t: normalize cloud condensate ! +! =f: not normalize cloud condensate ! +! ! +! ==================== end of description ===================== ! +! + implicit none + +! --- inputs + integer, intent(in) :: IX, NLAY, NLP1 + + logical, intent(in) :: uni_cld, lmfshal, lmfdeep2, effr_in + + real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & + & tlyr, tvly, qlyr, qstl, rhly, clw, cldcov, delp, dz, & + & effrl, effri, effrr, effrs, dzlay + + real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & + & slmsk + +! --- inputs/outputs + + real (kind=kind_phys), dimension(:,:), intent(inout) :: & + & cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, & + & cld_rwp, cld_rerain, cld_swp, cld_resnow + +! --- local variables: + real (kind=kind_phys), dimension(IX,NLAY) :: cldtot, cldcnv, & + & cwp, cip, crp, csp, rew, rei, res, rer, tem2d, clwf + + real (kind=kind_phys) :: clwmin, clwm, clwt, onemrh, value, & + & tem1, tem2, tem3 + + integer :: i, k, id, nf +! --- constant values +! real (kind=kind_phys), parameter :: xrc3 = 200. + real (kind=kind_phys), parameter :: xrc3 = 100. + +! +!===> ... begin here +! !> - Assgin liquid/ice/rain/snow cloud effective radius from input or predefined values. if(effr_in) then do k = 1, NLAY @@ -675,24 +1124,6 @@ subroutine progcld1 & enddo endif -!> - Compute SFC/low/middle/high cloud top pressure for each cloud -!! domain for given latitude. -! ptopc(k,i): top presure of each cld domain (k=1-4 are sfc,L,m,h; -! --- i=1,2 are low-lat (<45 degree) and pole regions) - - do i =1, IX - rxlat(i) = abs( xlat(i) / con_pi ) ! if xlat in pi/2 -> -pi/2 range -! rxlat(i) = abs(0.5 - xlat(i)/con_pi) ! if xlat in 0 -> pi range - enddo - - do id = 1, 4 - tem1 = ptopc(id,2) - ptopc(id,1) - - do i =1, IX - ptop1(i,id) = ptopc(id,1) + tem1*max( 0.0, 4.0*rxlat(i)-1.0 ) - enddo - enddo - !> - Compute cloud liquid/ice condensate path in \f$ g/m^2 \f$ . do k = 1, NLAY @@ -726,57 +1157,18 @@ subroutine progcld1 & !> - Compute layer cloud fraction. - clwmin = 0.0 - if (.not. lmfshal) then - do k = 1, NLAY - do i = 1, IX - clwt = 1.0e-6 * (plyr(i,k)*0.001) -! clwt = 2.0e-6 * (plyr(i,k)*0.001) - - if (clwf(i,k) > clwt) then - - onemrh= max( 1.e-10, 1.0-rhly(i,k) ) - clwm = clwmin / max( 0.01, plyr(i,k)*0.001 ) - - tem1 = min(max(sqrt(sqrt(onemrh*qstl(i,k))),0.0001),1.0) - tem1 = 2000.0 / tem1 -! tem1 = 1000.0 / tem1 + if (.not. lmfshal) then + call cloud_fraction_XuRandall & + & ( IX, NLAY, plyr, clwf, rhly, qstl, & ! --- inputs + & cldtot ) & ! --- outputs + else + call cloud_fraction_mass_flx_1 & + & ( IX, NLAY, lmfdeep2, xrc3, plyr, clwf, rhly, qstl, & ! --- inputs + & cldtot ) + endif - value = max( min( tem1*(clwf(i,k)-clwm), 50.0 ), 0.0 ) - tem2 = sqrt( sqrt(rhly(i,k)) ) - - cldtot(i,k) = max( tem2*(1.0-exp(-value)), 0.0 ) - endif - enddo - enddo - else - do k = 1, NLAY - do i = 1, IX - clwt = 1.0e-6 * (plyr(i,k)*0.001) -! clwt = 2.0e-6 * (plyr(i,k)*0.001) - - if (clwf(i,k) > clwt) then - onemrh= max( 1.e-10, 1.0-rhly(i,k) ) - clwm = clwmin / max( 0.01, plyr(i,k)*0.001 ) -! - tem1 = min(max((onemrh*qstl(i,k))**0.49,0.0001),1.0) !jhan - if (lmfdeep2) then - tem1 = xrc3 / tem1 - else - tem1 = 100.0 / tem1 - endif -! - value = max( min( tem1*(clwf(i,k)-clwm), 50.0 ), 0.0 ) - tem2 = sqrt( sqrt(rhly(i,k)) ) - - cldtot(i,k) = max( tem2*(1.0-exp(-value)), 0.0 ) - endif - enddo - enddo - endif - - endif ! if (uni_cld) then + endif ! if (uni_cld) then do k = 1, NLAY do i = 1, IX @@ -836,990 +1228,44 @@ subroutine progcld1 & ! do k = 1, NLAY do i = 1, IX - clouds(i,k,1) = cldtot(i,k) - clouds(i,k,2) = cwp(i,k) - clouds(i,k,3) = rew(i,k) - clouds(i,k,4) = cip(i,k) - clouds(i,k,5) = rei(i,k) -! clouds(i,k,6) = 0.0 - clouds(i,k,7) = rer(i,k) -! clouds(i,k,8) = 0.0 - clouds(i,k,9) = res(i,k) + cld_frac(i,k) = cldtot(i,k) + cld_lwp(i,k) = cwp(i,k) + cld_reliq(i,k) = rew(i,k) + cld_iwp(i,k) = cip(i,k) + cld_reice(i,k) = rei(i,k) +! cld_rwp(i,k) = 0.0 + cld_rerain(i,k) = rer(i,k) +! cld_swp(i,k) = 0.0 + cld_resnow(i,k) = res(i,k) enddo enddo - -! --- ... estimate clouds decorrelation length in km -! this is only a tentative test, need to consider change later - - if ( iovr == 3 ) then - do i = 1, ix - de_lgth(i) = max( 0.6, 2.78-4.6*rxlat(i) ) - enddo - endif - - ! Compute cloud decorrelation length - if (idcor == 1) then - call cmp_dcorr_lgth(ix, xlat, con_pi, de_lgth) - endif - if (idcor == 2) then - call cmp_dcorr_lgth(ix, latdeg, julian, yearlen, de_lgth) - endif - if (idcor == 0) then - de_lgth(:) = decorr_con - endif - - ! Call subroutine get_alpha_exp to define alpha parameter for exponential cloud overlap options - if (iovr == 3 .or. iovr == 4 .or. iovr == 5) then - call get_alpha_exp(ix, nLay, dzlay, de_lgth, alpha) - else - de_lgth(:) = 0. - alpha(:,:) = 0. - endif - - ! Revise alpha for exponential-random cloud overlap - ! Decorrelate layers when a clear layer follows a cloudy layer to enforce - ! random correlation between non-adjacent blocks of cloudy layers - if (iovr == 5) then - do k = 2, nLay - do i = 1, ix - if (clouds(i,k,1) == 0.0 .and. clouds(i,k-1,1) > 0.0) then - alpha(i,k) = 0.0 - endif - enddo - enddo - endif - -!> - Call gethml() to compute low,mid,high,total, and boundary layer -!! cloud fractions and clouds top/bottom layer indices for low, mid, -!! and high clouds. The three cloud domain boundaries are defined by -!! ptopc. The cloud overlapping method is defined by control flag -!! 'iovr', which may be different for lw and sw radiation programs. - call gethml & -! --- inputs: - & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, alpha, & - & IX,NLAY, & -! --- outputs: - & clds, mtop, mbot & - & ) - - ! return !................................... - end subroutine progcld1 + end subroutine progcld_zhao_carr !----------------------------------- !> @} - -!> \ingroup module_radiation_clouds -!> This subroutine computes cloud related quantities using Ferrier's -!! prognostic cloud microphysics scheme. -!!\param plyr (IX,NLAY), model layer mean pressure in mb (100Pa) -!!\param plvl (IX,NLP1), model level pressure in mb (100Pa) -!!\param tlyr (IX,NLAY), model layer mean temperature in K -!!\param tvly (IX,NLAY), model layer virtual temperature in K -!!\param qlyr (IX,NLAY), layer specific humidity in gm/gm -!!\param qstl (IX,NLAY), layer saturate humidity in gm/gm -!!\param rhly (IX,NLAY), layer relative humidity (=qlyr/qstl) -!!\param clw (IX,NLAY), layer cloud condensate amount -!!\param f_ice (IX,NLAY), fraction of layer cloud ice (ferrier micro-phys) -!!\param f_rain (IX,NLAY), fraction of layer rain water (ferrier micro-phys) -!!\param r_rime (IX,NLAY), mass ratio of total ice to unrimed ice (>=1) -!!\param flgmin (IX), minimum large ice fraction -!!\param xlat (IX), grid latitude in radians, default to pi/2 -> -!! -pi/2 range, otherwise see in-line comment -!!\param xlon (IX), grid longitude in radians (not used) -!!\param slmsk (IX), sea/land mask array (sea:0,land:1,sea-ice:2) -!!\param dz (IX,NLAY), layer thickness (km) -!!\param delp (IX,NLAY), model layer pressure thickness in mb (100Pa) -!!\param IX horizontal dimention -!!\param NLAY,NLP1 vertical layer/level dimensions -!!\param lmfshal flag for mass-flux shallow convection scheme in the cloud fraction calculation -!!\param lmfdeep2 flag for mass-flux deep convection scheme in the cloud fraction calculation -!!\param dzlay(ix,nlay) distance between model layer centers -!!\param latdeg(ix) latitude (in degrees 90 -> -90) -!!\param julian day of the year (fractional julian day) -!!\param yearlen current length of the year (365/366 days) -!!\param clouds (IX,NLAY,NF_CLDS), cloud profiles -!!\n (:,:,1) - layer total cloud fraction -!!\n (:,:,2) - layer cloud liq water path \f$(g/m^2)\f$ -!!\n (:,:,3) - mean eff radius for liq cloud (micron) -!!\n (:,:,4) - layer cloud ice water path \f$(g/m^2)\f$ -!!\n (:,:,5) - mean eff radius for ice cloud (micron) -!!\n (:,:,6) - layer rain drop water path \f$(g/m^2)\f$ -!!\n (:,:,7) - mean eff radius for rain drop (micron) -!!\n (:,:,8) - layer snow flake water path \f$(g/m^2)\f$ -!!\n (:,:,9) - mean eff radius for snow flake (micron) -!!\param clds (IX,5), fraction of clouds for low, mid, hi, tot, bl -!!\param mtop (IX,3), vertical indices for low, mid, hi cloud tops -!!\param mbot (IX,3), vertical indices for low, mid, hi cloud bases -!!\param de_lgth (IX), clouds decorrelation length (km) -!>\section gen_progcld2 progcld2 General Algorithm for the F-A MP scheme -!> @{ - subroutine progcld2 & - & ( plyr,plvl,tlyr,qlyr,qstl,rhly,tvly,clw, & ! --- inputs: - & xlat,xlon,slmsk,dz,delp, & - & ntrac, ntcw, ntiw, ntrw, & - & IX, NLAY, NLP1, lmfshal, lmfdeep2, & - & dzlay, latdeg, julian, yearlen, & - & clouds,clds,mtop,mbot,de_lgth,alpha & ! --- outputs: - & ) - -! ================= subprogram documentation block ================ ! -! ! -! subprogram: progcld2 computes cloud related quantities using ! -! WSM6 cloud microphysics scheme. ! -! ! -! abstract: this program computes cloud fractions from cloud ! -! condensates, ! -! and computes the low, mid, high, total and boundary layer cloud ! -! fractions and the vertical indices of low, mid, and high cloud ! -! top and base. the three vertical cloud domains are set up in the ! -! initial subroutine "cld_init". ! -! ! -! usage: call progcld2 ! -! ! -! subprograms called: gethml ! -! ! -! attributes: ! -! language: fortran 90 ! -! machine: ibm-sp, sgi ! -! ! -! ! -! ==================== definition of variables ==================== ! -! ! -! input variables: ! -! plyr (IX,NLAY) : model layer mean pressure in mb (100Pa) ! -! plvl (IX,NLP1) : model level pressure in mb (100Pa) ! -! tlyr (IX,NLAY) : model layer mean temperature in k ! -! tvly (IX,NLAY) : model layer virtual temperature in k ! -! qlyr (IX,NLAY) : layer specific humidity in gm/gm ! -! qstl (IX,NLAY) : layer saturate humidity in gm/gm ! -! rhly (IX,NLAY) : layer relative humidity (=qlyr/qstl) ! -! clw (IX,NLAY) : layer cloud condensate amount ! -! xlat (IX) : grid latitude in radians, default to pi/2 -> -pi/2! -! range, otherwise see in-line comment ! -! xlon (IX) : grid longitude in radians (not used) ! -! slmsk (IX) : sea/land mask array (sea:0,land:1,sea-ice:2) ! -! dz (ix,nlay) : layer thickness (km) ! -! delp (ix,nlay) : model layer pressure thickness in mb (100Pa) ! -! IX : horizontal dimention ! -! NLAY,NLP1 : vertical layer/level dimensions ! -! lmfshal : logical - true for mass flux shallow convection ! -! lmfdeep2 : logical - true for mass flux deep convection ! -! dzlay(ix,nlay) : thickness between model layer centers (km) ! -! latdeg(ix) : latitude (in degrees 90 -> -90) ! -! julian : day of the year (fractional julian day) ! -! yearlen : current length of the year (365/366 days) ! -! ! -! output variables: ! -! clouds(IX,NLAY,NF_CLDS) : cloud profiles ! -! clouds(:,:,1) - layer total cloud fraction ! -! clouds(:,:,2) - layer cloud liq water path (g/m**2) ! -! clouds(:,:,3) - mean eff radius for liq cloud (micron) ! -! clouds(:,:,4) - layer cloud ice water path (g/m**2) ! -! clouds(:,:,5) - mean eff radius for ice cloud (micron) ! -! clouds(:,:,6) - layer rain drop water path not assigned ! -! clouds(:,:,7) - mean eff radius for rain drop (micron) ! -! *** clouds(:,:,8) - layer snow flake water path not assigned ! -! clouds(:,:,9) - mean eff radius for snow flake (micron) ! -! *** fu's scheme need to be normalized by snow density (g/m**3/1.0e6) ! -! clds (IX,5) : fraction of clouds for low, mid, hi, tot, bl ! -! mtop (IX,3) : vertical indices for low, mid, hi cloud tops ! -! mbot (IX,3) : vertical indices for low, mid, hi cloud bases ! -! de_lgth(ix) : clouds decorrelation length (km) ! -! alpha(ix,nlay) : alpha decorrelation parameter -! ! -! module variables: ! -! ivflip : control flag of vertical index direction ! -! =0: index from toa to surface ! -! =1: index from surface to toa ! -! lmfshal : mass-flux shallow conv scheme flag ! -! lmfdeep2 : scale-aware mass-flux deep conv scheme flag ! -! lcrick : control flag for eliminating CRICK ! -! =t: apply layer smoothing to eliminate CRICK ! -! =f: do not apply layer smoothing ! -! lcnorm : control flag for in-cld condensate ! -! =t: normalize cloud condensate ! -! =f: not normalize cloud condensate ! -! ! -! ==================== end of description ===================== ! -! - implicit none - -! --- inputs - integer, intent(in) :: IX, NLAY, NLP1 - integer, intent(in) :: ntrac, ntcw, ntiw, ntrw - - logical, intent(in) :: lmfshal, lmfdeep2 - - real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & - & tlyr, qlyr, qstl, rhly, tvly, dz, delp, dzlay - - real (kind=kind_phys), dimension(:,:,:), intent(in) :: clw - - real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & - & slmsk - - real(kind=kind_phys), dimension(:), intent(in) :: latdeg - real(kind=kind_phys), intent(in) :: julian - integer, intent(in) :: yearlen - -! --- outputs - real (kind=kind_phys), dimension(:,:,:), intent(out) :: clouds - - real (kind=kind_phys), dimension(:,:), intent(out) :: clds - real (kind=kind_phys), dimension(:), intent(out) :: de_lgth - real (kind=kind_phys), dimension(:,:), intent(out) :: alpha - - integer, dimension(:,:), intent(out) :: mtop,mbot - -! --- local variables: - real (kind=kind_phys), dimension(IX,NLAY) :: cldtot, cldcnv, & - & cwp, cip, crp, csp, rew, rei, res, rer, tem2d, clwf - - real (kind=kind_phys) :: ptop1(IX,NK_CLDS+1), rxlat(ix) - - real (kind=kind_phys) :: clwmin, clwm, clwt, onemrh, value, & - & tem1, tem2, tem3 - - integer :: i, k, id, nf - -! --- constant values -! real (kind=kind_phys), parameter :: xrc3 = 200. - real (kind=kind_phys), parameter :: xrc3 = 100. - -! -!===> ... begin here -! - do nf=1,nf_clds - do k=1,nlay - do i=1,ix - clouds(i,k,nf) = 0.0 - enddo - enddo - enddo -! clouds(:,:,:) = 0.0 - - do k = 1, NLAY - do i = 1, IX - cldtot(i,k) = 0.0 - cldcnv(i,k) = 0.0 - cwp (i,k) = 0.0 - cip (i,k) = 0.0 - crp (i,k) = 0.0 - csp (i,k) = 0.0 - rew (i,k) = reliq_def - rei (i,k) = reice_def - rer (i,k) = rrain_def ! default rain radius to 1000 micron - res (i,k) = rsnow_def - clwf(i,k) = 0.0 - enddo - enddo -! - - do k = 1, NLAY - do i = 1, IX - clwf(i,k) = clw(i,k,ntcw) + clw(i,k,ntiw) - enddo - enddo -!> - Find top pressure for each cloud domain for given latitude. -!! ptopc(k,i): top presure of each cld domain (k=1-4 are sfc,L,m,h; -!! i=1,2 are low-lat (<45 degree) and pole regions) - - do i =1, IX - rxlat(i) = abs( xlat(i) / con_pi ) ! if xlat in pi/2 -> -pi/2 range -! rxlat(i) = abs(0.5 - xlat(i)/con_pi) ! if xlat in 0 -> pi range - enddo - - do id = 1, 4 - tem1 = ptopc(id,2) - ptopc(id,1) - - do i =1, IX - ptop1(i,id) = ptopc(id,1) + tem1*max( 0.0, 4.0*rxlat(i)-1.0 ) - enddo - enddo - -!> - Compute cloud liquid/ice condensate path in \f$ g/m^2 \f$ . - - do k = 1, NLAY - do i = 1, IX - cwp(i,k) = max(0.0, clw(i,k,ntcw) * gfac * delp(i,k)) - cip(i,k) = max(0.0, clw(i,k,ntiw) * gfac * delp(i,k)) - crp(i,k) = max(0.0, clw(i,k,ntrw) * gfac * delp(i,k)) - csp(i,k) = 0.0 - enddo - enddo - -!> - Compute cloud ice effective radii - - do k = 1, NLAY - do i = 1, IX - tem2 = tlyr(i,k) - con_ttp - - if (cip(i,k) > 0.0) then - tem3 = gord * cip(i,k) * plyr(i,k) / (delp(i,k)*tvly(i,k)) - - if (tem2 < -50.0) then - rei(i,k) = (1250.0/9.917) * tem3 ** 0.109 - elseif (tem2 < -40.0) then - rei(i,k) = (1250.0/9.337) * tem3 ** 0.08 - elseif (tem2 < -30.0) then - rei(i,k) = (1250.0/9.208) * tem3 ** 0.055 - else - rei(i,k) = (1250.0/9.387) * tem3 ** 0.031 - endif - rei(i,k) = max(10.0, min(rei(i,k), 150.0)) - endif - enddo - enddo - -!> - Calculate layer cloud fraction. - - clwmin = 0.0 - if (.not. lmfshal) then - do k = 1, NLAY - do i = 1, IX - clwt = 1.0e-6 * (plyr(i,k)*0.001) -! clwt = 2.0e-6 * (plyr(i,k)*0.001) - - if (clwf(i,k) > clwt) then - - onemrh= max( 1.e-10, 1.0-rhly(i,k) ) - clwm = clwmin / max( 0.01, plyr(i,k)*0.001 ) - - tem1 = min(max(sqrt(sqrt(onemrh*qstl(i,k))),0.0001),1.0) - tem1 = 2000.0 / tem1 - -! tem1 = 1000.0 / tem1 - - value = max( min( tem1*(clwf(i,k)-clwm), 50.0 ), 0.0 ) - tem2 = sqrt( sqrt(rhly(i,k)) ) - - cldtot(i,k) = max( tem2*(1.0-exp(-value)), 0.0 ) - endif - enddo - enddo - else - do k = 1, NLAY - do i = 1, IX - clwt = 1.0e-6 * (plyr(i,k)*0.001) -! clwt = 2.0e-6 * (plyr(i,k)*0.001) - - if (clwf(i,k) > clwt) then - onemrh= max( 1.e-10, 1.0-rhly(i,k) ) - clwm = clwmin / max( 0.01, plyr(i,k)*0.001 ) -! - tem1 = min(max((onemrh*qstl(i,k))**0.49,0.0001),1.0) !jhan - if (lmfdeep2) then - tem1 = xrc3 / tem1 - else - tem1 = 100.0 / tem1 - endif -! - value = max( min( tem1*(clwf(i,k)-clwm), 50.0 ), 0.0 ) - tem2 = sqrt( sqrt(rhly(i,k)) ) - - cldtot(i,k) = max( tem2*(1.0-exp(-value)), 0.0 ) - endif - enddo - enddo - endif - - do k = 1, NLAY - do i = 1, IX - if (cldtot(i,k) < climit) then - cldtot(i,k) = 0.0 - cwp(i,k) = 0.0 - cip(i,k) = 0.0 - crp(i,k) = 0.0 - csp(i,k) = 0.0 - endif - enddo - enddo - - if ( lcnorm ) then - do k = 1, NLAY - do i = 1, IX - if (cldtot(i,k) >= climit) then - tem1 = 1.0 / max(climit2, cldtot(i,k)) - cwp(i,k) = cwp(i,k) * tem1 - cip(i,k) = cip(i,k) * tem1 - crp(i,k) = crp(i,k) * tem1 - csp(i,k) = csp(i,k) * tem1 - endif - enddo - enddo - endif - -! - do k = 1, NLAY - do i = 1, IX - clouds(i,k,1) = cldtot(i,k) - clouds(i,k,2) = cwp(i,k) - clouds(i,k,3) = rew(i,k) - clouds(i,k,4) = cip(i,k) - clouds(i,k,5) = rei(i,k) - clouds(i,k,6) = crp(i,k) ! added for Thompson - clouds(i,k,7) = rer(i,k) - clouds(i,k,8) = csp(i,k) ! added for Thompson - clouds(i,k,9) = res(i,k) - enddo - enddo - - ! Compute cloud decorrelation length - if (idcor == 1) then - call cmp_dcorr_lgth(ix, xlat, con_pi, de_lgth) - endif - if (idcor == 2) then - call cmp_dcorr_lgth(ix, latdeg, julian, yearlen, de_lgth) - endif - if (idcor == 0) then - de_lgth(:) = decorr_con - endif - - ! Call subroutine get_alpha_exp to define alpha parameter for exponential cloud overlap options - if (iovr == 3 .or. iovr == 4 .or. iovr == 5) then - call get_alpha_exp(ix, nLay, dzlay, de_lgth, alpha) - else - de_lgth(:) = 0. - alpha(:,:) = 0. - endif - - ! Revise alpha for exponential-random cloud overlap - ! Decorrelate layers when a clear layer follows a cloudy layer to enforce - ! random correlation between non-adjacent blocks of cloudy layers - if (iovr == 5) then - do k = 2, nLay - do i = 1, ix - if (clouds(i,k,1) == 0.0 .and. clouds(i,k-1,1) > 0.0) then - alpha(i,k) = 0.0 - endif - enddo - enddo - endif - -!> - Call gethml() to compute low,mid,high,total, and boundary layer -!! cloud fractions and clouds top/bottom layer indices for low, mid, -!! and high clouds. -! --- compute low, mid, high, total, and boundary layer cloud fractions -! and clouds top/bottom layer indices for low, mid, and high clouds. -! The three cloud domain boundaries are defined by ptopc. The cloud -! overlapping method is defined by control flag 'iovr', which may -! be different for lw and sw radiation programs. - - call gethml & -! --- inputs: - & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, alpha, & - & IX,NLAY, & -! --- outputs: - & clds, mtop, mbot & - & ) - - -! - return -!................................... - end subroutine progcld2 -!................................... - -!> @} -!----------------------------------- +!----------------------------------- !> \ingroup module_radiation_clouds !> This subroutine computes cloud related quantities using !! zhao/moorthi's prognostic cloud microphysics scheme + pdfcld. -!!\param plyr (ix,nlay), model layer mean pressure in mb (100pa) -!!\param plvl (ix,nlp1), model level pressure in mb (100pa) -!!\param tlyr (ix,nlay), model layer mean temperature in K -!!\param tvly (ix,nlay), model layer virtual temperature in K -!!\param qlyr (ix,nlay), layer specific humidity in gm/gm -!!\param qstl (ix,nlay), layer saturate humidity in gm/gm -!!\param rhly (ix,nlay), layer relative humidity (=qlyr/qstl) -!!\param clw (ix,nlay), layer cloud condensate amount -!!\param cnvw (ix,nlay), layer convective cloud condensate -!!\param cnvc (ix,nlay), layer convective cloud cover -!!\param xlat (ix), grid latitude in radians, default to pi/2 -> -!! -pi/2 range, otherwise see in-line comment -!!\param xlon (ix), grid longitude in radians (not used) -!!\param slmsk (ix), sea/land mask array (sea:0,land:1,sea-ice:2) -!!\param dz (IX,NLAY), layer thickness (km) -!!\param delp (IX,NLAY), model layer pressure thickness in mb (100Pa) -!!\param ix horizontal dimention -!!\param nlay,nlp1 vertical layer/level dimensions -!!\param deltaq (ix,nlay), half total water distribution width -!!\param sup supersaturation -!!\param kdt -!!\param me print control flag -!!\param dzlay(ix,nlay) distance between model layer centers -!!\param latdeg(ix) latitude (in degrees 90 -> -90) -!!\param julian day of the year (fractional julian day) -!!\param yearlen current length of the year (365/366 days) -!!\param clouds (ix,nlay,nf_clds), cloud profiles -!!\n (:,:,1) - layer total cloud fraction -!!\n (:,:,2) - layer cloud liq water path (g/m**2) -!!\n (:,:,3) - mean eff radius for liq cloud (micron) -!!\n (:,:,4) - layer cloud ice water path (g/m**2) -!!\n (:,:,5) - mean eff radius for ice cloud (micron) -!!\n (:,:,6) - layer rain drop water path not assigned -!!\n (:,:,7) - mean eff radius for rain drop (micron) -!!\n (:,:,8) - layer snow flake water path not assigned -!!\n (:,:,9) - mean eff radius for snow flake(micron) -!!\param clds (ix,5), fraction of clouds for low, mid, hi, tot, bl -!!\param mtop (ix,3), vertical indices for low, mid, hi cloud tops -!!\param mbot (ix,3), vertical indices for low, mid, hi cloud bases -!!\param de_lgth (ix), clouds decorrelation length (km) -!!\param alpha (IX,NLAY), alpha decorrelation parameter -!>\section gen_progcld3 progcld3 General Algorithm +!>\section progcld_zhao_carr_pdf General Algorithm !! @{ - subroutine progcld3 & + subroutine progcld_zhao_carr_pdf & & ( plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw,cnvw,cnvc, & ! --- inputs: & xlat,xlon,slmsk, dz, delp, & & ix, nlay, nlp1, & - & deltaq,sup,kdt,me, & - & dzlay, latdeg, julian, yearlen, & - & clouds,clds,mtop,mbot,de_lgth,alpha & ! --- outputs: - & ) - -! ================= subprogram documentation block ================ ! -! ! -! subprogram: progcld3 computes cloud related quantities using ! -! zhao/moorthi's prognostic cloud microphysics scheme. ! -! ! -! abstract: this program computes cloud fractions from cloud ! -! condensates, calculates liquid/ice cloud droplet effective radius, ! -! and computes the low, mid, high, total and boundary layer cloud ! -! fractions and the vertical indices of low, mid, and high cloud ! -! top and base. the three vertical cloud domains are set up in the ! -! initial subroutine "cld_init". ! -! ! -! usage: call progcld3 ! -! ! -! subprograms called: gethml ! -! ! -! attributes: ! -! language: fortran 90 ! -! machine: ibm-sp, sgi ! -! ! -! ! -! ==================== defination of variables ==================== ! -! ! -! input variables: ! -! plyr (ix,nlay) : model layer mean pressure in mb (100pa) ! -! plvl (ix,nlp1) : model level pressure in mb (100pa) ! -! tlyr (ix,nlay) : model layer mean temperature in k ! -! tvly (ix,nlay) : model layer virtual temperature in k ! -! qlyr (ix,nlay) : layer specific humidity in gm/gm ! -! qstl (ix,nlay) : layer saturate humidity in gm/gm ! -! rhly (ix,nlay) : layer relative humidity (=qlyr/qstl) ! -! clw (ix,nlay) : layer cloud condensate amount ! -! xlat (ix) : grid latitude in radians, default to pi/2 -> -pi/2! -! range, otherwise see in-line comment ! -! xlon (ix) : grid longitude in radians (not used) ! -! slmsk (ix) : sea/land mask array (sea:0,land:1,sea-ice:2) ! -! dz (ix,nlay) : layer thickness (km) ! -! delp (ix,nlay) : model layer pressure thickness in mb (100Pa) ! -! ix : horizontal dimention ! -! nlay,nlp1 : vertical layer/level dimensions ! -! cnvw (ix,nlay) : layer convective cloud condensate ! -! cnvc (ix,nlay) : layer convective cloud cover ! -! deltaq(ix,nlay) : half total water distribution width ! -! sup : supersaturation ! -! dzlay(ix,nlay) : thickness between model layer centers (km) ! -! latdeg(ix) : latitude (in degrees 90 -> -90) ! -! julian : day of the year (fractional julian day) ! -! yearlen : current length of the year (365/366 days) ! - -! ! -! output variables: ! -! clouds(ix,nlay,nf_clds) : cloud profiles ! -! clouds(:,:,1) - layer total cloud fraction ! -! clouds(:,:,2) - layer cloud liq water path (g/m**2) ! -! clouds(:,:,3) - mean eff radius for liq cloud (micron) ! -! clouds(:,:,4) - layer cloud ice water path (g/m**2) ! -! clouds(:,:,5) - mean eff radius for ice cloud (micron) ! -! clouds(:,:,6) - layer rain drop water path not assigned ! -! clouds(:,:,7) - mean eff radius for rain drop (micron) ! -! *** clouds(:,:,8) - layer snow flake water path not assigned ! -! clouds(:,:,9) - mean eff radius for snow flake (micron) ! -! *** fu's scheme need to be normalized by snow density (g/m**3/1.0e6) ! -! clds (ix,5) : fraction of clouds for low, mid, hi, tot, bl ! -! mtop (ix,3) : vertical indices for low, mid, hi cloud tops ! -! mbot (ix,3) : vertical indices for low, mid, hi cloud bases ! -! de_lgth(ix) : clouds decorrelation length (km) ! -! alpha(ix,nlay) : alpha decorrelation parameter -! ! -! module variables: ! -! ivflip : control flag of vertical index direction ! -! =0: index from toa to surface ! -! =1: index from surface to toa ! -! lcrick : control flag for eliminating crick ! -! =t: apply layer smoothing to eliminate crick ! -! =f: do not apply layer smoothing ! -! lcnorm : control flag for in-cld condensate ! -! =t: normalize cloud condensate ! -! =f: not normalize cloud condensate ! -! ! -! ==================== end of description ===================== ! -! - implicit none - -! --- inputs - integer, intent(in) :: ix, nlay, nlp1,kdt - - real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & - & tlyr, tvly, qlyr, qstl, rhly, clw, dz, delp, dzlay -! & tlyr, tvly, qlyr, qstl, rhly, clw, cnvw, cnvc -! real (kind=kind_phys), dimension(:,:), intent(in) :: deltaq - real (kind=kind_phys), dimension(:,:) :: deltaq, cnvw, cnvc - real (kind=kind_phys) qtmp,qsc,rhs - real (kind=kind_phys), intent(in) :: sup - real (kind=kind_phys), parameter :: epsq = 1.0e-12 - - real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & - & slmsk - integer :: me - - real(kind=kind_phys), dimension(:), intent(in) :: latdeg - real(kind=kind_phys), intent(in) :: julian - integer, intent(in) :: yearlen - -! --- outputs - real (kind=kind_phys), dimension(:,:,:), intent(out) :: clouds - - real (kind=kind_phys), dimension(:,:), intent(out) :: clds - real (kind=kind_phys), dimension(:), intent(out) :: de_lgth - real (kind=kind_phys), dimension(:,:), intent(out) :: alpha - - integer, dimension(:,:), intent(out) :: mtop,mbot - -! --- local variables: - real (kind=kind_phys), dimension(ix,nlay) :: cldtot, cldcnv, & - & cwp, cip, crp, csp, rew, rei, res, rer, tem2d, clwf - - real (kind=kind_phys) :: ptop1(ix,nk_clds+1), rxlat(ix) - - real (kind=kind_phys) :: clwmin, clwm, clwt, onemrh, value, & - & tem1, tem2, tem3 - - integer :: i, k, id, nf - -! -!===> ... begin here -! - do nf=1,nf_clds - do k=1,nlay - do i=1,ix - clouds(i,k,nf) = 0.0 - enddo - enddo - enddo -! clouds(:,:,:) = 0.0 - - do k = 1, nlay - do i = 1, ix - cldtot(i,k) = 0.0 - cldcnv(i,k) = 0.0 - cwp (i,k) = 0.0 - cip (i,k) = 0.0 - crp (i,k) = 0.0 - csp (i,k) = 0.0 - rew (i,k) = reliq_def ! default liq radius to 10 micron - rei (i,k) = reice_def ! default ice radius to 50 micron - rer (i,k) = rrain_def ! default rain radius to 1000 micron - res (i,k) = rsnow_def ! default snow radius to 250 micron - tem2d (i,k) = min( 1.0, max( 0.0, (con_ttp-tlyr(i,k))*0.05 ) ) - clwf(i,k) = 0.0 - enddo - enddo -! - if ( lcrick ) then - do i = 1, ix - clwf(i,1) = 0.75*clw(i,1) + 0.25*clw(i,2) - clwf(i,nlay) = 0.75*clw(i,nlay) + 0.25*clw(i,nlay-1) - enddo - do k = 2, nlay-1 - do i = 1, ix - clwf(i,k) = 0.25*clw(i,k-1) + 0.5*clw(i,k) + 0.25*clw(i,k+1) - enddo - enddo - else - do k = 1, nlay - do i = 1, ix - clwf(i,k) = clw(i,k) - enddo - enddo - endif - - if(kdt==1) then - do k = 1, nlay - do i = 1, ix - deltaq(i,k) = (1.-0.95)*qstl(i,k) - enddo - enddo - endif - -!> -# Find top pressure (ptopc) for each cloud domain for given latitude. -! ptopc(k,i): top presure of each cld domain (k=1-4 are sfc,l,m,h; -! --- i=1,2 are low-lat (<45 degree) and pole regions) - - do i =1, IX - rxlat(i) = abs( xlat(i) / con_pi ) ! if xlat in pi/2 -> -pi/2 range -! rxlat(i) = abs(0.5 - xlat(i)/con_pi) ! if xlat in 0 -> pi range - enddo - - do id = 1, 4 - tem1 = ptopc(id,2) - ptopc(id,1) - - do i =1, ix - ptop1(i,id) = ptopc(id,1) + tem1*max( 0.0, 4.0*rxlat(i)-1.0 ) - enddo - enddo - -!> -# Calculate liquid/ice condensate path in \f$ g/m^2 \f$ - - do k = 1, nlay - do i = 1, ix - clwt = max(0.0,(clwf(i,k)+cnvw(i,k))) * gfac * delp(i,k) - cip(i,k) = clwt * tem2d(i,k) - cwp(i,k) = clwt - cip(i,k) - enddo - enddo - -!> -# Calculate effective liquid cloud droplet radius over land. - - do i = 1, ix - if (nint(slmsk(i)) == 1) then - do k = 1, nlay - rew(i,k) = 5.0 + 5.0 * tem2d(i,k) - enddo - endif - enddo - -!> -# Calculate layer cloud fraction. - - do k = 1, nlay - do i = 1, ix - tem1 = tlyr(i,k) - 273.16 - if(tem1 < con_thgni) then ! for pure ice, has to be consistent with gscond - qsc = sup * qstl(i,k) - rhs = sup - else - qsc = qstl(i,k) - rhs = 1.0 - endif - if(rhly(i,k) >= rhs) then - cldtot(i,k) = 1.0 - else - qtmp = qlyr(i,k) + clwf(i,k) - qsc - if(deltaq(i,k) > epsq) then -! if(qtmp <= -deltaq(i,k) .or. cwmik < epsq) then - if(qtmp <= -deltaq(i,k)) then - cldtot(i,k) = 0.0 - elseif(qtmp >= deltaq(i,k)) then - cldtot(i,k) = 1.0 - else - cldtot(i,k) = 0.5*qtmp/deltaq(i,k) + 0.5 - cldtot(i,k) = max(cldtot(i,k),0.0) - cldtot(i,k) = min(cldtot(i,k),1.0) - endif - else - if(qtmp > 0.) then - cldtot(i,k) = 1.0 - else - cldtot(i,k) = 0.0 - endif - endif - endif - cldtot(i,k) = cnvc(i,k) + (1-cnvc(i,k))*cldtot(i,k) - cldtot(i,k) = max(cldtot(i,k),0.) - cldtot(i,k) = min(cldtot(i,k),1.) - - enddo - enddo - - do k = 1, nlay - do i = 1, ix - if (cldtot(i,k) < climit) then - cldtot(i,k) = 0.0 - cwp(i,k) = 0.0 - cip(i,k) = 0.0 - crp(i,k) = 0.0 - csp(i,k) = 0.0 - endif - enddo - enddo - - if ( lcnorm ) then - do k = 1, nlay - do i = 1, ix - if (cldtot(i,k) >= climit) then - tem1 = 1.0 / max(climit2, cldtot(i,k)) - cwp(i,k) = cwp(i,k) * tem1 - cip(i,k) = cip(i,k) * tem1 - crp(i,k) = crp(i,k) * tem1 - csp(i,k) = csp(i,k) * tem1 - endif - enddo - enddo - endif - -!> -# Calculate effective ice cloud droplet radius following Heymsfield -!! and McFarquhar (1996) \cite heymsfield_and_mcfarquhar_1996. - - do k = 1, nlay - do i = 1, ix - tem2 = tlyr(i,k) - con_ttp - - if (cip(i,k) > 0.0) then -! tem3 = gord * cip(i,k) * (plyr(i,k)/delp(i,k)) / tvly(i,k) - tem3 = gord * cip(i,k) * plyr(i,k) / (delp(i,k)*tvly(i,k)) - - if (tem2 < -50.0) then - rei(i,k) = (1250.0/9.917) * tem3 ** 0.109 - elseif (tem2 < -40.0) then - rei(i,k) = (1250.0/9.337) * tem3 ** 0.08 - elseif (tem2 < -30.0) then - rei(i,k) = (1250.0/9.208) * tem3 ** 0.055 - else - rei(i,k) = (1250.0/9.387) * tem3 ** 0.031 - endif -! rei(i,k) = max(20.0, min(rei(i,k), 300.0)) -! rei(i,k) = max(10.0, min(rei(i,k), 100.0)) - rei(i,k) = max(10.0, min(rei(i,k), 150.0)) -! rei(i,k) = max(5.0, min(rei(i,k), 130.0)) - endif - enddo - enddo - -! - do k = 1, nlay - do i = 1, ix - clouds(i,k,1) = cldtot(i,k) - clouds(i,k,2) = cwp(i,k) - clouds(i,k,3) = rew(i,k) - clouds(i,k,4) = cip(i,k) - clouds(i,k,5) = rei(i,k) -! clouds(i,k,6) = 0.0 - clouds(i,k,7) = rer(i,k) -! clouds(i,k,8) = 0.0 - clouds(i,k,9) = res(i,k) - enddo - enddo - - ! Compute cloud decorrelation length - if (idcor == 1) then - call cmp_dcorr_lgth(ix, xlat, con_pi, de_lgth) - endif - if (idcor == 2) then - call cmp_dcorr_lgth(ix, latdeg, julian, yearlen, de_lgth) - endif - if (idcor == 0) then - de_lgth(:) = decorr_con - endif - - ! Call subroutine get_alpha_exp to define alpha parameter for exponential cloud overlap options - if (iovr == 3 .or. iovr == 4 .or. iovr == 5) then - call get_alpha_exp(ix, nLay, dzlay, de_lgth, alpha) - else - de_lgth(:) = 0. - alpha(:,:) = 0. - endif - - ! Revise alpha for exponential-random cloud overlap - ! Decorrelate layers when a clear layer follows a cloudy layer to enforce - ! random correlation between non-adjacent blocks of cloudy layers - if (iovr == 5) then - do k = 2, nLay - do i = 1, ix - if (clouds(i,k,1) == 0.0 .and. clouds(i,k-1,1) > 0.0) then - alpha(i,k) = 0.0 - endif - enddo - enddo - endif - -!> -# Call gethml() to compute low,mid,high,total, and boundary layer -!! cloud fractions and clouds top/bottom layer indices for low, mid, -!! and high clouds. -! the three cloud domain boundaries are defined by ptopc. the cloud -! overlapping method is defined by control flag 'iovr', which may -! be different for lw and sw radiation programs. - - - call gethml & -! --- inputs: - & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, alpha, & - & ix,nlay, & -! --- outputs: - & clds, mtop, mbot & - & ) - - -! - return -!................................... - end subroutine progcld3 -!! @} -!----------------------------------- - - -!----------------------------------- -!> \ingroup module_radiation_clouds -!> This subroutine computes cloud related quantities using -!! GFDL Lin MP prognostic cloud microphysics scheme. -!!\param plyr (ix,nlay), model layer mean pressure in mb (100Pa) -!!\param plvl (ix,nlp1), model level pressure in mb (100Pa) -!!\param tlyr (ix,nlay), model layer mean temperature in K -!!\param tvly (ix,nlay), model layer virtual temperature in K -!!\param qlyr (ix,nlay), layer specific humidity in gm/gm -!!\param qstl (ix,nlay), layer saturate humidity in gm/gm -!!\param rhly (ix,nlay), layer relative humidity (=qlyr/qstl) -!!\param clw (ix,nlay), layer cloud condensate amount -!!\param cnvw (ix,nlay), layer convective cloud condensate -!!\param cnvc (ix,nlay), layer convective cloud cover -!!\param xlat (ix), grid latitude in radians, default to pi/2 -> -pi/2 -!! range, otherwise see in-line comment -!!\param xlon (ix), grid longitude in radians (not used) -!!\param slmsk (ix), sea/land mask array (sea:0, land:1, sea-ice:2) -!!\param cldtot (ix,nlay), layer total cloud fraction -!!\param dz (ix,nlay), layer thickness (km) -!!\param delp (ix,nlay), model layer pressure thickness in mb (100Pa) -!!\param ix horizontal dimension -!!\param nlay vertical layer dimension -!!\param nlp1 vertical level dimension -!!\param dzlay(ix,nlay) distance between model layer centers -!!\param latdeg(ix) latitude (in degrees 90 -> -90) -!!\param julian day of the year (fractional julian day) -!!\param yearlen current length of the year (365/366 days) -!!\param clouds (ix,nlay,nf_clds), cloud profiles -!!\n clouds(:,:,1) - layer total cloud fraction -!!\n clouds(:,:,2) - layer cloud liquid water path (\f$g m^{-2}\f$) -!!\n clouds(:,:,3) - mean effective radius for liquid cloud (micron) -!!\n clouds(:,:,4) - layer cloud ice water path (\f$g m^{-2}\f$) -!!\n clouds(:,:,5) - mean effective radius for ice cloud (micron) -!!\n clouds(:,:,6) - layer rain drop water path (\f$g m^{-2}\f$) (not assigned) -!!\n clouds(:,:,7) - mean effective radius for rain drop (micron) -!!\n clouds(:,:,8) - layer snow flake water path (not assigned) (\f$g m^{-2}\f$) (not assigned) -!!\n clouds(:,:,9) - mean effective radius for snow flake (micron) -!!\param clds fraction of clouds for low, mid, hi cloud tops -!!\param mtop vertical indices for low, mid, hi cloud tops -!!\param mbot vertical indices for low, mid, hi cloud bases -!!\param de_lgth clouds decorrelation length (km) -!!\param alpha (IX,NLAY), alpha decorrelation parameter -!>\section gen_progcld4 progcld4 General Algorithm -!! @{ - subroutine progcld4 & - & ( plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw,cnvw,cnvc, & ! --- inputs: - & xlat,xlon,slmsk,cldtot, dz, delp, & - & IX, NLAY, NLP1, & - & dzlay, latdeg, julian, yearlen, & - & clouds,clds,mtop,mbot,de_lgth,alpha & ! --- outputs: + & deltaq,sup,kdt,me, & + & dzlay, cldtot, cldcnv, & + & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs + & cld_reice,cld_rwp, cld_rerain,cld_swp, cld_resnow & & ) ! ================= subprogram documentation block ================ ! ! ! -! subprogram: progcld4 computes cloud related quantities using ! -! GFDL Lin MP prognostic cloud microphysics scheme. ! +! subprogram: progcld_zhao_carr_pdf computes cloud related quantities using ! +! zhao/moorthi's prognostic cloud microphysics scheme. ! ! ! ! abstract: this program computes cloud fractions from cloud ! ! condensates, calculates liquid/ice cloud droplet effective radius, ! @@ -1828,7 +1274,7 @@ subroutine progcld4 & ! top and base. the three vertical cloud domains are set up in the ! ! initial subroutine "cld_init". ! ! ! -! usage: call progcld4 ! +! usage: call progcld_zhao_carr_pdf ! ! ! ! subprograms called: gethml ! ! ! @@ -1837,57 +1283,49 @@ subroutine progcld4 & ! machine: ibm-sp, sgi ! ! ! ! ! -! ==================== definition of variables ==================== ! +! ==================== defination of variables ==================== ! ! ! ! input variables: ! -! plyr (IX,NLAY) : model layer mean pressure in mb (100Pa) ! -! plvl (IX,NLP1) : model level pressure in mb (100Pa) ! -! tlyr (IX,NLAY) : model layer mean temperature in k ! -! tvly (IX,NLAY) : model layer virtual temperature in k ! -! qlyr (IX,NLAY) : layer specific humidity in gm/gm ! -! qstl (IX,NLAY) : layer saturate humidity in gm/gm ! -! rhly (IX,NLAY) : layer relative humidity (=qlyr/qstl) ! -! clw (IX,NLAY) : layer cloud condensate amount ! -! cnvw (IX,NLAY) : layer convective cloud condensate ! -! cnvc (IX,NLAY) : layer convective cloud cover ! -! xlat (IX) : grid latitude in radians, default to pi/2 -> -pi/2! +! plyr (ix,nlay) : model layer mean pressure in mb (100pa) ! +! plvl (ix,nlp1) : model level pressure in mb (100pa) ! +! tlyr (ix,nlay) : model layer mean temperature in k ! +! tvly (ix,nlay) : model layer virtual temperature in k ! +! qlyr (ix,nlay) : layer specific humidity in gm/gm ! +! qstl (ix,nlay) : layer saturate humidity in gm/gm ! +! rhly (ix,nlay) : layer relative humidity (=qlyr/qstl) ! +! clw (ix,nlay) : layer cloud condensate amount ! +! xlat (ix) : grid latitude in radians, default to pi/2 -> -pi/2! ! range, otherwise see in-line comment ! -! xlon (IX) : grid longitude in radians (not used) ! -! slmsk (IX) : sea/land mask array (sea:0,land:1,sea-ice:2) ! +! xlon (ix) : grid longitude in radians (not used) ! +! slmsk (ix) : sea/land mask array (sea:0,land:1,sea-ice:2) ! ! dz (ix,nlay) : layer thickness (km) ! ! delp (ix,nlay) : model layer pressure thickness in mb (100Pa) ! -! IX : horizontal dimention ! -! NLAY,NLP1 : vertical layer/level dimensions ! +! ix : horizontal dimention ! +! nlay,nlp1 : vertical layer/level dimensions ! +! cnvw (ix,nlay) : layer convective cloud condensate ! +! cnvc (ix,nlay) : layer convective cloud cover ! +! deltaq(ix,nlay) : half total water distribution width ! +! sup : supersaturation ! ! dzlay(ix,nlay) : thickness between model layer centers (km) ! -! latdeg(ix) : latitude (in degrees 90 -> -90) ! -! julian : day of the year (fractional julian day) ! -! yearlen : current length of the year (365/366 days) ! ! ! ! output variables: ! -! clouds(IX,NLAY,NF_CLDS) : cloud profiles ! -! clouds(:,:,1) - layer total cloud fraction ! -! clouds(:,:,2) - layer cloud liq water path (g/m**2) ! -! clouds(:,:,3) - mean eff radius for liq cloud (micron) ! -! clouds(:,:,4) - layer cloud ice water path (g/m**2) ! -! clouds(:,:,5) - mean eff radius for ice cloud (micron) ! -! clouds(:,:,6) - layer rain drop water path not assigned ! -! clouds(:,:,7) - mean eff radius for rain drop (micron) ! -! *** clouds(:,:,8) - layer snow flake water path not assigned ! -! clouds(:,:,9) - mean eff radius for snow flake (micron) ! -! *** fu's scheme need to be normalized by snow density (g/m**3/1.0e6) ! -! clds (IX,5) : fraction of clouds for low, mid, hi, tot, bl ! -! mtop (IX,3) : vertical indices for low, mid, hi cloud tops ! -! mbot (IX,3) : vertical indices for low, mid, hi cloud bases ! -! de_lgth(ix) : clouds decorrelation length (km) ! -! alpha(ix,nlay) : alpha decorrelation parameter +! cloud profiles: ! +! cld_frac (:,:) - layer total cloud fraction ! +! cld_lwp (:,:) - layer cloud liq water path (g/m**2) ! +! cld_reliq (:,:) - mean eff radius for liq cloud (micron) ! +! cld_iwp (:,:) - layer cloud ice water path (g/m**2) ! +! cld_reice (:,:) - mean eff radius for ice cloud (micron) ! +! cld_rwp (:,:) - layer rain drop water path not assigned ! +! cld_rerain(:,:) - mean eff radius for rain drop (micron) ! +! *** cld_swp (:,:) - layer snow flake water path not assigned ! +! cld_resnow(:,:) - mean eff radius for snow flake (micron) ! ! ! ! module variables: ! ! ivflip : control flag of vertical index direction ! ! =0: index from toa to surface ! ! =1: index from surface to toa ! -! lsashal : control flag for shallow convection ! -! lcrick : control flag for eliminating CRICK ! -! =t: apply layer smoothing to eliminate CRICK ! +! lcrick : control flag for eliminating crick ! +! =t: apply layer smoothing to eliminate crick ! ! =f: do not apply layer smoothing ! ! lcnorm : control flag for in-cld condensate ! ! =t: normalize cloud condensate ! @@ -1898,34 +1336,31 @@ subroutine progcld4 & implicit none ! --- inputs - integer, intent(in) :: IX, NLAY, NLP1 + integer, intent(in) :: ix, nlay, nlp1,kdt - real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & - & tlyr, tvly, qlyr, qstl, rhly, clw, cldtot, cnvw, cnvc, & - & delp, dz, dzlay + real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & + & tlyr, tvly, qlyr, qstl, rhly, clw, dz, delp, dzlay +! & tlyr, tvly, qlyr, qstl, rhly, clw, cnvw, cnvc +! real (kind=kind_phys), dimension(:,:), intent(in) :: deltaq + real (kind=kind_phys), dimension(:,:) :: deltaq, cnvw, cnvc + real (kind=kind_phys) qtmp,qsc,rhs + real (kind=kind_phys), intent(in) :: sup + real (kind=kind_phys), parameter :: epsq = 1.0e-12 - real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & + real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & & slmsk + integer :: me - real(kind=kind_phys), dimension(:), intent(in) :: latdeg - real(kind=kind_phys), intent(in) :: julian - integer, intent(in) :: yearlen - -! --- outputs - real (kind=kind_phys), dimension(:,:,:), intent(out) :: clouds - - real (kind=kind_phys), dimension(:,:), intent(out) :: clds - real (kind=kind_phys), dimension(:), intent(out) :: de_lgth - real (kind=kind_phys), dimension(:,:), intent(out) :: alpha +! --- inputs/outputs - integer, dimension(:,:), intent(out) :: mtop,mbot + real (kind=kind_phys), dimension(:,:), intent(inout) :: & + & cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, & + & cld_rwp, cld_rerain, cld_swp, cld_resnow ! --- local variables: - real (kind=kind_phys), dimension(IX,NLAY) :: cldcnv, & + real (kind=kind_phys), dimension(ix,nlay) :: cldtot, cldcnv, & & cwp, cip, crp, csp, rew, rei, res, rer, tem2d, clwf - real (kind=kind_phys) :: ptop1(IX,NK_CLDS+1), rxlat(ix) - real (kind=kind_phys) :: clwmin, clwm, clwt, onemrh, value, & & tem1, tem2, tem3 @@ -1934,90 +1369,115 @@ subroutine progcld4 & ! !===> ... begin here ! - do nf=1,nf_clds - do k=1,nlay - do i=1,ix - clouds(i,k,nf) = 0.0 - enddo - enddo - enddo -! clouds(:,:,:) = 0.0 - -!> - Assign liquid/ice/rain/snow cloud doplet effective radius as default value. - do k = 1, NLAY - do i = 1, IX + do k = 1, nlay + do i = 1, ix + cldtot(i,k) = 0.0 cldcnv(i,k) = 0.0 cwp (i,k) = 0.0 cip (i,k) = 0.0 crp (i,k) = 0.0 csp (i,k) = 0.0 - rew (i,k) = reliq_def !< default liq radius to 10 micron - rei (i,k) = reice_def !< default ice radius to 50 micron - rer (i,k) = rrain_def !< default rain radius to 1000 micron - res (i,k) = rsnow_def !< default snow radius to 250 micron + rew (i,k) = reliq_def ! default liq radius to 10 micron + rei (i,k) = reice_def ! default ice radius to 50 micron + rer (i,k) = rrain_def ! default rain radius to 1000 micron + res (i,k) = rsnow_def ! default snow radius to 250 micron tem2d (i,k) = min( 1.0, max( 0.0, (con_ttp-tlyr(i,k))*0.05 ) ) clwf(i,k) = 0.0 enddo enddo ! if ( lcrick ) then - do i = 1, IX + do i = 1, ix clwf(i,1) = 0.75*clw(i,1) + 0.25*clw(i,2) clwf(i,nlay) = 0.75*clw(i,nlay) + 0.25*clw(i,nlay-1) enddo - do k = 2, NLAY-1 - do i = 1, IX - clwf(i,K) = 0.25*clw(i,k-1) + 0.5*clw(i,k) + 0.25*clw(i,k+1) + do k = 2, nlay-1 + do i = 1, ix + clwf(i,k) = 0.25*clw(i,k-1) + 0.5*clw(i,k) + 0.25*clw(i,k+1) enddo enddo else - do k = 1, NLAY - do i = 1, IX + do k = 1, nlay + do i = 1, ix clwf(i,k) = clw(i,k) enddo enddo endif -!> - Compute top pressure for each cloud domain for given latitude. -!!\n ptopc(k,i): top presure of each cld domain (k=1-4 are sfc,L,m,h; -!! i=1,2 are low-lat (<45 degree) and pole regions) - - do i =1, IX - rxlat(i) = abs( xlat(i) / con_pi ) ! if xlat in pi/2 -> -pi/2 range -! rxlat(i) = abs(0.5 - xlat(i)/con_pi) ! if xlat in 0 -> pi range - enddo - - do id = 1, 4 - tem1 = ptopc(id,2) - ptopc(id,1) - - do i =1, IX - ptop1(i,id) = ptopc(id,1) + tem1*max( 0.0, 4.0*rxlat(i)-1.0 ) + if(kdt==1) then + do k = 1, nlay + do i = 1, ix + deltaq(i,k) = (1.-0.95)*qstl(i,k) + enddo enddo - enddo + endif -!> - Compute liquid/ice condensate path in \f$g m^{-2}\f$. +!> -# Calculate liquid/ice condensate path in \f$ g/m^2 \f$ - do k = 1, NLAY - do i = 1, IX - clwt = max(0.0,(clwf(i,k)+cnvw(i,k))) * gfac * delp(i,k) + do k = 1, nlay + do i = 1, ix + clwt = max(0.0,(clwf(i,k)+cnvw(i,k))) * gfac * delp(i,k) cip(i,k) = clwt * tem2d(i,k) cwp(i,k) = clwt - cip(i,k) enddo enddo -!> - Compute effective liquid cloud droplet radius over land. +!> -# Calculate effective liquid cloud droplet radius over land. - do i = 1, IX + do i = 1, ix if (nint(slmsk(i)) == 1) then - do k = 1, NLAY + do k = 1, nlay rew(i,k) = 5.0 + 5.0 * tem2d(i,k) enddo endif enddo - do k = 1, NLAY - do i = 1, IX +!> -# Calculate layer cloud fraction. + + do k = 1, nlay + do i = 1, ix + tem1 = tlyr(i,k) - 273.16 + if(tem1 < con_thgni) then ! for pure ice, has to be consistent with gscond + qsc = sup * qstl(i,k) + rhs = sup + else + qsc = qstl(i,k) + rhs = 1.0 + endif + if(rhly(i,k) >= rhs) then + cldtot(i,k) = 1.0 + else + qtmp = qlyr(i,k) + clwf(i,k) - qsc + if(deltaq(i,k) > epsq) then +! if(qtmp <= -deltaq(i,k) .or. cwmik < epsq) then + if(qtmp <= -deltaq(i,k)) then + cldtot(i,k) = 0.0 + elseif(qtmp >= deltaq(i,k)) then + cldtot(i,k) = 1.0 + else + cldtot(i,k) = 0.5*qtmp/deltaq(i,k) + 0.5 + cldtot(i,k) = max(cldtot(i,k),0.0) + cldtot(i,k) = min(cldtot(i,k),1.0) + endif + else + if(qtmp > 0.) then + cldtot(i,k) = 1.0 + else + cldtot(i,k) = 0.0 + endif + endif + endif + cldtot(i,k) = cnvc(i,k) + (1-cnvc(i,k))*cldtot(i,k) + cldtot(i,k) = max(cldtot(i,k),0.) + cldtot(i,k) = min(cldtot(i,k),1.) + + enddo + enddo + + do k = 1, nlay + do i = 1, ix if (cldtot(i,k) < climit) then + cldtot(i,k) = 0.0 cwp(i,k) = 0.0 cip(i,k) = 0.0 crp(i,k) = 0.0 @@ -2027,8 +1487,8 @@ subroutine progcld4 & enddo if ( lcnorm ) then - do k = 1, NLAY - do i = 1, IX + do k = 1, nlay + do i = 1, ix if (cldtot(i,k) >= climit) then tem1 = 1.0 / max(climit2, cldtot(i,k)) cwp(i,k) = cwp(i,k) * tem1 @@ -2040,14 +1500,15 @@ subroutine progcld4 & enddo endif -!> - Compute effective ice cloud droplet radius in Heymsfield and McFarquhar (1996) -!! \cite heymsfield_and_mcfarquhar_1996 . +!> -# Calculate effective ice cloud droplet radius following Heymsfield +!! and McFarquhar (1996) \cite heymsfield_and_mcfarquhar_1996. - do k = 1, NLAY - do i = 1, IX + do k = 1, nlay + do i = 1, ix tem2 = tlyr(i,k) - con_ttp if (cip(i,k) > 0.0) then +! tem3 = gord * cip(i,k) * (plyr(i,k)/delp(i,k)) / tvly(i,k) tem3 = gord * cip(i,k) * plyr(i,k) / (delp(i,k)*tvly(i,k)) if (tem2 < -50.0) then @@ -2062,7 +1523,7 @@ subroutine progcld4 & ! rei(i,k) = max(20.0, min(rei(i,k), 300.0)) ! rei(i,k) = max(10.0, min(rei(i,k), 100.0)) rei(i,k) = max(10.0, min(rei(i,k), 150.0)) -! rei(i,k) = max(5.0, min(rei(i,k), 130.0)) +! rei(i,k) = max(5.0, min(rei(i,k), 130.0)) endif enddo enddo @@ -2070,137 +1531,44 @@ subroutine progcld4 & ! do k = 1, NLAY do i = 1, IX - clouds(i,k,1) = cldtot(i,k) - clouds(i,k,2) = cwp(i,k) - clouds(i,k,3) = rew(i,k) - clouds(i,k,4) = cip(i,k) - clouds(i,k,5) = rei(i,k) -! clouds(i,k,6) = 0.0 - clouds(i,k,7) = rer(i,k) -! clouds(i,k,8) = 0.0 - clouds(i,k,9) = res(i,k) + cld_frac(i,k) = cldtot(i,k) + cld_lwp(i,k) = cwp(i,k) + cld_reliq(i,k) = rew(i,k) + cld_iwp(i,k) = cip(i,k) + cld_reice(i,k) = rei(i,k) +! cld_rwp(i,k) = 0.0 + cld_rerain(i,k) = rer(i,k) +! cld_swp(i,k) = 0.0 + cld_resnow(i,k) = res(i,k) enddo enddo - - ! Compute cloud decorrelation length - if (idcor == 1) then - call cmp_dcorr_lgth(ix, xlat, con_pi, de_lgth) - endif - if (idcor == 2) then - call cmp_dcorr_lgth(ix, latdeg, julian, yearlen, de_lgth) - endif - if (idcor == 0) then - de_lgth(:) = decorr_con - endif - - ! Call subroutine get_alpha_exp to define alpha parameter for exponential cloud overlap options - if (iovr == 3 .or. iovr == 4 .or. iovr == 5) then - call get_alpha_exp(ix, nLay, dzlay, de_lgth, alpha) - else - de_lgth(:) = 0. - alpha(:,:) = 0. - endif - - ! Revise alpha for exponential-random cloud overlap - ! Decorrelate layers when a clear layer follows a cloudy layer to enforce - ! random correlation between non-adjacent blocks of cloudy layers - if (iovr == 5) then - do k = 2, nLay - do i = 1, ix - if (clouds(i,k,1) == 0.0 .and. clouds(i,k-1,1) > 0.0) then - alpha(i,k) = 0.0 - endif - enddo - enddo - endif - -! --- compute low, mid, high, total, and boundary layer cloud fractions -! and clouds top/bottom layer indices for low, mid, and high clouds. -! The three cloud domain boundaries are defined by ptopc. The cloud -! overlapping method is defined by control flag 'iovr', which may -! be different for lw and sw radiation programs. - - call gethml & -! --- inputs: - & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, alpha, & - & IX,NLAY, & -! --- outputs: - & clds, mtop, mbot & - & ) - - ! return !................................... - end subroutine progcld4 + end subroutine progcld_zhao_carr_pdf !! @} !----------------------------------- + !----------------------------------- !> \ingroup module_radiation_clouds -!! This subroutine computes cloud related quantities using GFDL Lin MP -!! prognostic cloud microphysics scheme. Moist species from MP are fed -!! into the corresponding arrays for calculation of cloud fractions. -!! -!>\param plyr (ix,nlay), model layer mean pressure in mb (100Pa) -!>\param plvl (ix,nlp1), model level pressure in mb (100Pa) -!>\param tlyr (ix,nlay), model layer mean temperature in K -!>\param tvly (ix,nlay), model layer virtual temperature in K -!>\param qlyr (ix,nlay), layer specific humidity in \f$gm gm^{-1}\f$ -!>\param qstl (ix,nlay), layer saturate humidity in \f$gm gm^{-1}\f$ -!>\param rhly (ix,nlay), layer relative humidity (=qlyr/qstl) -!>\param clw (ix,nlay,ntrac), layer cloud condensate amount -!>\param xlat (ix), grid latitude in radians, default to pi/2->-pi/2 -!! range, otherwise see in-line comment -!>\param xlon (ix), grid longitude in radians (not used) -!>\param slmsk (ix), sea/land mask array (sea:0, land:1, sea-ice:2) -!>\param dz layer thickness (km) -!>\param delp model layer pressure thickness in mb (100Pa) -!>\param ntrac number of tracers minus one (Model%ntrac-1) -!>\param ntcw tracer index for cloud liquid water minus one (Model%ntcw-1) -!>\param ntiw tracer index for cloud ice water minus one (Model%ntiw-1) -!>\param ntrw tracer index for rain water minus one (Model%ntrw-1) -!>\param ntsw tracer index for snow water minus one (Model%ntsw-1) -!>\param ntgl tracer index for graupel minus one (Model%ntgl-1) -!>\param ntclamt tracer index for cloud amount minus one (Model%ntclamt-1) -!>\param ix horizontal dimension -!>\param nlay vertical layer dimension -!>\param nlp1 vertical level dimension -!!\param dzlay(ix,nlay) distance between model layer centers -!!\param latdeg(ix) latitude (in degrees 90 -> -90) -!!\param julian day of the year (fractional julian day) -!!\param yearlen current length of the year (365/366 days) -!>\param clouds (ix,nlay,nf_clds), cloud profiles -!!\n clouds(:,:,1) - layer totoal cloud fraction -!!\n clouds(:,:,2) - layer cloud liquid water path (\f$g m^{-2}\f$) -!!\n clouds(:,:,3) - mean effective radius for liquid cloud (micron) -!!\n clouds(:,:,4) - layer cloud ice water path (\f$g m^{-2}\f$) -!!\n clouds(:,:,5) - mean effective radius for ice cloud (micron) -!!\n clouds(:,:,6) - layer rain dropwater path (\f$g m^{-2}\f$) -!!\n clouds(:,:,7) - mean effective radius for rain drop (micron) -!!\n clouds(:,:,8) - layer snow flake water path (\f$g m^{-2}\f$) -!!\n clouds(:,:,9) - mean effective radius for snow flake (micron) -!>\param clds (ix,5), fraction of clouds for low, mid, hi, tot, bl -!>\param mtop (ix,3), vertical indices for low, mid, hi cloud tops -!>\param mbot (ix,3), vertical indices for low, mid, hi cloud bases -!>\param de_lgth clouds decorrelation length (km) -!!\param alpha (IX,NLAY), alpha decorrelation parameter -!>\section gen_progcld4o progcld4o General Algorithm +!> This subroutine computes cloud related quantities using +!! GFDL Lin MP prognostic cloud microphysics scheme. +!>\section progcld_gfdl_lin General Algorithm !! @{ - subroutine progcld4o & - & ( plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw, & ! --- inputs: - & xlat,xlon,slmsk, dz, delp, & - & ntrac,ntcw,ntiw,ntrw,ntsw,ntgl,ntclamt, & + subroutine progcld_gfdl_lin & + & ( plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw,cnvw,cnvc, & ! --- inputs: + & xlat,xlon,slmsk,cldtot, dz, delp, & & IX, NLAY, NLP1, & - & dzlay, latdeg, julian, yearlen, & - & clouds,clds,mtop,mbot,de_lgth,alpha & ! --- outputs: + & dzlay, cldtot1, cldcnv, & + & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs + & cld_reice,cld_rwp, cld_rerain,cld_swp, cld_resnow & & ) ! ================= subprogram documentation block ================ ! ! ! -! subprogram: progcld4o computes cloud related quantities using ! -! GFDL Lin MP prognostic cloud microphysics scheme. Moist species ! -! from MP are fed into the corresponding arrays for calcuation of ! +! subprogram: progcld_gfdl_lin computes cloud related quantities using ! +! GFDL Lin MP prognostic cloud microphysics scheme. ! ! ! ! abstract: this program computes cloud fractions from cloud ! ! condensates, calculates liquid/ice cloud droplet effective radius, ! @@ -2209,7 +1577,7 @@ subroutine progcld4o & ! top and base. the three vertical cloud domains are set up in the ! ! initial subroutine "cld_init". ! ! ! -! usage: call progcld4o ! +! usage: call progcld_gfdl_lin ! ! ! ! subprograms called: gethml ! ! ! @@ -2228,7 +1596,9 @@ subroutine progcld4o & ! qlyr (IX,NLAY) : layer specific humidity in gm/gm ! ! qstl (IX,NLAY) : layer saturate humidity in gm/gm ! ! rhly (IX,NLAY) : layer relative humidity (=qlyr/qstl) ! -! clw (IX,NLAY,NTRAC) : layer cloud condensate amount ! +! clw (IX,NLAY) : layer cloud condensate amount ! +! cnvw (IX,NLAY) : layer convective cloud condensate ! +! cnvc (IX,NLAY) : layer convective cloud cover ! ! xlat (IX) : grid latitude in radians, default to pi/2 -> -pi/2! ! range, otherwise see in-line comment ! ! xlon (IX) : grid longitude in radians (not used) ! @@ -2238,27 +1608,18 @@ subroutine progcld4o & ! IX : horizontal dimention ! ! NLAY,NLP1 : vertical layer/level dimensions ! ! dzlay(ix,nlay) : thickness between model layer centers (km) ! -! latdeg(ix) : latitude (in degrees 90 -> -90) ! -! julian : day of the year (fractional julian day) ! -! yearlen : current length of the year (365/366 days) ! ! ! ! output variables: ! -! clouds(IX,NLAY,NF_CLDS) : cloud profiles ! -! clouds(:,:,1) - layer total cloud fraction ! -! clouds(:,:,2) - layer cloud liq water path (g/m**2) ! -! clouds(:,:,3) - mean eff radius for liq cloud (micron) ! -! clouds(:,:,4) - layer cloud ice water path (g/m**2) ! -! clouds(:,:,5) - mean eff radius for ice cloud (micron) ! -! clouds(:,:,6) - layer rain drop water path not assigned ! -! clouds(:,:,7) - mean eff radius for rain drop (micron) ! -! *** clouds(:,:,8) - layer snow flake water path not assigned ! -! clouds(:,:,9) - mean eff radius for snow flake (micron) ! -! *** fu's scheme need to be normalized by snow density (g/m**3/1.0e6) ! -! clds (IX,5) : fraction of clouds for low, mid, hi, tot, bl ! -! mtop (IX,3) : vertical indices for low, mid, hi cloud tops ! -! mbot (IX,3) : vertical indices for low, mid, hi cloud bases ! -! de_lgth(ix) : clouds decorrelation length (km) ! -! alpha(ix,nlay) : alpha decorrelation parameter +! cloud profiles: ! +! cld_frac (:,:) - layer total cloud fraction ! +! cld_lwp (:,:) - layer cloud liq water path (g/m**2) ! +! cld_reliq (:,:) - mean eff radius for liq cloud (micron) ! +! cld_iwp (:,:) - layer cloud ice water path (g/m**2) ! +! cld_reice (:,:) - mean eff radius for ice cloud (micron) ! +! cld_rwp (:,:) - layer rain drop water path not assigned ! +! cld_rerain(:,:) - mean eff radius for rain drop (micron) ! +! *** cld_swp (:,:) - layer snow flake water path not assigned ! +! cld_resnow(:,:) - mean eff radius for snow flake (micron) ! ! ! ! module variables: ! ! ivflip : control flag of vertical index direction ! @@ -2278,55 +1639,35 @@ subroutine progcld4o & ! --- inputs integer, intent(in) :: IX, NLAY, NLP1 - integer, intent(in) :: ntrac, ntcw, ntiw, ntrw, ntsw, ntgl, & - & ntclamt real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & - & tlyr, tvly, qlyr, qstl, rhly, delp, dz, dzlay - + & tlyr, tvly, qlyr, qstl, rhly, clw, cldtot, cnvw, cnvc, & + & delp, dz, dzlay - real (kind=kind_phys), dimension(:,:,:), intent(in) :: clw real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & & slmsk - real(kind=kind_phys), dimension(:), intent(in) :: latdeg - real(kind=kind_phys), intent(in) :: julian - integer, intent(in) :: yearlen - -! --- outputs - real (kind=kind_phys), dimension(:,:,:), intent(out) :: clouds + real (kind=kind_phys), dimension(:,:), intent(inout) :: cldtot1 - real (kind=kind_phys), dimension(:,:), intent(out) :: clds - real (kind=kind_phys), dimension(:), intent(out) :: de_lgth - real (kind=kind_phys), dimension(:,:), intent(out) :: alpha +! --- inputs/outputs - integer, dimension(:,:), intent(out) :: mtop,mbot + real (kind=kind_phys), dimension(:,:), intent(inout) :: & + & cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, & + & cld_rwp, cld_rerain, cld_swp, cld_resnow ! --- local variables: real (kind=kind_phys), dimension(IX,NLAY) :: cldcnv, & - & cwp, cip, crp, csp, rew, rei, res, rer, tem2d - - real (kind=kind_phys) :: ptop1(IX,NK_CLDS+1), rxlat(ix) + & cwp, cip, crp, csp, rew, rei, res, rer, tem2d, clwf real (kind=kind_phys) :: clwmin, clwm, clwt, onemrh, value, & & tem1, tem2, tem3 - real (kind=kind_phys), dimension(IX,NLAY) :: cldtot integer :: i, k, id, nf ! !===> ... begin here ! - do nf=1,nf_clds - do k=1,nlay - do i=1,ix - clouds(i,k,nf) = 0.0 - enddo - enddo - enddo -! clouds(:,:,:) = 0.0 - -!> - Assign liquid/ice/rain/snow cloud droplet effective radius as default value. +!> - Assign liquid/ice/rain/snow cloud doplet effective radius as default value. do k = 1, NLAY do i = 1, IX cldcnv(i,k) = 0.0 @@ -2334,41 +1675,40 @@ subroutine progcld4o & cip (i,k) = 0.0 crp (i,k) = 0.0 csp (i,k) = 0.0 - rew (i,k) = reliq_def ! default liq radius to 10 micron - rei (i,k) = reice_def ! default ice radius to 50 micron - rer (i,k) = rrain_def ! default rain radius to 1000 micron - res (i,k) = rsnow_def ! default snow radius to 250 micron + rew (i,k) = reliq_def !< default liq radius to 10 micron + rei (i,k) = reice_def !< default ice radius to 50 micron + rer (i,k) = rrain_def !< default rain radius to 1000 micron + res (i,k) = rsnow_def !< default snow radius to 250 micron tem2d (i,k) = min( 1.0, max( 0.0, (con_ttp-tlyr(i,k))*0.05 ) ) - cldtot(i,k) = clw(i,k,ntclamt) + clwf(i,k) = 0.0 enddo enddo - -!> - Compute top pressure for each cloud domain for given latitude. -!! ptopc(k,i): top presure of each cld domain (k=1-4 are sfc,L,m,h; -!! i=1,2 are low-lat (<45 degree) and pole regions) - - do i =1, IX - rxlat(i) = abs( xlat(i) / con_pi ) ! if xlat in pi/2 -> -pi/2 range -! rxlat(i) = abs(0.5 - xlat(i)/con_pi) ! if xlat in 0 -> pi range - enddo - - do id = 1, 4 - tem1 = ptopc(id,2) - ptopc(id,1) - - do i =1, IX - ptop1(i,id) = ptopc(id,1) + tem1*max( 0.0, 4.0*rxlat(i)-1.0 ) +! + if ( lcrick ) then + do i = 1, IX + clwf(i,1) = 0.75*clw(i,1) + 0.25*clw(i,2) + clwf(i,nlay) = 0.75*clw(i,nlay) + 0.25*clw(i,nlay-1) enddo - enddo + do k = 2, NLAY-1 + do i = 1, IX + clwf(i,K) = 0.25*clw(i,k-1) + 0.5*clw(i,k) + 0.25*clw(i,k+1) + enddo + enddo + else + do k = 1, NLAY + do i = 1, IX + clwf(i,k) = clw(i,k) + enddo + enddo + endif -!> - Compute liquid/ice condensate path in \f$g m^{-2}\f$ +!> - Compute liquid/ice condensate path in \f$g m^{-2}\f$. do k = 1, NLAY do i = 1, IX - cwp(i,k) = max(0.0, clw(i,k,ntcw) * gfac * delp(i,k)) - cip(i,k) = max(0.0, clw(i,k,ntiw) * gfac * delp(i,k)) - crp(i,k) = max(0.0, clw(i,k,ntrw) * gfac * delp(i,k)) - csp(i,k) = max(0.0, (clw(i,k,ntsw)+clw(i,k,ntgl)) * & - & gfac * delp(i,k)) + clwt = max(0.0,(clwf(i,k)+cnvw(i,k))) * gfac * delp(i,k) + cip(i,k) = clwt * tem2d(i,k) + cwp(i,k) = clwt - cip(i,k) enddo enddo @@ -2408,7 +1748,7 @@ subroutine progcld4o & endif !> - Compute effective ice cloud droplet radius in Heymsfield and McFarquhar (1996) -!!\cite heymsfield_and_mcfarquhar_1996. +!! \cite heymsfield_and_mcfarquhar_1996 . do k = 1, NLAY do i = 1, IX @@ -2434,72 +1774,30 @@ subroutine progcld4o & enddo enddo -! do k = 1, NLAY do i = 1, IX - clouds(i,k,1) = cldtot(i,k) - clouds(i,k,2) = cwp(i,k) - clouds(i,k,3) = rew(i,k) - clouds(i,k,4) = cip(i,k) - clouds(i,k,5) = rei(i,k) - clouds(i,k,6) = crp(i,k) - clouds(i,k,7) = rer(i,k) - clouds(i,k,8) = csp(i,k) - clouds(i,k,9) = rei(i,k) + cldtot1(i,k) = cldtot(i,k) enddo enddo - ! Compute cloud decorrelation length - if (idcor == 1) then - call cmp_dcorr_lgth(ix, xlat, con_pi, de_lgth) - endif - if (idcor == 2) then - call cmp_dcorr_lgth(ix, latdeg, julian, yearlen, de_lgth) - endif - if (idcor == 0) then - de_lgth(:) = decorr_con - endif - - ! Call subroutine get_alpha_exp to define alpha parameter for exponential cloud overlap options - if (iovr == 3 .or. iovr == 4 .or. iovr == 5) then - call get_alpha_exp(ix, nLay, dzlay, de_lgth, alpha) - else - de_lgth(:) = 0. - alpha(:,:) = 0. - endif - - ! Revise alpha for exponential-random cloud overlap - ! Decorrelate layers when a clear layer follows a cloudy layer to enforce - ! random correlation between non-adjacent blocks of cloudy layers - if (iovr == 5) then - do k = 2, nLay - do i = 1, ix - if (clouds(i,k,1) == 0.0 .and. clouds(i,k-1,1) > 0.0) then - alpha(i,k) = 0.0 - endif - enddo +! + do k = 1, NLAY + do i = 1, IX + cld_frac(i,k) = cldtot(i,k) + cld_lwp(i,k) = cwp(i,k) + cld_reliq(i,k) = rew(i,k) + cld_iwp(i,k) = cip(i,k) + cld_reice(i,k) = rei(i,k) +! cld_rwp(i,k) = 0.0 + cld_rerain(i,k) = rer(i,k) +! cld_swp(i,k) = 0.0 + cld_resnow(i,k) = res(i,k) enddo - endif - -!> - Call gethml() to compute low, mid, high, total, and boundary layer cloud fractions -!! and clouds top/bottom layer indices for low, mid, and high clouds. -!! The three cloud domain boundaries are defined by ptopc. The cloud -!! overlapping method is defined by control flag 'iovr', which may -!! be different for lw and sw radiation programs. - - call gethml & -! --- inputs: - & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, alpha, & - & IX,NLAY, & -! --- outputs: - & clds, mtop, mbot & - & ) - - + enddo ! return !................................... - end subroutine progcld4o + end subroutine progcld_gfdl_lin !! @} !----------------------------------- @@ -2507,20 +1805,21 @@ end subroutine progcld4o !> \ingroup module_radiation_clouds !! This subroutine computes cloud related quantities using !! Ferrier-Aligo cloud microphysics scheme. - subroutine progcld5 & + subroutine progcld_fer_hires & & ( plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw, & ! --- inputs: & xlat,xlon,slmsk,dz,delp, & & ntrac,ntcw,ntiw,ntrw, & & IX, NLAY, NLP1, icloud, & & uni_cld, lmfshal, lmfdeep2, cldcov, & & re_cloud,re_ice,re_snow, & - & dzlay, latdeg, julian, yearlen, & - & clouds,clds,mtop,mbot,de_lgth,alpha & ! --- outputs: + & dzlay, cldtot, cldcnv, & + & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs + & cld_reice,cld_rwp, cld_rerain,cld_swp, cld_resnow & & ) ! ================= subprogram documentation block ================ ! ! ! -! subprogram: progcld5 computes cloud related quantities using ! +! subprogram: progcld_fer_hires computes cloud related quantities using ! ! Ferrier-Aligo cloud microphysics scheme. ! ! ! ! abstract: this program computes cloud fractions from cloud ! @@ -2530,7 +1829,7 @@ subroutine progcld5 & ! top and base. the three vertical cloud domains are set up in the ! ! initial subroutine "cld_init". ! ! ! -! usage: call progcld5 ! +! usage: call progcld_fer_hires ! ! ! ! subprograms called: gethml ! ! ! @@ -2564,27 +1863,18 @@ subroutine progcld5 & ! lmfdeep2 : logical - true for mass flux deep convection ! ! cldcov : layer cloud fraction (used when uni_cld=.true. ! ! dzlay(ix,nlay) : thickness between model layer centers (km) ! -! latdeg(ix) : latitude (in degrees 90 -> -90) ! -! julian : day of the year (fractional julian day) ! -! yearlen : current length of the year (365/366 days) ! ! ! ! output variables: ! -! clouds(IX,NLAY,NF_CLDS) : cloud profiles ! -! clouds(:,:,1) - layer total cloud fraction ! -! clouds(:,:,2) - layer cloud liq water path (g/m**2) ! -! clouds(:,:,3) - mean eff radius for liq cloud (micron) ! -! clouds(:,:,4) - layer cloud ice water path (g/m**2) ! -! clouds(:,:,5) - mean eff radius for ice cloud (micron) ! -! clouds(:,:,6) - layer rain drop water path not assigned ! -! clouds(:,:,7) - mean eff radius for rain drop (micron) ! -! *** clouds(:,:,8) - layer snow flake water path not assigned ! -! clouds(:,:,9) - mean eff radius for snow flake (micron) ! -! *** fu's scheme need to be normalized by snow density (g/m**3/1.0e6) ! -! clds (IX,5) : fraction of clouds for low, mid, hi, tot, bl ! -! mtop (IX,3) : vertical indices for low, mid, hi cloud tops ! -! mbot (IX,3) : vertical indices for low, mid, hi cloud bases ! -! de_lgth(ix) : clouds decorrelation length (km) ! -! alpha(ix,nlay) : alpha decorrelation parameter +! cloud profiles: ! +! cld_frac (:,:) - layer total cloud fraction ! +! cld_lwp (:,:) - layer cloud liq water path (g/m**2) ! +! cld_reliq (:,:) - mean eff radius for liq cloud (micron) ! +! cld_iwp (:,:) - layer cloud ice water path (g/m**2) ! +! cld_reice (:,:) - mean eff radius for ice cloud (micron) ! +! cld_rwp (:,:) - layer rain drop water path not assigned ! +! cld_rerain(:,:) - mean eff radius for rain drop (micron) ! +! *** cld_swp (:,:) - layer snow flake water path not assigned ! +! cld_resnow(:,:) - mean eff radius for snow flake (micron) ! ! ! ! module variables: ! ! ivflip : control flag of vertical index direction ! @@ -2620,25 +1910,16 @@ subroutine progcld5 & real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & & slmsk - real(kind=kind_phys), dimension(:), intent(in) :: latdeg - real(kind=kind_phys), intent(in) :: julian - integer, intent(in) :: yearlen - -! --- outputs - real (kind=kind_phys), dimension(:,:,:), intent(out) :: clouds - - real (kind=kind_phys), dimension(:,:), intent(out) :: clds - real (kind=kind_phys), dimension(:), intent(out) :: de_lgth - real (kind=kind_phys), dimension(:,:), intent(out) :: alpha +! --- inputs/outputs - integer, dimension(:,:), intent(out) :: mtop,mbot + real (kind=kind_phys), dimension(:,:), intent(inout) :: & + & cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, & + & cld_rwp, cld_rerain, cld_swp, cld_resnow ! --- local variables: real (kind=kind_phys), dimension(IX,NLAY) :: cldtot, cldcnv, & & cwp, cip, crp, csp, rew, rei, res, rer, tem2d, clwf - real (kind=kind_phys) :: ptop1(IX,NK_CLDS+1), rxlat(ix) - real (kind=kind_phys) :: clwmin, clwm, clwt, onemrh, value, & & tem1, tem2, tem3 @@ -2651,15 +1932,6 @@ subroutine progcld5 & ! !===> ... begin here ! - do nf=1,nf_clds - do k=1,nlay - do i=1,ix - clouds(i,k,nf) = 0.0 - enddo - enddo - enddo -! clouds(:,:,:) = 0.0 - do k = 1, NLAY do i = 1, IX cldtot(i,k) = 0.0 @@ -2700,22 +1972,6 @@ subroutine progcld5 & clwf(i,k) = clw(i,k,ntcw) + clw(i,k,ntiw) enddo enddo -!> - Find top pressure for each cloud domain for given latitude. -!! ptopc(k,i): top presure of each cld domain (k=1-4 are sfc,L,m,h; -!! i=1,2 are low-lat (<45 degree) and pole regions) - - do i =1, IX - rxlat(i) = abs( xlat(i) / con_pi ) ! if xlat in pi/2 -> -pi/2 range -! rxlat(i) = abs(0.5 - xlat(i)/con_pi) ! if xlat in 0 -> pi range - enddo - - do id = 1, 4 - tem1 = ptopc(id,2) - ptopc(id,1) - - do i =1, IX - ptop1(i,id) = ptopc(id,1) + tem1*max( 0.0, 4.0*rxlat(i)-1.0 ) - enddo - enddo !> - Compute cloud liquid/ice condensate path in \f$ g/m^2 \f$ . @@ -2741,54 +1997,14 @@ subroutine progcld5 & !> - Calculate layer cloud fraction. - clwmin = 0.0 if (.not. lmfshal) then - do k = 1, NLAY - do i = 1, IX - clwt = 1.0e-6 * (plyr(i,k)*0.001) -! clwt = 2.0e-6 * (plyr(i,k)*0.001) - - if (clwf(i,k) > clwt) then - - onemrh= max( 1.e-10, 1.0-rhly(i,k) ) - clwm = clwmin / max( 0.01, plyr(i,k)*0.001 ) - - tem1 = min(max(sqrt(sqrt(onemrh*qstl(i,k))),0.0001),1.0) - tem1 = 2000.0 / tem1 - -! tem1 = 1000.0 / tem1 - - value = max( min( tem1*(clwf(i,k)-clwm), 50.0 ), 0.0 ) - tem2 = sqrt( sqrt(rhly(i,k)) ) - - cldtot(i,k) = max( tem2*(1.0-exp(-value)), 0.0 ) - endif - enddo - enddo + call cloud_fraction_XuRandall & + & ( IX, NLAY, plyr, clwf, rhly, qstl, & ! --- inputs + & cldtot ) & ! --- outputs else - do k = 1, NLAY - do i = 1, IX - clwt = 1.0e-6 * (plyr(i,k)*0.001) -! clwt = 2.0e-6 * (plyr(i,k)*0.001) - - if (clwf(i,k) > clwt) then - onemrh= max( 1.e-10, 1.0-rhly(i,k) ) - clwm = clwmin / max( 0.01, plyr(i,k)*0.001 ) -! - tem1 = min(max((onemrh*qstl(i,k))**0.49,0.0001),1.0) !jhan - if (lmfdeep2) then - tem1 = xrc3 / tem1 - else - tem1 = 100.0 / tem1 - endif -! - value = max( min( tem1*(clwf(i,k)-clwm), 50.0 ), 0.0 ) - tem2 = sqrt( sqrt(rhly(i,k)) ) - - cldtot(i,k) = max( tem2*(1.0-exp(-value)), 0.0 ) - endif - enddo - enddo + call cloud_fraction_mass_flx_1 & + & ( IX, NLAY, lmfdeep2, xrc3, plyr, clwf, rhly, qstl, & ! --- inputs + & cldtot ) endif endif ! if (uni_cld) then @@ -2818,86 +2034,32 @@ subroutine progcld5 & enddo enddo endif +! do k = 1, NLAY do i = 1, IX - clouds(i,k,1) = cldtot(i,k) - clouds(i,k,2) = cwp(i,k) - clouds(i,k,3) = rew(i,k) - clouds(i,k,4) = cip(i,k) - clouds(i,k,5) = rei(i,k) - clouds(i,k,6) = crp(i,k) - clouds(i,k,7) = rer(i,k) - !mz inflg .ne.5 - clouds(i,k,8) = 0. - clouds(i,k,9) = 10. -!mz for diagnostics? + cld_frac(i,k) = cldtot(i,k) + cld_lwp(i,k) = cwp(i,k) + cld_reliq(i,k) = rew(i,k) + cld_iwp(i,k) = cip(i,k) + cld_reice(i,k) = rei(i,k) + cld_rwp(i,k) = crp(i,k) + cld_rerain(i,k) = rer(i,k) + cld_swp(i,k) = 0.0 + cld_resnow(i,k) = 10.0 re_cloud(i,k) = rew(i,k) re_ice(i,k) = rei(i,k) re_snow(i,k) = 10. - enddo enddo - - ! Compute cloud decorrelation length - if (idcor == 1) then - call cmp_dcorr_lgth(ix, xlat, con_pi, de_lgth) - endif - if (idcor == 2) then - call cmp_dcorr_lgth(ix, latdeg, julian, yearlen, de_lgth) - endif - if (idcor == 0) then - de_lgth(:) = decorr_con - endif - - ! Call subroutine get_alpha_exp to define alpha parameter for exponential cloud overlap options - if (iovr == 3 .or. iovr == 4 .or. iovr == 5) then - call get_alpha_exp(ix, nLay, dzlay, de_lgth, alpha) - else - de_lgth(:) = 0. - alpha(:,:) = 0. - endif - - ! Revise alpha for exponential-random cloud overlap - ! Decorrelate layers when a clear layer follows a cloudy layer to enforce - ! random correlation between non-adjacent blocks of cloudy layers - if (iovr == 5) then - do k = 2, nLay - do i = 1, ix - if (clouds(i,k,1) == 0.0 .and. clouds(i,k-1,1) > 0.0) then - alpha(i,k) = 0.0 - endif - enddo - enddo - endif - -!> - Call gethml() to compute low,mid,high,total, and boundary layer -!! cloud fractions and clouds top/bottom layer indices for low, mid, -!! and high clouds. -! --- compute low, mid, high, total, and boundary layer cloud fractions -! and clouds top/bottom layer indices for low, mid, and high clouds. -! The three cloud domain boundaries are defined by ptopc. The cloud -! overlapping method is defined by control flag 'iovr', which may -! be different for lw and sw radiation programs. - - call gethml & -! --- inputs: - & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, alpha, & - & IX,NLAY, & -! --- outputs: - & clds, mtop, mbot & - & ) - - ! return !................................... - end subroutine progcld5 + end subroutine progcld_fer_hires !................................... -!mz: this is the original progcld5 for Thompson MP (and WSM6), -! to be replaced by the GSL version of progcld6 for Thompson MP - subroutine progcld6 & +! This subroutine is used by Thompson/WSM6/NSSL cloud microphysics (EMC) + subroutine progcld_thompson_wsm6 & & ( plyr,plvl,tlyr,qlyr,qstl,rhly,clw, & ! --- inputs: & xlat,xlon,slmsk,dz,delp, & & ntrac,ntcw,ntiw,ntrw,ntsw,ntgl, & @@ -2905,14 +2067,16 @@ subroutine progcld6 & & uni_cld, lmfshal, lmfdeep2, cldcov, cnvw, & & re_cloud,re_ice,re_snow, & & lwp_ex, iwp_ex, lwp_fc, iwp_fc, & - & dzlay, latdeg, julian, yearlen, & - & clouds,clds,mtop,mbot,de_lgth,alpha & ! --- outputs: + & dzlay, cldtot, cldcnv, & + & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs + & cld_reice,cld_rwp, cld_rerain,cld_swp, cld_resnow & & ) ! ================= subprogram documentation block ================ ! ! ! -! subprogram: progcld6 computes cloud related quantities using ! -! Thompson/WSM6 cloud microphysics scheme. ! +! subprogram: progcld_thompson_wsm6 ! +! computes cloud related quantities using ! +! Thompson/WSM6/NSSL cloud microphysics scheme. ! ! ! ! abstract: this program computes cloud fractions from cloud ! ! condensates, ! @@ -2921,7 +2085,7 @@ subroutine progcld6 & ! top and base. the three vertical cloud domains are set up in the ! ! initial subroutine "cld_init". ! ! ! -! usage: call progcld6 ! +! usage: call progcld_thompson_wsm6 ! ! ! ! subprograms called: gethml ! ! ! @@ -2956,16 +2120,16 @@ subroutine progcld6 & ! cldcov : layer cloud fraction (used when uni_cld=.true. ! ! ! ! output variables: ! -! clouds(IX,NLAY,NF_CLDS) : cloud profiles ! -! clouds(:,:,1) - layer total cloud fraction ! -! clouds(:,:,2) - layer cloud liq water path (g/m**2) ! -! clouds(:,:,3) - mean eff radius for liq cloud (micron) ! -! clouds(:,:,4) - layer cloud ice water path (g/m**2) ! -! clouds(:,:,5) - mean eff radius for ice cloud (micron) ! -! clouds(:,:,6) - layer rain drop water path not assigned ! -! clouds(:,:,7) - mean eff radius for rain drop (micron) ! -! *** clouds(:,:,8) - layer snow flake water path not assigned ! -! clouds(:,:,9) - mean eff radius for snow flake (micron) ! +! cloud profiles: ! +! cld_frac (:,:) - layer total cloud fraction ! +! cld_lwp (:,:) - layer cloud liq water path (g/m**2) ! +! cld_reliq (:,:) - mean eff radius for liq cloud (micron) ! +! cld_iwp (:,:) - layer cloud ice water path (g/m**2) ! +! cld_reice (:,:) - mean eff radius for ice cloud (micron) ! +! cld_rwp (:,:) - layer rain drop water path not assigned ! +! cld_rerain(:,:) - mean eff radius for rain drop (micron) ! +! *** cld_swp (:,:) - layer snow flake water path not assigned ! +! cld_resnow(:,:) - mean eff radius for snow flake (micron) ! ! *** fu's scheme need to be normalized by snow density (g/m**3/1.0e6) ! ! clds (IX,5) : fraction of clouds for low, mid, hi, tot, bl ! ! mtop (IX,3) : vertical indices for low, mid, hi cloud tops ! @@ -3006,25 +2170,16 @@ subroutine progcld6 & real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & & slmsk - real(kind=kind_phys), dimension(:), intent(in) :: latdeg - real(kind=kind_phys), intent(in) :: julian - integer, intent(in) :: yearlen - -! --- outputs - real (kind=kind_phys), dimension(:,:,:), intent(out) :: clouds - - real (kind=kind_phys), dimension(:,:), intent(out) :: clds - real (kind=kind_phys), dimension(:), intent(out) :: de_lgth - real (kind=kind_phys), dimension(:,:), intent(out) :: alpha +! --- inputs/outputs - integer, dimension(:,:), intent(out) :: mtop,mbot + real (kind=kind_phys), dimension(:,:), intent(inout) :: & + & cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, & + & cld_rwp, cld_rerain, cld_swp, cld_resnow ! --- local variables: real (kind=kind_phys), dimension(IX,NLAY) :: cldtot, cldcnv, & & cwp, cip, crp, csp, rew, rei, res, rer, tem2d, clwf - real (kind=kind_phys) :: ptop1(IX,NK_CLDS+1), rxlat(ix) - real (kind=kind_phys) :: clwmin, clwm, clwt, onemrh, value, & & tem1, tem2, tem3 @@ -3036,15 +2191,6 @@ subroutine progcld6 & ! !===> ... begin here - do nf=1,nf_clds - do k=1,nlay - do i=1,ix - clouds(i,k,nf) = 0.0 - enddo - enddo - enddo -! clouds(:,:,:) = 0.0 - do k = 1, NLAY do i = 1, IX cldtot(i,k) = 0.0 @@ -3087,22 +2233,6 @@ subroutine progcld6 & & + clw(i,k,ntrw) + cnvw(i,k) enddo enddo -!> - Find top pressure for each cloud domain for given latitude. -!! ptopc(k,i): top presure of each cld domain (k=1-4 are sfc,L,m,h; -!! i=1,2 are low-lat (<45 degree) and pole regions) - - do i =1, IX - rxlat(i) = abs( xlat(i) / con_pi ) ! if xlat in pi/2 -> -pi/2 range -! rxlat(i) = abs(0.5 - xlat(i)/con_pi) ! if xlat in 0 -> pi range - enddo - - do id = 1, 4 - tem1 = ptopc(id,2) - ptopc(id,1) - - do i =1, IX - ptop1(i,id) = ptopc(id,1) + tem1*max( 0.0, 4.0*rxlat(i)-1.0 ) - enddo - enddo !> - Compute cloud liquid/ice condensate path in \f$ g/m^2 \f$ . @@ -3141,57 +2271,16 @@ subroutine progcld6 & !> - Calculate layer cloud fraction. - clwmin = 0.0 if (.not. lmfshal) then - do k = 1, NLAY - do i = 1, IX - clwt = 1.0e-6 * (plyr(i,k)*0.001) - - if (clwf(i,k) > clwt) then - - onemrh= max( 1.e-10, 1.0-rhly(i,k) ) - clwm = clwmin / max( 0.01, plyr(i,k)*0.001 ) - - tem1 = min(max(sqrt(sqrt(onemrh*qstl(i,k))),0.0001),1.0) - tem1 = 2000.0 / tem1 - - value = max( min( tem1*(clwf(i,k)-clwm), 50.0 ), 0.0 ) - tem2 = sqrt( sqrt(rhly(i,k)) ) - - cldtot(i,k) = max( tem2*(1.0-exp(-value)), 0.0 ) - endif - enddo - enddo + call cloud_fraction_XuRandall & + & ( IX, NLAY, plyr, clwf, rhly, qstl, & ! --- inputs + & cldtot ) & ! --- outputs else - do k = 1, NLAY-1 - do i = 1, IX - clwt = 1.0e-10 * (plyr(i,k)*0.001) - - if (clwf(i,k) > clwt) then - if(rhly(i,k) > 0.99) then - cldtot(i,k) = 1. - else - onemrh= max( 1.e-10, 1.0-rhly(i,k) ) - clwm = clwmin / max( 0.01, plyr(i,k)*0.001 ) - - tem1 = min(max((onemrh*qstl(i,k))**0.49,0.0001),1.0) !jhan - if (lmfdeep2) then - tem1 = xrc3 / tem1 - else - tem1 = 100.0 / tem1 - endif - - value = max( min( tem1*(clwf(i,k)-clwm), 50.0 ), 0.0 ) - tem2 = sqrt( sqrt(rhly(i,k)) ) - - cldtot(i,k) = max( tem2*(1.0-exp(-value)), 0.0 ) - endif - else - cldtot(i,k) = 0.0 - endif - enddo - enddo - endif + call cloud_fraction_mass_flx_2 & + & ( IX, NLAY, lmfdeep2, xrc3, plyr, clwf, rhly, qstl, & ! --- inputs + & cldtot ) + endif + endif ! if (uni_cld) then do k = 1, NLAY @@ -3235,71 +2324,22 @@ subroutine progcld6 & do k = 1, NLAY do i = 1, IX - clouds(i,k,1) = cldtot(i,k) - clouds(i,k,2) = cwp(i,k) - clouds(i,k,3) = rew(i,k) - clouds(i,k,4) = cip(i,k) - clouds(i,k,5) = rei(i,k) - clouds(i,k,6) = crp(i,k) ! added for Thompson - clouds(i,k,7) = rer(i,k) - clouds(i,k,8) = csp(i,k) ! added for Thompson - clouds(i,k,9) = res(i,k) + cld_frac(i,k) = cldtot(i,k) + cld_lwp(i,k) = cwp(i,k) + cld_reliq(i,k) = rew(i,k) + cld_iwp(i,k) = cip(i,k) + cld_reice(i,k) = rei(i,k) + cld_rwp(i,k) = crp(i,k) ! added for Thompson + cld_rerain(i,k) = rer(i,k) + cld_swp(i,k) = csp(i,k) ! added for Thompson + cld_resnow(i,k) = res(i,k) enddo enddo - ! Compute cloud decorrelation length - if (idcor == 1) then - call cmp_dcorr_lgth(ix, xlat, con_pi, de_lgth) - endif - if (idcor == 2) then - call cmp_dcorr_lgth(ix, latdeg, julian, yearlen, de_lgth) - endif - if (idcor == 0) then - de_lgth(:) = decorr_con - endif - - ! Call subroutine get_alpha_exp to define alpha parameter for exponential cloud overlap options - if ( iovr == 3 .or. iovr == 4 .or. iovr == 5) then - call get_alpha_exp(ix, nLay, dzlay, de_lgth, alpha) - else - de_lgth(:) = 0. - alpha(:,:) = 0. - endif - - ! Revise alpha for exponential-random cloud overlap - ! Decorrelate layers when a clear layer follows a cloudy layer to enforce - ! random correlation between non-adjacent blocks of cloudy layers - if (iovr == 5) then - do k = 2, nLay - do i = 1, ix - if (clouds(i,k,1) == 0.0 .and. clouds(i,k-1,1) > 0.0) then - alpha(i,k) = 0.0 - endif - enddo - enddo - endif - -!> - Call gethml() to compute low,mid,high,total, and boundary layer -!! cloud fractions and clouds top/bottom layer indices for low, mid, -!! and high clouds. -! --- compute low, mid, high, total, and boundary layer cloud fractions -! and clouds top/bottom layer indices for low, mid, and high clouds. -! The three cloud domain boundaries are defined by ptopc. The cloud -! overlapping method is defined by control flag 'iovr', which may -! be different for lw and sw radiation programs. - - call gethml & -! --- inputs: - & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, alpha, & - & IX,NLAY, & -! --- outputs: - & clds, mtop, mbot & - & ) - return !............................................ - end subroutine progcld6 + end subroutine progcld_thompson_wsm6 !............................................ !mz @@ -3322,8 +2362,9 @@ subroutine progcld_thompson & & uni_cld, lmfshal, lmfdeep2, cldcov, & & re_cloud,re_ice,re_snow, & & lwp_ex, iwp_ex, lwp_fc, iwp_fc, & - & dzlay, latdeg, julian, yearlen, gridkm, & - & clouds,clds,mtop,mbot,de_lgth,alpha & ! --- outputs: + & dzlay, gridkm, cldtot, cldcnv, & + & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs + & cld_reice,cld_rwp, cld_rerain,cld_swp, cld_resnow & & ) ! ================= subprogram documentation block ================ ! @@ -3374,21 +2415,16 @@ subroutine progcld_thompson & ! cldcov : layer cloud fraction (used when uni_cld=.true. ! ! ! ! output variables: ! -! clouds(IX,NLAY,NF_CLDS) : cloud profiles ! -! clouds(:,:,1) - layer total cloud fraction ! -! clouds(:,:,2) - layer cloud liq water path (g/m**2) ! -! clouds(:,:,3) - mean eff radius for liq cloud (micron) ! -! clouds(:,:,4) - layer cloud ice water path (g/m**2) ! -! clouds(:,:,5) - mean eff radius for ice cloud (micron) ! -! clouds(:,:,6) - layer rain drop water path not assigned ! -! clouds(:,:,7) - mean eff radius for rain drop (micron) ! -! clouds(:,:,8) - layer snow flake water path not assigned ! -! clouds(:,:,9) - mean eff radius for snow flake (micron) ! -! *** fu's scheme need to be normalized by snow density (g/m**3/1.0e6) ! -! clds (IX,5) : fraction of clouds for low, mid, hi, tot, bl ! -! mtop (IX,3) : vertical indices for low, mid, hi cloud tops ! -! mbot (IX,3) : vertical indices for low, mid, hi cloud bases ! -! de_lgth(ix) : clouds decorrelation length (km) ! +! cloud profiles: ! +! cld_frac (:,:) - layer total cloud fraction ! +! cld_lwp (:,:) - layer cloud liq water path (g/m**2) ! +! cld_reliq (:,:) - mean eff radius for liq cloud (micron) ! +! cld_iwp (:,:) - layer cloud ice water path (g/m**2) ! +! cld_reice (:,:) - mean eff radius for ice cloud (micron) ! +! cld_rwp (:,:) - layer rain drop water path not assigned ! +! cld_rerain(:,:) - mean eff radius for rain drop (micron) ! +! *** cld_swp (:,:) - layer snow flake water path not assigned ! +! cld_resnow(:,:) - mean eff radius for snow flake (micron) ! ! ! ! module variables: ! ! ivflip : control flag of vertical index direction ! @@ -3423,19 +2459,13 @@ subroutine progcld_thompson & real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & & slmsk + real(kind=kind_phys), dimension(:), intent(in) :: gridkm - real(kind=kind_phys), dimension(:), intent(in) :: latdeg, gridkm - real(kind=kind_phys), intent(in) :: julian - integer, intent(in) :: yearlen - -! --- outputs - real (kind=kind_phys), dimension(:,:,:), intent(out) :: clouds - - real (kind=kind_phys), dimension(:,:), intent(out) :: clds - real (kind=kind_phys), dimension(:), intent(out) :: de_lgth - real (kind=kind_phys), dimension(:,:), intent(out) :: alpha +! --- inputs/outputs - integer, dimension(:,:), intent(out) :: mtop,mbot + real (kind=kind_phys), dimension(:,:), intent(inout) :: & + & cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, & + & cld_rwp, cld_rerain, cld_swp, cld_resnow ! --- local variables: real (kind=kind_phys), dimension(IX,NLAY) :: cldtot, cldcnv, & @@ -3444,8 +2474,6 @@ subroutine progcld_thompson & real (kind=kind_phys), dimension(NLAY) :: cldfra1d, qv1d, & & qc1d, qi1d, qs1d, dz1d, p1d, t1d - real (kind=kind_phys) :: ptop1(IX,NK_CLDS+1), rxlat(ix) - real (kind=kind_phys) :: clwmin, tem1 real (kind=kind_phys) :: corr, xland, snow_mass_factor real (kind=kind_phys), parameter :: max_relh = 1.5 @@ -3458,14 +2486,6 @@ subroutine progcld_thompson & clwmin = 1.0E-9 - do nf=1,nf_clds - do k=1,nlay - do i=1,ix - clouds(i,k,nf) = 0.0 - enddo - enddo - enddo - do k = 1, NLAY do i = 1, IX cldtot(i,k) = 0.0 @@ -3481,23 +2501,6 @@ subroutine progcld_thompson & enddo enddo -!> - Find top pressure for each cloud domain for given latitude. -!! ptopc(k,i): top presure of each cld domain (k=1-4 are sfc,L,m,h; -!! i=1,2 are low-lat (<45 degree) and pole regions) - - do i =1, IX - rxlat(i) = abs( xlat(i) / con_pi ) ! if xlat in pi/2 -> -pi/2 range -! rxlat(i) = abs(0.5 - xlat(i)/con_pi) ! if xlat in 0 -> pi range - enddo - - do id = 1, 4 - tem1 = ptopc(id,2) - ptopc(id,1) - - do i =1, IX - ptop1(i,id) = ptopc(id,1) + tem1*max( 0.0, 4.0*rxlat(i)-1.0 ) - enddo - enddo - !> - Compute cloud liquid/ice condensate path in \f$ g/m^2 \f$ . !> - Since using Thompson MP, assume 1 percent of snow is actually in !! ice sizes. @@ -3598,15 +2601,15 @@ subroutine progcld_thompson & do k = 1, NLAY do i = 1, IX - clouds(i,k,1) = cldtot(i,k) - clouds(i,k,2) = cwp(i,k) - clouds(i,k,3) = rew(i,k) - clouds(i,k,4) = cip(i,k) - clouds(i,k,5) = rei(i,k) - clouds(i,k,6) = crp(i,k) - clouds(i,k,7) = rer(i,k) - clouds(i,k,8) = csp(i,k) - clouds(i,k,9) = res(i,k) + cld_frac(i,k) = cldtot(i,k) + cld_lwp(i,k) = cwp(i,k) + cld_reliq(i,k) = rew(i,k) + cld_iwp(i,k) = cip(i,k) + cld_reice(i,k) = rei(i,k) + cld_rwp(i,k) = crp(i,k) ! added for Thompson + cld_rerain(i,k) = rer(i,k) + cld_swp(i,k) = csp(i,k) ! added for Thompson + cld_resnow(i,k) = res(i,k) enddo enddo @@ -3626,56 +2629,6 @@ subroutine progcld_thompson & lwp_ex(i) = lwp_ex(i)*1.E-3 iwp_ex(i) = iwp_ex(i)*1.E-3 enddo - - ! Compute cloud decorrelation length - if (idcor == 1) then - call cmp_dcorr_lgth(ix, xlat, con_pi, de_lgth) - endif - if (idcor == 2) then - call cmp_dcorr_lgth(ix, latdeg, julian, yearlen, de_lgth) - endif - if (idcor == 0) then - de_lgth(:) = decorr_con - endif - - ! Call subroutine get_alpha_exp to define alpha parameter for exponential cloud overlap options - if ( iovr == 3 .or. iovr == 4 .or. iovr == 5) then - call get_alpha_exp(ix, nLay, dzlay, de_lgth, alpha) - else - de_lgth(:) = 0. - alpha(:,:) = 0. - endif - - ! Revise alpha for exponential-random cloud overlap - ! Decorrelate layers when a clear layer follows a cloudy layer to enforce - ! random correlation between non-adjacent blocks of cloudy layers - if (iovr == 5) then - do k = 2, nLay - do i = 1, ix - if (clouds(i,k,1) == 0.0 .and. clouds(i,k-1,1) > 0.0) then - alpha(i,k) = 0.0 - endif - enddo - enddo - endif - -!> - Call gethml() to compute low,mid,high,total, and boundary layer -!! cloud fractions and clouds top/bottom layer indices for low, mid, -!! and high clouds. -! --- compute low, mid, high, total, and boundary layer cloud fractions -! and clouds top/bottom layer indices for low, mid, and high clouds. -! The three cloud domain boundaries are defined by ptopc. The cloud -! overlapping method is defined by control flag 'iovr', which may -! be different for lw and sw radiation programs. - - call gethml & -! --- inputs: - & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, alpha, & - & IX,NLAY, & -! --- outputs: - & clds, mtop, mbot & - & ) - ! return @@ -3688,58 +2641,20 @@ end subroutine progcld_thompson !> \ingroup module_radiation_clouds !> This subroutine computes cloud related quantities using !! for unified cloud microphysics scheme. -!!\param plyr (IX,NLAY), model layer mean pressure in mb (100Pa) -!!\param plvl (IX,NLP1), model level pressure in mb (100Pa) -!!\param tlyr (IX,NLAY), model layer mean temperature in K -!!\param tvly (IX,NLAY), model layer virtual temperature in K -!!\param ccnd (IX,NLAY), layer cloud condensate amount -!!\param ncnd number of layer cloud condensate types -!!\param xlat (IX), grid latitude in radians, default to pi/2 -> -!! -pi/2 range, otherwise see in-line comment -!!\param xlon (IX), grid longitude in radians (not used) -!!\param slmsk (IX), sea/land mask array (sea:0,land:1,sea-ice:2) -!!\param dz (IX,NLAY), layer thickness (km) -!!\param delp (IX,NLAY), model layer pressure thickness in mb (100Pa) -!!\param IX horizontal dimention -!!\param NLAY,NLP1 vertical layer/level dimensions -!!\param cldtot unified cloud fraction from moist physics -!!\param effrl (IX,NLAY), effective radius for liquid water -!!\param effri (IX,NLAY), effective radius for ice water -!!\param effrr (IX,NLAY), effective radius for rain water -!!\param effrs (IX,NLAY), effective radius for snow water -!!\param effr_in logical - if .true. use input effective radii -!!\param dzlay(ix,nlay) distance between model layer centers -!!\param latdeg(ix) latitude (in degrees 90 -> -90) -!!\param julian day of the year (fractional julian day) -!!\param yearlen current length of the year (365/366 days) -!!\param clouds (IX,NLAY,NF_CLDS), cloud profiles -!!\n (:,:,1) - layer total cloud fraction -!!\n (:,:,2) - layer cloud liq water path \f$(g/m^2)\f$ -!!\n (:,:,3) - mean eff radius for liq cloud (micron) -!!\n (:,:,4) - layer cloud ice water path \f$(g/m^2)\f$ -!!\n (:,:,5) - mean eff radius for ice cloud (micron) -!!\n (:,:,6) - layer rain drop water path -!!\n (:,:,7) - mean eff radius for rain drop (micron) -!!\n (:,:,8) - layer snow flake water path -!!\n (:,:,9) - mean eff radius for snow flake (micron) -!!\param clds (IX,5), fraction of clouds for low, mid, hi, tot, bl -!!\param mtop (IX,3), vertical indices for low, mid, hi cloud tops -!!\param mbot (IX,3), vertical indices for low, mid, hi cloud bases -!!\param de_lgth (IX), clouds decorrelation length (km) -!!\param alpha (IX,NLAY), alpha decorrelation parameter -!>\section gen_progclduni progclduni General Algorithm +!>\section progclduni General Algorithm !> @{ subroutine progclduni & & ( plyr,plvl,tlyr,tvly,ccnd,ncnd, & ! --- inputs: & xlat,xlon,slmsk,dz,delp, IX, NLAY, NLP1, cldtot, & & effrl,effri,effrr,effrs,effr_in, & - & dzlay, latdeg, julian, yearlen, & - & clouds,clds,mtop,mbot,de_lgth,alpha & ! --- outputs: + & dzlay, cldtot1, cldcnv, & + & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs + & cld_reice,cld_rwp, cld_rerain,cld_swp, cld_resnow & & ) ! ================= subprogram documentation block ================ ! ! ! -! subprogram: progclduni computes cloud related quantities using ! +! subprogram: progclduni computes cloud related quantities using ! ! for unified cloud microphysics scheme. ! ! ! ! abstract: this program computes cloud fractions from cloud ! @@ -3748,8 +2663,11 @@ subroutine progclduni & ! fractions and the vertical indices of low, mid, and high cloud ! ! top and base. the three vertical cloud domains are set up in the ! ! initial subroutine "cld_init". ! +! This program is written by Moorthi ! +! to represent unified cloud across all physics while ! +! using SHOC+MG2/3+convection (RAS or SAS or CSAW) ! ! ! -! usage: call progclduni ! +! usage: call progclduni ! ! ! ! subprograms called: gethml ! ! ! @@ -3783,21 +2701,18 @@ subroutine progclduni & ! dz (ix,nlay) : layer thickness (km) ! ! delp (ix,nlay) : model layer pressure thickness in mb (100Pa) ! ! dzlay(ix,nlay) : thickness between model layer centers (km) ! -! latdeg(ix) : latitude (in degrees 90 -> -90) ! -! julian : day of the year (fractional julian day) ! -! yearlen : current length of the year (365/366 days) ! ! ! ! output variables: ! -! clouds(IX,NLAY,NF_CLDS) : cloud profiles ! -! clouds(:,:,1) - layer total cloud fraction ! -! clouds(:,:,2) - layer cloud liq water path (g/m**2) ! -! clouds(:,:,3) - mean eff radius for liq cloud (micron) ! -! clouds(:,:,4) - layer cloud ice water path (g/m**2) ! -! clouds(:,:,5) - mean eff radius for ice cloud (micron) ! -! clouds(:,:,6) - layer rain drop water path not assigned ! -! clouds(:,:,7) - mean eff radius for rain drop (micron) ! -! *** clouds(:,:,8) - layer snow flake water path not assigned ! -! clouds(:,:,9) - mean eff radius for snow flake (micron) ! +! cloud profiles: ! +! cld_frac (:,:) - layer total cloud fraction ! +! cld_lwp (:,:) - layer cloud liq water path (g/m**2) ! +! cld_reliq (:,:) - mean eff radius for liq cloud (micron) ! +! cld_iwp (:,:) - layer cloud ice water path (g/m**2) ! +! cld_reice (:,:) - mean eff radius for ice cloud (micron) ! +! cld_rwp (:,:) - layer rain drop water path not assigned ! +! cld_rerain(:,:) - mean eff radius for rain drop (micron) ! +! *** cld_swp (:,:) - layer snow flake water path not assigned ! +! cld_resnow(:,:) - mean eff radius for snow flake (micron) ! ! *** fu's scheme need to be normalized by snow density (g/m**3/1.0e6) ! ! clds (IX,5) : fraction of clouds for low, mid, hi, tot, bl ! ! mtop (IX,3) : vertical indices for low, mid, hi cloud tops ! @@ -3834,42 +2749,25 @@ subroutine progclduni & real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & & slmsk - real(kind=kind_phys), dimension(:), intent(in) :: latdeg - real(kind=kind_phys), intent(in) :: julian - integer, intent(in) :: yearlen - -! --- outputs - real (kind=kind_phys), dimension(:,:,:), intent(out) :: clouds - - real (kind=kind_phys), dimension(:,:), intent(out) :: clds - - real (kind=kind_phys), dimension(:), intent(out) :: de_lgth + real (kind=kind_phys), dimension(:,:), intent(inout) :: cldtot1 - real (kind=kind_phys), dimension(:,:), intent(out) :: alpha +! --- inputs/outputs - integer, dimension(:,:), intent(out) :: mtop,mbot + real (kind=kind_phys), dimension(:,:), intent(inout) :: & + & cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, & + & cld_rwp, cld_rerain, cld_swp, cld_resnow ! --- local variables: real (kind=kind_phys), dimension(IX,NLAY) :: cldcnv, cwp, cip, & & crp, csp, rew, rei, res, rer real (kind=kind_phys), dimension(IX,NLAY,ncnd) :: cndf - real (kind=kind_phys) :: ptop1(IX,NK_CLDS+1), rxlat(ix) - real (kind=kind_phys) :: tem1, tem2, tem3 integer :: i, k, id, nf, n ! !===> ... begin here -! -! do nf=1,nf_clds -! do k=1,nlay -! do i=1,ix -! clouds(i,k,nf) = 0.0 -! enddo -! enddo -! enddo ! do k = 1, NLAY do i = 1, IX @@ -4006,87 +2904,26 @@ subroutine progclduni & enddo enddo endif -! + do k = 1, NLAY do i = 1, IX - clouds(i,k,1) = cldtot(i,k) - clouds(i,k,2) = cwp(i,k) - clouds(i,k,3) = rew(i,k) - clouds(i,k,4) = cip(i,k) - clouds(i,k,5) = rei(i,k) - clouds(i,k,6) = crp(i,k) - clouds(i,k,7) = rer(i,k) - clouds(i,k,8) = csp(i,k) - clouds(i,k,9) = res(i,k) + cldtot1(i,k) = cldtot(i,k) enddo enddo - -!> -# Find top pressure for each cloud domain for given latitude. -! ptopc(k,i): top presure of each cld domain (k=1-4 are sfc,L,m,h; -! --- i=1,2 are low-lat (<45 degree) and pole regions) - - do i =1, IX - rxlat(i) = abs( xlat(i) / con_pi ) ! if xlat in pi/2 -> -pi/2 range -! rxlat(i) = abs(0.5 - xlat(i)/con_pi) ! if xlat in 0 -> pi range - enddo - - do id = 1, 4 - tem1 = ptopc(id,2) - ptopc(id,1) - do i =1, IX - ptop1(i,id) = ptopc(id,1) + tem1*max( 0.0, 4.0*rxlat(i)-1.0 ) +! + do k = 1, NLAY + do i = 1, IX + cld_frac(i,k) = cldtot(i,k) + cld_lwp(i,k) = cwp(i,k) + cld_reliq(i,k) = rew(i,k) + cld_iwp(i,k) = cip(i,k) + cld_reice(i,k) = rei(i,k) + cld_rwp(i,k) = crp(i,k) ! added for Thompson + cld_rerain(i,k) = rer(i,k) + cld_swp(i,k) = csp(i,k) ! added for Thompson + cld_resnow(i,k) = res(i,k) enddo enddo - - ! Compute cloud decorrelation length - if (idcor == 1) then - call cmp_dcorr_lgth(ix, xlat, con_pi, de_lgth) - endif - if (idcor == 2) then - call cmp_dcorr_lgth(ix, latdeg, julian, yearlen, de_lgth) - endif - if (idcor == 0) then - de_lgth(:) = decorr_con - endif - - ! Call subroutine get_alpha_exp to define alpha parameter for exponential cloud overlap options - if (iovr == 3 .or. iovr == 4 .or. iovr == 5) then - call get_alpha_exp(ix, nLay, dzlay, de_lgth, alpha) - else - de_lgth(:) = 0. - alpha(:,:) = 0. - endif - - ! Revise alpha for exponential-random cloud overlap - ! Decorrelate layers when a clear layer follows a cloudy layer to enforce - ! random correlation between non-adjacent blocks of cloudy layers - if (iovr == 5) then - do k = 2, nLay - do i = 1, ix - if (clouds(i,k,1) == 0.0 .and. clouds(i,k-1,1) > 0.0) then - alpha(i,k) = 0.0 - endif - enddo - enddo - endif - -!> - Call gethml() to compute low,mid,high,total, and boundary layer -!! cloud fractions and clouds top/bottom layer indices for low, mid, -!! and high clouds. -! --- compute low, mid, high, total, and boundary layer cloud fractions -! and clouds top/bottom layer indices for low, mid, and high clouds. -! The three cloud domain boundaries are defined by ptopc. The cloud -! overlapping method is defined by control flag 'iovr', which may -! be different for lw and sw radiation programs. - - call gethml & -! --- inputs: - & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, alpha, & - & IX,NLAY, & -! --- outputs: - & clds, mtop, mbot & - & ) - - ! return !................................... @@ -4118,7 +2955,8 @@ end subroutine progclduni !! @{ subroutine gethml & & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, alpha, & ! --- inputs: - & IX, NLAY, & + & IX, NLAY, iovr_rand, iovr_maxrand, iovr_max, & + & iovr_dcorr, iovr_exp, iovr_exprand, & & clds, mtop, mbot & ! --- outputs: & ) @@ -4178,6 +3016,13 @@ subroutine gethml & ! --- inputs: integer, intent(in) :: IX, NLAY + integer, intent(in) :: & + & iovr_rand, ! Flag for random cloud overlap method + & iovr_maxrand, ! Flag for maximum-random cloud overlap method + & iovr_max, ! Flag for maximum cloud overlap method + & iovr_dcorr, ! Flag for decorrelation-length cloud overlap method + & iovr_exp, ! Flag for exponential cloud overlap method + & iovr_exprand ! Flag for exponential-random cloud overlap method real (kind=kind_phys), dimension(:,:), intent(in) :: plyr, ptop1, & & cldtot, cldcnv, dz @@ -4222,7 +3067,7 @@ subroutine gethml & kinc = 1 endif ! end_if_ivflip - if ( iovr == 0 ) then ! random overlap + if ( iovr == iovr_rand ) then ! random overlap do k = kstr, kend, kinc do i = 1, IX @@ -4241,7 +3086,7 @@ subroutine gethml & clds(i,4) = 1.0 - cl1(i) ! save total cloud enddo - elseif ( iovr == 1 ) then ! max/ran overlap + elseif ( iovr == iovr_maxrand ) then ! max/ran overlap do k = kstr, kend, kinc do i = 1, IX @@ -4265,7 +3110,7 @@ subroutine gethml & clds(i,4) = 1.0 - cl1(i) * cl2(i) ! save total cloud enddo - elseif ( iovr == 2 ) then ! maximum overlap all levels + elseif ( iovr == iovr_max ) then ! maximum overlap all levels cl1(:) = 0.0 @@ -4286,7 +3131,7 @@ subroutine gethml & clds(i,4) = cl1(i) ! save total cloud enddo - elseif ( iovr == 3 ) then ! random if clear-layer divided, + elseif ( iovr == iovr_dcorr ) then ! random if clear-layer divided, ! otherwise de-corrlength method do i = 1, ix dz1(i) = - dz(i,kstr) @@ -4318,7 +3163,7 @@ subroutine gethml & clds(i,4) = 1.0 - cl1(i) * cl2(i) ! save total cloud enddo - elseif ( iovr == 4 .or. iovr == 5 ) then ! exponential overlap (iovr=4), or + elseif ( iovr == iovr_exp .or. iovr == iovr_exprand ) then ! exponential overlap (iovr=4), or ! exponential-random (iovr=5); ! distinction defined by alpha @@ -4399,7 +3244,7 @@ subroutine gethml & if (kth2(i) == 0) kbt2(i) = k kth2(i) = kth2(i) + 1 - if ( iovr == 0 ) then + if ( iovr == iovr_rand ) then cl2(i) = cl2(i) + ccur - cl2(i)*ccur else cl2(i) = max( cl2(i), ccur ) @@ -4481,7 +3326,7 @@ subroutine gethml & if (kth2(i) == 0) kbt2(i) = k kth2(i) = kth2(i) + 1 - if ( iovr == 0 ) then + if ( iovr == iovr_rand ) then cl2(i) = cl2(i) + ccur - cl2(i)*ccur else cl2(i) = max( cl2(i), ccur ) @@ -4967,6 +3812,154 @@ SUBROUTINE adjust_cloudFinal(cfr, qc, qi, Rho,dz, kts,kte) END SUBROUTINE adjust_cloudFinal + subroutine cloud_fraction_XuRandall & + & ( IX, NLAY, plyr, clwf, rhly, qstl, & ! --- inputs + & cldtot ) & ! --- outputs + +! --- inputs: + integer, intent(in) :: IX, NLAY + real (kind=kind_phys), dimension(:,:), intent(in) :: plyr, clwf, & + & rhly, qstl + +! --- outputs + real (kind=kind_phys), dimension(:,:), intent(inout) :: cldtot + +! --- local variables: + + real (kind=kind_phys) :: clwmin, clwm, clwt, onemrh, value, & + & tem1, tem2 + integer :: i, k + +!> - Compute layer cloud fraction. + + clwmin = 0.0 + do k = 1, NLAY + do i = 1, IX + clwt = 1.0e-6 * (plyr(i,k)*0.001) +! clwt = 2.0e-6 * (plyr(i,k)*0.001) + + if (clwf(i,k) > clwt) then + + onemrh= max( 1.e-10, 1.0-rhly(i,k) ) + clwm = clwmin / max( 0.01, plyr(i,k)*0.001 ) + + tem1 = min(max(sqrt(sqrt(onemrh*qstl(i,k))),0.0001),1.0) + tem1 = 2000.0 / tem1 + +! tem1 = 1000.0 / tem1 + + value = max( min( tem1*(clwf(i,k)-clwm), 50.0 ), 0.0 ) + tem2 = sqrt( sqrt(rhly(i,k)) ) + + cldtot(i,k) = max( tem2*(1.0-exp(-value)), 0.0 ) + endif + enddo + enddo + + end subroutine cloud_fraction_XuRandall + + subroutine cloud_fraction_mass_flx_1 & + & ( IX, NLAY, lmfdeep2, xrc3, plyr, clwf, rhly, qstl, & ! --- inputs + & cldtot ) & ! --- outputs + +! --- inputs: + integer, intent(in) :: IX, NLAY + real (kind=kind_phys), intent(in) :: xrc3 + real (kind=kind_phys), dimension(:,:), intent(in) :: plyr, clwf, & + & rhly, qstl + logical, intent(in) :: lmfdeep2 + +! --- outputs + real (kind=kind_phys), dimension(:,:), intent(inout) :: cldtot + +! --- local variables: + + real (kind=kind_phys) :: clwmin, clwm, clwt, onemrh, value, & + & tem1, tem2 + integer :: i, k + +!> - Compute layer cloud fraction. + + clwmin = 0.0 + do k = 1, NLAY + do i = 1, IX + clwt = 1.0e-6 * (plyr(i,k)*0.001) +! clwt = 2.0e-6 * (plyr(i,k)*0.001) + + if (clwf(i,k) > clwt) then + onemrh= max( 1.e-10, 1.0-rhly(i,k) ) + clwm = clwmin / max( 0.01, plyr(i,k)*0.001 ) +! + tem1 = min(max((onemrh*qstl(i,k))**0.49,0.0001),1.0) !jhan + if (lmfdeep2) then + tem1 = xrc3 / tem1 + else + tem1 = 100.0 / tem1 + endif +! + value = max( min( tem1*(clwf(i,k)-clwm), 50.0 ), 0.0 ) + tem2 = sqrt( sqrt(rhly(i,k)) ) + + cldtot(i,k) = max( tem2*(1.0-exp(-value)), 0.0 ) + endif + enddo + enddo + + end subroutine cloud_fraction_mass_flx_1 + + subroutine cloud_fraction_mass_flx_2 & + & ( IX, NLAY, lmfdeep2, xrc3, plyr, clwf, rhly, qstl, & ! --- inputs + & cldtot ) & ! --- outputs + +! --- inputs: + integer, intent(in) :: IX, NLAY + real (kind=kind_phys), intent(in) :: xrc3 + real (kind=kind_phys), dimension(:,:), intent(in) :: plyr, clwf, & + & rhly, qstl + logical, intent(in) :: lmfdeep2 + +! --- outputs + real (kind=kind_phys), dimension(:,:), intent(inout) :: cldtot + +! --- local variables: + + real (kind=kind_phys) :: clwmin, clwm, clwt, onemrh, value, & + & tem1, tem2 + integer :: i, k + +!> - Compute layer cloud fraction. + + clwmin = 0.0 + do k = 1, NLAY-1 + do i = 1, IX + clwt = 1.0e-10 * (plyr(i,k)*0.001) + + if (clwf(i,k) > clwt) then + if(rhly(i,k) > 0.99) then + cldtot(i,k) = 1. + else + onemrh= max( 1.e-10, 1.0-rhly(i,k) ) + clwm = clwmin / max( 0.01, plyr(i,k)*0.001 ) + + tem1 = min(max((onemrh*qstl(i,k))**0.49,0.0001),1.0) !jhan + if (lmfdeep2) then + tem1 = xrc3 / tem1 + else + tem1 = 100.0 / tem1 + endif + + value = max( min( tem1*(clwf(i,k)-clwm), 50.0 ), 0.0 ) + tem2 = sqrt( sqrt(rhly(i,k)) ) + + cldtot(i,k) = max( tem2*(1.0-exp(-value)), 0.0 ) + endif + else + cldtot(i,k) = 0.0 + endif + enddo + enddo + + end subroutine cloud_fraction_mass_flx_2 !........................................! end module module_radiation_clouds !! @} diff --git a/physics/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/radlw_main.F90 b/physics/radlw_main.F90 index 95bc0b059..6d4f5750d 100644 --- a/physics/radlw_main.F90 +++ b/physics/radlw_main.F90 @@ -2082,7 +2082,7 @@ subroutine mcica_subcol & ! ! NOTE: The code below is identical for case (4) and (5) because the ! distinction in the vertical correlation between EXP and ER is already -! built into the specification of alpha (in subroutine get_alpha_exp). +! built into the specification of alpha (in subroutine get_alpha_exper). ! --- setup 2 sets of random numbers diff --git a/physics/radsw_main.F90 b/physics/radsw_main.F90 index d09f586a3..4067dd0ec 100644 --- a/physics/radsw_main.F90 +++ b/physics/radsw_main.F90 @@ -2197,7 +2197,7 @@ subroutine mcica_subcol & ! ! NOTE: The code below is identical for case (4) and (5) because the ! distinction in the vertical correlation between EXP and ER is already -! built into the specification of alpha (in subroutine get_alpha_exp). +! built into the specification of alpha (in subroutine get_alpha_exper). ! --- setup 2 sets of random numbers diff --git a/physics/rrtmg_sw_pre.F90 b/physics/rrtmg_sw_pre.F90 deleted file mode 100644 index 1c7d3d76b..000000000 --- a/physics/rrtmg_sw_pre.F90 +++ /dev/null @@ -1,59 +0,0 @@ -!>\file rrtmg_sw_pre.f90 - module rrtmg_sw_pre - contains - -!>\defgroup rrtmg_sw_pre GFS RRTMG scheme Pre -!! @{ - subroutine rrtmg_sw_pre_init () - end subroutine rrtmg_sw_pre_init - -!> \section arg_table_rrtmg_sw_pre_run Argument Table -!! \htmlinclude rrtmg_sw_pre_run.html -!! - subroutine rrtmg_sw_pre_run (im, lsswr, coszen, nday, idxday, errmsg, errflg) - - use machine, only: kind_phys - - implicit none - - integer, intent(in) :: im - logical, intent(in) :: lsswr - real(kind=kind_phys), dimension(:), intent(in) :: coszen - integer, intent(out) :: nday - integer, dimension(:), intent(out) :: idxday - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Local variables - integer :: i - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - -! --- ... start radiation calculations -! remember to set heating rate unit to k/sec! - -!> -# Start SW radiation calculations - if (lsswr) then -!> - Check for daytime points for SW radiation. - nday = 0 - idxday = 0 - do i = 1, IM - if (coszen(i) >= 0.0001) then - nday = nday + 1 - idxday(nday) = i - endif - enddo - else - nday = 0 - idxday = 0 - endif - - end subroutine rrtmg_sw_pre_run - - subroutine rrtmg_sw_pre_finalize () - end subroutine rrtmg_sw_pre_finalize - -!! @} - end module rrtmg_sw_pre diff --git a/physics/rrtmgp_sw_aerosol_optics.F90 b/physics/rrtmgp_aerosol_optics.F90 similarity index 74% rename from physics/rrtmgp_sw_aerosol_optics.F90 rename to physics/rrtmgp_aerosol_optics.F90 index afd039249..eb7797125 100644 --- a/physics/rrtmgp_sw_aerosol_optics.F90 +++ b/physics/rrtmgp_aerosol_optics.F90 @@ -1,7 +1,7 @@ -module rrtmgp_sw_aerosol_optics +module rrtmgp_aerosol_optics use machine, only: kind_phys use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp - use mo_optical_props, only: ty_optical_props_2str + use mo_optical_props, only: ty_optical_props_2str, ty_optical_props_1scl use radiation_tools, only: check_error_msg use rrtmgp_sw_gas_optics, only: sw_gas_props use rrtmgp_lw_gas_optics, only: lw_gas_props @@ -14,29 +14,24 @@ module rrtmgp_sw_aerosol_optics implicit none - public rrtmgp_sw_aerosol_optics_init, rrtmgp_sw_aerosol_optics_run, rrtmgp_sw_aerosol_optics_finalize + public rrtmgp_aerosol_optics_run contains ! ######################################################################################### - ! SUBROUTINE rrtmgp_sw_aerosol_optics_init() + ! SUBROUTINE rrtmgp_aerosol_optics_run() ! ######################################################################################### - subroutine rrtmgp_sw_aerosol_optics_init() - end subroutine rrtmgp_sw_aerosol_optics_init - - ! ######################################################################################### - ! SUBROUTINE rrtmgp_sw_aerosol_optics_run() - ! ######################################################################################### -!! \section arg_table_rrtmgp_sw_aerosol_optics_run -!! \htmlinclude rrtmgp_sw_aerosol_optics_run.html +!! \section arg_table_rrtmgp_aerosol_optics_run +!! \htmlinclude rrtmgp_aerosol_optics_run.html !! - subroutine rrtmgp_sw_aerosol_optics_run(doSWrad, nCol, nLev, nTracer, nTracerAer, nDay, & - idxday, p_lev, p_lay, p_lk, tv_lay, relhum, lsmask, tracer, aerfld, lon, lat, & - aerodp, sw_optical_props_aerosol, errmsg, errflg ) + subroutine rrtmgp_aerosol_optics_run(doSWrad, doLWrad, nCol, nLev, nTracer, nTracerAer, & + nDay, idxday, p_lev, p_lay, p_lk, tv_lay, relhum, lsmask, tracer, aerfld, lon, lat, & + aerodp, sw_optical_props_aerosol, lw_optical_props_aerosol, errmsg, errflg ) ! Inputs logical, intent(in) :: & - doSWrad ! Logical flag for shortwave radiation call + doSWrad, & ! Logical flag for shortwave radiation call + doLWrad ! Logical flag for longwave radiation call integer, intent(in) :: & nCol, & ! Number of horizontal grid points nDay, & ! Number of daylit points @@ -66,6 +61,8 @@ subroutine rrtmgp_sw_aerosol_optics_run(doSWrad, nCol, nLev, nTracer, nTracerAer aerodp ! Vertical integrated optical depth for various aerosol species type(ty_optical_props_2str),intent(out) :: & sw_optical_props_aerosol ! RRTMGP DDT: Longwave aerosol optical properties (tau) + type(ty_optical_props_1scl),intent(inout) :: & + lw_optical_props_aerosol ! RRTMGP DDT: Longwave aerosol optical properties (tau) integer, intent(out) :: & errflg ! CCPP error flag character(len=*), intent(out) :: & @@ -76,6 +73,7 @@ subroutine rrtmgp_sw_aerosol_optics_run(doSWrad, nCol, nLev, nTracer, nTracerAer aerosolslw ! real(kind_phys), dimension(nCol, nLev, sw_gas_props%get_nband(), NF_AESW) :: & aerosolssw, aerosolssw2 + integer :: iBand ! Initialize CCPP error handling variables errmsg = '' @@ -84,9 +82,10 @@ subroutine rrtmgp_sw_aerosol_optics_run(doSWrad, nCol, nLev, nTracer, nTracerAer if (.not. doSWrad) return ! Call module_radiation_aerosols::setaer(),to setup aerosols property profile - call setaer(p_lev/100., p_lay/100., p_lk, tv_lay, relhum, lsmask, tracer, aerfld, lon, lat, nCol, nLev, & + call setaer(p_lev*0.01, p_lay*0.01, p_lk, tv_lay, relhum, lsmask, tracer, aerfld, lon, lat, nCol, nLev, & nLev+1, .true., .true., aerosolssw2, aerosolslw, aerodp) + ! Shortwave if (nDay .gt. 0) then ! Store aerosol optical properties ! SW. @@ -100,7 +99,7 @@ subroutine rrtmgp_sw_aerosol_optics_run(doSWrad, nCol, nLev, nTracer, nTracerAer aerosolssw(1:nCol,:,2:sw_gas_props%get_nband(),3) = aerosolssw2(1:nCol,:,1:sw_gas_props%get_nband()-1,3) ! Allocate RRTMGP DDT: Aerosol optics [nCol,nlev,nBands] - call check_error_msg('rrtmgp_sw_aerosol_optics_run',sw_optical_props_aerosol%alloc_2str( & + call check_error_msg('rrtmgp_aerosol_optics_run',sw_optical_props_aerosol%alloc_2str( & nDay, nlev, sw_gas_props%get_band_lims_wavenumber())) ! Copy aerosol optical information to RRTMGP DDT @@ -109,11 +108,16 @@ subroutine rrtmgp_sw_aerosol_optics_run(doSWrad, nCol, nLev, nTracer, nTracerAer sw_optical_props_aerosol%g = aerosolssw(idxday(1:nday),:,:,3) endif - end subroutine rrtmgp_sw_aerosol_optics_run + ! Longwave + if (.not. doLWrad) return + lw_optical_props_aerosol%tau = aerosolslw(:,:,:,1) * (1. - aerosolslw(:,:,:,2)) + + lw_optical_props_aerosol%band_lims_wvn = lw_gas_props%get_band_lims_wavenumber() + do iBand=1,lw_gas_props%get_nband() + lw_optical_props_aerosol%band2gpt(1:2,iBand) = iBand + lw_optical_props_aerosol%gpt2band(iBand) = iBand + end do + + end subroutine rrtmgp_aerosol_optics_run - ! ######################################################################################### - ! SUBROUTINE rrtmgp_sw_aerosol_optics_finalize() - ! ######################################################################################### - subroutine rrtmgp_sw_aerosol_optics_finalize() - end subroutine rrtmgp_sw_aerosol_optics_finalize -end module rrtmgp_sw_aerosol_optics +end module rrtmgp_aerosol_optics diff --git a/physics/rrtmgp_sw_aerosol_optics.meta b/physics/rrtmgp_aerosol_optics.meta similarity index 90% rename from physics/rrtmgp_sw_aerosol_optics.meta rename to physics/rrtmgp_aerosol_optics.meta index 2abacd92a..cd7c77d4d 100644 --- a/physics/rrtmgp_sw_aerosol_optics.meta +++ b/physics/rrtmgp_aerosol_optics.meta @@ -1,11 +1,11 @@ [ccpp-table-properties] - name = rrtmgp_sw_aerosol_optics + name = rrtmgp_aerosol_optics type = scheme dependencies = iounitdef.f,machine.F,radiation_aerosols.f,radiation_tools.F90 ######################################################################## [ccpp-arg-table] - name = rrtmgp_sw_aerosol_optics_run + name = rrtmgp_aerosol_optics_run type = scheme [doSWrad] standard_name = flag_for_calling_shortwave_radiation @@ -14,6 +14,13 @@ dimensions = () type = logical intent = in +[doLWrad] + standard_name = flag_for_calling_longwave_radiation + long_name = logical flags for lw radiation calls + units = flag + dimensions = () + type = logical + intent = in [ncol] standard_name = horizontal_loop_extent long_name = horizontal dimension @@ -151,6 +158,13 @@ dimensions = () type = ty_optical_props_2str intent = out +[lw_optical_props_aerosol] + standard_name = longwave_optical_properties_for_aerosols + long_name = Fortran DDT containing RRTMGP optical properties + units = DDT + dimensions = () + type = ty_optical_props_1scl + intent = inout [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/rrtmgp_lw_aerosol_optics.F90 b/physics/rrtmgp_lw_aerosol_optics.F90 deleted file mode 100644 index de42db1cd..000000000 --- a/physics/rrtmgp_lw_aerosol_optics.F90 +++ /dev/null @@ -1,104 +0,0 @@ -module rrtmgp_lw_aerosol_optics - use machine, only: kind_phys - use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp - use mo_optical_props, only: ty_optical_props_1scl - use radiation_tools, only: check_error_msg - use rrtmgp_sw_gas_optics, only: sw_gas_props - use rrtmgp_lw_gas_optics, only: lw_gas_props - use module_radiation_aerosols, only: & - NF_AESW, & ! Number of optical-fields in SW output (3=tau+g+omega) - NF_AELW, & ! Number of optical-fields in LW output (3=tau+g+omega) - setaer, & ! Routine to compute aerosol radiative properties (tau,g,omega) - NSPC1 ! Number of species for vertically integrated aerosol optical-depth - use netcdf - - implicit none - - public rrtmgp_lw_aerosol_optics_init, rrtmgp_lw_aerosol_optics_run, rrtmgp_lw_aerosol_optics_finalize - -contains - - ! ######################################################################################### - ! SUBROUTINE rrtmgp_lw_aerosol_optics_init() - ! ######################################################################################### - subroutine rrtmgp_lw_aerosol_optics_init() - end subroutine rrtmgp_lw_aerosol_optics_init - - ! ######################################################################################### - ! SUBROUTINE rrtmgp_lw_aerosol_optics_run() - ! ######################################################################################### -!! \section arg_table_rrtmgp_lw_aerosol_optics_run -!! \htmlinclude rrtmgp_lw_aerosol_optics.html -!! - subroutine rrtmgp_lw_aerosol_optics_run(doLWrad, nCol, nLev, nspc, nTracer, nTracerAer, & - p_lev, p_lay, p_lk, tv_lay, relhum, lsmask, tracer, aerfld, lon, lat, & - lw_optical_props_aerosol, errmsg, errflg) - - ! Inputs - logical, intent(in) :: & - doLWrad ! Logical flag for longwave radiation call - integer, intent(in) :: & - nCol, & ! Number of horizontal grid points - nLev, & ! Number of vertical layers - nspc, & ! Number of aerosol optical-depths - nTracer, & ! Number of tracers - nTracerAer ! Number of aerosol tracers - real(kind_phys), dimension(:), intent(in) :: & - lon, & ! Longitude - lat, & ! Latitude - lsmask ! Land/sea/sea-ice mask - real(kind_phys), dimension(:,:),intent(in) :: & - p_lay, & ! Pressure @ layer-centers (Pa) - tv_lay, & ! Virtual-temperature @ layer-centers (K) - relhum, & ! Relative-humidity @ layer-centers - p_lk ! Exner function @ layer-centers (1) - real(kind_phys), dimension(:,:, :),intent(in) :: & - tracer ! trace gas concentrations - real(kind_phys), dimension(:,:, :),intent(in) :: & - aerfld ! aerosol input concentrations - real(kind_phys), dimension(:,:),intent(in) :: & - p_lev ! Pressure @ layer-interfaces (Pa) - - ! Outputs - type(ty_optical_props_1scl),intent(inout) :: & - lw_optical_props_aerosol ! RRTMGP DDT: Longwave aerosol optical properties (tau) - integer, intent(out) :: & - errflg ! CCPP error flag - character(len=*), intent(out) :: & - errmsg ! CCPP error message - - ! Local variables - real(kind_phys), dimension(nCol, nLev, lw_gas_props%get_nband(), NF_AELW) :: & - aerosolslw ! - real(kind_phys), dimension(nCol, nLev, sw_gas_props%get_nband(), NF_AESW) :: & - aerosolssw - real(kind_phys), dimension(nCol,nspc) :: aerodp - integer :: iBand - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (.not. doLWrad) return - - ! Call module_radiation_aerosols::setaer(),to setup aerosols property profile - call setaer(p_lev/100., p_lay/100., p_lk, tv_lay, relhum, lsmask, tracer, aerfld, lon, lat, ncol, nLev, & - nLev+1, .true., .true., aerosolssw, aerosolslw, aerodp) - - ! Copy aerosol optical information to RRTMGP DDT - lw_optical_props_aerosol%tau = aerosolslw(:,:,:,1) * (1. - aerosolslw(:,:,:,2)) - - lw_optical_props_aerosol%band_lims_wvn = lw_gas_props%get_band_lims_wavenumber() - do iBand=1,lw_gas_props%get_nband() - lw_optical_props_aerosol%band2gpt(1:2,iBand) = iBand - lw_optical_props_aerosol%gpt2band(iBand) = iBand - end do - - end subroutine rrtmgp_lw_aerosol_optics_run - - ! ######################################################################################### - ! SUBROUTINE rrtmgp_lw_aerosol_optics_finalize() - ! ######################################################################################### - subroutine rrtmgp_lw_aerosol_optics_finalize() - end subroutine rrtmgp_lw_aerosol_optics_finalize -end module rrtmgp_lw_aerosol_optics diff --git a/physics/rrtmgp_lw_aerosol_optics.meta b/physics/rrtmgp_lw_aerosol_optics.meta deleted file mode 100644 index 165051409..000000000 --- a/physics/rrtmgp_lw_aerosol_optics.meta +++ /dev/null @@ -1,153 +0,0 @@ -[ccpp-table-properties] - name = rrtmgp_lw_aerosol_optics - type = scheme - dependencies = iounitdef.f,machine.F,radiation_aerosols.f,radiation_tools.F90 - -######################################################################## -[ccpp-arg-table] - name = rrtmgp_lw_aerosol_optics_run - type = scheme -[doLWrad] - standard_name = flag_for_calling_longwave_radiation - long_name = logical flags for lw radiation calls - units = flag - dimensions = () - type = logical - intent = in -[ncol] - standard_name = horizontal_loop_extent - long_name = horizontal dimension - units = count - dimensions = () - type = integer - intent = in -[nLev] - standard_name = vertical_layer_dimension - long_name = number of vertical levels - units = count - dimensions = () - type = integer - intent = in -[nspc] - standard_name = number_of_species_for_aerosol_optical_depth - long_name = number of species for output aerosol optical depth plus total - units = count - dimensions = () - type = integer - intent = in -[nTracer] - standard_name = number_of_tracers - long_name = number of tracers - units = count - dimensions = () - type = integer - intent = in -[nTracerAer] - standard_name = number_of_aerosol_tracers_MG - long_name = number of aerosol tracers for Morrison Gettelman MP - units = count - dimensions = () - type = integer - intent = in -[p_lev] - standard_name = air_pressure_at_interface_for_RRTMGP - long_name = air pressure at vertical interface for radiation calculation - units = Pa - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = in -[p_lay] - standard_name = air_pressure_at_layer_for_RRTMGP - long_name = air pressure at vertical layer for radiation calculation - units = Pa - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[p_lk] - standard_name = dimensionless_exner_function - long_name = dimensionless Exner function at model layer centers - units = none - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[tv_lay] - standard_name = virtual_temperature - long_name = layer virtual temperature - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[relhum] - standard_name = relative_humidity - long_name = layer relative humidity - units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[lsmask] - standard_name = area_type - long_name = landmask: sea/land/ice=0/1/2 - units = flag - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[tracer] - standard_name = chemical_tracers - long_name = chemical tracers - units = g g-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = in -[aerfld] - standard_name = mass_number_concentration_of_aerosol_from_gocart_climatology - long_name = GOCART aerosol climatology number concentration - units = kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_aerosol_tracers_MG) - type = real - kind = kind_phys - intent = in -[lon] - standard_name = longitude - long_name = longitude - units = radian - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[lat] - standard_name = latitude - long_name = latitude - units = radian - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[lw_optical_props_aerosol] - standard_name = longwave_optical_properties_for_aerosols - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_1scl - intent = inout -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out diff --git a/physics/rrtmgp_lw_cloud_optics.F90 b/physics/rrtmgp_lw_cloud_optics.F90 index 5ddcec078..835261071 100644 --- a/physics/rrtmgp_lw_cloud_optics.F90 +++ b/physics/rrtmgp_lw_cloud_optics.F90 @@ -383,10 +383,13 @@ end subroutine rrtmgp_lw_cloud_optics_init !! \htmlinclude rrtmgp_lw_cloud_optics.html !! subroutine rrtmgp_lw_cloud_optics_run(doLWrad, doG_cldoptics, icliq_lw, icice_lw, & - doGP_cldoptics_PADE, doGP_cldoptics_LUT, doGP_lwscat, nCol, nLev, nbndsGPlw, & - p_lay, cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, & - cld_rwp, cld_rerain, precip_frac, lon, lat, cldtaulw, & - lw_optical_props_cloudsByBand, lw_optical_props_precipByBand, errmsg, errflg) + doGP_cldoptics_PADE, doGP_cldoptics_LUT, doGP_lwscat, do_mynnedmf, imfdeepcnv, & + imfdeepcnv_gf, imfdeepcnv_samf, nCol, nLev, nbndsGPlw , p_lay, cld_frac, cld_lwp, & + cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, cld_rerain, & + precip_frac, cld_cnv_lwp, cld_cnv_reliq, cld_cnv_iwp, cld_cnv_reice, cld_pbl_lwp, & + cld_pbl_reliq, cld_pbl_iwp, cld_pbl_reice, lon, lat, cldtaulw, & + lw_optical_props_cloudsByBand, lw_optical_props_cnvcloudsByBand, & + lw_optical_props_MYNNcloudsByBand, lw_optical_props_precipByBand, errmsg, errflg) ! Inputs logical, intent(in) :: & @@ -394,17 +397,21 @@ subroutine rrtmgp_lw_cloud_optics_run(doLWrad, doG_cldoptics, icliq_lw, icice_lw doG_cldoptics, & ! Use legacy RRTMG cloud-optics? doGP_cldoptics_PADE, & ! Use RRTMGP cloud-optics: PADE approximation? doGP_cldoptics_LUT, & ! Use RRTMGP cloud-optics: LUTs? - doGP_lwscat ! Include scattering in LW cloud-optics? + doGP_lwscat, & ! Include scattering in LW cloud-optics? + do_mynnedmf ! integer, intent(in) :: & - nbndsGPlw, & ! Number of longwave bands + nbndsGPlw, & ! nCol, & ! Number of horizontal gridpoints nLev, & ! Number of vertical levels icliq_lw, & ! Choice of treatment of liquid cloud optical properties (RRTMG legacy) - icice_lw ! Choice of treatment of ice cloud optical properties (RRTMG legacy) - real(kind_phys), dimension(nCol), intent(in) :: & + icice_lw, & ! Choice of treatment of ice cloud optical properties (RRTMG legacy) + imfdeepcnv, & ! + imfdeepcnv_gf, & ! + imfdeepcnv_samf ! + real(kind_phys), dimension(:), intent(in) :: & lon, & ! Longitude lat ! Latitude - real(kind_phys), dimension(ncol,nLev),intent(in) :: & + real(kind_phys), dimension(:,:),intent(in) :: & p_lay, & ! Layer pressure (Pa) cld_frac, & ! Total cloud fraction by layer cld_lwp, & ! Cloud liquid water path @@ -415,7 +422,15 @@ subroutine rrtmgp_lw_cloud_optics_run(doLWrad, doG_cldoptics, icliq_lw, icice_lw cld_resnow, & ! Cloud snow effective radius cld_rwp, & ! Cloud rain water path cld_rerain, & ! Cloud rain effective radius - precip_frac ! Precipitation fraction by layer. + precip_frac, & ! Precipitation fraction by layer. + cld_cnv_lwp, & ! Water path for convective liquid cloud-particles (microns) + cld_cnv_reliq, & ! Effective radius for convective liquid cloud-particles (microns) + cld_cnv_iwp, & ! Water path for convective ice cloud-particles (microns) + cld_cnv_reice, & ! Effective radius for convective ice cloud-particles (microns) + cld_pbl_lwp, & ! Water path for SGS PBL liquid cloud-particles + cld_pbl_reliq, & ! Effective radius for SGS PBL liquid cloud-particles + cld_pbl_iwp, & ! Water path for SGS PBL ice cloud-particles + cld_pbl_reice ! Effective radius for SGS PBL ice cloud-particles ! Outputs character(len=*), intent(out) :: & @@ -423,9 +438,11 @@ subroutine rrtmgp_lw_cloud_optics_run(doLWrad, doG_cldoptics, icliq_lw, icice_lw integer, intent(out) :: & errflg ! CCPP error flag type(ty_optical_props_2str),intent(inout) :: & - lw_optical_props_cloudsByBand, & ! RRTMGP DDT: Longwave optical properties in each band (clouds) - lw_optical_props_precipByBand ! RRTMGP DDT: Longwave optical properties in each band (precipitation) - real(kind_phys), dimension(ncol,nLev), intent(inout) :: & + lw_optical_props_cloudsByBand, & ! RRTMGP DDT: Longwave optical properties in each band (clouds) + lw_optical_props_cnvcloudsByBand, & ! RRTMGP DDT: Longwave optical properties in each band (convective cloud) + lw_optical_props_MYNNcloudsByBand, & ! RRTMGP DDT: Longwave optical properties in each band (MYNN-PBL cloud) + lw_optical_props_precipByBand ! RRTMGP DDT: Longwave optical properties in each band (precipitation) + real(kind_phys), dimension(:,:), intent(inout) :: & cldtaulw ! Approx 10.mu band layer cloud optical depth ! Local variables @@ -444,27 +461,60 @@ subroutine rrtmgp_lw_cloud_optics_run(doLWrad, doG_cldoptics, icliq_lw, icice_lw if (.not. doLWrad) return - lw_optical_props_cloudsByBand%band_lims_wvn = lw_gas_props%get_band_lims_wavenumber() - lw_optical_props_precipByBand%band_lims_wvn = lw_gas_props%get_band_lims_wavenumber() - do iBand=1,lw_gas_props%get_nband() - lw_optical_props_cloudsByBand%band2gpt(1:2,iBand) = iBand - lw_optical_props_cloudsByBand%band2gpt(1:2,iBand) = iBand - lw_optical_props_precipByBand%gpt2band(iBand) = iBand - lw_optical_props_precipByBand%gpt2band(iBand) = iBand - end do - ! Compute cloud-optics for RTE. if (doGP_cldoptics_PADE .or. doGP_cldoptics_LUT) then - ! i) RRTMGP cloud-optics. - call check_error_msg('rrtmgp_lw_cloud_optics_run',lw_cloud_props%cloud_optics(& - cld_lwp, & ! IN - Cloud liquid water path (g/m2) - cld_iwp, & ! IN - Cloud ice water path (g/m2) - cld_reliq, & ! IN - Cloud liquid effective radius (microns) - cld_reice, & ! IN - Cloud ice effective radius (microns) - lw_optical_props_cloudsByBand)) ! OUT - RRTMGP DDT containing cloud radiative properties - ! in each band - ! Add in rain and snow(+groupel) + ! i) Cloud-optics. + lw_optical_props_cloudsByBand%band_lims_wvn = lw_gas_props%get_band_lims_wavenumber() + do iBand=1,lw_gas_props%get_nband() + lw_optical_props_cloudsByBand%band2gpt(1:2,iBand) = iBand + lw_optical_props_cloudsByBand%gpt2band(iBand) = iBand + end do + call check_error_msg('rrtmgp_lw_cloud_optics_run - clouds',lw_cloud_props%cloud_optics(& + cld_lwp, & ! IN - Cloud liquid water path (g/m2) + cld_iwp, & ! IN - Cloud ice water path (g/m2) + cld_reliq, & ! IN - Cloud liquid effective radius (microns) + cld_reice, & ! IN - Cloud ice effective radius (microns) + lw_optical_props_cloudsByBand)) ! OUT - RRTMGP DDT containing cloud radiative properties + ! in each band + ! ii) Convective cloud-optics + if (imfdeepcnv == imfdeepcnv_samf .or. imfdeepcnv == imfdeepcnv_gf) then + lw_optical_props_cnvcloudsByBand%band_lims_wvn = lw_gas_props%get_band_lims_wavenumber() + do iBand=1,lw_gas_props%get_nband() + lw_optical_props_cnvcloudsByBand%band2gpt(1:2,iBand) = iBand + lw_optical_props_cnvcloudsByBand%gpt2band(iBand) = iBand + end do + call check_error_msg('rrtmgp_lw_cnvcloud_optics_run - convective cloud',lw_cloud_props%cloud_optics(& + cld_cnv_lwp, & ! IN - Convective cloud liquid water path (g/m2) + cld_cnv_iwp, & ! IN - Convective cloud ice water path (g/m2) + cld_cnv_reliq, & ! IN - Convective cloud liquid effective radius (microns) + cld_cnv_reice, & ! IN - Convective cloud ice effective radius (microns) + lw_optical_props_cnvcloudsByBand)) ! OUT - RRTMGP DDT containing convective cloud radiative properties + ! in each band + endif + + ! iii) MYNN cloud-optics + if (do_mynnedmf) then + lw_optical_props_MYNNcloudsByBand%band_lims_wvn = lw_gas_props%get_band_lims_wavenumber() + do iBand=1,lw_gas_props%get_nband() + lw_optical_props_MYNNcloudsByBand%band2gpt(1:2,iBand) = iBand + lw_optical_props_MYNNcloudsByBand%gpt2band(iBand) = iBand + end do + call check_error_msg('rrtmgp_lw_MYNNcloud_optics_run - MYNN-EDMF cloud',lw_cloud_props%cloud_optics(& + cld_pbl_lwp, & ! IN - MYNN-EDMF PBL cloud liquid water path (g/m2) + cld_pbl_iwp, & ! IN - MYNN-EDMF PBL cloud ice water path (g/m2) + cld_pbl_reliq, & ! IN - MYNN-EDMF PBL cloud liquid effective radius (microns) + cld_pbl_reice, & ! IN - MYNN-EDMF PBL cloud ice effective radius (microns) + lw_optical_props_MYNNcloudsByBand)) ! OUT - RRTMGP DDT containing MYNN-EDMF PBL cloud radiative properties + ! in each band + endif + + ! iv) Cloud precipitation optics: rain and snow(+groupel) + lw_optical_props_precipByBand%band_lims_wvn = lw_gas_props%get_band_lims_wavenumber() + do iBand=1,lw_gas_props%get_nband() + lw_optical_props_precipByBand%band2gpt(1:2,iBand) = iBand + lw_optical_props_precipByBand%gpt2band(iBand) = iBand + end do do iCol=1,nCol do iLay=1,nLev if (cld_frac(iCol,iLay) .gt. 0.) then @@ -484,17 +534,7 @@ subroutine rrtmgp_lw_cloud_optics_run(doLWrad, doG_cldoptics, icliq_lw, icice_lw enddo enddo endif - if (doG_cldoptics) then - ! ii) RRTMG cloud-optics. - if (any(cld_frac .gt. 0)) then - call rrtmg_lw_cloud_optics(ncol, nLev, nbndsGPlw, cld_lwp, cld_reliq, cld_iwp,& - cld_reice, cld_rwp, cld_rerain, cld_swp, cld_resnow, cld_frac, icliq_lw, & - icice_lw, tau_cld, tau_precip) - lw_optical_props_cloudsByBand%tau = tau_cld - lw_optical_props_precipByBand%tau = tau_precip - endif - endif - + ! All-sky LW optical depth ~10microns (DJS asks: Same as SW, move to cloud-diagnostics?) cldtaulw = lw_optical_props_cloudsByBand%tau(:,:,7) diff --git a/physics/rrtmgp_lw_cloud_optics.meta b/physics/rrtmgp_lw_cloud_optics.meta index 35e27979e..c58496dc5 100644 --- a/physics/rrtmgp_lw_cloud_optics.meta +++ b/physics/rrtmgp_lw_cloud_optics.meta @@ -141,6 +141,34 @@ dimensions = () type = logical intent = in +[do_mynnedmf] + standard_name = flag_for_mellor_yamada_nakanishi_niino_pbl_scheme + long_name = flag to activate MYNN-EDMF + units = flag + dimensions = () + type = logical + intent = in +[imfdeepcnv] + standard_name = control_for_deep_convection_scheme + long_name = flag for mass-flux deep convection scheme + units = flag + dimensions = () + type = integer + intent = in +[imfdeepcnv_gf] + standard_name = identifier_for_grell_freitas_deep_convection + long_name = flag for Grell-Freitas deep convection scheme + units = flag + dimensions = () + type = integer + intent = in +[imfdeepcnv_samf] + standard_name = identifer_for_scale_aware_mass_flux_deep_convection + long_name = flag for SAMF deep convection scheme + units = flag + dimensions = () + type = integer + intent = in [ncol] standard_name = horizontal_loop_extent long_name = horizontal dimension @@ -235,6 +263,70 @@ type = real kind = kind_phys intent = in +[cld_cnv_lwp] + standard_name = convective_cloud_liquid_water_path + long_name = layer convective cloud liquid water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_cnv_iwp] + standard_name = convective_cloud_ice_water_path + long_name = layer convective cloud ice water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_cnv_reliq] + standard_name = mean_effective_radius_for_liquid_convective_cloud + long_name = mean effective radius for liquid convective cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_cnv_reice] + standard_name = mean_effective_radius_for_ice_convective_cloud + long_name = mean effective radius for ice convective cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_pbl_lwp] + standard_name = MYNN_SGS_cloud_liquid_water_path + long_name = layer convective cloud liquid water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_pbl_iwp] + standard_name = MYNN_SGS_cloud_ice_water_path + long_name = layer convective cloud ice water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_pbl_reliq] + standard_name = mean_effective_radius_for_liquid_MYNN_SGS_cloud + long_name = mean effective radius for liquid MYNN_SGS cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_pbl_reice] + standard_name = mean_effective_radius_for_ice_MYNN_SGS_cloud + long_name = mean effective radius for ice MYNN_SGS cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in [p_lay] standard_name = air_pressure_at_layer_for_RRTMGP long_name = air pressure layer @@ -281,6 +373,20 @@ dimensions = () type = ty_optical_props_2str intent = inout +[lw_optical_props_cnvcloudsByBand] + standard_name = longwave_optical_properties_for_convective_cloudy_atmosphere_by_band + long_name = Fortran DDT containing RRTMGP optical properties + units = DDT + dimensions = () + type = ty_optical_props_2str + intent = inout +[lw_optical_props_MYNNcloudsByBand] + standard_name = longwave_optical_properties_for_MYNN_EDMF_PBL_cloudy_atmosphere_by_band + long_name = Fortran DDT containing RRTMGP optical properties + units = DDT + dimensions = () + type = ty_optical_props_2str + intent = inout [lw_optical_props_precipByBand] standard_name = longwave_optical_properties_for_precipitation_by_band long_name = Fortran DDT containing RRTMGP optical properties diff --git a/physics/rrtmgp_lw_cloud_sampling.F90 b/physics/rrtmgp_lw_cloud_sampling.F90 index d8d499577..cb11607dc 100644 --- a/physics/rrtmgp_lw_cloud_sampling.F90 +++ b/physics/rrtmgp_lw_cloud_sampling.F90 @@ -18,20 +18,25 @@ module rrtmgp_lw_cloud_sampling !! \section arg_table_rrtmgp_lw_cloud_sampling_run !! \htmlinclude rrtmgp_lw_cloud_sampling_run.html !! - subroutine rrtmgp_lw_cloud_sampling_run(doLWrad, nCol, nLev, icseed_lw, iovr, & + subroutine rrtmgp_lw_cloud_sampling_run(doLWrad, nCol, nLev, icseed_lw, iovr,iovr_convcld,& iovr_max, iovr_maxrand, iovr_rand, iovr_dcorr, iovr_exp, iovr_exprand, isubc_lw, & - cld_frac, precip_frac, cloud_overlap_param, precip_overlap_param, & - doGP_lwscat, lw_optical_props_cloudsByBand, lw_optical_props_precipByBand, & - lw_optical_props_clouds, lw_optical_props_precip, errmsg, errflg) + cld_frac, precip_frac, cloud_overlap_param, precip_overlap_param, cld_cnv_frac, & + cnv_cloud_overlap_param, imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_samf, & + lw_optical_props_cloudsByBand, lw_optical_props_cnvcloudsByBand, & + lw_optical_props_precipByBand, lw_optical_props_clouds, lw_optical_props_cnvclouds, & + lw_optical_props_precip, errmsg, errflg) ! Inputs logical, intent(in) :: & - doLWrad, & ! Logical flag for shortwave radiation call - doGP_lwscat ! Include scattering in LW cloud-optics? + doLWrad ! Logical flag for shortwave radiation call integer, intent(in) :: & nCol, & ! Number of horizontal gridpoints nLev, & ! Number of vertical layers + imfdeepcnv, & ! + imfdeepcnv_gf, & ! + imfdeepcnv_samf, & ! iovr, & ! Choice of cloud-overlap method + iovr_convcld, & ! Choice of convective cloud-overlap iovr_max, & ! Flag for maximum cloud overlap method iovr_maxrand, & ! Flag for maximum-random cloud overlap method iovr_rand, & ! Flag for random cloud overlap method @@ -39,19 +44,21 @@ subroutine rrtmgp_lw_cloud_sampling_run(doLWrad, nCol, nLev, icseed_lw, iovr, iovr_exp, & ! Flag for exponential cloud overlap method iovr_exprand, & ! Flag for exponential-random cloud overlap method isubc_lw - integer,intent(in),dimension(ncol) :: & + integer,intent(in),dimension(:) :: & icseed_lw ! auxiliary special cloud related array when module ! variable isubc_lw=2, it provides permutation seed ! for each column profile that are used for generating ! random numbers. when isubc_lw /=2, it will not be used. - real(kind_phys), dimension(ncol,nLev),intent(in) :: & + real(kind_phys), dimension(:,:),intent(in) :: & cld_frac, & ! Total cloud fraction by layer - precip_frac ! Precipitation fraction by layer - real(kind_phys), dimension(ncol,nLev), intent(in) :: & + cld_cnv_frac, & ! Convective cloud fraction by layer + precip_frac, & ! Precipitation fraction by layer cloud_overlap_param, & ! Cloud overlap parameter + cnv_cloud_overlap_param, & ! Convective cloud overlap parameter precip_overlap_param ! Precipitation overlap parameter type(ty_optical_props_2str),intent(in) :: & lw_optical_props_cloudsByBand, & ! RRTMGP DDT: Longwave optical properties in each band (clouds) + lw_optical_props_cnvcloudsByBand, & ! RRTMGP DDT: Longwave optical properties in each band (convective cloud) lw_optical_props_precipByBand ! RRTMGP DDT: Longwave optical properties in each band (precipitation) ! Outputs @@ -61,6 +68,7 @@ subroutine rrtmgp_lw_cloud_sampling_run(doLWrad, nCol, nLev, icseed_lw, iovr, errflg ! CCPP error code type(ty_optical_props_2str),intent(inout) :: & lw_optical_props_clouds, & ! RRTMGP DDT: Shortwave optical properties by spectral point (clouds) + lw_optical_props_cnvclouds, & ! RRTMGP DDT: Shortwave optical properties by spectral point (convective cloud) lw_optical_props_precip ! RRTMGP DDT: Shortwave optical properties by spectral point (precipitation) ! Local variables @@ -70,7 +78,7 @@ subroutine rrtmgp_lw_cloud_sampling_run(doLWrad, nCol, nLev, icseed_lw, iovr, real(kind_phys), dimension(lw_gas_props%get_ngpt(),nLev,ncol) :: rng3D,rng3D2 real(kind_phys), dimension(lw_gas_props%get_ngpt()*nLev) :: rng2D real(kind_phys), dimension(lw_gas_props%get_ngpt()) :: rng1D - logical, dimension(ncol,nLev,lw_gas_props%get_ngpt()) :: cldfracMCICA,precipfracSAMP + logical, dimension(ncol,nLev,lw_gas_props%get_ngpt()) :: maskMCICA ! Initialize CCPP error handling variables errmsg = '' @@ -119,7 +127,7 @@ subroutine rrtmgp_lw_cloud_sampling_run(doLWrad, nCol, nLev, icseed_lw, iovr, ! Cloud-overlap. ! Maximum-random, random or maximum. if (iovr == iovr_maxrand .or. iovr == iovr_rand .or. iovr == iovr_max) then - call sampled_mask(rng3D, cld_frac, cldfracMCICA) + call sampled_mask(rng3D, cld_frac, maskMCICA) endif ! Exponential decorrelation length overlap if (iovr == iovr_dcorr) then @@ -129,13 +137,13 @@ subroutine rrtmgp_lw_cloud_sampling_run(doLWrad, nCol, nLev, icseed_lw, iovr, call random_number(rng2D,rng_stat) rng3D2(:,:,iCol) = reshape(source = rng2D,shape=[lw_gas_props%get_ngpt(),nLev]) enddo - call sampled_mask(rng3D, cld_frac, cldfracMCICA, & + call sampled_mask(rng3D, cld_frac, maskMCICA, & overlap_param = cloud_overlap_param(:,1:nLev-1), & randoms2 = rng3D2) endif ! Exponential or Exponential-random if (iovr == iovr_exp .or. iovr == iovr_exprand) then - call sampled_mask(rng3D, cld_frac, cldfracMCICA, & + call sampled_mask(rng3D, cld_frac, maskMCICA, & overlap_param = cloud_overlap_param(:,1:nLev-1)) endif @@ -143,50 +151,10 @@ subroutine rrtmgp_lw_cloud_sampling_run(doLWrad, nCol, nLev, icseed_lw, iovr, ! Sampling. Map band optical depth to each g-point using McICA ! call check_error_msg('rrtmgp_lw_cloud_sampling_run_draw_samples',& - draw_samples(cldfracMCICA, doGP_lwscat, & + draw_samples(maskMCICA, .true., & lw_optical_props_cloudsByBand, & lw_optical_props_clouds)) - ! #################################################################################### - ! Next sample the precipitation... - ! (Use same RNGs as was used by the clouds.) - ! #################################################################################### - lw_optical_props_precip%band2gpt = lw_gas_props%get_band_lims_gpoint() - lw_optical_props_precip%band_lims_wvn = lw_gas_props%get_band_lims_wavenumber() - do iBand=1,lw_gas_props%get_nband() - lw_optical_props_precip%gpt2band(lw_optical_props_precip%band2gpt(1,iBand):lw_optical_props_precip%band2gpt(2,iBand)) = iBand - end do - - ! Precipitation overlap. - ! Maximum-random, random or maximum. - if (iovr == iovr_maxrand .or. iovr == iovr_rand .or. iovr == iovr_max) then - call sampled_mask(rng3D, precip_frac, precipfracSAMP) - endif - ! Exponential decorrelation length overlap - if (iovr == iovr_dcorr) then - call sampled_mask(rng3D, precip_frac, precipfracSAMP, & - overlap_param = precip_overlap_param(:,1:nLev-1), & - randoms2 = rng3D2) - endif - ! Exponential or Exponential-random - if (iovr == iovr_exp .or. iovr == iovr_exprand) then - call sampled_mask(rng3D, precip_frac, precipfracSAMP, & - overlap_param = precip_overlap_param(:,1:nLev-1)) - endif - - ! - ! Sampling. Map band optical depth to each g-point using McICA - ! - call check_error_msg('rrtmgp_lw_precip_sampling_run_draw_samples',& - draw_samples(precipfracSAMP, doGP_lwscat, & - lw_optical_props_precipByBand, & - lw_optical_props_precip)) - - ! #################################################################################### - ! Just add precipitation optics to cloud-optics - ! #################################################################################### - lw_optical_props_clouds%tau = lw_optical_props_clouds%tau + lw_optical_props_precip%tau - end subroutine rrtmgp_lw_cloud_sampling_run ! ######################################################################################### diff --git a/physics/rrtmgp_lw_cloud_sampling.meta b/physics/rrtmgp_lw_cloud_sampling.meta index 2e4029ae2..c1ae9d139 100644 --- a/physics/rrtmgp_lw_cloud_sampling.meta +++ b/physics/rrtmgp_lw_cloud_sampling.meta @@ -14,12 +14,33 @@ dimensions = () type = logical intent = in -[doGP_lwscat] - standard_name = flag_to_include_longwave_scattering_in_cloud_optics - long_name = logical flag to control the addition of LW scattering in RRTMGP +[imfdeepcnv] + standard_name = control_for_deep_convection_scheme + long_name = flag for mass-flux deep convection scheme units = flag dimensions = () - type = logical + type = integer + intent = in +[imfdeepcnv_gf] + standard_name = identifier_for_grell_freitas_deep_convection + long_name = flag for Grell-Freitas deep convection scheme + units = flag + dimensions = () + type = integer + intent = in +[imfdeepcnv_samf] + standard_name = identifer_for_scale_aware_mass_flux_deep_convection + long_name = flag for SAMF deep convection scheme + units = flag + dimensions = () + type = integer + intent = in +[iovr_convcld] + standard_name = flag_for_convective_cloud_overlap_method_for_radiation + long_name = flag for convective cloud overlap method + units = flag + dimensions = () + type = integer intent = in [ncol] standard_name = horizontal_loop_extent @@ -106,6 +127,14 @@ type = real kind = kind_phys intent = in +[cld_cnv_frac] + standard_name = convective_cloud_fraction_for_RRTMGP + long_name = layer convective cloud fraction + units = frac + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in [precip_frac] standard_name = precipitation_fraction_by_layer long_name = precipitation fraction in each layer @@ -122,6 +151,14 @@ type = real kind = kind_phys intent = in +[cnv_cloud_overlap_param] + standard_name = convective_cloud_overlap_param + long_name = convective cloud overlap parameter + units = km + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in [precip_overlap_param] standard_name = precip_overlap_param long_name = precipitation overlap parameter @@ -137,6 +174,13 @@ dimensions = () type = ty_optical_props_2str intent = in +[lw_optical_props_cnvcloudsByBand] + standard_name = longwave_optical_properties_for_convective_cloudy_atmosphere_by_band + long_name = Fortran DDT containing RRTMGP optical properties + units = DDT + dimensions = () + type = ty_optical_props_2str + intent = in [lw_optical_props_precipByBand] standard_name = longwave_optical_properties_for_precipitation_by_band long_name = Fortran DDT containing RRTMGP optical properties @@ -158,6 +202,13 @@ dimensions = () type = ty_optical_props_2str intent = inout +[lw_optical_props_cnvclouds] + standard_name = longwave_optical_properties_for_convective_cloudy_atmosphere + long_name = Fortran DDT containing RRTMGP optical properties + units = DDT + dimensions = () + type = ty_optical_props_2str + intent = inout [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/rrtmgp_lw_rte.F90 b/physics/rrtmgp_lw_rte.F90 index aed4f0027..a141a4e08 100644 --- a/physics/rrtmgp_lw_rte.F90 +++ b/physics/rrtmgp_lw_rte.F90 @@ -26,10 +26,12 @@ end subroutine rrtmgp_lw_rte_init !! \htmlinclude rrtmgp_lw_rte_run.html !! subroutine rrtmgp_lw_rte_run(doLWrad, doLWclrsky, use_LW_jacobian, doGP_lwscat, nCol, & - nLev, top_at_1, sfc_emiss_byband, sources, lw_optical_props_clrsky, & - lw_optical_props_clouds, lw_optical_props_aerosol, nGauss_angles, fluxlwUP_allsky, & - fluxlwDOWN_allsky, fluxlwUP_clrsky, fluxlwDOWN_clrsky, fluxlwUP_jac, & - fluxlwUP_radtime, fluxlwDOWN_radtime, errmsg, errflg) + nLev, top_at_1, doGP_sgs_cnv, doGP_sgs_mynn, sfc_emiss_byband, sources, & + lw_optical_props_clrsky, lw_optical_props_clouds, lw_optical_props_precipByBand, & + lw_optical_props_cnvcloudsByBand, lw_optical_props_MYNNcloudsByBand, & + lw_optical_props_aerosol, nGauss_angles, fluxlwUP_allsky, fluxlwDOWN_allsky, & + fluxlwUP_clrsky, fluxlwDOWN_clrsky, fluxlwUP_jac, fluxlwUP_radtime, & + fluxlwDOWN_radtime, errmsg, errflg) ! Inputs logical, intent(in) :: & @@ -37,23 +39,27 @@ subroutine rrtmgp_lw_rte_run(doLWrad, doLWclrsky, use_LW_jacobian, doGP_lwscat, doLWrad, & ! Logical flag for longwave radiation call doLWclrsky, & ! Compute clear-sky fluxes for clear-sky heating-rate? use_LW_jacobian, & ! Compute Jacobian of LW to update radiative fluxes between radiation calls? + doGP_sgs_mynn, & ! Flag for sgs MYNN-EDMF PBL cloud scheme + doGP_sgs_cnv, & ! Flagg for sgs convective cloud scheme doGP_lwscat ! Include scattering in LW cloud-optics? integer, intent(in) :: & nCol, & ! Number of horizontal gridpoints nLev, & ! Number of vertical levels nGauss_angles ! Number of angles used in Gaussian quadrature - real(kind_phys), dimension(lw_gas_props%get_nband(),ncol), intent(in) :: & - sfc_emiss_byband ! Surface emissivity in each band + real(kind_phys), dimension(:,:), intent(in) :: & + sfc_emiss_byband ! Surface emissivity in each band type(ty_source_func_lw),intent(in) :: & - sources ! RRTMGP DDT: longwave source functions + sources ! RRTMGP DDT: longwave source functions type(ty_optical_props_1scl),intent(inout) :: & - lw_optical_props_aerosol, &! RRTMGP DDT: longwave aerosol radiative properties - lw_optical_props_clrsky ! RRTMGP DDT: longwave clear-sky radiative properties + lw_optical_props_aerosol, &! RRTMGP DDT: longwave aerosol optical properties + lw_optical_props_clrsky ! RRTMGP DDT: longwave clear-sky optical properties type(ty_optical_props_2str),intent(inout) :: & - lw_optical_props_clouds ! RRTMGP DDT: longwave cloud radiative properties - + lw_optical_props_clouds, & ! RRTMGP DDT: longwave cloud optical properties + lw_optical_props_precipByBand, & ! RRTMGP DDT: longwave precipitation optical properties + lw_optical_props_cnvcloudsByBand, & ! RRTMGP DDT: longwave convective cloud optical properties + lw_optical_props_MYNNcloudsByBand ! RRTMGP DDT: longwave MYNN-EDMF PBL cloud optical properties ! Outputs - real(kind_phys), dimension(ncol,nLev+1), intent(inout) :: & + real(kind_phys), dimension(:,:), intent(inout) :: & fluxlwUP_jac, & ! Jacobian of upwelling LW surface radiation (W/m2/K) fluxlwUP_allsky, & ! All-sky flux (W/m2) fluxlwDOWN_allsky, & ! All-sky flux (W/m2) @@ -121,9 +127,22 @@ subroutine rrtmgp_lw_rte_run(doLWrad, doLWclrsky, use_LW_jacobian, doGP_lwscat, endif ! - ! All-sky fluxes + ! All-sky fluxes (clear-sky + clouds + precipitation) ! + ! Include convective cloud? + if (doGP_sgs_cnv) then + call check_error_msg('rrtmgp_lw_rte_run',lw_optical_props_cnvcloudsByBand%increment(lw_optical_props_clrsky)) + endif + + ! Include MYNN-EDMF PBL clouds? + if (doGP_sgs_mynn) then + call check_error_msg('rrtmgp_lw_rte_run',lw_optical_props_MYNNcloudsByBand%increment(lw_optical_props_clrsky)) + endif + + ! Add in precipitation + call check_error_msg('rrtmgp_lw_rte_run',lw_optical_props_precipByBand%increment(lw_optical_props_clouds)) + ! Include LW cloud-scattering? if (doGP_lwscat) then ! Add clear-sky optics to cloud-optics (2-stream) diff --git a/physics/rrtmgp_lw_rte.meta b/physics/rrtmgp_lw_rte.meta index 069537964..0ad0754b5 100644 --- a/physics/rrtmgp_lw_rte.meta +++ b/physics/rrtmgp_lw_rte.meta @@ -36,6 +36,20 @@ dimensions = () type = logical intent = in +[doGP_sgs_cnv] + standard_name = flag_to_include_sgs_convective_cloud_in_RRTMGP + long_name = logical flag to control sgs convective cloud in RRTMGP + units = flag + dimensions = () + type = logical + intent = in +[doGP_sgs_mynn] + standard_name = flag_to_include_sgs_MYNN_EDMF_cloud_in_RRTMGP + long_name = logical flag to control MYNN-EDMF PBL cloud in RRTMGP + units = flag + dimensions = () + type = logical + intent = in [ncol] standard_name = horizontal_loop_extent long_name = horizontal dimension @@ -86,6 +100,27 @@ dimensions = () type = ty_optical_props_2str intent = inout +[lw_optical_props_precipByBand] + standard_name = longwave_optical_properties_for_precipitation_by_band + long_name = Fortran DDT containing RRTMGP optical properties + units = DDT + dimensions = () + type = ty_optical_props_2str + intent = inout +[lw_optical_props_cnvcloudsByBand] + standard_name = longwave_optical_properties_for_convective_cloudy_atmosphere_by_band + long_name = Fortran DDT containing RRTMGP optical properties + units = DDT + dimensions = () + type = ty_optical_props_2str + intent = inout +[lw_optical_props_MYNNcloudsByBand] + standard_name = longwave_optical_properties_for_MYNN_EDMF_PBL_cloudy_atmosphere_by_band + long_name = Fortran DDT containing RRTMGP optical properties + units = DDT + dimensions = () + type = ty_optical_props_2str + intent = inout [lw_optical_props_aerosol] standard_name = longwave_optical_properties_for_aerosols long_name = Fortran DDT containing RRTMGP optical properties diff --git a/physics/rrtmgp_sw_cloud_optics.F90 b/physics/rrtmgp_sw_cloud_optics.F90 index f80440522..fd648de02 100644 --- a/physics/rrtmgp_sw_cloud_optics.F90 +++ b/physics/rrtmgp_sw_cloud_optics.F90 @@ -395,27 +395,34 @@ end subroutine rrtmgp_sw_cloud_optics_init !! \htmlinclude rrtmgp_sw_cloud_optics.html !! subroutine rrtmgp_sw_cloud_optics_run(doSWrad, doG_cldoptics, icliq_sw, icice_sw, & - doGP_cldoptics_PADE, doGP_cldoptics_LUT, nCol, nLev, nDay, nbndsGPsw, idxday, & - cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, & - cld_rerain, precip_frac, sw_optical_props_cloudsByBand, & - sw_optical_props_precipByBand, cldtausw, errmsg, errflg) + doGP_cldoptics_PADE, doGP_cldoptics_LUT, do_mynnedmf, imfdeepcnv, imfdeepcnv_gf, & + imfdeepcnv_samf, nCol, nLev, nDay, nbndsGPsw, idxday, cld_frac, cld_lwp, cld_reliq, & + cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, cld_rerain, precip_frac, & + cld_cnv_lwp, cld_cnv_reliq, cld_cnv_iwp, cld_cnv_reice, cld_pbl_lwp, cld_pbl_reliq, & + cld_pbl_iwp, cld_pbl_reice, sw_optical_props_cloudsByBand, & + sw_optical_props_cnvcloudsByBand, sw_optical_props_precipByBand, & + sw_optical_props_MYNNcloudsByBand, cldtausw, errmsg, errflg) ! Inputs logical, intent(in) :: & doSWrad, & ! Logical flag for shortwave radiation call doG_cldoptics, & ! Use legacy RRTMG cloud-optics? doGP_cldoptics_PADE, & ! Use RRTMGP cloud-optics: PADE approximation? - doGP_cldoptics_LUT ! Use RRTMGP cloud-optics: LUTs? + doGP_cldoptics_LUT, & ! Use RRTMGP cloud-optics: LUTs? + do_mynnedmf ! integer, intent(in) :: & nbndsGPsw, & ! Number of shortwave bands nCol, & ! Number of horizontal gridpoints nLev, & ! Number of vertical levels nday, & ! Number of daylit points. icliq_sw, & ! Choice of treatment of liquid cloud optical properties (RRTMG legacy) - icice_sw ! Choice of treatment of ice cloud optical properties (RRTMG legacy) - integer,intent(in),dimension(ncol) :: & + icice_sw, & ! Choice of treatment of ice cloud optical properties (RRTMG legacy) + imfdeepcnv, & ! + imfdeepcnv_gf, & ! + imfdeepcnv_samf ! + integer,intent(in),dimension(:) :: & idxday ! Indices for daylit points. - real(kind_phys), dimension(ncol,nLev),intent(in) :: & + real(kind_phys), dimension(:,:),intent(in) :: & cld_frac, & ! Total cloud fraction by layer cld_lwp, & ! Cloud liquid water path cld_reliq, & ! Cloud liquid effective radius @@ -425,18 +432,27 @@ subroutine rrtmgp_sw_cloud_optics_run(doSWrad, doG_cldoptics, icliq_sw, icice_sw cld_resnow, & ! Cloud snow effective radius cld_rwp, & ! Cloud rain water path cld_rerain, & ! Cloud rain effective radius - precip_frac ! Precipitation fraction by layer - + precip_frac, & ! Precipitation fraction by layer + cld_cnv_lwp, & ! Water path for convective liquid cloud-particles (microns) + cld_cnv_reliq, & ! Effective radius for convective liquid cloud-particles (microns) + cld_cnv_iwp, & ! Water path for convective ice cloud-particles (microns) + cld_cnv_reice, & ! Effective radius for convective ice cloud-particles (microns) + cld_pbl_lwp, & ! Water path for SGS PBL liquid cloud-particles + cld_pbl_reliq, & ! Effective radius for SGS PBL liquid cloud-particles + cld_pbl_iwp, & ! Water path for SGS PBL ice cloud-particles + cld_pbl_reice ! Effective radius for SGS PBL ice cloud-particles ! Outputs character(len=*), intent(out) :: & - errmsg ! CCPP error message + errmsg ! CCPP error message integer, intent(out) :: & - errflg ! CCPP error flag + errflg ! CCPP error flag type(ty_optical_props_2str),intent(out) :: & - sw_optical_props_cloudsByBand, & ! RRTMGP DDT: Shortwave optical properties in each band (clouds) - sw_optical_props_precipByBand ! RRTMGP DDT: Shortwave optical properties in each band (cloud precipitation) - real(kind_phys), dimension(ncol,NLev), intent(out) :: & - cldtausw ! Approx 10.mu band layer cloud optical depth + sw_optical_props_cloudsByBand, & ! RRTMGP DDT: Shortwave optical properties in each band (clouds) + sw_optical_props_cnvcloudsByBand, & ! RRTMGP DDT: Shortwave optical properties in each band (convective cloud) + sw_optical_props_MYNNcloudsByBand,& ! RRTMGP DDT: Shortwave optical properties in each band (MYNN PBL cloud) + sw_optical_props_precipByBand ! RRTMGP DDT: Shortwave optical properties in each band (cloud precipitation) + real(kind_phys), dimension(:,:), intent(out) :: & + cldtausw ! Approx 10.mu band layer cloud optical depth ! Local variables integer :: iDay, iLay, iBand @@ -457,26 +473,53 @@ subroutine rrtmgp_sw_cloud_optics_run(doSWrad, doG_cldoptics, icliq_sw, icice_sw ! Compute cloud/precipitation optics. if (doGP_cldoptics_PADE .or. doGP_cldoptics_LUT) then - call check_error_msg('rrtmgp_sw_cloud_optics_run',sw_optical_props_cloudsByBand%alloc_2str(& - nday, nLev, sw_cloud_props%get_band_lims_wavenumber())) - sw_optical_props_cloudsByBand%tau(:,:,:) = 0._kind_phys - sw_optical_props_cloudsByBand%ssa(:,:,:) = 1._kind_phys - sw_optical_props_cloudsByBand%g(:,:,:) = 0._kind_phys - call check_error_msg('rrtmgp_sw_cloud_optics_run',sw_optical_props_precipByBand%alloc_2str(& - nday, nLev, sw_cloud_props%get_band_lims_wavenumber())) + ! i) Cloud-optics. + call check_error_msg('rrtmgp_sw_cloud_optics_run - sw_optical_props_cloudsByBand',& + sw_optical_props_cloudsByBand%alloc_2str(nday, nLev, sw_cloud_props%get_band_lims_wavenumber())) + + call check_error_msg('rrtmgp_sw_cloud_optics_run - clouds',sw_cloud_props%cloud_optics(& + cld_lwp(idxday(1:nday),:), & ! IN - Cloud liquid water path + cld_iwp(idxday(1:nday),:), & ! IN - Cloud ice water path + cld_reliq(idxday(1:nday),:), & ! IN - Cloud liquid effective radius + cld_reice(idxday(1:nday),:), & ! IN - Cloud ice effective radius + sw_optical_props_cloudsByBand)) ! OUT - RRTMGP DDT: Shortwave optical properties, + ! in each band (tau,ssa,g) + + ! ii) Convective cloud-optics + if (imfdeepcnv == imfdeepcnv_samf .or. imfdeepcnv == imfdeepcnv_gf) then + call check_error_msg('rrtmgp_sw_cloud_optics_run - sw_optical_props_cnvcloudsByBand',& + sw_optical_props_cnvcloudsByBand%alloc_2str(nday, nLev, sw_cloud_props%get_band_lims_wavenumber())) + + call check_error_msg('rrtmgp_sw_cloud_optics_run - convective clouds',sw_cloud_props%cloud_optics(& + cld_cnv_lwp(idxday(1:nday),:), & ! IN - Convective cloud liquid water path + cld_cnv_iwp(idxday(1:nday),:), & ! IN - Convective cloud ice water path + cld_cnv_reliq(idxday(1:nday),:), & ! IN - Convective cloud liquid effective radius + cld_cnv_reice(idxday(1:nday),:), & ! IN - Convective cloud ice effective radius + sw_optical_props_cnvcloudsByBand)) ! OUT - RRTMGP DDT: Shortwave optical properties, + ! in each band (tau,ssa,g) + endif + + ! iii) MYNN cloud-optics + if (do_mynnedmf) then + call check_error_msg('rrtmgp_sw_cloud_optics_run - sw_optical_props_MYNNcloudsByBand',& + sw_optical_props_MYNNcloudsByBand%alloc_2str(nday, nLev, sw_cloud_props%get_band_lims_wavenumber())) + + call check_error_msg('rrtmgp_sw_MYNNcloud_optics_run - MYNN-EDMF cloud',sw_cloud_props%cloud_optics(& + cld_pbl_lwp(idxday(1:nday),:), & ! IN - MYNN-EDMF PBL cloud liquid water path (g/m2) + cld_pbl_iwp(idxday(1:nday),:), & ! IN - MYNN-EDMF PBL cloud ice water path (g/m2) + cld_pbl_reliq(idxday(1:nday),:), & ! IN - MYNN-EDMF PBL cloud liquid effective radius (microns) + cld_pbl_reice(idxday(1:nday),:), & ! IN - MYNN-EDMF PBL cloud ice effective radius (microns) + sw_optical_props_MYNNcloudsByBand)) ! OUT - RRTMGP DDT containing MYNN-EDMF PBL cloud radiative properties + ! in each band + endif + + ! iv) Cloud precipitation optics: rain and snow(+groupel) + call check_error_msg('rrtmgp_sw_cloud_optics_run - sw_optical_props_precipByBand',& + sw_optical_props_precipByBand%alloc_2str(nday, nLev, sw_cloud_props%get_band_lims_wavenumber())) sw_optical_props_precipByBand%tau(:,:,:) = 0._kind_phys sw_optical_props_precipByBand%ssa(:,:,:) = 1._kind_phys sw_optical_props_precipByBand%g(:,:,:) = 0._kind_phys - ! RRTMGP cloud-optics. - call check_error_msg('rrtmgp_sw_cloud_optics_run',sw_cloud_props%cloud_optics(& - cld_lwp(idxday(1:nday),:), & ! IN - Cloud liquid water path - cld_iwp(idxday(1:nday),:), & ! IN - Cloud ice water path - cld_reliq(idxday(1:nday),:), & ! IN - Cloud liquid effective radius - cld_reice(idxday(1:nday),:), & ! IN - Cloud ice effective radius - sw_optical_props_cloudsByBand)) ! OUT - RRTMGP DDT: Shortwave optical properties, - ! in each band (tau,ssa,g) - ! Cloud precipitation optics: rain and snow(+groupel) do iDay=1,nDay do iLay=1,nLev if (cld_frac(idxday(iDay),iLay) .gt. 1.e-12_kind_phys) then @@ -511,46 +554,6 @@ subroutine rrtmgp_sw_cloud_optics_run(doSWrad, doG_cldoptics, icliq_sw, icice_sw enddo enddo endif - if (doG_cldoptics) then - call check_error_msg('rrtmgp_sw_cloud_optics_run',sw_optical_props_cloudsByBand%alloc_2str(& - nday, nLev, sw_gas_props%get_band_lims_wavenumber())) - sw_optical_props_cloudsByBand%tau(:,:,:) = 0._kind_phys - sw_optical_props_cloudsByBand%ssa(:,:,:) = 1._kind_phys - sw_optical_props_cloudsByBand%g(:,:,:) = 0._kind_phys - call check_error_msg('rrtmgp_sw_cloud_optics_run',sw_optical_props_precipByBand%alloc_2str(& - nday, nLev, sw_gas_props%get_band_lims_wavenumber())) - sw_optical_props_precipByBand%tau(:,:,:) = 0._kind_phys - sw_optical_props_precipByBand%ssa(:,:,:) = 1._kind_phys - sw_optical_props_precipByBand%g(:,:,:) = 0._kind_phys - - ! RRTMG cloud(+precipitation) optics - if (any(cld_frac .gt. 0)) then - call rrtmg_sw_cloud_optics(nday, nLev, sw_gas_props%get_nband(), & - cld_lwp(idxday(1:nday),:), cld_reliq(idxday(1:nday),:), & - cld_iwp(idxday(1:nday),:), cld_reice(idxday(1:nday),:), & - cld_rwp(idxday(1:nday),:), cld_rerain(idxday(1:nday),:), & - cld_swp(idxday(1:nday),:), cld_resnow(idxday(1:nday),:), & - cld_frac(idxday(1:nday),:), icliq_sw, icice_sw, & - tau_cld, ssa_cld, asy_cld, & - tau_precip, ssa_precip, asy_precip) - - ! Cloud-optics (Need to reorder from G->GP band conventions) - sw_optical_props_cloudsByBand%tau(:,:,1) = tau_cld(:,:,sw_gas_props%get_nband()) - sw_optical_props_cloudsByBand%ssa(:,:,1) = ssa_cld(:,:,sw_gas_props%get_nband()) - sw_optical_props_cloudsByBand%g(:,:,1) = asy_cld(:,:,sw_gas_props%get_nband()) - sw_optical_props_cloudsByBand%tau(:,:,2:sw_gas_props%get_nband()) = tau_cld(:,:,1:sw_gas_props%get_nband()-1) - sw_optical_props_cloudsByBand%ssa(:,:,2:sw_gas_props%get_nband()) = ssa_cld(:,:,1:sw_gas_props%get_nband()-1) - sw_optical_props_cloudsByBand%g(:,:,2:sw_gas_props%get_nband()) = asy_cld(:,:,1:sw_gas_props%get_nband()-1) - ! Precipitation-optics (Need to reorder from G->GP band conventions) - sw_optical_props_precipByBand%tau(:,:,1) = tau_precip(:,:,sw_gas_props%get_nband()) - sw_optical_props_precipByBand%ssa(:,:,1) = ssa_precip(:,:,sw_gas_props%get_nband()) - sw_optical_props_precipByBand%g(:,:,1) = asy_precip(:,:,sw_gas_props%get_nband()) - sw_optical_props_precipByBand%tau(:,:,2:sw_gas_props%get_nband()) = tau_precip(:,:,1:sw_gas_props%get_nband()-1) - sw_optical_props_precipByBand%ssa(:,:,2:sw_gas_props%get_nband()) = ssa_precip(:,:,1:sw_gas_props%get_nband()-1) - sw_optical_props_precipByBand%g(:,:,2:sw_gas_props%get_nband()) = asy_precip(:,:,1:sw_gas_props%get_nband()-1) - - endif - endif ! All-sky SW optical depth ~0.55microns (DJS asks: Move to cloud diagnostics?) cldtausw(idxday(1:nDay),:) = sw_optical_props_cloudsByBand%tau(:,:,11) diff --git a/physics/rrtmgp_sw_cloud_optics.meta b/physics/rrtmgp_sw_cloud_optics.meta index d73258cb2..064b7cf80 100644 --- a/physics/rrtmgp_sw_cloud_optics.meta +++ b/physics/rrtmgp_sw_cloud_optics.meta @@ -147,6 +147,34 @@ dimensions = () type = logical intent = in +[do_mynnedmf] + standard_name = flag_for_mellor_yamada_nakanishi_niino_pbl_scheme + long_name = flag to activate MYNN-EDMF + units = flag + dimensions = () + type = logical + intent = in +[imfdeepcnv] + standard_name = control_for_deep_convection_scheme + long_name = flag for mass-flux deep convection scheme + units = flag + dimensions = () + type = integer + intent = in +[imfdeepcnv_gf] + standard_name = identifier_for_grell_freitas_deep_convection + long_name = flag for Grell-Freitas deep convection scheme + units = flag + dimensions = () + type = integer + intent = in +[imfdeepcnv_samf] + standard_name = identifer_for_scale_aware_mass_flux_deep_convection + long_name = flag for SAMF deep convection scheme + units = flag + dimensions = () + type = integer + intent = in [cld_frac] standard_name = total_cloud_fraction long_name = layer total cloud fraction @@ -227,6 +255,70 @@ type = real kind = kind_phys intent = in +[cld_cnv_lwp] + standard_name = convective_cloud_liquid_water_path + long_name = layer convective cloud liquid water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_cnv_iwp] + standard_name = convective_cloud_ice_water_path + long_name = layer convective cloud ice water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_cnv_reliq] + standard_name = mean_effective_radius_for_liquid_convective_cloud + long_name = mean effective radius for liquid convective cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_cnv_reice] + standard_name = mean_effective_radius_for_ice_convective_cloud + long_name = mean effective radius for ice convective cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_pbl_lwp] + standard_name = MYNN_SGS_cloud_liquid_water_path + long_name = layer convective cloud liquid water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_pbl_iwp] + standard_name = MYNN_SGS_cloud_ice_water_path + long_name = layer convective cloud ice water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_pbl_reliq] + standard_name = mean_effective_radius_for_liquid_MYNN_SGS_cloud + long_name = mean effective radius for liquid MYNN_SGS cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_pbl_reice] + standard_name = mean_effective_radius_for_ice_MYNN_SGS_cloud + long_name = mean effective radius for ice MYNN_SGS cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in [nbndsGPsw] standard_name = number_of_shortwave_bands long_name = number of sw bands used in RRTMGP @@ -255,6 +347,13 @@ dimensions = () type = ty_optical_props_2str intent = out +[sw_optical_props_cnvcloudsByBand] + standard_name = shortwave_optical_properties_for_convective_cloudy_atmosphere_by_band + long_name = Fortran DDT containing RRTMGP optical properties + units = DDT + dimensions = () + type = ty_optical_props_2str + intent = out [sw_optical_props_precipByBand] standard_name = shortwave_optical_properties_for_precipitation_by_band long_name = Fortran DDT containing RRTMGP optical properties @@ -262,6 +361,13 @@ dimensions = () type = ty_optical_props_2str intent = out +[sw_optical_props_MYNNcloudsByBand] + standard_name = shortwave_optical_properties_for_MYNN_EDMF_PBL_cloudy_atmosphere_by_band + long_name = Fortran DDT containing RRTMGP optical properties + units = DDT + dimensions = () + type = ty_optical_props_2str + intent = out [cldtausw] standard_name = cloud_optical_depth_layers_at_0p55mu_band long_name = approx .55mu band layer cloud optical depth diff --git a/physics/rrtmgp_sw_cloud_sampling.F90 b/physics/rrtmgp_sw_cloud_sampling.F90 index 3172ae315..c4a5de4c8 100644 --- a/physics/rrtmgp_sw_cloud_sampling.F90 +++ b/physics/rrtmgp_sw_cloud_sampling.F90 @@ -19,10 +19,12 @@ module rrtmgp_sw_cloud_sampling !! \htmlinclude rrtmgp_sw_cloud_sampling.html !! subroutine rrtmgp_sw_cloud_sampling_run(doSWrad, nCol, nDay, nLev, idxday, iovr, & - iovr_max, iovr_maxrand, iovr_rand, iovr_dcorr, iovr_exp, iovr_exprand, isubc_sw, & - icseed_sw, cld_frac, precip_frac, cloud_overlap_param, precip_overlap_param, & - sw_optical_props_cloudsByBand, sw_optical_props_precipByBand, & - sw_optical_props_clouds, sw_optical_props_precip, errmsg, errflg) + iovr_convcld, iovr_max, iovr_maxrand, iovr_rand, iovr_dcorr, iovr_exp, iovr_exprand, & + isubc_sw,icseed_sw, cld_frac, precip_frac, cloud_overlap_param, precip_overlap_param,& + imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_samf, cnv_cloud_overlap_param, cld_cnv_frac, & + sw_optical_props_cnvcloudsByBand, sw_optical_props_cloudsByBand, & + sw_optical_props_precipByBand, sw_optical_props_clouds, sw_optical_props_cnvclouds, & + sw_optical_props_precip, errmsg, errflg) ! Inputs logical, intent(in) :: & @@ -31,7 +33,11 @@ subroutine rrtmgp_sw_cloud_sampling_run(doSWrad, nCol, nDay, nLev, idxday, iovr, nCol, & ! Number of horizontal gridpoints nDay, & ! Number of daylit points. nLev, & ! Number of vertical layers + imfdeepcnv, & ! + imfdeepcnv_gf, & ! + imfdeepcnv_samf, & ! iovr, & ! Choice of cloud-overlap method + iovr_convcld, & ! Choice of convective cloud-overlap method iovr_max, & ! Flag for maximum cloud overlap method iovr_maxrand, & ! Flag for maximum-random cloud overlap method iovr_rand, & ! Flag for random cloud overlap method @@ -39,21 +45,24 @@ subroutine rrtmgp_sw_cloud_sampling_run(doSWrad, nCol, nDay, nLev, idxday, iovr, iovr_exp, & ! Flag for exponential cloud overlap method iovr_exprand, & ! Flag for exponential-random cloud overlap method isubc_sw - integer,intent(in),dimension(ncol) :: & + integer,intent(in),dimension(:) :: & idxday ! Indices for daylit points. - integer,intent(in),dimension(ncol) :: & + integer,intent(in),dimension(:) :: & icseed_sw ! auxiliary special cloud related array when module ! variable isubc_sw=2, it provides permutation seed ! for each column profile that are used for generating ! random numbers. when isubc_sw /=2, it will not be used. - real(kind_phys), dimension(ncol,nLev),intent(in) :: & + real(kind_phys), dimension(:,:),intent(in) :: & cld_frac, & ! Total cloud fraction by layer + cld_cnv_frac, & ! Convective cloud fraction by layer precip_frac ! Precipitation fraction by layer - real(kind_phys), dimension(ncol,nLev), intent(in) :: & + real(kind_phys), dimension(:,:), intent(in) :: & cloud_overlap_param, & ! Cloud overlap parameter + cnv_cloud_overlap_param, & ! Convective cloud overlap parameter precip_overlap_param ! Precipitation overlap parameter type(ty_optical_props_2str),intent(in) :: & sw_optical_props_cloudsByBand, & ! RRTMGP DDT: Shortwave optical properties in each band (clouds) + sw_optical_props_cnvcloudsByBand,& ! RRTMGP DDT: Shortwave optical properties in each band (convectivecloud) sw_optical_props_precipByBand ! RRTMGP DDT: Shortwave optical properties in each band (precipitation) ! Outputs @@ -63,6 +72,7 @@ subroutine rrtmgp_sw_cloud_sampling_run(doSWrad, nCol, nDay, nLev, idxday, iovr, errflg ! Error flag type(ty_optical_props_2str),intent(out) :: & sw_optical_props_clouds, & ! RRTMGP DDT: Shortwave optical properties at each spectral point (clouds) + sw_optical_props_cnvclouds, & ! RRTMGP DDT: Shortwave optical properties at each spectral point (convectivecloud) sw_optical_props_precip ! RRTMGP DDT: Shortwave optical properties at each spectral point (precipitation) ! Local variables @@ -73,7 +83,7 @@ subroutine rrtmgp_sw_cloud_sampling_run(doSWrad, nCol, nDay, nLev, idxday, iovr, real(kind_phys), dimension(sw_gas_props%get_ngpt(),nLev,nday) :: rng3D,rng3D2 real(kind_phys), dimension(sw_gas_props%get_ngpt()*nLev) :: rng2D real(kind_phys), dimension(sw_gas_props%get_ngpt()) :: rng1D - logical, dimension(nday,nLev,sw_gas_props%get_ngpt()) :: cldfracMCICA,precipfracSAMP + logical, dimension(nday,nLev,sw_gas_props%get_ngpt()) :: maskMCICA ! Initialize CCPP error handling variables errmsg = '' @@ -121,7 +131,7 @@ subroutine rrtmgp_sw_cloud_sampling_run(doSWrad, nCol, nDay, nLev, idxday, iovr, ! Cloud overlap. ! Maximum-random, random, or maximum cloud overlap if (iovr == iovr_maxrand .or. iovr == iovr_max .or. iovr == iovr_rand) then - call sampled_mask(rng3D, cld_frac(idxday(1:nDay),:), cldfracMCICA) + call sampled_mask(rng3D, cld_frac(idxday(1:nDay),:), maskMCICA) endif ! Decorrelation-length overlap if (iovr == iovr_dcorr) then @@ -130,13 +140,13 @@ subroutine rrtmgp_sw_cloud_sampling_run(doSWrad, nCol, nDay, nLev, idxday, iovr, call random_number(rng2D,rng_stat) rng3D2(:,:,iday) = reshape(source = rng2D,shape=[sw_gas_props%get_ngpt(),nLev]) enddo - call sampled_mask(rng3D, cld_frac(idxday(1:nDay),:), cldfracMCICA, & + call sampled_mask(rng3D, cld_frac(idxday(1:nDay),:), maskMCICA, & overlap_param = cloud_overlap_param(idxday(1:nDay),1:nLev-1),& randoms2 = rng3D2) endif ! Exponential or exponential-random cloud overlap if (iovr == iovr_exp .or. iovr == iovr_exprand) then - call sampled_mask(rng3D, cld_frac(idxday(1:nDay),:), cldfracMCICA, & + call sampled_mask(rng3D, cld_frac(idxday(1:nDay),:), maskMCICA, & overlap_param = cloud_overlap_param(idxday(1:nDay),1:nLev-1)) endif @@ -144,76 +154,9 @@ subroutine rrtmgp_sw_cloud_sampling_run(doSWrad, nCol, nDay, nLev, idxday, iovr, ! Sampling. Map band optical depth to each g-point using McICA ! call check_error_msg('rrtmgp_sw_cloud_sampling_run_draw_samples', & - draw_samples(cldfracMCICA, .true., & + draw_samples(maskMCICA, .true., & sw_optical_props_cloudsByBand, & sw_optical_props_clouds)) - - ! ################################################################################# - ! Next sample precipitation (same as clouds for now) - ! ################################################################################# - - ! Allocate space RRTMGP DDTs [nday,nLev,nGpt] - call check_error_msg('rrtmgp_sw_cloud_sampling_run', & - sw_optical_props_precip%alloc_2str( nday, nLev, sw_gas_props)) - - ! Precipitation overlap - ! Maximum-random, random or maximum precipitation overlap - if (iovr == iovr_maxrand .or. iovr == iovr_max .or. iovr == iovr_rand) then - call sampled_mask(rng3D, precip_frac(idxday(1:nDay),:), precipfracSAMP) - endif - ! Exponential decorrelation length overlap - if (iovr == iovr_dcorr) then - call sampled_mask(rng3D, precip_frac(idxday(1:nDay),:), precipfracSAMP, & - overlap_param = precip_overlap_param(idxday(1:nDay),1:nLev-1),& - randoms2 = rng3D2) - endif - if (iovr == iovr_exp .or. iovr == iovr_exprand) then - call sampled_mask(rng3D, precip_frac(idxday(1:nDay),:),precipfracSAMP, & - overlap_param = precip_overlap_param(idxday(1:nDay),1:nLev-1)) - endif - - ! - ! Sampling. Map band optical depth to each g-point using McICA - ! - call check_error_msg('rrtmgp_sw_precip_sampling_run_draw_samples', & - draw_samples(precipfracSAMP, .true., & - sw_optical_props_precipByBand, & - sw_optical_props_precip)) - - ! ################################################################################# - ! Just add precipitation optics to cloud-optics - ! ################################################################################# - do iGpt=1,sw_gas_props%get_ngpt() - do iday=1,nDay - do iLay=1,nLev - tauloc = sw_optical_props_clouds%tau(iday,iLay,iGpt) + & - sw_optical_props_precip%tau(iday,iLay,iGpt) - if (sw_optical_props_precip%tau(iday,iLay,iGpt) > 0) then - ssaloc = (sw_optical_props_clouds%tau(iday,iLay,iGpt) * & - sw_optical_props_clouds%ssa(iday,iLay,iGpt) + & - sw_optical_props_precip%tau(iday,iLay,iGpt) * & - sw_optical_props_precip%ssa(iday,iLay,iGpt)) / & - tauloc - if (ssaloc > 0) then - asyloc = (sw_optical_props_clouds%tau(iday,iLay,iGpt) * & - sw_optical_props_clouds%ssa(iday,iLay,iGpt) * & - sw_optical_props_clouds%g(iday,iLay,iGpt) + & - sw_optical_props_precip%tau(iday,iLay,iGpt) * & - sw_optical_props_precip%ssa(iday,iLay,iGpt) * & - sw_optical_props_precip%g(iday,iLay,iGpt)) / & - (tauloc*ssaloc) - else - tauloc = sw_optical_props_clouds%tau(iday,iLay,iGpt) - ssaloc = sw_optical_props_clouds%ssa(iday,iLay,iGpt) - asyloc = sw_optical_props_clouds%g(iday,iLay,iGpt) - endif - sw_optical_props_clouds%tau(iday,iLay,iGpt) = tauloc - sw_optical_props_clouds%ssa(iday,iLay,iGpt) = ssaloc - sw_optical_props_clouds%g(iday,iLay,iGpt) = asyloc - endif - enddo - enddo - enddo endif end subroutine rrtmgp_sw_cloud_sampling_run diff --git a/physics/rrtmgp_sw_cloud_sampling.meta b/physics/rrtmgp_sw_cloud_sampling.meta index cda161e81..1415108f8 100644 --- a/physics/rrtmgp_sw_cloud_sampling.meta +++ b/physics/rrtmgp_sw_cloud_sampling.meta @@ -14,6 +14,34 @@ dimensions = () type = logical intent = in +[imfdeepcnv] + standard_name = control_for_deep_convection_scheme + long_name = flag for mass-flux deep convection scheme + units = flag + dimensions = () + type = integer + intent = in +[imfdeepcnv_gf] + standard_name = identifier_for_grell_freitas_deep_convection + long_name = flag for Grell-Freitas deep convection scheme + units = flag + dimensions = () + type = integer + intent = in +[imfdeepcnv_samf] + standard_name = identifer_for_scale_aware_mass_flux_deep_convection + long_name = flag for SAMF deep convection scheme + units = flag + dimensions = () + type = integer + intent = in +[iovr_convcld] + standard_name = flag_for_convective_cloud_overlap_method_for_radiation + long_name = flag for convective cloud overlap method + units = flag + dimensions = () + type = integer + intent = in [ncol] standard_name = horizontal_loop_extent long_name = horizontal dimension @@ -121,6 +149,22 @@ type = real kind = kind_phys intent = in +[cld_cnv_frac] + standard_name = convective_cloud_fraction_for_RRTMGP + long_name = layer convective cloud fraction + units = frac + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cnv_cloud_overlap_param] + standard_name = convective_cloud_overlap_param + long_name = convective cloud overlap parameter + units = km + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in [cloud_overlap_param] standard_name = cloud_overlap_param long_name = cloud overlap parameter @@ -144,6 +188,13 @@ dimensions = () type = ty_optical_props_2str intent = in +[sw_optical_props_cnvcloudsByBand] + standard_name = shortwave_optical_properties_for_convective_cloudy_atmosphere_by_band + long_name = Fortran DDT containing RRTMGP optical properties + units = DDT + dimensions = () + type = ty_optical_props_2str + intent = in [sw_optical_props_precipByBand] standard_name = shortwave_optical_properties_for_precipitation_by_band long_name = Fortran DDT containing RRTMGP optical properties @@ -158,6 +209,13 @@ dimensions = () type = ty_optical_props_2str intent = out +[sw_optical_props_cnvclouds] + standard_name = shortwave_optical_properties_for_convective_cloudy_atmosphere + long_name = Fortran DDT containing RRTMGP optical properties + units = DDT + dimensions = () + type = ty_optical_props_2str + intent = out [sw_optical_props_precip] standard_name = shortwave_optical_properties_for_precipitation long_name = Fortran DDT containing RRTMGP optical properties diff --git a/physics/rrtmgp_sw_rte.F90 b/physics/rrtmgp_sw_rte.F90 index 1726d4bbd..e1879bd7a 100644 --- a/physics/rrtmgp_sw_rte.F90 +++ b/physics/rrtmgp_sw_rte.F90 @@ -24,53 +24,58 @@ end subroutine rrtmgp_sw_rte_init !! \section arg_table_rrtmgp_sw_rte_run !! \htmlinclude rrtmgp_sw_rte.html !! - subroutine rrtmgp_sw_rte_run(doSWrad, doSWclrsky, nCol, nLev, nDay, idxday, coszen, p_lay, & - t_lay, top_at_1, iSFC, sw_optical_props_clrsky, sfc_alb_nir_dir, sfc_alb_nir_dif, & - sfc_alb_uvvis_dir, sfc_alb_uvvis_dif, toa_src_sw, sw_optical_props_clouds, & - sw_optical_props_aerosol, scmpsw, fluxswUP_allsky, fluxswDOWN_allsky, fluxswUP_clrsky,& - fluxswDOWN_clrsky, errmsg, errflg) - + subroutine rrtmgp_sw_rte_run(doSWrad, doSWclrsky, nCol, nLev, nDay, idxday, coszen, p_lay,& + t_lay, top_at_1, doGP_sgs_cnv, doGP_sgs_mynn, iSFC, sfc_alb_nir_dir, sfc_alb_nir_dif,& + sfc_alb_uvvis_dir, sfc_alb_uvvis_dif, toa_src_sw, sw_optical_props_clrsky, & + sw_optical_props_clouds, sw_optical_props_precipByBand, & + sw_optical_props_cnvcloudsByBand, sw_optical_props_MYNNcloudsByBand, & + sw_optical_props_aerosol, scmpsw, fluxswUP_allsky, fluxswDOWN_allsky, & + fluxswUP_clrsky, fluxswDOWN_clrsky, errmsg, errflg) + ! Inputs logical, intent(in) :: & - top_at_1, & ! Vertical ordering flag - doSWrad, & ! Flag to calculate SW irradiances - doSWclrsky ! Compute clear-sky fluxes? + top_at_1, & ! Vertical ordering flag + doGP_sgs_mynn, & ! Flag for MYNN-EDMF PBL cloud scheme + doGP_sgs_cnv, & ! Flag for sgs convective clouds scheme + doSWrad, & ! Flag to calculate SW irradiances + doSWclrsky ! Compute clear-sky fluxes? integer, intent(in) :: & - nCol, & ! Number of horizontal gridpoints - nday, & ! Number of daytime points - nLev, & ! Number of vertical levels - iSFC ! Vertical index for surface-level - integer, intent(in), dimension(ncol) :: & - idxday ! Index array for daytime points - real(kind_phys),intent(in), dimension(ncol) :: & - coszen ! Cosize of SZA - real(kind_phys), dimension(ncol,NLev), intent(in) :: & - p_lay, & ! Pressure @ model layer-centers (Pa) - t_lay ! Temperature (K) + nCol, & ! Number of horizontal gridpoints + nday, & ! Number of daytime points + nLev, & ! Number of vertical levels + iSFC ! Vertical index for surface-level + integer, intent(in), dimension(:) :: & + idxday ! Index array for daytime points + real(kind_phys),intent(in), dimension(:) :: & + sfc_alb_nir_dir, & ! Surface albedo (direct) + sfc_alb_nir_dif, & ! Surface albedo (diffuse) + sfc_alb_uvvis_dir, & ! Surface albedo (direct) + sfc_alb_uvvis_dif, & ! Surface albedo (diffuse) + coszen ! Cosize of SZA + real(kind_phys), dimension(:,:), intent(in) :: & + p_lay, & ! Pressure @ model layer-centers (Pa) + t_lay, & ! Temperature (K) + toa_src_sw ! TOA incident spectral flux (W/m2) type(ty_optical_props_2str),intent(inout) :: & - sw_optical_props_clrsky ! RRTMGP DDT: shortwave clear-sky radiative properties - type(ty_optical_props_2str),intent(in) :: & - sw_optical_props_clouds, & ! RRTMGP DDT: shortwave cloud radiative properties - sw_optical_props_aerosol ! RRTMGP DDT: shortwave aerosol radiative properties - real(kind_phys), dimension(sw_gas_props%get_nband(),ncol), intent(in) :: & - sfc_alb_nir_dir, & ! Surface albedo (direct) - sfc_alb_nir_dif, & ! Surface albedo (diffuse) - sfc_alb_uvvis_dir, & ! Surface albedo (direct) - sfc_alb_uvvis_dif ! Surface albedo (diffuse) - real(kind_phys), dimension(ncol,sw_gas_props%get_ngpt()), intent(in) :: & - toa_src_sw ! TOA incident spectral flux (W/m2) + sw_optical_props_clrsky ! RRTMGP DDT: shortwave clear-sky radiative properties + type(ty_optical_props_2str),intent(in) :: & + sw_optical_props_clouds, & ! RRTMGP DDT: shortwave cloud optical properties + sw_optical_props_cnvcloudsByBand, & ! RRTMGP DDT: shortwave convecive cloud optical properties + sw_optical_props_MYNNcloudsByBand, & ! RRTMGP DDT: shortwave MYNN-EDMF PBL cloud optical properties + sw_optical_props_precipByBand, & ! RRTMGP DDT: shortwave precipitation optical properties + sw_optical_props_aerosol ! RRTMGP DDT: shortwave aerosol optical properties ! Outputs character(len=*), intent(out) :: & errmsg ! CCPP error message integer, intent(out) :: & errflg ! CCPP error flag - real(kind_phys), dimension(ncol,NLev+1), intent(inout) :: & + real(kind_phys), dimension(:,:), intent(inout) :: & fluxswUP_allsky, & ! RRTMGP upward all-sky flux profiles (W/m2) fluxswDOWN_allsky, & ! RRTMGP downward all-sky flux profiles (W/m2) fluxswUP_clrsky, & ! RRTMGP upward clear-sky flux profiles (W/m2) fluxswDOWN_clrsky ! RRTMGP downward clear-sky flux profiles (W/m2) - type(cmpfsw_type), dimension(ncol), intent(inout) :: & + type(cmpfsw_type), dimension(:), intent(inout) :: & scmpsw ! 2D surface fluxes, components: ! uvbfc - total sky downward uv-b flux (W/m2) ! uvbf0 - clear sky downward uv-b flux (W/m2) @@ -88,7 +93,9 @@ subroutine rrtmgp_sw_rte_run(doSWrad, doSWclrsky, nCol, nLev, nDay, idxday, cosz real(kind_phys), dimension(nday,NLev+1,sw_gas_props%get_nband()),target :: & fluxSW_up_allsky, fluxSW_up_clrsky, fluxSW_dn_allsky, fluxSW_dn_clrsky, fluxSW_dn_dir_allsky real(kind_phys), dimension(ncol,NLev) :: vmrTemp - integer :: iBand + integer :: iBand, iDay,ibd + real(kind_phys), dimension(2,sw_gas_props%get_nband()) :: bandlimits + real(kind_phys), dimension(2), parameter :: nIR_uvvis_bnd = (/12850,16000/) ! Initialize CCPP error handling variables errmsg = '' @@ -105,23 +112,30 @@ subroutine rrtmgp_sw_rte_run(doSWrad, doSWclrsky, nCol, nLev, nDay, idxday, cosz flux_clrsky%bnd_flux_up => fluxSW_up_clrsky flux_clrsky%bnd_flux_dn => fluxSW_dn_clrsky - ! *Note* Legacy RRTMG code. May need to revisit + ! Use near-IR albedo for bands with wavenumbers extending to 12850cm-1 + ! Use uv-vis albedo for bands with wavenumbers greater than 16000cm-1 + ! For overlapping band, average near-IR and us-vis albedos. + bandlimits = sw_gas_props%get_band_lims_wavenumber() do iBand=1,sw_gas_props%get_nband() - if (iBand .lt. 10) then - sfc_alb_dir(iBand,:) = sfc_alb_nir_dir(iBand,idxday(1:nday)) - sfc_alb_dif(iBand,:) = sfc_alb_nir_dif(iBand,idxday(1:nday)) + if (bandlimits(1,iBand) .lt. nIR_uvvis_bnd(1)) then + sfc_alb_dir(iBand,:) = sfc_alb_nir_dir(idxday(1:nday)) + sfc_alb_dif(iBand,:) = sfc_alb_nir_dif(idxday(1:nday)) endif - if (iBand .eq. 10) then - sfc_alb_dir(iBand,:) = 0.5_kind_phys*(sfc_alb_nir_dir(iBand,idxday(1:nday)) + sfc_alb_uvvis_dir(iBand,idxday(1:nday))) - sfc_alb_dif(iBand,:) = 0.5_kind_phys*(sfc_alb_nir_dif(iBand,idxday(1:nday)) + sfc_alb_uvvis_dif(iBand,idxday(1:nday))) + if (bandlimits(1,iBand) .eq. nIR_uvvis_bnd(1)) then + sfc_alb_dir(iBand,:) = 0.5_kind_phys*(sfc_alb_nir_dir(idxday(1:nday)) + sfc_alb_uvvis_dir(idxday(1:nday))) + sfc_alb_dif(iBand,:) = 0.5_kind_phys*(sfc_alb_nir_dif(idxday(1:nday)) + sfc_alb_uvvis_dif(idxday(1:nday))) + ibd = iBand endif - if (iBand .gt. 10) then - sfc_alb_dir(iBand,:) = sfc_alb_uvvis_dir(iBand,idxday(1:nday)) - sfc_alb_dif(iBand,:) = sfc_alb_uvvis_dif(iBand,idxday(1:nday)) + if (bandlimits(1,iBand) .ge. nIR_uvvis_bnd(2)) then + sfc_alb_dir(iBand,:) = sfc_alb_uvvis_dir(idxday(1:nday)) + sfc_alb_dif(iBand,:) = sfc_alb_uvvis_dif(idxday(1:nday)) endif enddo + ! ! Compute clear-sky fluxes (if requested) + ! + ! Clear-sky fluxes (gas+aerosol) call check_error_msg('rrtmgp_sw_rte_run',sw_optical_props_aerosol%increment(sw_optical_props_clrsky)) ! Delta-scale optical properties @@ -139,10 +153,25 @@ subroutine rrtmgp_sw_rte_run(doSWrad, doSWclrsky, nCol, nLev, nDay, idxday, cosz fluxswUP_clrsky(idxday(1:nday),:) = sum(flux_clrsky%bnd_flux_up,dim=3) fluxswDOWN_clrsky(idxday(1:nday),:) = sum(flux_clrsky%bnd_flux_dn,dim=3) endif - + + ! ! Compute all-sky fluxes - ! All-sky fluxes (clear-sky + clouds) + ! + + ! Include convective cloud? + if (doGP_sgs_cnv) then + call check_error_msg('rrtmgp_sw_rte_run',sw_optical_props_cnvcloudsByBand%increment(sw_optical_props_clrsky)) + endif + + ! Include MYNN-EDMF PBL cloud? + if (doGP_sgs_mynn) then + call check_error_msg('rrtmgp_sw_rte_run',sw_optical_props_MYNNcloudsByBand%increment(sw_optical_props_clrsky)) + endif + + ! All-sky fluxes (clear-sky + clouds + precipitation) + call check_error_msg('rrtmgp_sw_rte_run',sw_optical_props_precipByBand%increment(sw_optical_props_clrsky)) call check_error_msg('rrtmgp_sw_rte_run',sw_optical_props_clouds%increment(sw_optical_props_clrsky)) + ! Delta-scale optical properties call check_error_msg('rrtmgp_sw_rte_run',sw_optical_props_clrsky%delta_scale()) call check_error_msg('rrtmgp_sw_rte_run',rte_sw( & @@ -153,12 +182,26 @@ subroutine rrtmgp_sw_rte_run(doSWrad, doSWclrsky, nCol, nLev, nDay, idxday, cosz sfc_alb_dir, & ! IN - Shortwave surface albedo (direct) sfc_alb_dif, & ! IN - Shortwave surface albedo (diffuse) flux_allsky)) ! OUT - Fluxes, clear-sky, 3D (nCol,NLev,nBand) + ! Store fluxes fluxswUP_allsky(idxday(1:nday),:) = sum(flux_allsky%bnd_flux_up,dim=3) fluxswDOWN_allsky(idxday(1:nday),:) = sum(flux_allsky%bnd_flux_dn,dim=3) - scmpsw(idxday(1:nday))%nirbm = sum(flux_allsky%bnd_flux_dn_dir(1:nday,iSFC,:),dim=2) - scmpsw(idxday(1:nday))%nirdf = sum(flux_allsky%bnd_flux_dn( 1:nday,iSFC,:),dim=2) - & - sum(flux_allsky%bnd_flux_dn_dir(1:nday,iSFC,:),dim=2) + do iDay=1,nDay + ! Near IR + scmpsw(idxday(iDay))%nirbm = sum(flux_allsky%bnd_flux_dn_dir(iDay,iSFC,1:ibd-1)) + & + flux_allsky%bnd_flux_dn_dir(iDay,iSFC,ibd)/2. + scmpsw(idxday(iDay))%nirdf = (sum(flux_allsky%bnd_flux_dn(iDay,iSFC,1:ibd-1)) + & + flux_allsky%bnd_flux_dn(iDay,iSFC,ibd)/2.) - & + (sum(flux_allsky%bnd_flux_dn_dir(iDay,iSFC,1:ibd-1)) + & + flux_allsky%bnd_flux_dn_dir(iDay,iSFC,ibd)/2.) + ! UV-VIS + scmpsw(idxday(iDay))%visbm = sum(flux_allsky%bnd_flux_dn_dir(iDay,iSFC,ibd+1:sw_gas_props%get_nband())) + & + flux_allsky%bnd_flux_dn_dir(iDay,iSFC,ibd)/2. + scmpsw(idxday(iDay))%visdf = (sum(flux_allsky%bnd_flux_dn(iDay,iSFC,ibd+1:sw_gas_props%get_nband())) + & + flux_allsky%bnd_flux_dn(iDay,iSFC,ibd)/2. ) - & + (sum(flux_allsky%bnd_flux_dn_dir(iDay,iSFC,ibd+1:sw_gas_props%get_nband())) + & + flux_allsky%bnd_flux_dn_dir(iDay,iSFC,ibd)/2.) + enddo else fluxswUP_allsky(:,:) = 0._kind_phys fluxswDOWN_allsky(:,:) = 0._kind_phys @@ -166,6 +209,7 @@ subroutine rrtmgp_sw_rte_run(doSWrad, doSWclrsky, nCol, nLev, nDay, idxday, cosz fluxswDOWN_clrsky(:,:) = 0._kind_phys scmpsw = cmpfsw_type( 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 ) endif + end subroutine rrtmgp_sw_rte_run ! ######################################################################################### diff --git a/physics/rrtmgp_sw_rte.meta b/physics/rrtmgp_sw_rte.meta index e59698c0f..9ab24c8b3 100644 --- a/physics/rrtmgp_sw_rte.meta +++ b/physics/rrtmgp_sw_rte.meta @@ -73,6 +73,20 @@ dimensions = () type = logical intent = in +[doGP_sgs_cnv] + standard_name = flag_to_include_sgs_convective_cloud_in_RRTMGP + long_name = logical flag to control sgs convective cloud in RRTMGP + units = flag + dimensions = () + type = logical + intent = in +[doGP_sgs_mynn] + standard_name = flag_to_include_sgs_MYNN_EDMF_cloud_in_RRTMGP + long_name = logical flag to control MYNN-EDMF PBL cloud in RRTMGP + units = flag + dimensions = () + type = logical + intent = in [iSFC] standard_name = vertical_index_for_surface_in_RRTMGP long_name = index for surface layer in RRTMGP @@ -102,6 +116,27 @@ dimensions = () type = ty_optical_props_2str intent = in +[sw_optical_props_precipByBand] + standard_name = shortwave_optical_properties_for_precipitation_by_band + long_name = Fortran DDT containing RRTMGP optical properties + units = DDT + dimensions = () + type = ty_optical_props_2str + intent = in +[sw_optical_props_cnvcloudsByBand] + standard_name = shortwave_optical_properties_for_convective_cloudy_atmosphere_by_band + long_name = Fortran DDT containing RRTMGP optical properties + units = DDT + dimensions = () + type = ty_optical_props_2str + intent = in +[sw_optical_props_MYNNcloudsByBand] + standard_name = shortwave_optical_properties_for_MYNN_EDMF_PBL_cloudy_atmosphere_by_band + long_name = Fortran DDT containing RRTMGP optical properties + units = DDT + dimensions = () + type = ty_optical_props_2str + intent = in [sw_optical_props_aerosol] standard_name = shortwave_optical_properties_for_aerosols long_name = Fortran DDT containing RRTMGP optical properties @@ -110,34 +145,34 @@ type = ty_optical_props_2str intent = in [sfc_alb_nir_dir] - standard_name = surface_albedo_nearIR_direct - long_name = near-IR (direct) surface albedo (sfc_alb_nir_dir) - units = none - dimensions = (number_of_shortwave_bands,horizontal_loop_extent) + standard_name = surface_albedo_due_to_near_IR_direct + long_name = surface albedo due to near IR direct beam + units = frac + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in [sfc_alb_nir_dif] - standard_name = surface_albedo_nearIR_diffuse - long_name = near-IR (diffuse) surface albedo (sfc_alb_nir_dif) - units = none - dimensions = (number_of_shortwave_bands,horizontal_loop_extent) + standard_name = surface_albedo_due_to_near_IR_diffused + long_name = surface albedo due to near IR diffused beam + units = frac + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in [sfc_alb_uvvis_dir] - standard_name = surface_albedo_uvvis_direct - long_name = UVVIS (direct) surface albedo (sfc_alb_uvvis_dir) - units = none - dimensions = (number_of_shortwave_bands,horizontal_loop_extent) + standard_name = surface_albedo_due_to_UV_and_VIS_direct + long_name = surface albedo due to UV+VIS direct beam + units = frac + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in [sfc_alb_uvvis_dif] - standard_name = surface_albedo_uvvis_diffuse - long_name = UVVIS (diffuse) surface albedo (sfc_alb_uvvis_dif) - units = none - dimensions = (number_of_shortwave_bands,horizontal_loop_extent) + standard_name = surface_albedo_due_to_UV_and_VIS_diffused + long_name = surface albedo due to UV+VIS diffused beam + units = frac + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in diff --git a/physics/samfdeepcnv.f b/physics/samfdeepcnv.f index 3801e684f..bb33b20cf 100644 --- a/physics/samfdeepcnv.f +++ b/physics/samfdeepcnv.f @@ -149,23 +149,22 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & & dh, dhh, dp, & dq, dqsdp, dqsdt, dt, & dt2, dtmax, dtmin, - & dxcrtas, dxcrtuf, + & dxcrtas, dxcrtuf, & dv1h, dv2h, dv3h, - & dv2q, & dz, dz1, e1, edtmax, & edtmaxl, edtmaxs, el2orc, elocp, & es, etah, & cthk, dthk, ! & evfact, evfactl, & fact1, fact2, factor, - & gamma, pprime, cm, + & gamma, pprime, cm, cq, & qlk, qrch, qs, & rain, rfact, shear, tfac, & val, val1, val2, & w1, w1l, w1s, w2, & w2l, w2s, w3, w3l, & w3s, w4, w4l, w4s, - & rho, betaw, + & rho, betaw, tauadv, & xdby, xpw, xpwd, ! & xqrch, mbdt, tem, & xqrch, tem, tem1, tem2, @@ -179,8 +178,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & ! real(kind=kind_phys) aa1(im), acrt(im), acrtfct(im), real(kind=kind_phys) aa1(im), tkemean(im),clamt(im), & ps(im), del(im,km), prsl(im,km), -! & umean(im), tauadv(im), gdx(im), - & gdx(im), + & umean(im), advfac(im), gdx(im), & delhbar(im), delq(im), delq2(im), & delqbar(im), delqev(im), deltbar(im), & deltv(im), dtconv(im), edt(im), @@ -225,7 +223,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & ! Until a realistic Nccn is provided, Nccns are assumed ! as Nccn=100 for sea and Nccn=1000 for land ! - parameter(cm=1.0) + parameter(cm=1.0,cq=1.3) ! parameter(fact1=(cvap-cliq)/rv,fact2=hvap/rv-fact1*t0c) parameter(clamd=0.03,tkemx=0.65,tkemn=0.05) parameter(clamca=0.03) @@ -249,8 +247,11 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & & wet_dep ! ! for updraft velocity calculation - real(kind=kind_phys) wu2(im,km), buo(im,km), drag(im,km) - real(kind=kind_phys) wc(im), scaldfunc(im), sigmagfm(im) + real(kind=kind_phys) wu2(im,km), buo(im,km), drag(im,km), + & wc(im) +! +! for updraft fraction & scale-aware function + real(kind=kind_phys) scaldfunc(im), sigmagfm(im) ! c cloud water ! real(kind=kind_phys) tvo(im,km) @@ -264,7 +265,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & & dellae(im,km,ntr), & dellau(im,km), dellav(im,km), hcko(im,km), & ucko(im,km), vcko(im,km), qcko(im,km), - & ecko(im,km,ntr), + & ecko(im,km,ntr),ercko(im,km,ntr), & eta(im,km), etad(im,km), zi(im,km), & qrcko(im,km), qrcdo(im,km), & pwo(im,km), pwdo(im,km), c0t(im,km), @@ -365,6 +366,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & xpwav(i)= 0. xpwev(i)= 0. vshear(i) = 0. + advfac(i) = 0. rainevap(i) = 0. gdx(i) = sqrt(garea(i)) enddo @@ -392,6 +394,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & c0(i) = c0s endif enddo +! !> - determine rain conversion parameter above the freezing level which exponentially decreases with decreasing temperature from Han et al.'s (2017) \cite han_et_al_2017 equation 8. do k = 1, km do i = 1, im @@ -582,6 +585,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & ctr(i,k,kk) = qtr(i,k,n) ctro(i,k,kk) = qtr(i,k,n) ecko(i,k,kk) = 0. + ercko(i,k,kk) = 0. ecdo(i,k,kk) = 0. endif enddo @@ -1145,6 +1149,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & if(cnvflg(i)) then indx = kb(i) ecko(i,indx,n) = ctro(i,indx,n) + ercko(i,indx,n) = ctro(i,indx,n) endif enddo enddo @@ -1192,9 +1197,11 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & if(k > kb(i) .and. k < kmax(i)) then dz = zi(i,k) - zi(i,k-1) tem = 0.25 * (xlamue(i,k)+xlamue(i,k-1)) * dz + tem = cq * tem factor = 1. + tem ecko(i,k,n) = ((1.-tem)*ecko(i,k-1,n)+tem* & (ctro(i,k,n)+ctro(i,k-1,n)))/factor + ercko(i,k,n) = ecko(i,k,n) endif endif enddo @@ -1209,9 +1216,11 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & if(k > kb(i) .and. k < kmax(i)) then dz = zi(i,k) - zi(i,k-1) tem = 0.25 * (xlamue(i,k)+xlamue(i,k-1)) * dz + tem = cq * tem factor = 1. + tem ecko(i,k,kk) = ((1. - tem) * ecko(i,k-1,kk) + tem * & (ctro(i,k,kk) + ctro(i,k-1,kk))) / factor + ercko(i,k,kk) = ecko(i,k,kk) chem_c(i,k,n) = fscav(n) * ecko(i,k,kk) tem = chem_c(i,k,n) / (1. + c0t(i,k) * dz) chem_pw(i,k,n) = c0t(i,k) * dz * tem * eta(i,k-1) @@ -1459,10 +1468,10 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & qrch = qeso(i,k) & + gamma * dbyo(i,k) / (hvap * (1. + gamma)) cj - tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz - tem1 = 0.25 * (xlamud(i,k)+xlamud(i,k-1)) * dz - factor = 1. + tem - tem1 - qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5* + tem = 0.25 * (xlamue(i,k)+xlamue(i,k-1)) * dz + tem = cq * tem + factor = 1. + tem + qcko(i,k) = ((1.-tem)*qcko(i,k-1)+tem* & (qo(i,k)+qo(i,k-1)))/factor qrcko(i,k) = qcko(i,k) cj @@ -1634,10 +1643,10 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & qrch = qeso(i,k) & + gamma * dbyo(i,k) / (hvap * (1. + gamma)) cj - tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz - tem1 = 0.25 * (xlamud(i,k)+xlamud(i,k-1)) * dz - factor = 1. + tem - tem1 - qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5* + tem = 0.25 * (xlamue(i,k)+xlamue(i,k-1)) * dz + tem = cq * tem + factor = 1. + tem + qcko(i,k) = ((1.-tem)*qcko(i,k-1)+tem* & (qo(i,k)+qo(i,k-1)))/factor qrcko(i,k) = qcko(i,k) cj @@ -1926,6 +1935,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & if (cnvflg(i) .and. k < jmin(i)) then dz = zi(i,k+1) - zi(i,k) tem = 0.5 * xlamde * dz + tem = cq * tem factor = 1. + tem ecdo(i,k,n) = ((1.-tem)*ecdo(i,k+1,n)+tem* & (ctro(i,k,n)+ctro(i,k+1,n)))/factor @@ -1945,15 +1955,10 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & ! detad = etad(i,k+1) - etad(i,k) cj dz = zi(i,k+1) - zi(i,k) - if(k >= kd94(i)) then - tem = xlamde * dz - tem1 = 0.5 * xlamdd * dz - else - tem = xlamde * dz - tem1 = 0.5 * (xlamd(i)+xlamdd) * dz - endif - factor = 1. + tem - tem1 - qcdo(i,k) = ((1.-tem1)*qrcdo(i,k+1)+tem*0.5* + tem = 0.5 * xlamde * dz + tem = cq * tem + factor = 1. + tem + qcdo(i,k) = ((1.-tem)*qrcdo(i,k+1)+tem* & (qo(i,k)+qo(i,k+1)))/factor cj ! pwdo(i,k) = etad(i,k+1) * qcdo(i,k+1) - @@ -2084,7 +2089,6 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & dv1h = heo(i,k) dv2h = .5 * (heo(i,k) + heo(i,k-1)) dv3h = heo(i,k-1) - dv2q = .5 * (qo(i,k) + qo(i,k-1)) c tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) tem1 = 0.5 * (xlamud(i,k)+xlamud(i,k-1)) @@ -2107,11 +2111,12 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & & + adw*edto(i)*ptem1*etad(i,k)*.5*(hcdo(i,k)+hcdo(i,k-1))*dz & ) * factor cj + tem1 = -eta(i,k) * qrcko(i,k) + tem2 = -eta(i,k-1) * qcko(i,k-1) + ptem1 = -etad(i,k) * qrcdo(i,k) + ptem2 = -etad(i,k-1) * qcdo(i,k-1) dellaq(i,k) = dellaq(i,k) + - & (- (aup*tem*eta(i,k-1)+adw*edto(i)*ptem*etad(i,k))*dv2q*dz - & + aup*tem1*eta(i,k-1)*.5*(qrcko(i,k)+qcko(i,k-1))*dz - & + adw*edto(i)*ptem1*etad(i,k)*.5*(qrcdo(i,k)+qcdo(i,k-1))*dz - & ) * factor + & (aup*(tem1-tem2)-adw*edto(i)*(ptem1-ptem2))*factor cj tem1=eta(i,k)*(uo(i,k)-ucko(i,k)) tem2=eta(i,k-1)*(uo(i,k-1)-ucko(i,k-1)) @@ -2141,7 +2146,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & if(k > jmin(i)) adw = 0. dp = 1000. * del(i,k) cj - tem1 = -eta(i,k) * ecko(i,k,n) + tem1 = -eta(i,k) * ercko(i,k,n) tem2 = -eta(i,k-1) * ecko(i,k-1,n) ptem1 = -etad(i,k) * ecdo(i,k,n) ptem2 = -etad(i,k-1) * ecdo(i,k-1,n) @@ -2500,10 +2505,10 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & xqrch = qeso(i,k) & + gamma * xdby / (hvap * (1. + gamma)) cj - tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz - tem1 = 0.25 * (xlamud(i,k)+xlamud(i,k-1)) * dz - factor = 1. + tem - tem1 - qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5* + tem = 0.25 * (xlamue(i,k)+xlamue(i,k-1)) * dz + tem = cq * tem + factor = 1. + tem + qcko(i,k) = ((1.-tem)*qcko(i,k-1)+tem* & (qo(i,k)+qo(i,k-1)))/factor cj dq = eta(i,k) * (qcko(i,k) - xqrch) @@ -2589,15 +2594,10 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & ! detad = etad(i,k+1) - etad(i,k) cj dz = zi(i,k+1) - zi(i,k) - if(k >= kd94(i)) then - tem = xlamde * dz - tem1 = 0.5 * xlamdd * dz - else - tem = xlamde * dz - tem1 = 0.5 * (xlamd(i)+xlamdd) * dz - endif - factor = 1. + tem - tem1 - qcdo(i,k) = ((1.-tem1)*qrcd(i,k+1)+tem*0.5* + tem = 0.5 * xlamde * dz + tem = cq * tem + factor = 1. + tem + qcdo(i,k) = ((1.-tem)*qrcd(i,k+1)+tem* & (qo(i,k)+qo(i,k+1)))/factor cj ! xpwd = etad(i,k+1) * qcdo(i,k+1) - @@ -2741,41 +2741,40 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & endif ! !> - Calculate advective time scale (tauadv) using a mean cloud layer wind speed. -! do i= 1, im -! if(cnvflg(i)) then -! sumx(i) = 0. -! umean(i) = 0. -! endif -! enddo -! do k = 2, km1 -! do i = 1, im -! if(cnvflg(i)) then -! if(k >= kbcon1(i) .and. k < ktcon1(i)) then -! dz = zi(i,k) - zi(i,k-1) -! tem = sqrt(u1(i,k)*u1(i,k)+v1(i,k)*v1(i,k)) -! umean(i) = umean(i) + tem * dz -! sumx(i) = sumx(i) + dz -! endif -! endif -! enddo -! enddo -! do i= 1, im -! if(cnvflg(i)) then -! umean(i) = umean(i) / sumx(i) -! umean(i) = max(umean(i), 1.) -! tauadv(i) = gdx(i) / umean(i) -! endif -! enddo + do i= 1, im + if(cnvflg(i)) then + sumx(i) = 0. + umean(i) = 0. + endif + enddo + do k = 2, km1 + do i = 1, im + if(cnvflg(i)) then + if(k >= kbcon1(i) .and. k < ktcon1(i)) then + dz = zi(i,k) - zi(i,k-1) + tem = sqrt(u1(i,k)*u1(i,k)+v1(i,k)*v1(i,k)) + umean(i) = umean(i) + tem * dz + sumx(i) = sumx(i) + dz + endif + endif + enddo + enddo + do i= 1, im + if(cnvflg(i)) then + umean(i) = umean(i) / sumx(i) + umean(i) = max(umean(i), 1.) + tauadv = gdx(i) / umean(i) + advfac(i) = tauadv / dtconv(i) + advfac(i) = min(advfac(i), 1.) + endif + enddo !> - From Han et al.'s (2017) \cite han_et_al_2017 equation 6, calculate cloud base mass flux as a function of the mean updraft velcoity for the grid sizes where the quasi-equilibrium assumption of Arakawa-Schubert is not valid any longer. !! As discussed in Han et al. (2017) \cite han_et_al_2017 , when dtconv is larger than tauadv, the convective mixing is not fully conducted before the cumulus cloud is advected out of the grid cell. In this case, therefore, the cloud base mass flux is further reduced in proportion to the ratio of tauadv to dtconv. do i= 1, im if(cnvflg(i) .and. .not.asqecflg(i)) then k = kbcon(i) rho = po(i,k)*100. / (rd*to(i,k)) -! tfac = tauadv(i) / dtconv(i) -! tfac = min(tfac, 1.) -! xmb(i) = tfac*betaw*rho*wc(i) - xmb(i) = betaw*rho*wc(i) + xmb(i) = advfac(i)*betaw*rho*wc(i) endif enddo !> - For the cases where the quasi-equilibrium assumption of Arakawa-Schubert is valid, first calculate the large scale destabilization as in equation 5 of Pan and Wu (1995) \cite pan_and_wu_1995 : @@ -2815,10 +2814,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & !! !! Again when dtconv is larger than tauadv, the cloud base mass flux is further reduced in proportion to the ratio of tauadv to dtconv. if(asqecflg(i)) then -! tfac = tauadv(i) / dtconv(i) -! tfac = min(tfac, 1.) -! xmb(i) = -tfac * fld(i) / xk(i) - xmb(i) = -fld(i) / xk(i) + xmb(i) = -advfac(i) * fld(i) / xk(i) endif enddo !! @@ -2832,18 +2828,6 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & !! ! !> - For scale-aware parameterization, the updraft fraction (sigmagfm) is first computed as a function of the lateral entrainment rate at cloud base (see Han et al.'s (2017) \cite han_et_al_2017 equation 4 and 5), following the study by Grell and Freitas (2014) \cite grell_and_freitas_2014. - if(hwrf_samfdeep) then - do i = 1, im - if(cnvflg(i)) then - tem = min(max(xlamx(i), 7.e-5), 3.e-4) - tem = 0.2 / tem - tem1 = 3.14 * tem * tem - sigmagfm(i) = tem1 / garea(i) - sigmagfm(i) = max(sigmagfm(i), 0.001) - sigmagfm(i) = min(sigmagfm(i), 0.999) - endif - enddo - else do i = 1, im if(cnvflg(i)) then tem = min(max(xlamue(i,kbcon(i)), 7.e-5), 3.e-4) @@ -2854,7 +2838,6 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & sigmagfm(i) = min(sigmagfm(i), 0.999) endif enddo - endif ! !> - Then, calculate the reduction factor (scaldfunc) of the vertical convective eddy transport of mass flux as a function of updraft fraction from the studies by Arakawa and Wu (2013) \cite arakawa_and_wu_2013 (also see Han et al.'s (2017) \cite han_et_al_2017 equation 1 and 2). The final cloud base mass flux with scale-aware parameterization is obtained from the mass flux when sigmagfm << 1, multiplied by the reduction factor (Han et al.'s (2017) \cite han_et_al_2017 equation 2). do i = 1, im diff --git a/physics/samfshalcnv.f b/physics/samfshalcnv.f index 0e11ed49c..364049e4d 100644 --- a/physics/samfshalcnv.f +++ b/physics/samfshalcnv.f @@ -102,15 +102,16 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & & c0l, d0, & desdt, dp, & dq, dqsdp, dqsdt, dt, - & dt2, dtmax, dtmin, dxcrt, + & dt2, dtmax, dtmin, + & dxcrt, dxcrtc0, & dv1h, dv2h, dv3h, - & dv2q, & dz, dz1, e1, - & el2orc, elocp, aafac, cm, - & es, etah, h1, + & el2orc, elocp, aafac, + & cm, cq, + & es, etah, h1, shevf, ! & evfact, evfactl, & fact1, fact2, factor, dthk, - & gamma, pprime, betaw, + & gamma, pprime, betaw, tauadv, & qlk, qrch, qs, & rfact, shear, tfac, & val, val1, val2, @@ -127,8 +128,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & real(kind=kind_phys) aa1(im), cina(im), & tkemean(im), clamt(im), & ps(im), del(im,km), prsl(im,km), -! & umean(im), tauadv(im), gdx(im), - & gdx(im), + & umean(im), advfac(im), gdx(im), & delhbar(im), delq(im), delq2(im), & delqbar(im), delqev(im), deltbar(im), ! & deltv(im), dtconv(im), edt(im), @@ -172,16 +172,17 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & ! Until a realistic Nccn is provided, Nccns are assumed ! as Nccn=100 for sea and Nccn=1000 for land ! - parameter(cm=1.0) + parameter(cm=1.0,cq=1.3) ! parameter(fact1=(cvap-cliq)/rv,fact2=hvap/rv-fact1*t0c) parameter(clamd=0.1,tkemx=0.65,tkemn=0.05) parameter(dtke=tkemx-tkemn) parameter(dthk=25.,sfclfac=0.2,rhcrt=0.75) parameter(cinpcrmx=180.,cinpcrmn=120.) - parameter(cinacrmx=-120.) +! shevf is an enhancing evaporation factor for shallow convection + parameter(cinacrmx=-120.,shevf=2.0) parameter(dtmax=10800.,dtmin=600.) parameter(bet1=1.875,cd1=.506,f1=2.0,gam1=.5) - parameter(betaw=.03,dxcrt=15.e3) + parameter(betaw=.03,dxcrt=15.e3,dxcrtc0=9.e3) parameter(h1=0.33333333) c local variables and arrays real(kind=kind_phys) pfld(im,km), to(im,km), qo(im,km), @@ -195,8 +196,11 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & real(kind=kind_phys), parameter :: escav = 0.8 ! wet scavenging efficiency ! ! for updraft velocity calculation - real(kind=kind_phys) wu2(im,km), buo(im,km), drag(im,km) - real(kind=kind_phys) wc(im), scaldfunc(im), sigmagfm(im) + real(kind=kind_phys) wu2(im,km), buo(im,km), drag(im,km), + & wc(im) +! +! for updraft fraction & scale-aware function + real(kind=kind_phys) scaldfunc(im), sigmagfm(im) ! c cloud water ! real(kind=kind_phys) qlko_ktcon(im), dellal(im,km), tvo(im,km), @@ -209,7 +213,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & & dellau(im,km), dellav(im,km), hcko(im,km), & ucko(im,km), vcko(im,km), qcko(im,km), & qrcko(im,km), ecko(im,km,ntr), - & eta(im,km), + & ercko(im,km,ntr), eta(im,km), & zi(im,km), pwo(im,km), c0t(im,km), & sumx(im), tx1(im), cnvwt(im,km) &, rhbar(im) @@ -290,6 +294,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & aa1(i) = 0. cina(i) = 0. ! vshear(i) = 0. + advfac(i) = 0. gdx(i) = sqrt(garea(i)) xmb(i) = 0. scaldfunc(i)=-1.0 ! wang initialized @@ -337,6 +342,15 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & endif enddo ! +!> - determine scale-aware rain conversion parameter decreasing with decreasing grid size + do i=1,im + if(gdx(i) < dxcrtc0) then + tem = gdx(i) / dxcrtc0 + tem1 = tem**3 + c0(i) = c0(i) * tem1 + endif + enddo +! !> - determine rain conversion parameter above the freezing level which exponentially decreases with decreasing temperature from Han et al.'s (2017) \cite han_et_al_2017 equation 8. do k = 1, km do i = 1, im @@ -496,6 +510,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & ctr(i,k,kk) = qtr(i,k,n) ctro(i,k,kk) = qtr(i,k,n) ecko(i,k,kk) = 0. + ercko(i,k,kk) = 0. endif enddo enddo @@ -950,6 +965,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & if(cnvflg(i)) then indx = kb(i) ecko(i,indx,n) = ctro(i,indx,n) + ercko(i,indx,n) = ctro(i,indx,n) endif enddo enddo @@ -996,9 +1012,11 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & if(k > kb(i) .and. k < kmax(i)) then dz = zi(i,k) - zi(i,k-1) tem = 0.25 * (xlamue(i,k)+xlamue(i,k-1)) * dz + tem = cq * tem factor = 1. + tem ecko(i,k,n) = ((1.-tem)*ecko(i,k-1,n)+tem* & (ctro(i,k,n)+ctro(i,k-1,n)))/factor + ercko(i,k,n) = ecko(i,k,n) endif endif enddo @@ -1013,9 +1031,11 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & if(k > kb(i) .and. k < kmax(i)) then dz = zi(i,k) - zi(i,k-1) tem = 0.25 * (xlamue(i,k)+xlamue(i,k-1)) * dz + tem = cq * tem factor = 1. + tem ecko(i,k,kk) = ((1. - tem) * ecko(i,k-1,kk) + tem * & (ctro(i,k,kk) + ctro(i,k-1,kk))) / factor + ercko(i,k,kk) = ecko(i,k,kk) chem_c(i,k,n) = escav * fscav(n) * ecko(i,k,kk) tem = chem_c(i,k,n) / (1. + c0t(i,k) * dz) chem_pw(i,k,n) = c0t(i,k) * dz * tem * eta(i,k-1) @@ -1192,10 +1212,10 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & qrch = qeso(i,k) & + gamma * dbyo(i,k) / (hvap * (1. + gamma)) cj - tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz - tem1 = 0.5 * xlamud(i) * dz - factor = 1. + tem - tem1 - qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5* + tem = 0.25 * (xlamue(i,k)+xlamue(i,k-1)) * dz + tem = cq * tem + factor = 1. + tem + qcko(i,k) = ((1.-tem)*qcko(i,k-1)+tem* & (qo(i,k)+qo(i,k-1)))/factor qrcko(i,k) = qcko(i,k) cj @@ -1358,10 +1378,10 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & qrch = qeso(i,k) & + gamma * dbyo(i,k) / (hvap * (1. + gamma)) cj - tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz - tem1 = 0.5 * xlamud(i) * dz - factor = 1. + tem - tem1 - qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5* + tem = 0.25 * (xlamue(i,k)+xlamue(i,k-1)) * dz + tem = cq * tem + factor = 1. + tem + qcko(i,k) = ((1.-tem)*qcko(i,k-1)+tem* & (qo(i,k)+qo(i,k-1)))/factor qrcko(i,k) = qcko(i,k) cj @@ -1565,7 +1585,6 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & dv1h = heo(i,k) dv2h = .5 * (heo(i,k) + heo(i,k-1)) dv3h = heo(i,k-1) - dv2q = .5 * (qo(i,k) + qo(i,k-1)) c tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) tem1 = xlamud(i) @@ -1578,10 +1597,9 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & & + tem1*eta(i,k-1)*.5*(hcko(i,k)+hcko(i,k-1))*dz & ) * factor cj - dellaq(i,k) = dellaq(i,k) + - & ( - tem*eta(i,k-1)*dv2q*dz - & + tem1*eta(i,k-1)*.5*(qrcko(i,k)+qcko(i,k-1))*dz - & ) * factor + tem1 = -eta(i,k) * qrcko(i,k) + tem2 = -eta(i,k-1) * qcko(i,k-1) + dellaq(i,k) = dellaq(i,k) + (tem1-tem2) * factor cj tem1=eta(i,k)*(uo(i,k)-ucko(i,k)) tem2=eta(i,k-1)*(uo(i,k-1)-ucko(i,k-1)) @@ -1603,7 +1621,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & if(k > kb(i) .and. k < ktcon(i)) then dp = 1000. * del(i,k) cj - tem1 = -eta(i,k) * ecko(i,k,n) + tem1 = -eta(i,k) * ercko(i,k,n) tem2 = -eta(i,k-1) * ecko(i,k-1,n) dellae(i,k,n) = dellae(i,k,n) + (tem1-tem2) * grav/dp cj @@ -1775,31 +1793,33 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & enddo ! !> - Calculate advective time scale (tauadv) using a mean cloud layer wind speed. -! do i= 1, im -! if(cnvflg(i)) then -! sumx(i) = 0. -! umean(i) = 0. -! endif -! enddo -! do k = 2, km1 -! do i = 1, im -! if(cnvflg(i)) then -! if(k >= kbcon1(i) .and. k < ktcon1(i)) then -! dz = zi(i,k) - zi(i,k-1) -! tem = sqrt(u1(i,k)*u1(i,k)+v1(i,k)*v1(i,k)) -! umean(i) = umean(i) + tem * dz -! sumx(i) = sumx(i) + dz -! endif -! endif -! enddo -! enddo -! do i= 1, im -! if(cnvflg(i)) then -! umean(i) = umean(i) / sumx(i) -! umean(i) = max(umean(i), 1.) -! tauadv(i) = gdx(i) / umean(i) -! endif -! enddo + do i= 1, im + if(cnvflg(i)) then + sumx(i) = 0. + umean(i) = 0. + endif + enddo + do k = 2, km1 + do i = 1, im + if(cnvflg(i)) then + if(k >= kbcon1(i) .and. k < ktcon1(i)) then + dz = zi(i,k) - zi(i,k-1) + tem = sqrt(u1(i,k)*u1(i,k)+v1(i,k)*v1(i,k)) + umean(i) = umean(i) + tem * dz + sumx(i) = sumx(i) + dz + endif + endif + enddo + enddo + do i= 1, im + if(cnvflg(i)) then + umean(i) = umean(i) / sumx(i) + umean(i) = max(umean(i), 1.) + tauadv = gdx(i) / umean(i) + advfac(i) = tauadv / dtconv(i) + advfac(i) = min(advfac(i), 1.) + endif + enddo c c compute cloud base mass flux as a function of the mean c updraft velcoity @@ -1810,10 +1830,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & if(cnvflg(i)) then k = kbcon(i) rho = po(i,k)*100. / (rd*to(i,k)) -! tfac = tauadv(i) / dtconv(i) -! tfac = min(tfac, 1.) -! xmb(i) = tfac*betaw*rho*wc(i) - xmb(i) = betaw*rho*wc(i) + xmb(i) = advfac(i)*betaw*rho*wc(i) endif enddo ! @@ -2145,7 +2162,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & ! evef = edt(i) * evfact ! if(islimsk(i) == 1) evef=edt(i) * evfactl ! if(islimsk(i) == 1) evef=.07 - qcond(i) = evef * (q1(i,k) - qeso(i,k)) + qcond(i) = shevf * evef * (q1(i,k) - qeso(i,k)) & / (1. + el2orc * qeso(i,k) / t1(i,k)**2) dp = 1000. * del(i,k) factor = dp / grav diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index be54675b0..eb2b7ad1c 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -138,7 +138,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw,ntiw,ntke, & integer i,is,k,n,ndt,km1,kmpbl,kmscu,ntrac1,idtend integer kps,kbx,kmx integer lcld(im),kcld(im),krad(im),mrad(im) - integer kx1(im), kpblx(im) + integer kx1(im), kb1(im), kpblx(im) ! real(kind=kind_phys) tke(im,km), tkeh(im,km-1) ! @@ -198,6 +198,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw,ntiw,ntke, & & q_diff(im,0:km-1,ntrac-1) real(kind=kind_phys) rrkp, phkp real(kind=kind_phys) tsumn(im), tsump(im), rtnp(im) + real(kind=kind_phys) sfcpbl(im) ! logical pblflg(im), sfcflg(im), flg(im) logical scuflg(im), pcnvflg(im) @@ -233,6 +234,8 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw,ntiw,ntke, & & zlup, zldn, bsum, cs0, & tem, tem1, tem2, tem3, & ptem, ptem0, ptem1, ptem2 +! + real(kind=kind_phys) slfac ! real(kind=kind_phys) ck0, ck1, ch0, ch1, ce0, rchck ! @@ -242,7 +245,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw,ntiw,ntke, & !! parameter(wfac=7.0,cfac=4.5) parameter(gamcrt=3.,gamcrq=0.,sfcfrac=0.1) - parameter(vk=0.4,rimin=-100.) + parameter(vk=0.4,rimin=-100.,slfac=0.1) parameter(rbcr=0.25,zolcru=-0.02,tdzmin=1.e-3) parameter(rlmn=30.,rlmn0=5.,rlmn1=5.,rlmn2=10.) parameter(prmin=0.25,prmax=4.0) @@ -573,7 +576,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw,ntiw,ntke, & enddo enddo ! -! Find pbl height based on bulk richardson number (mrf pbl scheme) +! Find first quess pbl height based on bulk richardson number (mrf pbl scheme) ! and also for diagnostic purpose ! do i=1,im @@ -623,6 +626,73 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw,ntiw,ntke, & if(kpbl(i) <= 1) pblflg(i)=.false. enddo ! +! update thermal at a level of slfac*hpbl for unstable pbl +! + do i=1,im + sfcpbl(i) = slfac * hpbl(i) + kb1(i) = 1 + flg(i) = .false. + if(pblflg(i)) then + flg(i) = .true. + endif + enddo + do k = 2, kmpbl + do i=1,im + if (flg(i) .and. zl(i,k) <= sfcpbl(i)) then + kb1(i) = k + else + flg(i) = .false. + endif + enddo + enddo + do i=1,im + if(pblflg(i)) kb1(i)=min(kb1(i),kpbl(i)) + enddo +! +! re-compute pbl height with the updated thermal +! + do i=1,im + flg(i) = .true. + if(pblflg(i) .and. kb1(i) > 1) then + flg(i) = .false. + rbup(i) = rbsoil(i) +! thermal(i) = thvx(i,kb1(i)) + thermal(i) = thlvx(i,kb1(i)) + kpblx(i) = kb1(i) + hpblx(i) = zl(i,kb1(i)) + endif + enddo + do k = 2, kmpbl + do i = 1, im + if(.not.flg(i) .and. k > kb1(i)) then + rbdn(i) = rbup(i) + spdk2 = max((u1(i,k)**2+v1(i,k)**2),1.) +! rbup(i) = (thvx(i,k)-thermal(i))* +! & (g*zl(i,k)/thvx(i,1))/spdk2 + rbup(i) = (thlvx(i,k)-thermal(i))* + & (g*zl(i,k)/thlvx(i,1))/spdk2 + kpblx(i) = k + flg(i) = rbup(i) > crb(i) + endif + enddo + enddo + do i = 1,im + if(pblflg(i) .and. kb1(i) > 1) then + k = kpblx(i) + if(rbdn(i) >= crb(i)) then + rbint = 0. + elseif(rbup(i) <= crb(i)) then + rbint = 1. + else + rbint = (crb(i)-rbdn(i))/(rbup(i)-rbdn(i)) + endif + hpblx(i) = zl(i,k-1) + rbint*(zl(i,k)-zl(i,k-1)) + if(hpblx(i) < zi(i,kpblx(i))) kpblx(i)=kpblx(i)-1 + hpbl(i) = hpblx(i) + kpbl(i) = kpblx(i) + endif + enddo +! !> ## Compute Monin-Obukhov similarity parameters !! - Calculate the Monin-Obukhov nondimensional stability paramter, commonly !! referred to as \f$\zeta\f$ using the following equation from Businger et al.(1971) \cite businger_et_al_1971 @@ -716,7 +786,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw,ntiw,ntke, & enddo do k = 2, kmpbl do i = 1, im - if(.not.flg(i)) then + if(.not.flg(i) .and. k > kb1(i)) then rbdn(i) = rbup(i) spdk2 = max((u1(i,k)**2+v1(i,k)**2),1.) rbup(i) = (thlvx(i,k)-thermal(i))* diff --git a/physics/scm_sfc_flux_spec.F90 b/physics/scm_sfc_flux_spec.F90 index e4f425eb2..fc4aaf5d1 100644 --- a/physics/scm_sfc_flux_spec.F90 +++ b/physics/scm_sfc_flux_spec.F90 @@ -52,18 +52,25 @@ end subroutine scm_sfc_flux_spec_finalize !! -# Calculate the Monin-Obukhov similarity function for heat and moisture from the bulk Richardson number and diagnosed similarity function for momentum. !! -# Calculate the surface drag coefficient for heat and moisture. !! -# Calculate the u and v wind at 10m. - subroutine scm_sfc_flux_spec_run (u1, v1, z1, t1, q1, p1, roughness_length, spec_sh_flux, spec_lh_flux, & - exner_inverse, T_surf, cp, grav, hvap, rd, fvirt, vonKarman, sh_flux, lh_flux, sh_flux_chs, u_star, sfc_stress, cm, ch, & + subroutine scm_sfc_flux_spec_run (im, u1, v1, z1, t1, q1, p1, roughness_length, spec_sh_flux, spec_lh_flux, & + exner_inverse, T_surf, cp, grav, hvap, rd, fvirt, vonKarman, tgice, islmsk, dry, frland, cice, icy, tisfc,& + oceanfrac, min_seaice, cplflx, cplice, flag_cice, wet, min_lakeice, tsfcl, tsfc_wat, slmsk, lakefrac, lkm,& + lakedepth, use_flake, sh_flux, lh_flux, sh_flux_chs, u_star, sfc_stress, cm, ch, & fm, fh, rb, u10m, v10m, wind1, qss, t2m, q2m, errmsg, errflg) use machine, only: kind_phys - real(kind=kind_phys), intent(in) :: u1(:), v1(:), z1(:), t1(:), q1(:), p1(:), roughness_length(:), & - spec_sh_flux(:), spec_lh_flux(:), exner_inverse(:), T_surf(:) - real(kind=kind_phys), intent(in) :: cp, grav, hvap, rd, fvirt, vonKarman - real(kind=kind_phys), intent(out) :: sh_flux(:), lh_flux(:), u_star(:), sfc_stress(:), & + integer, intent(in) :: im, lkm + integer, intent(inout) :: islmsk(:) + logical, intent(in) :: cplflx, cplice + logical, intent(inout) :: dry(:), icy(:), flag_cice(:), wet(:), use_flake(:) + real(kind=kind_phys), intent(in) :: cp, grav, hvap, rd, fvirt, vonKarman, min_seaice, tgice, min_lakeice + real(kind=kind_phys), intent(in) :: u1(:), v1(:), z1(:), t1(:), q1(:), p1(:), roughness_length(:), & + spec_sh_flux(:), spec_lh_flux(:), exner_inverse(:), T_surf(:), oceanfrac(:), lakefrac(:), lakedepth(:) + real(kind=kind_phys), intent(inout) :: cice(:), tisfc(:), tsfcl(:), tsfc_wat(:), slmsk(:) + real(kind=kind_phys), intent(out) :: sh_flux(:), lh_flux(:), u_star(:), sfc_stress(:), & cm(:), ch(:), fm(:), fh(:), rb(:), u10m(:), v10m(:), wind1(:), qss(:), t2m(:), q2m(:), & - sh_flux_chs(:) + sh_flux_chs(:), frland(:) character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -72,6 +79,8 @@ subroutine scm_sfc_flux_spec_run (u1, v1, z1, t1, q1, p1, roughness_length, spec real(kind=kind_phys) :: rho, q1_non_neg, w_thv1, rho_cp_inverse, rho_hvap_inverse, Obukhov_length, thv1, tvs, & dtv, adtv, wind10m, u_fraction, roughness_length_m + + real(kind=kind_phys), parameter :: timin = 173.0_kind_phys ! minimum temperature allowed for snow/ice ! Initialize CCPP error handling variables errmsg = '' @@ -79,7 +88,7 @@ subroutine scm_sfc_flux_spec_run (u1, v1, z1, t1, q1, p1, roughness_length, spec ! !--- set control properties (including namelist read) !calculate u_star from wind profiles (need roughness length, and wind and height at lowest model level) - do i=1, size(z1) + do i=1, im sh_flux(i) = spec_sh_flux(i) lh_flux(i) = spec_lh_flux(i) sh_flux_chs(i) = sh_flux(i) @@ -135,7 +144,82 @@ subroutine scm_sfc_flux_spec_run (u1, v1, z1, t1, q1, p1, roughness_length, spec t2m(i) = 0.0 q2m(i) = 0.0 end do - + + !GJF: The following code is from GFS_surface_composites.F90; only statements that are used in physics schemes outside of surface schemes are kept + !GJF: Adding this code means that this scheme should be called before dcyc2t3 + do i = 1, im + if (islmsk(i) == 1) then + dry(i) = .true. + frland(i) = 1.0_kind_phys + cice(i) = 0.0_kind_phys + icy(i) = .false. + tsfcl(i) = T_surf(i) !GJF + else + frland(i) = 0.0_kind_phys + if (oceanfrac(i) > 0.0_kind_phys) then + if (cice(i) >= min_seaice) then + icy(i) = .true. + tisfc(i) = T_surf(i) !GJF + tisfc(i) = max(timin, min(tisfc(i), tgice)) + ! This cplice namelist option was added to deal with the + ! situation of the FV3ATM-HYCOM coupling without an active sea + ! ice (e.g., CICE6) component. By default, the cplice is true + ! when cplflx is .true. (e.g., for the S2S application). + ! Whereas, for the HAFS FV3ATM-HYCOM coupling, cplice is set as + ! .false.. In the future HAFS FV3ATM-MOM6 coupling, the cplflx + ! could be .true., while cplice being .false.. + if (cplice .and. cplflx) then + flag_cice(i) = .true. + else + flag_cice(i) = .false. + endif + islmsk(i) = 2 + else + cice(i) = 0.0_kind_phys + flag_cice(i) = .false. + islmsk(i) = 0 + icy(i) = .false. + endif + if (cice(i) < 1.0_kind_phys) then + wet(i) = .true. ! some open ocean + endif + else + if (cice(i) >= min_lakeice) then + icy(i) = .true. + tisfc(i) = T_surf(i) !GJF + tisfc(i) = max(timin, min(tisfc(i), tgice)) + islmsk(i) = 2 + else + cice(i) = 0.0_kind_phys + islmsk(i) = 0 + icy(i) = .false. + endif + flag_cice(i) = .false. + if (cice(i) < 1.0_kind_phys) then + wet(i) = .true. ! some open lake + endif + if (wet(i)) then ! Water + tsfc_wat(i) = T_surf(i) + endif + endif + endif + if (nint(slmsk(i)) /= 1) slmsk(i) = islmsk(i) + enddo + +! to prepare to separate lake from ocean under water category + do i = 1, im + if ((wet(i) .or. icy(i)) .and. lakefrac(i) > 0.0_kind_phys) then + if (lkm == 1 .and. lakefrac(i) >= 0.15 .and. lakedepth(i) > 1.0_kind_phys) then + use_flake(i) = .true. + else + use_flake(i) = .false. + endif + else + use_flake(i) = .false. + endif + enddo +! + end subroutine scm_sfc_flux_spec_run end module scm_sfc_flux_spec diff --git a/physics/scm_sfc_flux_spec.meta b/physics/scm_sfc_flux_spec.meta index 46bb10897..03e3205f5 100644 --- a/physics/scm_sfc_flux_spec.meta +++ b/physics/scm_sfc_flux_spec.meta @@ -34,6 +34,13 @@ [ccpp-arg-table] name = scm_sfc_flux_spec_run type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in [u1] standard_name = x_wind_at_surface_adjacent_layer long_name = x component of 1st model layer wind @@ -170,6 +177,165 @@ type = real kind = kind_phys intent = in +[tgice] + standard_name = freezing_point_temperature_of_seawater + long_name = freezing point temperature of seawater + units = K + dimensions = () + type = real + kind = kind_phys + intent = in +[islmsk] + standard_name = sea_land_ice_mask + long_name = sea/land/ice mask (=0/1/2) + units = flag + dimensions = (horizontal_loop_extent) + type = integer + intent = inout +[dry] + standard_name = flag_nonzero_land_surface_fraction + long_name = flag indicating presence of some land surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = inout +[frland] + standard_name = land_area_fraction_for_microphysics + long_name = land area fraction used in microphysics schemes + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[cice] + standard_name = sea_ice_area_fraction_of_sea_area_fraction + long_name = ice fraction over open water + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[icy] + standard_name = flag_nonzero_sea_ice_surface_fraction + long_name = flag indicating presence of some sea ice surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = inout +[tisfc] + standard_name = surface_skin_temperature_over_ice + long_name = surface skin temperature over ice + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[oceanfrac] + standard_name = sea_area_fraction + long_name = fraction of horizontal grid area occupied by ocean + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[min_seaice] + standard_name = min_sea_ice_area_fraction + long_name = minimum sea ice value + units = frac + dimensions = () + type = real + kind = kind_phys + intent = in +[cplflx] + standard_name = flag_for_surface_flux_coupling + long_name = flag controlling cplflx collection (default off) + units = flag + dimensions = () + type = logical + intent = in +[cplice] + standard_name = flag_for_sea_ice_coupling + long_name = flag controlling cplice collection (default on) + units = flag + dimensions = () + type = logical + intent = in +[flag_cice] + standard_name = flag_for_cice + long_name = flag for cice + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = inout +[wet] + standard_name = flag_nonzero_wet_surface_fraction + long_name = flag indicating presence of some ocean or lake surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = inout +[min_lakeice] + standard_name = min_lake_ice_area_fraction + long_name = minimum lake ice value + units = frac + dimensions = () + type = real + kind = kind_phys + intent = in +[tsfcl] + standard_name = surface_skin_temperature_over_land + long_name = surface skin temperature over land + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[tsfc_wat] + standard_name = surface_skin_temperature_over_water + long_name = surface skin temperature over water + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[slmsk] + standard_name = area_type + long_name = landmask: sea/land/ice=0/1/2 + units = flag + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[lakefrac] + standard_name = lake_area_fraction + long_name = fraction of horizontal grid area occupied by lake + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[lkm] + standard_name = control_for_lake_surface_scheme + long_name = flag for lake surface model + units = flag + dimensions = () + type = integer + intent = in +[lakedepth] + standard_name = lake_depth + long_name = lake depth + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[use_flake] + standard_name = flag_for_using_flake + long_name = flag indicating lake points using flake model + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = inout [sh_flux] standard_name = surface_upward_temperature_flux long_name = surface upward sensible heat flux diff --git a/physics/sfc_diag_post.F90 b/physics/sfc_diag_post.F90 index 6f14fe93d..36541b0fc 100644 --- a/physics/sfc_diag_post.F90 +++ b/physics/sfc_diag_post.F90 @@ -16,7 +16,7 @@ end subroutine sfc_diag_post_finalize !! #endif subroutine sfc_diag_post_run (im, lsm, lsm_noahmp, dry, lssav, dtf, con_eps, con_epsm1, pgr,& - t2m, q2m, u10m, v10m, tmpmin, tmpmax, spfhmin, spfhmax, & + t2mmp,q2mp, t2m, q2m, u10m, v10m, tmpmin, tmpmax, spfhmin, spfhmax, & wind10mmax, u10mmax, v10mmax, dpt2m, errmsg, errflg) use machine, only: kind_phys @@ -29,6 +29,7 @@ subroutine sfc_diag_post_run (im, lsm, lsm_noahmp, dry, lssav, dtf, con_eps, con logical , dimension(:), intent(in) :: dry real(kind=kind_phys), dimension(:), intent(in) :: pgr, u10m, v10m real(kind=kind_phys), dimension(:), intent(inout) :: t2m, q2m, tmpmin, tmpmax, spfhmin, spfhmax + real(kind=kind_phys), dimension(:), intent(inout) :: t2mmp, q2mp real(kind=kind_phys), dimension(:), intent(inout) :: wind10mmax, u10mmax, v10mmax, dpt2m character(len=*), intent(out) :: errmsg @@ -41,6 +42,15 @@ subroutine sfc_diag_post_run (im, lsm, lsm_noahmp, dry, lssav, dtf, con_eps, con errmsg = '' errflg = 0 +! if (lsm == lsm_noahmp) then +! do i=1,im +! if(dry(i)) then +! t2m(i) = t2mmp(i) +! q2m(i) = q2mp(i) +! endif +! enddo +! endif + if (lssav) then do i=1,im tmpmax(i) = max(tmpmax(i),t2m(i)) diff --git a/physics/sfc_diag_post.meta b/physics/sfc_diag_post.meta index 873dd671e..56534d71b 100644 --- a/physics/sfc_diag_post.meta +++ b/physics/sfc_diag_post.meta @@ -74,6 +74,22 @@ type = real kind = kind_phys intent = in +[t2mmp] + standard_name = temperature_at_2m_from_noahmp + long_name = 2 meter temperature from noahmp + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[q2mp] + standard_name = specific_humidity_at_2m_from_noahmp + long_name = 2 meter specific humidity from noahmp + units = kg kg-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out [t2m] standard_name = air_temperature_at_2m long_name = 2 meter temperature diff --git a/physics/sfc_nst.f b/physics/sfc_nst.f index 9258b5256..22961458d 100644 --- a/physics/sfc_nst.f +++ b/physics/sfc_nst.f @@ -6,18 +6,6 @@ module sfc_nst contains -! \brief This subroutine is empty since there are no procedures that need to be done to initialize the GFS NSST code. -!! This subroutine is empty since there are no procedures that need to be done to initialize the GFS NSST code. -!! - subroutine sfc_nst_init - end subroutine sfc_nst_init - -! \brief This subroutine is empty since there are no procedures that need to be done to finalize the GFS NSST code. -!! This subroutine is empty since there are no procedures that need to be done to finalize the GFS NSST code. -!! - subroutine sfc_nst_finalize - end subroutine sfc_nst_finalize - !>\defgroup gfs_nst_main GFS Near-Surface Sea Temperature Scheme Module !> \brief This subroutine calls the Thermal Skin-layer and Diurnal Thermocline models to update the NSST profile. !! \section arg_table_sfc_nst_run Argument Table @@ -704,211 +692,4 @@ subroutine sfc_nst_run & return end subroutine sfc_nst_run !> @} - end module sfc_nst - -!> This module contains the CCPP-compliant GFS near-surface sea temperature pre -!! interstitial codes. - module sfc_nst_pre - - contains - -! \defgroup GFS_NSST_PRE GFS Near-Surface Sea Temperature Pre -!! -!! The NSST scheme is one of the three schemes used to represent the -!! surface in the GFS physics suite. The other two are the Noah land -!! surface model and the sice simplified ice model. -!! - subroutine sfc_nst_pre_init - end subroutine sfc_nst_pre_init - - subroutine sfc_nst_pre_finalize - end subroutine sfc_nst_pre_finalize - -!! \section arg_table_sfc_nst_pre_run Argument Table -!! \htmlinclude sfc_nst_pre_run.html -!! -!> \section NSST_general_pre_algorithm General Algorithm -!! @{ - subroutine sfc_nst_pre_run - & (im, wet, tgice, tsfco, tsurf_wat, - & tseal, xt, xz, dt_cool, z_c, tref, cplflx, - & oceanfrac, nthreads, errmsg, errflg) - - use machine , only : kind_phys - use module_nst_water_prop, only: get_dtzm_2d - - implicit none - - integer, parameter :: kp = kind_phys - -! --- inputs: - integer, intent(in) :: im, nthreads - logical, dimension(:), intent(in) :: wet - real (kind=kind_phys), intent(in) :: tgice - real (kind=kind_phys), dimension(:), intent(in) :: - & tsfco, xt, xz, dt_cool, z_c, oceanfrac - logical, intent(in) :: cplflx - -! --- input/outputs: - real (kind=kind_phys), dimension(:), intent(inout) :: - & tsurf_wat, tseal, tref - -! --- outputs: - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - -! --- locals - integer :: i - real(kind=kind_phys), parameter :: zero = 0.0_kp, - & one = 1.0_kp, - & half = 0.5_kp, - & omz1 = 2.0_kp - real(kind=kind_phys) :: tem1, tem2, dnsst - real(kind=kind_phys), dimension(im) :: dtzm, z_c_0 - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - do i=1,im - if (wet(i) .and. oceanfrac(i) > 0.0) then -! tem = (oro(i)-oro_uf(i)) * rlapse - ! DH* 20190927 simplyfing this code because tem is zero - !tem = zero - !tseal(i) = tsfco(i) + tem - tseal(i) = tsfco(i) - !tsurf_wat(i) = tsurf_wat(i) + tem - ! *DH - endif - enddo -! -! update tsfc & tref with T1 from OGCM & NSST Profile if coupled -! - if (cplflx) then - z_c_0 = zero - call get_dtzm_2d (xt, xz, dt_cool, & - & z_c_0, wet, zero, omz1, im, 1, nthreads, dtzm) - do i=1,im - if (wet(i) .and. oceanfrac(i) > zero ) then -! dnsst = tsfc_wat(i) - tref(i) ! retrive/get difference of Ts and Tf - tref(i) = max(tgice, tsfco(i) - dtzm(i)) ! update Tf with T1 and NSST T-Profile -! tsfc_wat(i) = max(271.2,tref(i) + dnsst) ! get Ts updated due to Tf update -! tseal(i) = tsfc_wat(i) - if (abs(xz(i)) > zero) then - tem2 = one / xz(i) - else - tem2 = zero - endif - tseal(i) = tref(i) + (xt(i)+xt(i)) * tem2 - dt_cool(i) - tsurf_wat(i) = tseal(i) - endif - enddo - endif - - return - end subroutine sfc_nst_pre_run -!! @} - end module sfc_nst_pre - -!> This module contains the CCPP-compliant GFS near-surface sea temperature post -!! interstitial codes. - module sfc_nst_post - - contains - -! \defgroup GFS_NSST_POST GFS Near-Surface Sea Temperature Post -!! \brief Brief description of the parameterization -!! - subroutine sfc_nst_post_init - end subroutine sfc_nst_post_init - -! \brief Brief description of the subroutine -!! - subroutine sfc_nst_post_finalize - end subroutine sfc_nst_post_finalize - -!> \brief Brief description of the subroutine -!! -!! \section arg_table_sfc_nst_post_run Argument Table -!! \htmlinclude sfc_nst_post_run.html -!! -! \section NSST_general_post_algorithm General Algorithm -! -! \section NSST_detailed_post_algorithm Detailed Algorithm -! @{ - subroutine sfc_nst_post_run & - & ( im, kdt, rlapse, tgice, wet, use_flake, icy, oro, oro_uf, & - & nstf_name1, & - & nstf_name4, nstf_name5, xt, xz, dt_cool, z_c, tref, xlon, & - & tsurf_wat, tsfc_wat, nthreads, dtzm, errmsg, errflg & - & ) - - use machine , only : kind_phys - use module_nst_water_prop, only: get_dtzm_2d - - implicit none - - integer, parameter :: kp = kind_phys - -! --- inputs: - integer, intent(in) :: im, kdt, nthreads - logical, dimension(:), intent(in) :: wet, icy, use_flake - real (kind=kind_phys), intent(in) :: rlapse, tgice - real (kind=kind_phys), dimension(:), intent(in) :: oro, oro_uf - integer, intent(in) :: nstf_name1, nstf_name4, nstf_name5 - real (kind=kind_phys), dimension(:), intent(in) :: xt, xz, & - & dt_cool, z_c, tref, xlon - -! --- input/outputs: - real (kind=kind_phys), dimension(:), intent(inout) :: tsurf_wat, & - & tsfc_wat - -! --- outputs: - real (kind=kind_phys), dimension(:), intent(out) :: dtzm - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - -! --- locals - integer :: i - real(kind=kind_phys) :: zsea1, zsea2 - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - -! if (lprnt) print *,' tseaz2=',tseal(ipr),' tref=',tref(ipr), -! & ' dt_cool=',dt_cool(ipr),' dt_warm=',2.0*xt(ipr)/xz(ipr), -! & ' kdt=',kdt - -! do i = 1, im -! if (wet(i) .and. .not. icy(i)) then -! tsurf_wat(i) = tsurf_wat(i) - (oro(i)-oro_uf(i)) * rlapse -! endif -! enddo - -! --- ... run nsst model ... --- - - if (nstf_name1 > 1) then - zsea1 = 0.001_kp*real(nstf_name4) - zsea2 = 0.001_kp*real(nstf_name5) - call get_dtzm_2d (xt, xz, dt_cool, z_c, wet, zsea1, zsea2, & - & im, 1, nthreads, dtzm) - do i = 1, im -! if (wet(i) .and. .not.icy(i)) then -! if (wet(i) .and. (frac_grid .or. .not. icy(i))) then - if (wet(i) .and. .not. use_flake(i)) then - tsfc_wat(i) = max(tgice, tref(i) + dtzm(i)) -! tsfc_wat(i) = max(271.2, tref(i) + dtzm(i)) - & -! (oro(i)-oro_uf(i))*rlapse - endif - enddo - endif - -! if (lprnt) print *,' tseaz2=',tsea(ipr),' tref=',tref(ipr), & -! & ' dt_cool=',dt_cool(ipr),' dt_warm=',dt_warm(ipr),' kdt=',kdt - - return - end subroutine sfc_nst_post_run - - end module sfc_nst_post + end module sfc_nst \ No newline at end of file diff --git a/physics/sfc_nst.meta b/physics/sfc_nst.meta index d80ebf0cf..fa15749b6 100644 --- a/physics/sfc_nst.meta +++ b/physics/sfc_nst.meta @@ -616,331 +616,4 @@ units = 1 dimensions = () type = integer - intent = out - -######################################################################## -[ccpp-table-properties] - name = sfc_nst_pre - type = scheme - dependencies = date_def.f,funcphys.f90,machine.F,module_nst_model.f90,module_nst_parameters.f90,module_nst_water_prop.f90 - -######################################################################## -[ccpp-arg-table] - name = sfc_nst_pre_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in -[wet] - standard_name = flag_nonzero_wet_surface_fraction - long_name = flag indicating presence of some ocean or lake surface area fraction - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = in -[tgice] - standard_name = freezing_point_temperature_of_seawater - long_name = freezing point temperature of seawater - units = K - dimensions = () - type = real - kind = kind_phys - intent = in -[tsfco] - standard_name = sea_surface_temperature - long_name = sea surface temperature - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[tsurf_wat] - standard_name = surface_skin_temperature_after_iteration_over_water - long_name = surface skin temperature after iteration over water - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[tseal] - standard_name = surface_skin_temperature_for_nsst - long_name = ocean surface skin temperature - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[xt] - standard_name = heat_content_in_diurnal_thermocline - long_name = heat content in diurnal thermocline layer - units = K m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[xz] - standard_name = diurnal_thermocline_layer_thickness - long_name = diurnal thermocline layer thickness - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[dt_cool] - standard_name = molecular_sublayer_temperature_correction_in_sea_water - long_name = sub-layer cooling amount - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[z_c] - standard_name = molecular_sublayer_thickness_in_sea_water - long_name = sub-layer cooling thickness - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[tref] - standard_name = reference_sea_surface_temperature - long_name = reference/foundation temperature - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[cplflx] - standard_name = flag_for_surface_flux_coupling - long_name = flag controlling cplflx collection (default off) - units = flag - dimensions = () - type = logical - intent = in -[oceanfrac] - standard_name = sea_area_fraction - long_name = fraction of horizontal grid area occupied by ocean - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[nthreads] - standard_name = number_of_openmp_threads - long_name = number of OpenMP threads available for physics schemes - units = count - dimensions = () - type = integer - intent = in -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out - -######################################################################## -[ccpp-table-properties] - name = sfc_nst_post - type = scheme - dependencies = date_def.f,funcphys.f90,machine.F,module_nst_model.f90,module_nst_parameters.f90,module_nst_water_prop.f90 - -######################################################################## -[ccpp-arg-table] - name = sfc_nst_post_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in -[kdt] - standard_name = index_of_timestep - long_name = current time step index - units = index - dimensions = () - type = integer - intent = in -[rlapse] - standard_name = air_temperature_lapse_rate_constant - long_name = environmental air temperature lapse rate constant - units = K m-1 - dimensions = () - type = real - kind = kind_phys - intent = in -[tgice] - standard_name = freezing_point_temperature_of_seawater - long_name = freezing point temperature of seawater - units = K - dimensions = () - type = real - kind = kind_phys - intent = in -[wet] - standard_name = flag_nonzero_wet_surface_fraction - long_name = flag indicating presence of some ocean or lake surface area fraction - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = in -[use_flake] - standard_name = flag_for_using_flake - long_name = flag indicating lake points using flake model - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = in -[icy] - standard_name = flag_nonzero_sea_ice_surface_fraction - long_name = flag indicating presence of some sea ice surface area fraction - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = in -[oro] - standard_name = height_above_mean_sea_level - long_name = height_above_mean_sea_level - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[oro_uf] - standard_name = unfiltered_height_above_mean_sea_level - long_name = unfiltered height_above_mean_sea_level - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[nstf_name1] - standard_name = control_for_nsstm - long_name = NSSTM flag: off/uncoupled/coupled=0/1/2 - units = flag - dimensions = () - type = integer - intent = in -[nstf_name4] - standard_name = lower_bound_for_depth_of_sea_temperature_for_nsstm - long_name = zsea1 - units = mm - dimensions = () - type = integer - intent = in -[nstf_name5] - standard_name = upper_bound_for_depth_of_sea_temperature_for_nsstm - long_name = zsea2 - units = mm - dimensions = () - type = integer - intent = in -[xt] - standard_name = heat_content_in_diurnal_thermocline - long_name = heat content in diurnal thermocline layer - units = K m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[xz] - standard_name = diurnal_thermocline_layer_thickness - long_name = diurnal thermocline layer thickness - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[dt_cool] - standard_name = molecular_sublayer_temperature_correction_in_sea_water - long_name = sub-layer cooling amount - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[z_c] - standard_name = molecular_sublayer_thickness_in_sea_water - long_name = sub-layer cooling thickness - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[tref] - standard_name = reference_sea_surface_temperature - long_name = reference/foundation temperature - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[xlon] - standard_name = longitude - long_name = longitude - units = radian - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[tsurf_wat] - standard_name = surface_skin_temperature_after_iteration_over_water - long_name = surface skin temperature after iteration over water - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[tsfc_wat] - standard_name = surface_skin_temperature_over_water - long_name = surface skin temperature over water - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[nthreads] - standard_name = number_of_openmp_threads - long_name = number of OpenMP threads available for physics schemes - units = count - dimensions = () - type = integer - intent = in -[dtzm] - standard_name = mean_change_over_depth_in_sea_water_temperature - long_name = mean of dT(z) (zsea1 to zsea2) - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out + intent = out \ No newline at end of file diff --git a/physics/sfc_nst_post.f b/physics/sfc_nst_post.f new file mode 100644 index 000000000..80f96d3f8 --- /dev/null +++ b/physics/sfc_nst_post.f @@ -0,0 +1,92 @@ +!> \file sfc_nst_post.f +!! This file contains code to be executed after the GFS NSST model. + + module sfc_nst_post + + contains + +! \defgroup GFS_NSST_POST GFS Near-Surface Sea Temperature Post + +!> \section arg_table_sfc_nst_post_run Argument Table +!! \htmlinclude sfc_nst_post_run.html +!! +! \section NSST_general_post_algorithm General Algorithm +! +! \section NSST_detailed_post_algorithm Detailed Algorithm +! @{ + subroutine sfc_nst_post_run & + & ( im, kdt, rlapse, tgice, wet, use_flake, icy, oro, oro_uf, & + & nstf_name1, & + & nstf_name4, nstf_name5, xt, xz, dt_cool, z_c, tref, xlon, & + & tsurf_wat, tsfc_wat, nthreads, dtzm, errmsg, errflg & + & ) + + use machine , only : kind_phys + use module_nst_water_prop, only: get_dtzm_2d + + implicit none + + integer, parameter :: kp = kind_phys + +! --- inputs: + integer, intent(in) :: im, kdt, nthreads + logical, dimension(:), intent(in) :: wet, icy, use_flake + real (kind=kind_phys), intent(in) :: rlapse, tgice + real (kind=kind_phys), dimension(:), intent(in) :: oro, oro_uf + integer, intent(in) :: nstf_name1, nstf_name4, nstf_name5 + real (kind=kind_phys), dimension(:), intent(in) :: xt, xz, & + & dt_cool, z_c, tref, xlon + +! --- input/outputs: + real (kind=kind_phys), dimension(:), intent(inout) :: tsurf_wat, & + & tsfc_wat + +! --- outputs: + real (kind=kind_phys), dimension(:), intent(out) :: dtzm + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + +! --- locals + integer :: i + real(kind=kind_phys) :: zsea1, zsea2 + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + +! if (lprnt) print *,' tseaz2=',tseal(ipr),' tref=',tref(ipr), +! & ' dt_cool=',dt_cool(ipr),' dt_warm=',2.0*xt(ipr)/xz(ipr), +! & ' kdt=',kdt + +! do i = 1, im +! if (wet(i) .and. .not. icy(i)) then +! tsurf_wat(i) = tsurf_wat(i) - (oro(i)-oro_uf(i)) * rlapse +! endif +! enddo + +! --- ... run nsst model ... --- + + if (nstf_name1 > 1) then + zsea1 = 0.001_kp*real(nstf_name4) + zsea2 = 0.001_kp*real(nstf_name5) + call get_dtzm_2d (xt, xz, dt_cool, z_c, wet, zsea1, zsea2, & + & im, 1, nthreads, dtzm) + do i = 1, im +! if (wet(i) .and. .not.icy(i)) then +! if (wet(i) .and. (frac_grid .or. .not. icy(i))) then + if (wet(i) .and. .not. use_flake(i)) then + tsfc_wat(i) = max(tgice, tref(i) + dtzm(i)) +! tsfc_wat(i) = max(271.2, tref(i) + dtzm(i)) - & +! (oro(i)-oro_uf(i))*rlapse + endif + enddo + endif + +! if (lprnt) print *,' tseaz2=',tsea(ipr),' tref=',tref(ipr), & +! & ' dt_cool=',dt_cool(ipr),' dt_warm=',dt_warm(ipr),' kdt=',kdt + + return + end subroutine sfc_nst_post_run + + end module sfc_nst_post diff --git a/physics/sfc_nst_post.meta b/physics/sfc_nst_post.meta new file mode 100644 index 000000000..aefa53bb0 --- /dev/null +++ b/physics/sfc_nst_post.meta @@ -0,0 +1,192 @@ +######################################################################## +[ccpp-table-properties] + name = sfc_nst_post + type = scheme + dependencies = machine.F,module_nst_parameters.f90,module_nst_water_prop.f90 + +######################################################################## +[ccpp-arg-table] + name = sfc_nst_post_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[kdt] + standard_name = index_of_timestep + long_name = current time step index + units = index + dimensions = () + type = integer + intent = in +[rlapse] + standard_name = air_temperature_lapse_rate_constant + long_name = environmental air temperature lapse rate constant + units = K m-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[tgice] + standard_name = freezing_point_temperature_of_seawater + long_name = freezing point temperature of seawater + units = K + dimensions = () + type = real + kind = kind_phys + intent = in +[wet] + standard_name = flag_nonzero_wet_surface_fraction + long_name = flag indicating presence of some ocean or lake surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in +[use_flake] + standard_name = flag_for_using_flake + long_name = flag indicating lake points using flake model + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in +[icy] + standard_name = flag_nonzero_sea_ice_surface_fraction + long_name = flag indicating presence of some sea ice surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in +[oro] + standard_name = height_above_mean_sea_level + long_name = height_above_mean_sea_level + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[oro_uf] + standard_name = unfiltered_height_above_mean_sea_level + long_name = unfiltered height_above_mean_sea_level + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[nstf_name1] + standard_name = control_for_nsstm + long_name = NSSTM flag: off/uncoupled/coupled=0/1/2 + units = flag + dimensions = () + type = integer + intent = in +[nstf_name4] + standard_name = lower_bound_for_depth_of_sea_temperature_for_nsstm + long_name = zsea1 + units = mm + dimensions = () + type = integer + intent = in +[nstf_name5] + standard_name = upper_bound_for_depth_of_sea_temperature_for_nsstm + long_name = zsea2 + units = mm + dimensions = () + type = integer + intent = in +[xt] + standard_name = heat_content_in_diurnal_thermocline + long_name = heat content in diurnal thermocline layer + units = K m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[xz] + standard_name = diurnal_thermocline_layer_thickness + long_name = diurnal thermocline layer thickness + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[dt_cool] + standard_name = molecular_sublayer_temperature_correction_in_sea_water + long_name = sub-layer cooling amount + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[z_c] + standard_name = molecular_sublayer_thickness_in_sea_water + long_name = sub-layer cooling thickness + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[tref] + standard_name = reference_sea_surface_temperature + long_name = reference/foundation temperature + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[xlon] + standard_name = longitude + long_name = longitude + units = radian + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[tsurf_wat] + standard_name = surface_skin_temperature_after_iteration_over_water + long_name = surface skin temperature after iteration over water + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[tsfc_wat] + standard_name = surface_skin_temperature_over_water + long_name = surface skin temperature over water + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[nthreads] + standard_name = number_of_openmp_threads + long_name = number of OpenMP threads available for physics schemes + units = count + dimensions = () + type = integer + intent = in +[dtzm] + standard_name = mean_change_over_depth_in_sea_water_temperature + long_name = mean of dT(z) (zsea1 to zsea2) + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out diff --git a/physics/sfc_nst_pre.f b/physics/sfc_nst_pre.f new file mode 100644 index 000000000..04a08f591 --- /dev/null +++ b/physics/sfc_nst_pre.f @@ -0,0 +1,99 @@ +!> \file sfc_nst_pre.f +!! This file contains preparation for the GFS NSST model. + + module sfc_nst_pre + + contains + +! \defgroup GFS_NSST_PRE GFS Near-Surface Sea Temperature Pre +!! +!! The NSST scheme is one of the three schemes used to represent the +!! surface in the GFS physics suite. The other two are the Noah land +!! surface model and the sice simplified ice model. +!! + +!! \section arg_table_sfc_nst_pre_run Argument Table +!! \htmlinclude sfc_nst_pre_run.html +!! +!> \section NSST_general_pre_algorithm General Algorithm +!! @{ + subroutine sfc_nst_pre_run + & (im, wet, tgice, tsfco, tsurf_wat, + & tseal, xt, xz, dt_cool, z_c, tref, cplflx, + & oceanfrac, nthreads, errmsg, errflg) + + use machine , only : kind_phys + use module_nst_water_prop, only: get_dtzm_2d + + implicit none + + integer, parameter :: kp = kind_phys + +! --- inputs: + integer, intent(in) :: im, nthreads + logical, dimension(:), intent(in) :: wet + real (kind=kind_phys), intent(in) :: tgice + real (kind=kind_phys), dimension(:), intent(in) :: + & tsfco, xt, xz, dt_cool, z_c, oceanfrac + logical, intent(in) :: cplflx + +! --- input/outputs: + real (kind=kind_phys), dimension(:), intent(inout) :: + & tsurf_wat, tseal, tref + +! --- outputs: + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + +! --- locals + integer :: i + real(kind=kind_phys), parameter :: zero = 0.0_kp, + & one = 1.0_kp, + & half = 0.5_kp, + & omz1 = 2.0_kp + real(kind=kind_phys) :: tem1, tem2, dnsst + real(kind=kind_phys), dimension(im) :: dtzm, z_c_0 + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + do i=1,im + if (wet(i) .and. oceanfrac(i) > 0.0) then +! tem = (oro(i)-oro_uf(i)) * rlapse + ! DH* 20190927 simplyfing this code because tem is zero + !tem = zero + !tseal(i) = tsfco(i) + tem + tseal(i) = tsfco(i) + !tsurf_wat(i) = tsurf_wat(i) + tem + ! *DH + endif + enddo +! +! update tsfc & tref with T1 from OGCM & NSST Profile if coupled +! + if (cplflx) then + z_c_0 = zero + call get_dtzm_2d (xt, xz, dt_cool, & + & z_c_0, wet, zero, omz1, im, 1, nthreads, dtzm) + do i=1,im + if (wet(i) .and. oceanfrac(i) > zero ) then +! dnsst = tsfc_wat(i) - tref(i) ! retrive/get difference of Ts and Tf + tref(i) = max(tgice, tsfco(i) - dtzm(i)) ! update Tf with T1 and NSST T-Profile +! tsfc_wat(i) = max(271.2,tref(i) + dnsst) ! get Ts updated due to Tf update +! tseal(i) = tsfc_wat(i) + if (abs(xz(i)) > zero) then + tem2 = one / xz(i) + else + tem2 = zero + endif + tseal(i) = tref(i) + (xt(i)+xt(i)) * tem2 - dt_cool(i) + tsurf_wat(i) = tseal(i) + endif + enddo + endif + + return + end subroutine sfc_nst_pre_run +!! @} + end module sfc_nst_pre \ No newline at end of file diff --git a/physics/sfc_nst_pre.meta b/physics/sfc_nst_pre.meta new file mode 100644 index 000000000..88788ff5c --- /dev/null +++ b/physics/sfc_nst_pre.meta @@ -0,0 +1,133 @@ +######################################################################## +[ccpp-table-properties] + name = sfc_nst_pre + type = scheme + dependencies = machine.F,module_nst_parameters.f90,module_nst_water_prop.f90 + +######################################################################## +[ccpp-arg-table] + name = sfc_nst_pre_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[wet] + standard_name = flag_nonzero_wet_surface_fraction + long_name = flag indicating presence of some ocean or lake surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in +[tgice] + standard_name = freezing_point_temperature_of_seawater + long_name = freezing point temperature of seawater + units = K + dimensions = () + type = real + kind = kind_phys + intent = in +[tsfco] + standard_name = sea_surface_temperature + long_name = sea surface temperature + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[tsurf_wat] + standard_name = surface_skin_temperature_after_iteration_over_water + long_name = surface skin temperature after iteration over water + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[tseal] + standard_name = surface_skin_temperature_for_nsst + long_name = ocean surface skin temperature + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[xt] + standard_name = heat_content_in_diurnal_thermocline + long_name = heat content in diurnal thermocline layer + units = K m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[xz] + standard_name = diurnal_thermocline_layer_thickness + long_name = diurnal thermocline layer thickness + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[dt_cool] + standard_name = molecular_sublayer_temperature_correction_in_sea_water + long_name = sub-layer cooling amount + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[z_c] + standard_name = molecular_sublayer_thickness_in_sea_water + long_name = sub-layer cooling thickness + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[tref] + standard_name = reference_sea_surface_temperature + long_name = reference/foundation temperature + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[cplflx] + standard_name = flag_for_surface_flux_coupling + long_name = flag controlling cplflx collection (default off) + units = flag + dimensions = () + type = logical + intent = in +[oceanfrac] + standard_name = sea_area_fraction + long_name = fraction of horizontal grid area occupied by ocean + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[nthreads] + standard_name = number_of_openmp_threads + long_name = number of OpenMP threads available for physics schemes + units = count + dimensions = () + type = integer + intent = in +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out \ No newline at end of file diff --git a/physics/sfcsub.F b/physics/sfcsub.F index e8b61f083..78e5201be 100644 --- a/physics/sfcsub.F +++ b/physics/sfcsub.F @@ -34,7 +34,7 @@ module sfccyc_module integer, parameter :: kpdalf(2)=(/214,217/) ! real (kind=kind_io8), parameter :: ten=10.0, one=1.0, zero=0.0 - integer, parameter :: xdata=5000, ydata=2500, mdata=xdata*ydata + integer, parameter :: xdata=7200, ydata=3600, mdata=xdata*ydata integer :: veg_type_landice integer :: soil_type_landice integer :: num_threads diff --git a/physics/module_SGSCloud_RadPost.F90 b/physics/sgscloud_radpost.F90 similarity index 98% rename from physics/module_SGSCloud_RadPost.F90 rename to physics/sgscloud_radpost.F90 index c94d2dda1..04c8b661c 100644 --- a/physics/module_SGSCloud_RadPost.F90 +++ b/physics/sgscloud_radpost.F90 @@ -1,4 +1,4 @@ -!> \file module_SGSCloud_RadPost.F90 +!> \file SGSCloud_RadPost.F90 !! Contains the post (interstitial) work after the call to the radiation schemes: !! 1) Restores the original qc & qi diff --git a/physics/module_SGSCloud_RadPost.meta b/physics/sgscloud_radpost.meta similarity index 100% rename from physics/module_SGSCloud_RadPost.meta rename to physics/sgscloud_radpost.meta diff --git a/physics/module_SGSCloud_RadPre.F90 b/physics/sgscloud_radpre.F90 similarity index 97% rename from physics/module_SGSCloud_RadPre.F90 rename to physics/sgscloud_radpre.F90 index 02b400859..6567a331b 100644 --- a/physics/module_SGSCloud_RadPre.F90 +++ b/physics/sgscloud_radpre.F90 @@ -1,4 +1,4 @@ -!>\file module_SGSCloud_RadPre.F90 +!>\file SGSCloud_RadPre.F90 !! Contains the preliminary (interstitial) work to the call to the radiation schemes: !! 1) Backs up the original qc & qi !! 2) Adds the partioning of convective condensate into liqice/ice for effective radii @@ -23,10 +23,13 @@ end subroutine sgscloud_radpre_init subroutine sgscloud_radpre_finalize () end subroutine sgscloud_radpre_finalize -!> This interstitial code adds the subgrid clouds to the resolved-scale clouds -!! if there is no resolved-scale clouds in that particular grid box. It can also -!! specify a cloud fraction for resolved-scale clouds, using Xu-Randall (1996), -!! if desired. +!> This interstitial code adds the subgrid clouds to the resolved-scale clouds +!! if there is no resolved-scale clouds in that particular grid box. It can also +!! specify a cloud fraction for resolved-scale clouds as is done currently when +!! using MYNN-EDMF. For clouds coming from the convection schemes (in this case +!! only used by GF scheme), two cloud fraction options are available: +!! Xu-Randall (XR1996) or Chaboureau and Bechtold (CB2005), chosen by the +!! switch "conv_cf_opt" = 0: CB2005, 1: XR1996. !> \section arg_table_sgscloud_radpre_run Argument Table !! \htmlinclude sgscloud_radpre_run.html !! diff --git a/physics/module_SGSCloud_RadPre.meta b/physics/sgscloud_radpre.meta similarity index 100% rename from physics/module_SGSCloud_RadPre.meta rename to physics/sgscloud_radpre.meta diff --git a/physics/gcm_shoc.F90 b/physics/shoc.F90 similarity index 99% rename from physics/gcm_shoc.F90 rename to physics/shoc.F90 index 4852310fc..4e49fad40 100644 --- a/physics/gcm_shoc.F90 +++ b/physics/shoc.F90 @@ -1,4 +1,4 @@ -!> \file gcm_shoc.F90 +!> \file shoc.F90 !! Contains the Simplified Higher-Order Closure (SHOC) scheme. !> This module contains the CCPP-compliant SHOC scheme. diff --git a/physics/gcm_shoc.meta b/physics/shoc.meta similarity index 100% rename from physics/gcm_shoc.meta rename to physics/shoc.meta diff --git a/physics/smoke/dep_dry_gocart_mod.F90 b/physics/smoke/dep_dry_gocart_mod.F90 new file mode 100755 index 000000000..9fb5edfd1 --- /dev/null +++ b/physics/smoke/dep_dry_gocart_mod.F90 @@ -0,0 +1,302 @@ +!>\file dep_dry_gocart_mod.F90 +!! This file is GOCART dry deposition module to calculate the dry deposition +!! velocities of smoke and dust. + +module dep_dry_gocart_mod + + use machine , only : kind_phys + use rrfs_smoke_data + + implicit none + + private + + public :: gocart_drydep_driver + +CONTAINS + +subroutine gocart_drydep_driver(numgas, & + moist,p8w,chem,rho_phy,dz8w,ddvel,xland,hfx, & + ivgtyp,tsk,pbl,ust,znt,g, & + num_moist,num_chem, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + IMPLICIT NONE + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + num_moist,num_chem, & + its,ite, jts,jte, kts,kte,numgas + REAL(kind_phys), INTENT(IN ) :: g + REAL(kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ),& + INTENT(IN ) :: moist + REAL(kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ) ,& + INTENT(INOUT) :: chem + REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ) ,& + INTENT(IN ) :: dz8w, p8w,rho_phy + INTEGER, DIMENSION( ims:ime , jms:jme ) ,& + INTENT(IN ) :: ivgtyp + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ) ,& + INTENT(INOUT) :: tsk, & + pbl, & + ust, & + xland,znt,hfx + +!! .. Local Scalars .. + + INTEGER :: iland, iprt, iseason, jce, jcs, & + n, nr, ipr, jpr, nvr, & + idrydep_onoff,imx,jmx,lmx + integer :: ii,jj,kk,i,j,k,nv + integer, dimension (1,1) :: ilwi + real(kind_phys), DIMENSION (5) :: tc,bems + real(kind_phys), dimension (1,1) :: z0,w10m,gwet,airden,airmas,& + delz_sfc,hflux,ts,pblz,ustar,& + ps,dvel,drydf + REAL(kind_phys), DIMENSION( its:ite, jts:jte, num_chem ) :: ddvel + + do nv=1,num_chem + do j=jts,jte + do i=its,ite + ddvel(i,j,nv)=0. + enddo + enddo + enddo + imx=1 + jmx=1 + lmx=1 + do j=jts,jte + do i=its,ite + dvel(1,1)=0. + ilwi(1,1)=0 + if(xland(i,j).gt.1.5)ilwi=1 +! for aerosols, ii=1 or ii=2 + ii=1 + if(ivgtyp(i,j).eq.19.or.ivgtyp(i,j).eq.23)ii=1 + airden(1,1)=rho_phy(i,kts,j) + delz_sfc(1,1)=dz8w(i,kts,j) + ustar(1,1)=ust(i,j) + hflux(1,1)=hfx(i,j) + pblz(1,1)=pbl(i,j) + ps(1,1)=p8w(i,kts,j)*.01 + z0(1,1)=znt(i,j) + ts(1,1)=tsk(i,j) + + call depvel_gocart(ii,imx,jmx,lmx,& + airden, delz_sfc, pblz, ts, ustar, hflux, ilwi, & + ps, z0, dvel, drydf,g) + do nv=1,num_chem + ddvel(i,j,nv)=dvel(1,1) + enddo + enddo + enddo +end subroutine gocart_drydep_driver + + + +SUBROUTINE depvel_gocart( & + ii,imx,jmx,lmx,& + airden, delz_sfc, pblz, ts, ustar, hflux, ilwi, & + ps, z0, dvel, drydf,g0) + +! **************************************************************************** +! * * +! * Calculate dry deposition velocity. * +! * * +! * Input variables: * +! * AEROSOL(k) - Logical, T = aerosol species, F = gas species * +! * IREG(i,j) - # of landtypes in grid square * +! * ILAND(i,j,ldt) - Land type ID for element ldt =1,IREG(i,j) * +! * IUSE(i,j,ldt) - Fraction of gridbox area occupied by land type * +! * element ldt * +! * USTAR(i,j) - Friction velocity (m s-1) * +! * DELZ_SFC(i,j) - Thickness of layer above surface * +! * PBLZ(i,j) - Mixing depth (m) * +! * Z0(i,j) - Roughness height (m) * +! * * +! * Determined in this subroutine (local): * +! * OBK - Monin-Obukhov length (m): set to 1.E5 m under * +! * neutral conditions * +! * Rs(ldt) - Bulk surface resistance(s m-1) for species k to * +! * surface ldt * +! * Ra - Aerodynamic resistance. * +! * Rb - Sublayer resistance. * +! * Rs - Surface resistance. * +! * Rttl - Total deposition resistance (s m-1) for species k * +! * Rttl(k) = Ra + Rb + Rs. * +! * * +! * Returned: * +! * DVEL(i,j,k) - Deposition velocity (m s-1) of species k * +! * DRYDf(i,j,k) - Deposition frequency (s-1) of species k, * +! * = DVEL / DELZ_SFC * +! * * +! **************************************************************************** + + + IMPLICIT NONE + INTEGER, INTENT(IN) :: imx,jmx,lmx + REAL(kind_phys), INTENT(IN) :: airden(imx,jmx), delz_sfc(imx,jmx) + REAL(kind_phys), INTENT(IN) :: hflux(imx,jmx), ts(imx,jmx) + REAL(kind_phys), INTENT(IN) :: ustar(imx,jmx), pblz(imx,jmx) + REAL(kind_phys), INTENT(IN) :: ps(imx,jmx) + INTEGER, INTENT(IN) :: ilwi(imx,jmx) + REAL(kind_phys), INTENT(IN) :: z0(imx,jmx) + REAL(kind=kind_phys), INTENT(IN) :: g0 + REAL(kind_phys), INTENT(OUT) :: dvel(imx,jmx), drydf(imx,jmx) + + REAL(kind_phys) :: obk, vds, czh, rttl, frac, logmfrac, psi_h, cz, eps + REAL(kind_phys) :: vd, ra, rb, rs + INTEGER :: i, j, k, ldt, iolson, ii + CHARACTER(LEN=50) :: msg + REAL(kind_phys) :: prss, tempk, tempc, xnu, ckustr, reyno, aird, diam, xm, z + REAL(kind_phys) :: frpath, speed, dg, dw, rt + REAL(kind_phys) :: rad0, rix, gfact, gfaci, rdc, rixx, rluxx, rgsx, rclx + REAL(kind_phys) :: dtmp1, dtmp2, dtmp3, dtmp4 + REAL(kind_phys) :: biofit,vk + + psi_h=0.0 + ! executable statements + j_loop: DO j = 1,jmx + i_loop: DO i = 1,imx + vk=.4 + vd = 0.0 + ra = 0.0 + rb = 0.0 ! only required for gases (SO2) + rs = 0.0 + +! **************************************************************************** +! * Compute the the Monin-Obhukov length. * +! * The direct computation of the Monin-Obhukov length is: * +! * * +! * - Air density * Cp * T(surface air) * Ustar^3 * +! * OBK = ---------------------------------------------- * +! * vK * g * Sensible Heat flux * +! * * +! * Cp = 1000 J/kg/K = specific heat at constant pressure * +! * vK = 0.4 = von Karman's constant * +! **************************************************************************** + + IF (hflux(i,j) == 0.0) THEN + obk = 1.0E5 + ELSE + ! MINVAL(hflux), MINVAL(airden), MINVAL(ustar) =?? + obk = -airden(i,j) * 1000.0 * ts(i,j) * (ustar(i,j))**3 & + / (vk * g0 * hflux(i,j)) +! -- debug: + IF ( obk == 0.0 ) WRITE(*,211) obk, i, j +211 FORMAT(1X,'OBK=', E11.2, 1X,' i,j = ', 2I4) + + END IF + + cz = delz_sfc(i,j) / 2.0 ! center of the grid box above surface + +! **************************************************************************** +! * (1) Aerosodynamic resistance Ra and sublayer resistance Rb. * +! * * +! * The Reynolds number REYNO diagnoses whether a surface is * +! * aerodynamically rough (REYNO > 10) or smooth. Surface is * +! * rough in all cases except over water with low wind speeds. * +! * * +! * For gas species over land and ice (REYNO >= 10) and for aerosol * +! * species for all surfaces: * +! * * +! * Ra = 1./VT (VT from GEOS Kzz at L=1, m/s). * +! * * +! * The following equations are from Walcek et al, 1986: * +! * * +! * For gas species when REYNO < 10 (smooth), Ra and Rb are combined * +! * as Ra: * +! * * +! * Ra = { ln(ku* z1/Dg) - Sh } / ku* eq.(13) * +! * * +! * where z1 is the altitude at the center of the lowest model layer * +! * (CZ); * +! * Sh is a stability correction function; * +! * k is the von Karman constant (0.4, vK); * +! * u* is the friction velocity (USTAR). * +! * * +! * Sh is computed as a function of z1 and L eq ( 4) and (5)): * +! * * +! * 0 < z1/L <= 1: Sh = -5 * z1/L * +! * z1/L < 0: Sh = exp{ 0.598 + 0.39*ln(E) - 0.09(ln(E))^2 } * +! * where E = min(1,-z1/L) (Balkanski, thesis). * +! * * +! * For gas species when REYNO >= 10, * +! * * +! * Rb = 2/ku* (Dair/Dg)**(2/3) eq.(12) * +! * where Dg is the gas diffusivity, and * +! * Dair is the air diffusivity. * +! * * +! * For aerosol species, Rb is combined with surface resistance as Rs. * +! * * +! **************************************************************************** + + frac = cz / obk + IF (frac > 1.0) frac = 1.0 + IF (frac > 0.0 .AND. frac <= 1.0) THEN + psi_h = -5.0*frac + ELSE IF (frac < 0.0) THEN + eps = MIN(1.0D0, -frac) + logmfrac = LOG(eps) + psi_h = EXP( 0.598 + 0.39 * logmfrac - 0.09 * (logmfrac)**2 ) + END IF + !-------------------------------------------------------------- + ! Aerosol species, Rs here is the combination of Rb and Rs. + + ra = (LOG(cz/z0(i,j)) - psi_h) / (vk*ustar(i,j)) + + vds = 0.002*ustar(i,j) + IF (obk < 0.0) & + vds = vds * (1.0+(-300.0/obk)**0.6667) + + czh = pblz(i,j)/obk + IF (czh < -30.0) vds = 0.0009*ustar(i,j)*(-czh)**0.6667 + + ! --Set Vds to be less than VDSMAX (entry in input file divided -- + ! by 1.E4). VDSMAX is taken from Table 2 of Walcek et al. [1986]. + ! Invert to get corresponding R + if(ii.eq.1)then + rs=1.0/MIN(vds,2.0D-2) + else + rs=1.0/MIN(vds,2.0D-3) + endif + + + ! ------ Set max and min values for bulk surface resistances ------ + + rs= MAX(1.0D0, MIN(rs, 9.9990D+3)) + +! **************************************************************************** +! * * +! * Compute dry deposition velocity. * +! * * +! * IUSE is the fraction of the grid square occupied by surface ldt in * +! * units of per mil (IUSE=500 -> 50% of the grid square). Add the * +! * contribution of surface type ldt to the deposition velocity; this is * +! * a loop over all surface types in the gridbox. * +! * * +! * Total resistance = Ra + Rb + Rs. +! * * +! **************************************************************************** + + rttl = ra + rb + rs + vd = vd + 1./rttl + + ! ------ Load array DVEL ------ + dvel(i,j) = vd * 1.2 + + ! -- Set a minimum value for DVEL + ! MIN(VdSO2) = 2.0e-3 m/s over ice + ! = 3.0e-3 m/s over land + ! MIN(vd_aerosol) = 1.0e-4 m/s + + IF (dvel(i,j) < 1.0E-4) dvel(i,j) = 1.0E-4 + drydf(i,j) = dvel(i,j) / delz_sfc(i,j) + + END DO i_loop + END DO j_loop + +END SUBROUTINE depvel_gocart + +end module dep_dry_gocart_mod diff --git a/physics/smoke/dep_dry_mod.F90 b/physics/smoke/dep_dry_mod.F90 new file mode 100755 index 000000000..9520d2897 --- /dev/null +++ b/physics/smoke/dep_dry_mod.F90 @@ -0,0 +1,303 @@ +!>\file dep_dry_mod.F90 +!! This file is for the dry depostion driver. + +module dep_dry_mod + + use machine , only : kind_phys + use rrfs_smoke_config, only : epsilc, GOCART_SIMPLE => CHEM_OPT_GOCART, CTRA_OPT_NONE +! use chem_tracers_mod, only : p_o3,p_dust_1,p_vash_1,p_vash_4,p_vash_10,p_dms, +! & +! config_flags => chem_config + use dep_dry_gocart_mod + use dep_simple_mod + use dep_vertmx_mod +! use aero_soa_vbs_mod, only : soa_vbs_depdriver + + implicit none + + + private + + public :: dry_dep_driver + +contains + + subroutine dry_dep_driver(data,ktau,dtstep,julday,current_month,t_phy,p_phy, & + moist,p8w,rmol,alt,gmt,t8w,raincv, & + chem,rho_phy,dz8w,exch_h,hfx, & + ivgtyp,tsk,gsw,vegfra,pbl,ust,znt,z,z_at_w, & + xland,xlat,xlong,h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3, & + anh3,ddep,dep_vel_o3,g, & + e_co,kemit,snowh,numgas, & + num_chem,num_moist, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) +!---------------------------------------------------------------------- +! USE module_model_constants +! USE module_configure +! USE module_state_description +! USE module_dep_simple +! USE module_initial_chem_namelists,only:p_o3,p_dust_1,p_vash_1,p_vash_4,p_vash_10,p_dms +! USE module_vertmx_wrf +! USE module_chemvars,only:epsilc +! USE module_data_sorgam +! USE module_aerosols_sorgam +! USE module_gocart_settling +! use module_dep_simple +! USE module_gocart_drydep,only: gocart_drydep_driver +! USE module_aerosols_soa_vbs, only: soa_vbs_depdriver +! USE module_mosaic_drydep, only: mosaic_drydep_driver +! USE module_mixactivate_wrappers, only: mosaic_mixactivate, sorgam_mixactivate + IMPLICIT NONE + type(smoke_data), pointer, intent(inout) :: data + + INTEGER, INTENT(IN ) :: numgas, current_month, & + num_chem,num_moist, julday, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + INTEGER, INTENT(IN ) :: & + ktau + REAL(kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & + INTENT(IN ) :: moist + REAL(kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(INOUT ) :: chem + + INTEGER, INTENT(IN ) :: kemit + REAL(kind_phys), DIMENSION( ims:ime, kms:kemit, jms:jme ), & + INTENT(IN ) :: & + e_co + + + + + REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: & + alt, & + t8w, & + dz8w, & + p8w,z_at_w , & + exch_h,rho_phy,z + REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(INOUT) :: & + h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3 + INTEGER,DIMENSION( ims:ime , jms:jme ) , & + INTENT(IN ) :: & + ivgtyp + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ) , & + INTENT(INOUT) :: & + tsk, & + gsw, & + vegfra, & + pbl, & + snowh, & + raincv, & + ust, & + hfx, & + xland, & + xlat, & + xlong, & + znt,rmol + REAL(kind_phys), DIMENSION( ims:ime, jms:jme, num_chem ), & + INTENT(OUT ) :: ddep + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ) , & + INTENT(OUT) :: & + dep_vel_o3 + REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ), & + INTENT(IN ) :: & + p_phy, & + t_phy + + REAL(kind_phys), INTENT(IN ) :: & + dtstep,g,gmt + +!--- deposition and emissions stuff +! .. Parameters .. +! .. +! .. Local Scalars .. + + REAL(kind_phys) :: cdt, factor + + INTEGER :: idrydep_onoff + +! INTEGER :: chem_conv_tr, chem_opt + +! CHARACTER (4) :: luse_typ,mminlu_loc +! .. +! .. Local Arrays .. + REAL(kind_phys), DIMENSION( its:ite, jts:jte, num_chem ) :: ddvel + +! REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ) :: dryrho_phy + REAL(kind_phys), DIMENSION( kts:kte ) :: dryrho_1d + +! turbulent transport + real(kind_phys) :: pblst(kts:kte),ekmfull(kts:kte+1),zzfull(kts:kte+1),zz(kts:kte) + integer :: i,j,k,nv +! +! necessary for aerosols (module dependent) +! + REAL(kind_phys), DIMENSION( its:ite, jts:jte ) :: aer_res + REAL(kind_phys), DIMENSION( its:ite, jts:jte ) :: aer_res_def + REAL(kind_phys), DIMENSION( its:ite, jts:jte ) :: aer_res_zcen + +! .. +! .. Intrinsic Functions .. + INTRINSIC max, min + +! chem_opt = chem_opt +! chem_conv_tr = chem_conv_tr + +! +! compute dry deposition velocities = ddvel +! +! 28-jun-2005 rce - initialize ddvel=0; call aerosol drydep routine +! only when drydep_opt == WESELY +! the wesely_driver routine computes aer_res, and currently +! you cannot compute aerosol drydep without it !! +! 08-jul-2005 rce - pass idrydep_onoff to mixactivate routines +! +! write(6,*)'call dry dep driver' + dep_vel_o3(:,:)=0. + ddvel(:,:,:) = 0.0 + idrydep_onoff = 0 + +! drydep_select: SELECT CASE(drydep_opt) + +! CASE ( WESELY ) +! +! drydep_opt == WESELY means +! wesely for gases +! other (appropriate) routine for aerosols +! +! CALL wrf_debug(15,'DOING DRY DEP VELOCITIES WITH WESELY METHOD') + + IF( chem_opt /= GOCART_SIMPLE ) THEN + call wesely_driver(data,ktau,dtstep, & + current_month, & + gmt,julday,t_phy,moist,p8w,t8w,raincv, & + p_phy,chem,rho_phy,dz8w,ddvel,aer_res_def,aer_res_zcen, & + ivgtyp,tsk,gsw,vegfra,pbl,rmol,ust,znt,xlat,xlong,z,z_at_w,& + snowh,numgas, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + ENDIF + IF (( chem_opt == GOCART_SIMPLE ) .or. & + ( chem_opt == GOCARTRACM_KPP) .or. & + ( chem_opt == 316) .or. & + ( chem_opt == 317) .or. & +! ( chem_opt == 502) .or. & + (chem_opt == 304 )) then +! +! this does aerosol species (dust,seas, bc,oc) for gocart only +! this does aerosol species (dust,seas, bc,oc,sulf) for gocart only +!, + call gocart_drydep_driver(numgas, & + moist,p8w,chem,rho_phy,dz8w,ddvel,xland,hfx, & + ivgtyp,tsk,pbl,ust,znt,g, & + num_moist,num_chem, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + ELSE if (chem_opt == 501 ) then +! for caesium .1cm/s +! + ddvel(:,:,:)=.001 + ELSE if (chem_opt == 108 ) then +!! call soa_vbs_depdriver (ust,t_phy, & +!! moist,p8w,rmol,znt,pbl, & +!! alt,p_phy,chem,rho_phy,dz8w, & +!! h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3, & +!! aer_res,ddvel(:,:,numgas+1:num_chem), & +!! num_chem-numgas, & +!! ids,ide, jds,jde, kds,kde, & +!! ims,ime, jms,jme, kms,kme, & +!! its,ite, jts,jte, kts,kte ) +! limit aerosol ddvels to <= 0.5 m/s +! drydep routines occasionally produce unrealistically-large particle +! diameter leading to unrealistically-large sedimentation velocity + ddvel(:,:,numgas+1:num_chem) = min( 0.50, ddvel(:,:,numgas+1:num_chem)) + ELSE + !Set dry deposition velocity to zero when using the + !chemistry tracer mode. + ddvel(:,:,:) = 0. + END IF + idrydep_onoff = 1 + +! +! Compute dry deposition according to NGAC +! + cdt = real(dtstep, kind=kind_phys) + do nv = 1, num_chem + do j = jts, jte + do i = its, ite + factor = 1._kind_phys - exp(-ddvel(i,j,nv)*cdt/dz8w(i,kts,j)) + ddep(i,j,nv) = max(0.0, factor * chem(i,kts,j,nv)) & !ug/m2/s + * (p8w(i,kts,j)-p8w(i,kts+1,j))/g/dtstep + end do + end do + end do + + +! This will be called later from subgrd_transport_driver.F !!!!!!!! +! +! + do 100 j=jts,jte + do 100 i=its,ite + if(p_dust_1.gt.1)dep_vel_o3(i,j)=ddvel(i,j,p_dust_1) + pblst=0. +! +! +!-- start with vertical mixing +! + do k=kts,kte+1 + zzfull(k)=z_at_w(i,k,j)-z_at_w(i,kts,j) + enddo + + if (chem_conv_tr == CTRA_OPT_NONE) then + ekmfull = 0. + else + ekmfull(kts)=0. + do k=kts+1,kte + ekmfull(k)=max(1.e-6,exch_h(i,k,j)) + enddo + ekmfull(kte+1)=0. + end if + +!!$! UNCOMMENT THIS AND FINE TUNE LEVELS TO YOUR DOMAIN IF YOU WANT TO +!!$! FORCE MIXING TO A CERTAIN DEPTH: +!!$! +!!$! --- Mix the emissions up several layers +! + do k=kts,kte + zz(k)=z(i,k,j)-z_at_w(i,kts,j) + enddo +! vertical mixing routine (including deposition) +! need to be careful here with that dumm tracer in spot 1 +! do not need lho,lho2 +! (03-may-2006 rce - calc dryrho_1d and pass it to vertmx) +! +! if(p_o3.gt.1)dep_vel_o3(i,j)=ddvel(i,j,p_o3) + do nv=1,num_chem-0 + do k=kts,kte + pblst(k)=max(epsilc,chem(i,k,j,nv)) + dryrho_1d(k) = 1./alt(i,k,j) + enddo + + !mix_select: SELECT CASE(chem_opt) + !CASE DEFAULT + call vertmx(data,dtstep,pblst,ekmfull,dryrho_1d, & + zzfull,zz,ddvel(i,j,nv),kts,kte) + + !END SELECT mix_select + + do k=kts,kte + chem(i,k,j,nv)=max(epsilc,pblst(k)) + enddo + enddo +100 continue + +END SUBROUTINE dry_dep_driver + +end module dep_dry_mod diff --git a/physics/smoke/dep_simple_mod.F90 b/physics/smoke/dep_simple_mod.F90 new file mode 100755 index 000000000..37a8189b5 --- /dev/null +++ b/physics/smoke/dep_simple_mod.F90 @@ -0,0 +1,766 @@ +!>\file dep_simple_mod.F90 +!! This file contains the Wesely dry deposition module. + +module dep_simple_mod + + use rrfs_smoke_data + use rrfs_smoke_config, GOCART_SIMPLE => CHEM_OPT_GOCART, chem_opt=>chem_opt +! use chem_tracers_mod, config_flags => chem_config + +! USE module_data_sorgam + + implicit none + +!-------------------------------------------------- +! .. Default Accessibility .. +!-------------------------------------------------- + PUBLIC + + + CONTAINS + +SUBROUTINE wesely_driver( data, ktau, dtstep, current_month, & + gmt, julday, t_phy,moist, p8w, t8w, raincv, & + p_phy, chem, rho_phy, dz8w, ddvel, aer_res_def, & + aer_res_zcen, ivgtyp, tsk, gsw, vegfra, pbl, & + rmol, ust, znt, xlat, xlong, & + z, z_at_w, snowh, numgas, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + implicit none +!-------------------------------------------------- +! Wesely dry dposition driver +!-------------------------------------------------- + +! USE module_model_constants +! USE module_wrf_control,only:num_moist,num_chem +! USE module_state_description +! USE module_initial_chem_namelists +! USE module_data_sorgam +! USE module_state_description, only: param_first_scalar + type(smoke_data), intent(inout), pointer :: data + INTEGER, INTENT(IN ) :: julday, & + numgas, current_month, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + INTEGER, INTENT(IN ) :: ktau + REAL(kind_phys), INTENT(IN ) :: dtstep,gmt + +!-------------------------------------------------- +! advected moisture variables +!-------------------------------------------------- + REAL(KIND_PHYS), DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), INTENT(IN ) :: & + moist +!-------------------------------------------------- +! advected chemical species +!-------------------------------------------------- + REAL(KIND_PHYS), DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), INTENT(INOUT ) :: & + chem +!-------------------------------------------------- +! deposition velocities +!-------------------------------------------------- + REAL(KIND_PHYS), DIMENSION( its:ite, jts:jte, num_chem ), INTENT(INOUT ) :: & + ddvel +!-------------------------------------------------- +! input from met model +!-------------------------------------------------- + REAL(KIND_PHYS), DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN ) :: & + t_phy, & + p_phy, & + dz8w, & + z, & + t8w, & + p8w, & + z_at_w, & + rho_phy + INTEGER,DIMENSION( ims:ime , jms:jme ), INTENT(IN ) :: & + ivgtyp + REAL(KIND_PHYS), DIMENSION( ims:ime , jms:jme ), INTENT(INOUT ) :: & + tsk, & + gsw, & + vegfra, & + pbl, & + rmol, & + ust, & + xlat, & + xlong, & + raincv, & + znt + REAL(KIND_PHYS), intent(inout) :: aer_res_def(its:ite,jts:jte) + REAL(KIND_PHYS), intent(inout) :: aer_res_zcen(its:ite,jts:jte) + REAL(KIND_PHYS), INTENT(IN) :: snowh(ims:ime,jms:jme) + +!-------------------------------------------------- +! .. Local Scalars +!-------------------------------------------------- + REAL(kind_phys) :: clwchem, dvfog, dvpart, pa, rad, dep_vap + REAL(KIND_PHYS) :: rhchem, ta, ustar, vegfrac, z1, zntt + INTEGER :: i, iland, iprt, iseason, j, jce, jcs, n, nr, ipr,jpr,nvr + LOGICAL :: highnh3, rainflag, vegflag, wetflag +!-------------------------------------------------- +! .. Local Arrays +!-------------------------------------------------- + REAL(KIND_PHYS) :: p(kts:kte) + REAL(KIND_PHYS) :: srfres(numgas) + REAL(KIND_PHYS) :: ddvel0d(numgas) + +!----------------------------------------------------------- +! necessary for aerosols (module dependent) +!----------------------------------------------------------- + real(kind_phys) :: rcx(numgas) + + +!----------------------------------------------------------- +! .. Intrinsic Functions +!----------------------------------------------------------- +! integer :: chem_opt + + INTRINSIC max, min + + data => get_thread_smoke_data() + +! chem_opt = chem_opt + + dep_vap = depo_fact + !print*,'hli simple chem_opt',chem_opt + +! CALL wrf_debug(15,'in dry_dep_wesely') + + if( julday < 90 .or. julday > 270 ) then + iseason = 2 +! CALL wrf_debug(15,'setting iseason to 2') + else + iseason = 1 + endif + + +tile_lat_loop : & + do j = jts,jte +tile_lon_loop : & + do i = its,ite + iprt = 0 + + iland = luse2usgs( ivgtyp(i,j) ) +!-- + + ta = tsk(i,j) + rad = gsw(i,j) + vegfrac = vegfra(i,j) + pa = .01*p_phy(i,kts,j) + clwchem = moist(i,kts,j,p_qc) + ustar = ust(i,j) + zntt = znt(i,j) + z1 = z_at_w(i,kts+1,j) - z_at_w(i,kts,j) +!----------------------------------------------------------- +! Set logical default values +!----------------------------------------------------------- + rainflag = .FALSE. + wetflag = .FALSE. + highnh3 = .FALSE. +! if(p_qr > 1) then +! if(moist(i,kts,j,p_qr) > 1.e-18 .or. raincv(i,j) > 0.) then +! rainflag = .true. +! endif +! endif + rhchem = MIN( 100.,100. * moist(i,kts,j,p_qv) / & + (3.80*exp(17.27*(t_phy(i,kts,j)-273.)/(t_phy(i,kts,j)-36.))/pa)) + rhchem = MAX(5.,RHCHEM) + if (rhchem >= 95.) wetflag = .true. + +!----------------------------------------------------------- +!--- deposition +!----------------------------------------------------------- +! if(snowc(i,j).gt.0.)iseason=4 + CALL rc( data, rcx, ta, rad, rhchem, iland, & + iseason, numgas, wetflag, rainflag, highnh3, & + iprt, moist(i,kts,j,p_qv), p8w(i,kts,j) ) + srfres(1:numgas-2) = rcx(1:numgas-2) + srfres(numgas-1:numgas) = 0. + CALL deppart( data, rmol(i,j), ustar, rhchem, clwchem, iland, dvpart, dvfog ) + ddvel0d(1:numgas) = 0. + aer_res_def(i,j) = 0. + aer_res_zcen(i,j) = 0. + CALL landusevg( data, ddvel0d, ustar, rmol(i,j), zntt, z1, dvpart, iland, & + numgas, srfres, aer_res_def(i,j), aer_res_zcen(i,j), p_sulf ) + +!----------------------------------------------------------- +!wig: CBMZ does not have HO and HO2 last so need to copy all species +! ddvel(i,j,1:numgas-2)=ddvel0d(1:numgas-2) +!----------------------------------------------------------- + ddvel(i,j,1:numgas) = ddvel0d(1:numgas) + end do tile_lon_loop + end do tile_lat_loop + +!----------------------------------------------------------- +! For the additional CBMZ species, assign similar RADM counter parts for +! now. Short lived species get a zero velocity since dry dep should be +! unimportant. **ALSO**, treat p_sulf as h2so4 vapor, not aerosol sulfate +!----------------------------------------------------------- +! + +!----------------------------------------------------------- +! For gocartsimple : need msa. On the other hand sulf comes from aerosol routine +!----------------------------------------------------------- + if (chem_opt == GOCART_SIMPLE ) then + do j=jts,jte + do i=its,ite + ddvel(i,j,p_msa) = ddvel(i,j,p_sulf) + ddvel(i,j,p_sulf) = 0. + ddvel(i,j,p_dms) = 0. + end do + end do + end if + +END SUBROUTINE wesely_driver + + SUBROUTINE rc( data, rcx, t, rad, rh, iland, & + iseason, numgas, wetflag, rainflag, highnh3, & + iprt, spec_hum, p_srf ) +!---------------------------------------------------------------------- +! THIS SUBROUTINE CALCULATES SURFACE RESISTENCES ACCORDING +! TO THE MODEL OF +! M. L. WESELY, +! ATMOSPHERIC ENVIRONMENT 23 (1989), 1293-1304 +! WITH SOME ADDITIONS ACCORDING TO +! J. W. ERISMAN, A. VAN PUL, AND P. WYERS, +! ATMOSPHERIC ENVIRONMENT 28 (1994), 2595-2607 +! WRITTEN BY WINFRIED SEIDL, APRIL 1997 +! MODYFIED BY WINFRIED SEIDL, MARCH 2000 +! FOR MM5 VERSION 3 +!---------------------------------------------------------------------- + +! USE module_state_description +! USE module_initial_chem_namelists + implicit none + type(smoke_data), pointer, intent(inout) :: data +!---------------------------------------------------------------------- +! ... dummy arguments +!---------------------------------------------------------------------- + INTEGER, intent(in) :: iland, iseason, numgas + INTEGER, intent(in) :: iprt + REAL(KIND_PHYS), intent(in) :: rad, rh + REAL(KIND_PHYS), intent(in) :: t ! surface temp (K) + REAL(KIND_PHYS), intent(in) :: p_srf ! surface pressure (Pa) + REAL(KIND_PHYS), intent(in) :: spec_hum ! surface specific humidity (kg/kg) + real(kind_phys), intent(out) :: rcx(numgas) + LOGICAL, intent(in) :: highnh3, rainflag, wetflag + +!---------------------------------------------------------------------- +! .. Local Scalars .. +!---------------------------------------------------------------------- + REAL(KIND_PHYS), parameter :: t0 = 298. + REAL(KIND_PHYS), parameter :: tmelt = 273.16 + INTEGER :: lt, n + INTEGER :: chem_opt + REAL(KIND_PHYS) :: rclx, rdc, resice, rgsx, rluo1, rluo2 + REAL(KIND_PHYS) :: rlux, rmx, rs, rsmx, rdtheta, z, wrk + REAL(KIND_PHYS) :: qs, es, ws, dewm, dv_pan, drat + REAL(KIND_PHYS) :: crs, tc + REAL(KIND_PHYS) :: rs_pan, tc_pan + LOGICAL :: has_dew +!---------------------------------------------------------------------- +! .. Local Arrays .. +!---------------------------------------------------------------------- + REAL(KIND_PHYS) :: hstary(numgas) + +!---------------------------------------------------------------------- +! .. Intrinsic Functions .. +!---------------------------------------------------------------------- + INTRINSIC exp + + chem_opt = chem_opt + + rcx(1:numgas) = 1. + + tc = t - 273.15 + rdtheta = 0. + + z = 200./(rad+0.1) + +!!! HARDWIRE VALUES FOR TESTING +! z=0.4727409 +! tc=22.76083 +! t=tc+273.15 +! rad = 412.8426 +! rainflag=.false. +! wetflag=.false. + + IF ( tc<=0. .OR. tc>=40. ) THEN + rs = 9999. + ELSE + rs = data%ri(iland,iseason)*(1+z*z)*(400./(tc*(40.-tc))) + END IF + rdc = 100.*(1. + 1000./(rad + 10.))/(1. + 1000.*rdtheta) + rluo1 = 1./(1./3000. + 3./data%rlu(iland,iseason)) + rluo2 = 1./(1./1000. + 3./data%rlu(iland,iseason)) + resice = 1000.*exp( -(tc + 4.) ) + wrk = (t0 - t)/(t0*t) + + + DO n = 1, numgas + IF( data%hstar(n) /= 0. ) then + hstary(n) = data%hstar(n)*exp( data%dhr(n)*wrk ) +!---------------------------------------------------------------------- +! SPECIAL TREATMENT FOR HNO3, HNO4, H2O2, PAA +!---------------------------------------------------------------------- + rmx = 1./(hstary(n)/3000. + 100.*data%f0(n)) + rsmx = rs*data%dratio(n) + rmx + rclx = 1./(1.e-5*hstary(n)/data%rcls(iland,iseason) & + + data%f0(n)/data%rclo(iland,iseason)) + resice + rgsx = 1./(1.e-5*hstary(n)/data%rgss(iland,iseason) & + + data%f0(n)/data%rgso(iland,iseason)) + resice + rlux = data%rlu(iland,iseason)/(1.e-5*hstary(n) + data%f0(n)) + resice + IF( wetflag ) THEN + rlux = 1./(1./(3.*data%rlu(iland,iseason)) + 1.e-7*hstary(n) + data%f0(n)/rluo1) + END IF + IF( rainflag ) THEN + rlux = 1./(1./(3.*data%rlu(iland,iseason)) + 1.e-7*hstary(n) + data%f0(n)/rluo2) + END IF + rcx(n) = 1./(1./rsmx + 1./rlux + 1./(rdc + rclx) + 1./(data%rac(iland,iseason) + rgsx)) + rcx(n) = max( 1.,rcx(n) ) + end IF + END DO + +!-------------------------------------------------- +! SPECIAL TREATMENT FOR OZONE +!-------------------------------------------------- +! SPECIAL TREATMENT FOR SO2 (Wesely) +! HSTARY(P_SO2)=DATA%HSTAR(P_SO2)*EXP(DATA%DHR(P_SO2)*(1./T-1./298.)) +! RMX=1./(HSTARY(P_SO2)/3000.+100.*DATA%F0(P_SO2)) +! RSMX=RS*DATA%DRATIO(P_SO2)+RMX +! RLUX=DATA%RLU(ILAND,ISEASON)/(1.E-5*HSTARY(P_SO2)+DATA%F0(P_SO2)) +! & +RESICE +! RCLX=DATA%RCLS(ILAND,ISEASON)+RESICE +! RGSX=DATA%RGSS(ILAND,ISEASON)+RESICE +! IF ((wetflag).OR.(RAINFLAG)) THEN +! IF (ILAND.EQ.1) THEN +! RLUX=50. +! ELSE +! RLUX=100. +! END IF +! END IF +! RCX(P_SO2)=1./(1./RSMX+1./RLUX+1./(RDC+RCLX) +! & +1./(DATA%RAC(ILAND,ISEASON)+RGSX)) +! IF (RCX(P_SO2).LT.1.) RCX(P_SO2)=1. + +!-------------------------------------------------- +! SO2 according to Erisman et al. 1994 +! R_STOM +!-------------------------------------------------- +is_so2 : & + if( p_so2 > 1 ) then + rsmx = rs*data%dratio(p_so2) +!-------------------------------------------------- +! R_EXT +!-------------------------------------------------- + IF (tc> -1. ) THEN + IF (rh<81.3) THEN + rlux = 25000.*exp(-0.0693*rh) + ELSE + rlux = 0.58E12*exp(-0.278*rh) + END IF + END IF + IF (((wetflag) .OR. (rainflag)) .AND. (tc> -1. )) THEN + rlux = 1. + END IF + IF ((tc>= -5. ) .AND. (tc<= -1. )) THEN + rlux = 200. + END IF + IF (tc< -5. ) THEN + rlux = 500. + END IF +!-------------------------------------------------- +! INSTEAD OF R_INC R_CL and R_DC of Wesely are used +!-------------------------------------------------- + rclx = data%rcls(iland,iseason) +!-------------------------------------------------- +! DRY SURFACE +!-------------------------------------------------- + rgsx = 1000. +!-------------------------------------------------- +! WET SURFACE +!-------------------------------------------------- + IF ((wetflag) .OR. (rainflag)) THEN + IF (highnh3) THEN + rgsx = 0. + ELSE + rgsx = 500. + END IF + END IF +!-------------------------------------------------- +! WATER +!-------------------------------------------------- + IF (iland==iswater_temp) THEN + rgsx = 0. + END IF +!-------------------------------------------------- +! SNOW +!-------------------------------------------------- + IF( iseason==4 .OR. iland==isice_temp ) THEN + IF( tc > 2. ) THEN + rgsx = 0. + else IF ( tc >= -1. .AND. tc <= 2. ) THEN + rgsx = 70.*(2. - tc) + else IF ( tc < -1. ) THEN + rgsx = 500. + END IF + END IF +!-------------------------------------------------- +! TOTAL SURFACE RESISTENCE +!-------------------------------------------------- + IF ((iseason/=4) .AND. (data%ixxxlu(iland)/=1) .AND. (iland/=iswater_temp) .AND. & + (iland/=isice_temp)) THEN + rcx(p_so2) = 1./(1./rsmx+1./rlux+1./(rclx+rdc+rgsx)) + ELSE + rcx(p_so2) = rgsx + END IF + rcx(p_so2) = max( 1.,rcx(p_so2) ) + end if is_so2 +!-------------------------------------------------- +! NH3 according to Erisman et al. 1994 +! R_STOM +!-------------------------------------------------- + END SUBROUTINE rc + + SUBROUTINE deppart( data, rmol, ustar, rh, clw, iland, & + dvpart, dvfog ) +!-------------------------------------------------- +! THIS SUBROUTINE CALCULATES SURFACE DEPOSITION VELOCITIES +! FOR FINE AEROSOL PARTICLES ACCORDING TO THE MODEL OF +! J. W. ERISMAN, A. VAN PUL, AND P. WYERS, +! ATMOSPHERIC ENVIRONMENT 28 (1994), 2595-2607 +! WRITTEN BY WINFRIED SEIDL, APRIL 1997 +! MODIFIED BY WINFRIED SEIDL, MARCH 2000 +! FOR MM5 VERSION 3 +!-------------------------------------------------- + implicit none + type(smoke_data), pointer, intent(inout) :: data + +!-------------------------------------------------- +! .. Scalar Arguments .. +!-------------------------------------------------- + INTEGER, intent(in) :: iland + REAL(KIND_PHYS), intent(in) :: clw, rh, rmol, ustar + REAL(KIND_PHYS), intent(out) :: dvfog, dvpart + +!-------------------------------------------------- +! .. Intrinsic Functions .. +!-------------------------------------------------- + INTRINSIC exp + + dvpart = ustar/data%kpart(iland) + IF (rmol<0.) THEN +!-------------------------------------------------- +! UNSTABLE LAYERING CORRECTION +!-------------------------------------------------- + dvpart = dvpart*(1.+(-300.*rmol)**0.66667) + END IF + IF (rh>80.) THEN +!-------------------------------------------------- +! HIGH RELATIVE HUMIDITY CORRECTION +! ACCORDING TO J. W. ERISMAN ET AL. +! ATMOSPHERIC ENVIRONMENT 31 (1997), 321-332 +!-------------------------------------------------- + dvpart = dvpart*(1.+0.37*exp((rh-80.)/20.)) + END IF + +!-------------------------------------------------- +! SEDIMENTATION VELOCITY OF FOG WATER ACCORDING TO +! R. FORKEL, W. SEIDL, R. DLUGI AND E. DEIGELE +! J. GEOPHYS. RES. 95D (1990), 18501-18515 +!-------------------------------------------------- + dvfog = 0.06*clw + IF (data%ixxxlu(iland)==5) THEN +!-------------------------------------------------- +! TURBULENT DEPOSITION OF FOG WATER IN CONIFEROUS FOREST ACCORDI +! A. T. VERMEULEN ET AL. +! ATMOSPHERIC ENVIRONMENT 31 (1997), 375-386 +!-------------------------------------------------- + dvfog = dvfog + 0.195*ustar*ustar + END IF + + END SUBROUTINE deppart + + SUBROUTINE landusevg( data, vgs, ustar, rmol, z0, zz, & + dvparx, iland, numgas, srfres, aer_res_def, & + aer_res_zcen, p_sulf ) +!-------------------------------------------------- +! This subroutine calculates the species specific deposition velocit +! as a function of the local meteorology and land use. The depositi +! Velocity is also landuse specific. +! Reference: Hsieh, C.M., Wesely, M.L. and Walcek, C.J. (1986) +! A Dry Deposition Module for Regional Acid Deposition +! EPA report under agreement DW89930060-01 +! Revised version by Darrell Winner (January 1991) +! Environmental Engineering Science 138-78 +! California Institute of Technology +! Pasadena, CA 91125 +! Modified by Winfried Seidl (August 1997) +! Fraunhofer-Institut fuer Atmosphaerische Umweltforschung +! Garmisch-Partenkirchen, D-82467 +! for use of Wesely and Erisman surface resistances +! Inputs: +! Ustar : The grid average friction velocity (m/s) +! Rmol : Reciprocal of the Monin-Obukhov length (1/m) +! Z0 : Surface roughness height for the grid square (m) +! SrfRes : Array of landuse/atmospheric/species resistances (s/m) +! Slist : Array of chemical species codes +! Dvparx : Array of surface deposition velocity of fine aerosol p +! Outputs: +! Vgs : Array of species and landuse specific deposition +! velocities (m/s) +! Vg : Cell-average deposition velocity by species (m/s) +! Variables used: +! SCPR23 : (Schmidt #/Prandtl #)**(2/3) Diffusion correction fac +! Zr : Reference Height (m) +! Iatmo : Parameter specifying the stabilty class (Function of +! Z0 : Surface roughness height (m) +! karman : Von Karman constant (from module_model_constants) +!-------------------------------------------------- + +! USE module_model_constants, only: karman + implicit none + + type(smoke_data), pointer, intent(inout) :: data + +!-------------------------------------------------- +! .. Scalar Arguments .. +!-------------------------------------------------- + INTEGER, intent(in) :: iland, numgas, p_sulf + REAL(KIND_PHYS), intent(in) :: dvparx, ustar, z0, zz + REAL(KIND_PHYS), intent(inout) :: rmol + REAL(KIND_PHYS), intent(inout) :: aer_res_def + REAL(KIND_PHYS), intent(inout) :: aer_res_zcen +!-------------------------------------------------- +! .. Array Arguments .. +!-------------------------------------------------- + REAL(KIND_PHYS), intent(in) :: srfres(numgas) + REAL(KIND_PHYS), intent(out) :: vgs(numgas) + +!-------------------------------------------------- +! .. Local Scalars .. +!-------------------------------------------------- + INTEGER :: jspec + REAL(KIND_PHYS) :: vgp, vgpart, zr + REAL(KIND_PHYS) :: rmol_tmp +!-------------------------------------------------- +! .. Local Arrays .. +!-------------------------------------------------- + REAL(KIND_PHYS) :: vgspec(numgas) + +!-------------------------------------------------- +! Calculate aerodynamic resistance for reference +! height = layer center +!-------------------------------------------------- + zr = zz*.5 + rmol_tmp = rmol + CALL depvel( data, numgas, rmol_tmp, zr, z0, ustar, & + vgspec, vgpart, aer_res_zcen ) +!-------------------------------------------------- +! Set the reference height (2.0 m) +!-------------------------------------------------- +! zr = 10.0 + zr = 2.0 + +!-------------------------------------------------- +! CALCULATE THE DEPOSITION VELOCITY without any surface +! resistance term, i.e. 1 / (ra + rb) +!-------------------------------------------------- + CALL depvel( data, numgas, rmol, zr, z0, ustar, & + vgspec, vgpart, aer_res_def ) + +!-------------------------------------------------- +! Calculate the deposition velocity for each species +! and grid cell by looping through all the possibile combinations +! of the two +!-------------------------------------------------- + vgp = 1.0/((1.0/vgpart)+(1.0/dvparx)) +!-------------------------------------------------- +! Loop through the various species +!-------------------------------------------------- + DO jspec = 1, numgas +!-------------------------------------------------- +! Add in the surface resistance term, rc (SrfRes) +!-------------------------------------------------- + vgs(jspec) = 1.0/(1.0/vgspec(jspec) + srfres(jspec)) + END DO + vgs(p_sulf) = vgp + + CALL cellvg( data, vgs, ustar, zz, zr, rmol, numgas ) + + END SUBROUTINE landusevg + + SUBROUTINE cellvg( data, vgtemp, ustar, dz, zr, rmol, nspec ) +!-------------------------------------------------- +! THIS PROGRAM HAS BEEN DESIGNED TO CALCULATE THE CELL AVERAGE +! DEPOSITION VELOCITY GIVEN THE VALUE OF VG AT SOME REFERENCE +! HEIGHT ZR WHICH IS MUCH SMALLER THAN THE CELL HEIGHT DZ. +! PROGRAM WRITTEN BY GREGORY J.MCRAE (NOVEMBER 1977) +! Modified by Darrell A. Winner (February 1991) +!.....PROGRAM VARIABLES... +! VgTemp - DEPOSITION VELOCITY AT THE REFERENCE HEIGHT +! USTAR - FRICTION VELOCITY +! RMOL - RECIPROCAL OF THE MONIN-OBUKHOV LENGTH +! ZR - REFERENCE HEIGHT +! DZ - CELL HEIGHT +! CELLVG - CELL AVERAGE DEPOSITION VELOCITY +! VK - VON KARMAN CONSTANT +!-------------------------------------------------- + +! USE module_model_constants, only: karman + implicit none + type(smoke_data), pointer, intent(inout) :: data + +!-------------------------------------------------- +! .. Scalar Arguments .. +!-------------------------------------------------- + INTEGER, intent(in) :: nspec + REAL(KIND_PHYS), intent(in) :: dz, rmol, ustar, zr +!-------------------------------------------------- +! .. Array Arguments .. +!-------------------------------------------------- + REAL(KIND_PHYS), intent(out) :: vgtemp(nspec) +!-------------------------------------------------- +! .. Local Scalars .. +!-------------------------------------------------- + INTEGER :: nss + REAL(KIND_PHYS) :: a, fac, pdz, pzr, vk +!-------------------------------------------------- +! .. Intrinsic Functions .. +!-------------------------------------------------- + INTRINSIC alog, sqrt + +!-------------------------------------------------- +! Set the von Karman constant +!-------------------------------------------------- + vk = karman + +!-------------------------------------------------- +! DETERMINE THE STABILITY BASED ON THE CONDITIONS +! 1/L < 0 UNSTABLE +! 1/L = 0 NEUTRAL +! 1/L > 0 STABLE +!-------------------------------------------------- + DO nss = 1, nspec + IF (rmol < 0.) THEN + pdz = sqrt(1.0 - 9.0*dz*rmol) + pzr = sqrt(1.0 - 9.0*zr*rmol) + fac = ((pdz - 1.0)/(pzr - 1.0))*((pzr + 1.0)/(pdz + 1.0)) + a = 0.74*dz*alog(fac) + (0.164/rmol)*(pdz-pzr) + ELSE IF (rmol == 0.) THEN + a = 0.74*(dz*alog(dz/zr) - dz + zr) + ELSE + a = 0.74*(dz*alog(dz/zr) - dz + zr) + (2.35*rmol)*(dz - zr)**2 + END IF +!-------------------------------------------------- +! CALCULATE THE DEPOSITION VELOCITIY +!-------------------------------------------------- + vgtemp(nss) = vgtemp(nss)/(1.0 + vgtemp(nss)*a/(vk*ustar*(dz - zr))) + END DO + + END SUBROUTINE cellvg + + SUBROUTINE depvel( data, numgas, rmol, zr, z0, ustar, & + depv, vgpart, aer_res ) +!-------------------------------------------------- +! THIS FUNCTION HAS BEEN DESIGNED TO EVALUATE AN UPPER LIMIT +! FOR THE POLLUTANT DEPOSITION VELOCITY AS A FUNCTION OF THE +! SURFACE ROUGHNESS AND METEOROLOGICAL CONDITIONS. +! PROGRAM WRITTEN BY GREGORY J.MCRAE (NOVEMBER 1977) +! Modified by Darrell A. Winner (Feb. 1991) +! by Winfried Seidl (Aug. 1997) +!.....PROGRAM VARIABLES... +! RMOL - RECIPROCAL OF THE MONIN-OBUKHOV LENGTH +! ZR - REFERENCE HEIGHT +! Z0 - SURFACE ROUGHNESS HEIGHT +! SCPR23 - (Schmidt #/Prandtl #)**(2/3) Diffusion correction fact +! UBAR - ABSOLUTE VALUE OF SURFACE WIND SPEED +! DEPVEL - POLLUTANT DEPOSITION VELOCITY +! Vk - VON KARMAN CONSTANT +! USTAR - FRICTION VELOCITY U* +! POLINT - POLLUTANT INTEGRAL +! AER_RES - AERODYNAMIC RESISTANCE +!.....REFERENCES... +! MCRAE, G.J. ET AL. (1983) MATHEMATICAL MODELING OF PHOTOCHEMICAL +! AIR POLLUTION, ENVIRONMENTAL QUALITY LABORATORY REPORT 18, +! CALIFORNIA INSTITUTE OF TECHNOLOGY, PASADENA, CALIFORNIA. +!.....RESTRICTIONS... +! 1. THE MODEL EDDY DIFFUSIVITIES ARE BASED ON MONIN-OBUKHOV +! SIMILARITY THEORY AND SO ARE ONLY APPLICABLE IN THE +! SURFACE LAYER, A HEIGHT OF O(30M). +! 2. ALL INPUT UNITS MUST BE CONSISTENT +! 3. THE PHI FUNCTIONS USED TO CALCULATE THE FRICTION +! VELOCITY U* AND THE POLLUTANT INTEGRALS ARE BASED +! ON THE WORK OF BUSINGER ET AL.(1971). +! 4. THE MOMENTUM AND POLLUTANT DIFFUSIVITIES ARE NOT +! THE SAME FOR THE CASES L<0 AND L>0. +!-------------------------------------------------- + +! USE module_model_constants, only: karman + implicit none + type(smoke_data), pointer, intent(inout) :: data + +!-------------------------------------------------- +! .. Scalar Arguments .. +!-------------------------------------------------- + INTEGER, intent(in) :: numgas + REAL(KIND_PHYS), intent(in) :: ustar, z0, zr + REAL(KIND_PHYS), intent(out) :: vgpart, aer_res + REAL(KIND_PHYS), intent(inout) :: rmol +!-------------------------------------------------- +! .. Array Arguments .. +!-------------------------------------------------- + REAL(KIND_PHYS), intent(out) :: depv(numgas) +!-------------------------------------------------- +! .. Local Scalars .. +!-------------------------------------------------- + INTEGER :: l + REAL(KIND_PHYS) :: ao, ar, polint, vk +!-------------------------------------------------- +! .. Intrinsic Functions .. +!-------------------------------------------------- + INTRINSIC alog +!-------------------------------------------------- +! Set the von Karman constant +!-------------------------------------------------- + vk = karman + +!-------------------------------------------------- +! Calculate the diffusion correction factor +! SCPR23 is calculated as (Sc/Pr)**(2/3) using Sc= 1.15 and Pr= 1.0 +! DATA%SCPR23 = 1.10 +!-------------------------------------------------- +! DETERMINE THE STABILITY BASED ON THE CONDITIONS +! 1/L < 0 UNSTABLE +! 1/L = 0 NEUTRAL +! 1/L > 0 STABLE +!-------------------------------------------------- + + if(abs(rmol) < 1.E-6 ) rmol = 0. + + IF (rmol<0) THEN + ar = ((1.0-9.0*zr*rmol)**(0.25)+0.001)**2 + ao = ((1.0-9.0*z0*rmol)**(0.25)+0.001)**2 + polint = 0.74*(alog((ar-1.0)/(ar+1.0))-alog((ao-1.0)/(ao+1.0))) + ELSE IF (rmol==0.) THEN + polint = 0.74*alog(zr/z0) + ELSE + polint = 0.74*alog(zr/z0) + 4.7*rmol*(zr-z0) + END IF + +!-------------------------------------------------- +! CALCULATE THE Maximum DEPOSITION VELOCITY +!-------------------------------------------------- + DO l = 1, numgas + depv(l) = ustar*vk/(2.0*data%scpr23(l)+polint) + END DO + vgpart = ustar*vk/polint + aer_res = polint/(karman*max(ustar,1.0e-4)) + + END SUBROUTINE depvel + + ! NOTE: dep_init is now in rrfs_smoke_data + +end module dep_simple_mod diff --git a/physics/smoke/dep_vertmx_mod.F90 b/physics/smoke/dep_vertmx_mod.F90 new file mode 100755 index 000000000..d56b1b87e --- /dev/null +++ b/physics/smoke/dep_vertmx_mod.F90 @@ -0,0 +1,212 @@ +!>\file dep_vertmx_mod.F90 +!! This file calculates change in time of phi due to vertical mixing and dry deposition. + +MODULE dep_vertmx_mod + use rrfs_smoke_data + use machine , only : kind_phys + +CONTAINS + +!----------------------------------------------------------------------- + SUBROUTINE vertmx( data, dt, phi, kt_turb, dryrho, & + zsigma, zsigma_half, vd, kts, ktem1 ) +! !! purpose - calculate change in time of phi due to vertical mixing +! !! and dry deposition (for 1 species, 1 vertical column, 1 time step) +! !! Mariusz Pagowski, March 2001 +! !! conventions used: +! !! input is lower case +! !! output is upper case +! +! !! modifications by R Easter, May 2006 +! !! added dryrho so this routine conserves column mass burde +! !! when dry deposition velocity is zero +! !! changed "kte" to "ktem1" for consistency with the kte in WRF +! +! ARGUMENTS +! +! dt = time step (s) +! phi = initial/final (at input/output) species mixing ratios at "T" points +! kt_turb = turbulent exchange coefficients (m^2/s) at "W" points +! dryrho = dry air density (kg/m^3) at "T" points +! zsigma = heights (m) at "W" points +! zsigma_half = heights (m) at "T" points +! vd = dry deposition velocity (m/s) +! kts, ktem1 = vertical indices of bottom and top "T" points +! + IMPLICIT NONE + type(smoke_data), intent(inout) :: data + +! .. Scalar Arguments .. + INTEGER, INTENT(IN) :: kts,ktem1 + REAL(KIND=KIND_PHYS), INTENT(IN) :: dt, vd +! .. +! .. Array Arguments .. + REAL(KIND=KIND_PHYS), INTENT(IN), DIMENSION (kts:ktem1+1) :: kt_turb, zsigma + REAL(KIND=KIND_PHYS), INTENT(IN), DIMENSION (kts:ktem1) :: dryrho, zsigma_half + REAL(KIND=KIND_PHYS), INTENT(INOUT), DIMENSION (kts:ktem1) :: phi +! .. +! .. Local Scalars .. + INTEGER :: k +! .. +! .. Local Arrays .. + REAL(KIND=KIND_PHYS), DIMENSION (kts+1:ktem1) :: a_coeff + REAL(KIND=KIND_PHYS), DIMENSION (kts:ktem1) :: b_coeff, lhs1, lhs2, lhs3, rhs +! .. +! .. External Subroutines .. +! EXTERNAL coeffs, rlhside, tridiag +! .. + CALL coeffs( data, kts, ktem1, dryrho, zsigma, zsigma_half, a_coeff, b_coeff ) + + CALL rlhside( data, kts, ktem1, kt_turb, dryrho, a_coeff, b_coeff, & + phi, dt, vd, rhs, lhs1, lhs2, lhs3 ) + + CALL tridiag( data, kts, ktem1, lhs1, lhs2, lhs3, rhs ) + + DO k = kts,ktem1 + phi(k) = rhs(k) + END DO + + END SUBROUTINE vertmx + + +!----------------------------------------------------------------------- + SUBROUTINE rlhside( data, kts, ktem1, k_turb, dryrho, a_coeff, b_coeff, & + phi, dt, vd, rhs, lhs1, lhs2, lhs3 ) + !! to calculate right and left hand sides in diffusion equation + !! for the tridiagonal solver + !! Mariusz Pagowski, March 2001 + !! conventions used: + !! input is lower case + !! output is upper case + IMPLICIT NONE + type(smoke_data), intent(inout) :: data + +! .. Scalar Arguments .. + INTEGER, INTENT(IN) :: kts,ktem1 + REAL(KIND=KIND_PHYS), INTENT(IN) :: dt, vd +! .. +! .. Array Arguments .. + REAL(KIND=KIND_PHYS), INTENT(IN), DIMENSION (kts:ktem1+1) :: k_turb + REAL(KIND=KIND_PHYS), INTENT(IN), DIMENSION (kts+1:ktem1) :: a_coeff + REAL(KIND=KIND_PHYS), INTENT(IN), DIMENSION (kts:ktem1) :: b_coeff, dryrho + REAL(KIND=KIND_PHYS), INTENT(IN), DIMENSION (kts:ktem1) :: phi + REAL(KIND=KIND_PHYS), INTENT(OUT), DIMENSION (kts:ktem1) :: lhs1, lhs2, lhs3, rhs +! .. +! .. Local Scalars .. + !REAL(KIND_PHYS) :: a1, a2, alfa_explicit = .25, beta_implicit = .75 + REAL(KIND_PHYS) :: a1, a2, alfa_explicit = .0, beta_implicit = 1. + INTEGER :: i + +! .. + i = kts + a2 = a_coeff(i+1)*k_turb(i+1) + rhs(i) = (1./(dt*b_coeff(i)) - alfa_explicit*(vd*dryrho(i)+a2))*phi(i) + & + alfa_explicit*(a2*phi(i+1)) + lhs1(i) = 0. + lhs2(i) = 1./(dt*b_coeff(i)) + beta_implicit*(vd*dryrho(i)+a2) + lhs3(i) = -beta_implicit*a2 + + DO i = kts+1, ktem1-1 + a1 = a_coeff(i)*k_turb(i) + a2 = a_coeff(i+1)*k_turb(i+1) + + rhs(i) = (1./(dt*b_coeff(i)) - alfa_explicit*(a1+a2))*phi(i) + & + alfa_explicit*(a1*phi(i-1) + a2*phi(i+1)) + + lhs1(i) = -beta_implicit*a1 + lhs2(i) = 1./(dt*b_coeff(i)) + beta_implicit*(a1+a2) + lhs3(i) = -beta_implicit*a2 + END DO + + i = ktem1 + a1 = a_coeff(i)*k_turb(i) + rhs(i) = (1./(dt*b_coeff(i)) - alfa_explicit*(a1 ))*phi(i) + & + alfa_explicit*(a1*phi(i-1)) + lhs1(i) = -beta_implicit*a1 + lhs2(i) = 1./(dt*b_coeff(i)) + beta_implicit*(a1 ) + lhs3(i) = 0. + + END SUBROUTINE rlhside + + +!----------------------------------------------------------------------- + SUBROUTINE tridiag( data, kts, ktem1, a, b, c, f ) + !! to solve system of linear eqs on tridiagonal matrix n times n + !! after Peaceman and Rachford, 1955 + !! a,b,c,F - are vectors of order n + !! a,b,c - are coefficients on the LHS + !! F - is initially RHS on the output becomes a solution vector + !! Mariusz Pagowski, March 2001 + !! conventions used: + !! input is lower case + !! output is upper case + IMPLICIT NONE + type(smoke_data), intent(inout) :: data + +! .. Scalar Arguments .. + INTEGER, INTENT(IN) :: kts,ktem1 +! .. +! .. Array Arguments .. + REAL(KIND=KIND_PHYS), INTENT(IN), DIMENSION (kts:ktem1) :: a, b, c + REAL(KIND=KIND_PHYS), INTENT(INOUT), DIMENSION (kts:ktem1) :: f +! .. +! .. Local Scalars .. + REAL(KIND_PHYS) :: p + INTEGER :: i +! .. +! .. Local Arrays .. + REAL(KIND=KIND_PHYS), DIMENSION (kts:ktem1) :: q +! .. + q(kts) = -c(kts)/b(kts) + f(kts) = f(kts)/b(kts) + + DO i = kts+1, ktem1 + p = 1./(b(i)+a(i)*q(i-1)) + q(i) = -c(i)*p + f(i) = (f(i)-a(i)*f(i-1))*p + END DO + + DO i = ktem1 - 1, kts, -1 + f(i) = f(i) + q(i)*f(i+1) + END DO + + END SUBROUTINE tridiag + + +!----------------------------------------------------------------------- + SUBROUTINE coeffs( data, kts, ktem1, dryrho, & + z_sigma, z_sigma_half, a_coeff, b_coeff ) +! !! to calculate coefficients in diffusion equation +! !! Mariusz Pagowski, March 2001 +! !! conventions used: +! !! input is lower case +! !! output is upper case +! .. Scalar Arguments .. + IMPLICIT NONE + type(smoke_data), intent(inout) :: data + + INTEGER, INTENT(IN) :: kts,ktem1 +! .. +! .. Array Arguments .. + REAL(KIND=KIND_PHYS), INTENT(IN), DIMENSION (kts:ktem1+1) :: z_sigma + REAL(KIND=KIND_PHYS), INTENT(IN), DIMENSION (kts:ktem1) :: z_sigma_half, dryrho + REAL(KIND=KIND_PHYS), INTENT(OUT), DIMENSION (kts+1:ktem1) :: a_coeff + REAL(KIND=KIND_PHYS), INTENT(OUT), DIMENSION (kts:ktem1) :: b_coeff +! .. +! .. Local Scalars .. + INTEGER :: i + REAL(KIND=KIND_PHYS) :: dryrho_at_w +! .. + DO i = kts, ktem1 + b_coeff(i) = 1./(dryrho(i)*(z_sigma(i+1)-z_sigma(i))) + END DO + + DO i = kts+1, ktem1 + dryrho_at_w = 0.5*(dryrho(i)+dryrho(i-1)) + a_coeff(i) = dryrho_at_w/(z_sigma_half(i)-z_sigma_half(i-1)) + END DO + + END SUBROUTINE coeffs + +!----------------------------------------------------------------------- +END MODULE dep_vertmx_mod diff --git a/physics/smoke/dep_wet_ls_mod.F90 b/physics/smoke/dep_wet_ls_mod.F90 new file mode 100755 index 000000000..3a7a186ea --- /dev/null +++ b/physics/smoke/dep_wet_ls_mod.F90 @@ -0,0 +1,562 @@ +!>\file dep_wet_ls_mod.F90 +!! This file contains aerosol wet deposition module. + +module dep_wet_ls_mod + use rrfs_smoke_data + use machine , only : kind_phys + use rrfs_smoke_config +! use chem_tracers_mod +! use chem_rc_mod +! use chem_tracers_mod +! use chem_const_mod, only : grav => grvity + + implicit none + + ! -- large scale wet deposition scavenging factors + + private + + public :: dep_wet_ls_init + public :: wetdep_ls + public :: WetRemovalGOCART + +contains + +! subroutine dep_wet_ls_init(config, rc) + subroutine dep_wet_ls_init(data) + implicit none + type(smoke_data), intent(inout) :: data + + ! -- I/O arguments +! type(chem_config_type), intent(in) :: config +! integer, intent(out) :: rc + + ! -- local variables + integer :: ios, n + + ! -- begin + !rc = CHEM_RC_SUCCESS + + ! -- set aerosol wet scavenging coefficients + if (associated(data%alpha)) then + deallocate(data%alpha, stat=ios) + !if (chem_rc_test((ios /= 0), msg="Failed to deallocate memory", & + ! file=__FILE__, line=__LINE__, rc=rc)) return + end if + + allocate(data%alpha(num_chem), stat=ios) + !if (chem_rc_test((ios /= 0), msg="Failed to allocate memory", & + ! file=__FILE__, line=__LINE__, rc=rc)) return + + data%alpha = 0. + + select case (wetdep_ls_opt) + case (WDLS_OPT_GSD) + + select case (chem_opt) + case (CHEM_OPT_GOCART) + data%alpha = 1.0 + end select + + case (WDLS_OPT_NGAC) + + select case (chem_opt) + case (CHEM_OPT_GOCART) + data%alpha(p_so2 ) = 0. + data%alpha(p_sulf ) = 1.5 + data%alpha(p_dms ) = 0. + data%alpha(p_msa ) = 0. + data%alpha(p_p25 ) = 1. + data%alpha(p_bc1 ) = 0.7 + data%alpha(p_bc2 ) = 0.7 + data%alpha(p_oc1 ) = 1. + data%alpha(p_oc2 ) = 1. + data%alpha(p_dust_1) = 1. + data%alpha(p_dust_2) = 1. + data%alpha(p_dust_3) = 1. + data%alpha(p_dust_4) = 1. + data%alpha(p_dust_5) = 1. + data%alpha(p_seas_1) = 1. + data%alpha(p_seas_2) = 1. + data%alpha(p_seas_3) = 1. + data%alpha(p_seas_4) = 1. + data%alpha(p_seas_5) = 1. + data%alpha(p_p10 ) = 1. + case default + ! -- NGAC large scale wet deposition only works with GOCART + end select + + case default + end select + + ! -- replace first default wet scavenging coefficients with input values if + ! available + if (any(wetdep_ls_alpha > 0._kind_phys)) then + n = min(size(data%alpha), size(wetdep_ls_alpha)) + data%alpha(1:n) = real(wetdep_ls_alpha(1:n)) + end if + + end subroutine dep_wet_ls_init + + + + subroutine wetdep_ls(data,dt,var,rain,moist,rho,var_rmv, & + num_moist,num_chem,p_qc,p_qi,dz8w,vvel, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + IMPLICIT NONE + type(smoke_data), intent(inout) :: data + + INTEGER, INTENT(IN ) :: num_chem,num_moist,p_qc, p_qi, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + real(kind_phys), INTENT(IN ) :: dt + REAL(kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & + INTENT(IN ) :: moist + REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ), & + INTENT(IN ) :: rho,dz8w,vvel + REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ,1:num_chem), & + INTENT(INOUT) :: var + REAL(kind_phys), DIMENSION( ims:ime, jms:jme ), & + INTENT(IN ) :: rain + REAL(kind_phys), DIMENSION( ims:ime , jms:jme,num_chem ), & + INTENT(INOUT ) :: var_rmv + REAL(kind_phys), DIMENSION( its:ite , jts:jte ) :: var_sum + REAL(kind_phys), DIMENSION( its:ite , kts:kte, jts:jte ) :: var_rmvl + REAL(kind_phys), DIMENSION( its:ite , jts:jte ) :: frc,var_sum_clw,rain_clw + real(kind_phys) :: dvar,factor,rho_water + integer :: nv,i,j,k + + rho_water = 1000. + var_rmv (:,:,:)=0. + + do nv=1,num_chem +! +! simple LS removal +! + +! +! proportionality constant +! + frc(:,:)=0.1 + do i=its,ite + do j=jts,jte + var_sum_clw(i,j)=0. + var_sum(i,j)=0. + var_rmvl(i,:,j)=0. + rain_clw(i,j)=0. + if(rain(i,j).gt.1.e-6)then +! convert rain back to rate +! + rain_clw(i,j)=rain(i,j)/dt +! total cloud water +! + do k=1,kte + dvar=max(0.,(moist(i,k,j,p_qc)+moist(i,k,j,p_qi))) + var_sum_clw(i,j)=var_sum_clw(i,j)+dvar + enddo + endif + enddo + enddo +! +! get rid of it +! + do i=its,ite + do j=jts,jte + if(rain(i,j).gt.1.e-6 .and. var_sum_clw(i,j).gt.1.e-10 ) then + do k=kts,kte + if(var(i,k,j,nv).gt.1.e-08 .and. (moist(i,k,j,p_qc)+moist(i,k,j,p_qi)).gt.1.e-8)then + factor = max(0.,frc(i,j)*rho(i,k,j)*dz8w(i,k,j)*vvel(i,k,j)) + dvar=max(0.,data%alpha(nv)*factor/(1+factor)*var(i,k,j,nv)) + dvar=min(dvar,var(i,k,j,nv)) + var_rmvl(i,k,j)=dvar + if((var(i,k,j,nv)-dvar).lt.1.e-16)then + dvar=var(i,k,j,nv)-1.e-16 + var_rmvl(i,k,j)=dvar !lzhang + var(i,k,j,nv)=var(i,k,j,nv)-dvar + else + var(i,k,j,nv)=var(i,k,j,nv)-dvar + endif + !var_rmv(i,j,nv)=var_rmv(i,j,nv)+var_rmvl(i,k,j) + !!convert wetdeposition into ug/m2/s + var_rmv(i,j,nv)=var_rmv(i,j,nv)+(var_rmvl(i,k,j)*rho(i,k,j)*dz8w(i,k,j)/dt) !lzhang + endif + enddo + var_rmv(i,j,nv)=max(0.,var_rmv(i,j,nv)) + endif + enddo + enddo + enddo + + end subroutine wetdep_ls + +!------------------------------------------------------------------------- +! NASA/GSFC, Global Modeling and Assimilation Office, Code 900.3 ! +!------------------------------------------------------------------------- +!BOP +! +! !IROUTINE: WetRemovalGOCART - Calculate aerosol wet removal due +! to large scale processes. +! +! !INTERFACE: +! + + subroutine WetRemovalGOCART ( data,i1, i2, j1, j2, k1, k2, n1, n2, cdt, & + num_chem, var_rmv, chem, ple, tmpu, & + rhoa, dqcond, precc, precl, grav, & + ims, ime, jms, jme, kms, kme) +! ims, ime, jms, jme, kms, kme, rc ) + +! !USES: + IMPLICIT NONE + type(smoke_data), intent(inout) :: data + +! !INPUT PARAMETERS: + integer, intent(in) :: i1, i2, j1, j2, k1, k2, n1, n2, num_chem, & + ims, ime, jms, jme, kms, kme + real(kind_phys), intent(in) :: cdt, grav + REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ,1:num_chem),& + INTENT(INOUT) :: chem + REAL(kind_phys), DIMENSION( ims:ime , jms:jme,num_chem ), & + INTENT(INOUT ) :: var_rmv !! tracer loss flux [kg m-2 s-1] + real(kind_phys), dimension(ims:ime, kms:kme, jms:jme),& + INTENT(IN) :: ple, tmpu, rhoa, dqcond + real(kind_phys), dimension(ims:ime , jms:jme) , & + INTENT(IN) :: precc, precl ! cv, ls precip [mm day-1] + +! !OUTPUT PARAMETERS: +! integer, intent(out) :: rc ! Error return code: + ! 0 - all is well + ! 1 - + +! !DESCRIPTION: Calculates the updated species concentration due to wet +! removal. As written, intended to function for large +! scale (not convective) wet removal processes + +! +! !REVISION HISTORY: +! +! 08Jan2010 - Colarco, based on GOCART implementation, does not +! include any size dependent term +! +!EOP +!------------------------------------------------------------------------- + +! !Local Variables + character(len=*), parameter :: myname = 'WetRemovalGOCART' + integer :: i, j, k, n, nbins, LH, kk, ios,nv + real(kind_phys) :: pdog(i1:i2,k1:k2,j1:j2) ! air mass factor dp/g [kg m-2] + real(kind_phys) :: pls, pcv, pac ! ls, cv, tot precip [mm day-1] + real(kind_phys) :: qls(k1:k2), qcv(k1:k2) ! ls, cv portion dqcond [kg m-3 s-1] + real(kind_phys) :: qmx, qd, A ! temporary variables on moisture + real(kind_phys) :: F, B, BT ! temporary variables on cloud, freq. + real(kind_phys), allocatable :: fd(:,:) ! flux across layers [kg m-2] + real(kind_phys), allocatable :: DC(:) ! scavenge change in mass mixing ratio +! Rain parameters from Liu et al. + real(kind_phys), parameter :: B0_ls = 1.0e-4 + real(kind_phys), parameter :: F0_ls = 1.0 + real(kind_phys), parameter :: XL_ls = 5.0e-4 + real(kind_phys), parameter :: B0_cv = 1.5e-3 + real(kind_phys), parameter :: F0_cv = 0.3 + real(kind_phys), parameter :: XL_cv = 2.0e-3 +! Duration of rain: ls = model timestep, cv = 1800 s (<= cdt) + real(kind_phys) :: Td_ls + real(kind_phys) :: Td_cv + + +! Efficiency of dust wet removal (since dust is really not too hygroscopic) +! Applied only to in-cloud scavenging + real(kind_phys) :: effRemoval +! real(kind_phys),dimension(20) ::fwet +! tracer: p_so2=1 p_sulf=2 p_dms=3 p_msa=4 p_p25=5 p_bc1=6 p_bc2=7 p_oc1=8 +! p_oc2=9 p_dust_1=10 p_dust_2=11 p_dust_3=12 p_dust_4=13 p_dust_5=14 +! p_seas_1=15 p_seas_2=16 p_seas_3=17 p_seas_4=18 p_seas_5=19 p_p10 =20 +! data fwet /0.,1.5,0.,0.,1.,0.7,0.7,0.4,0.4,1.,1.,1.,1.,1.,1.,1.,1.,1.,1.,1./ +! rc=0. + +! Initialize local variables +! -------------------------- +! rc = CHEM_RC_SUCCESS + + Td_ls = cdt + Td_cv = cdt + nbins = n2-n1+1 + var_rmv = 0.0 + +! Allocate the dynamic arrays + allocate(fd(k1:k2,nbins),stat=ios) +! if (chem_rc_test((ios .ne. 0), msg="Failed to allocate memory", & +! file=__FILE__, line=__LINE__, rc=rc)) return + allocate(dc(nbins),stat=ios) +! if (chem_rc_test((ios .ne. 0), msg="Failed to allocate memory", & +! file=__FILE__, line=__LINE__, rc=rc)) return + +! Accumulate the 3-dimensional arrays of rhoa and pdog + do j = j1, j2 + do i = i1, i2 + !pdog(i,k1:k2,j) = (ple(i,k1+1:k2+1,j)-ple(i,k1:k2,j)) / grav + pdog(i,k1:k2,j) = (ple(i,k1:k2,j)-ple(i,k1+1:k2+1,j)) / grav !lzhang + enddo + enddo + + do nv=1, num_chem +! Loop over spatial indices + do j = j1, j2 + big_i_loop: do i = i1, i2 + +! Check for total precipitation amount +! Assume no precip in column if precl+precc = 0 + pac = precl(i,j) + precc(i,j) + if(pac .le. 0.) cycle big_i_loop + pls = precl(i,j) + pcv = precc(i,j) + +! Initialize the precipitation fields + qls(:) = 0. + qcv(:) = 0. + fd(:,:) = 0. + +! Find the highest model layer experiencing rainout. Assumes no +! scavenging if T < 258 K + !LH = 0 + LH = k2+1 !lzhang + !do k = k1, k2 + do k = k2, k1,-1 !lzhang + if(dqcond(i,k,j) .lt. 0. .and. tmpu(i,k,j) .gt. 258.) then + LH = k + exit + endif + end do + if(LH .gt. k2) cycle big_i_loop !lzhang + +! convert dqcond from kg water/kg air/s to kg water/m3/s and reverse +! sign so that dqcond < 0. (positive precip) means qls and qcv > 0. + !do k = LH, k2 + do k = LH, k1, -1 !lzhang + qls(k) = -dqcond(i,k,j)*pls/pac*rhoa(i,k,j) + qcv(k) = -dqcond(i,k,j)*pcv/pac*rhoa(i,k,j) + end do + +! Loop over vertical to do the scavenging! + !do k = LH, k2 + do k = LH, k1, -1 !lzhang + +!----------------------------------------------------------------------------- +! (1) LARGE-SCALE RAINOUT: +! Tracer loss by rainout = TC0 * F * exp(-B*dt) +! where B = precipitation frequency, +! F = fraction of grid box covered by precipitating clouds. +! We assume that tracer scavenged by rain is falling down to the +! next level, where a fraction could be re-evaporated to gas phase +! if Qls is less then 0 in that level. +!----------------------------------------------------------------------------- + if (qls(k) .gt. 0.) then + F = F0_ls / (1. + F0_ls*B0_ls*XL_ls/(qls(k)*cdt/Td_ls)) + B = B0_ls/F0_ls +1./(F0_ls*XL_ls/qls(k)) + BT = B * Td_ls + if (BT.gt.10.) BT = 10. !< Avoid overflow > +! Adjust du level: + do n = 1, nbins + effRemoval = data%alpha(nv) + DC(n) = chem(i,k,j,nv) * F * effRemoval *(1.-exp(-BT)) + if (DC(n).lt.0.) DC(n) = 0. + chem(i,k,j,nv) = chem(i,k,j,nv)-DC(n) + if (chem(i,k,j,nv) .lt. 1.0E-32) chem(i,k,j,nv) = 1.0E-32 + end do +! Flux down: unit is kg m-2 +! Formulated in terms of production in the layer. In the revaporation step +! we consider possibly adding flux from above... + do n = 1, nbins + Fd(k,n) = DC(n)*pdog(i,k,j) + end do + + end if ! if Qls > 0 >>> + +!----------------------------------------------------------------------------- +! * (2) LARGE-SCALE WASHOUT: +! * Occurs when rain at this level is less than above. +!----------------------------------------------------------------------------- + !if(k .gt. LH .and. qls(k) .ge. 0.) then + if(k .lt. LH .and. qls(k) .ge. 0.) then !lzhang + !if(qls(k) .lt. qls(k-1)) then + if(qls(k) .lt. qls(k+1)) then !lzhang +! Find a maximum F overhead until the level where Qls<0. + Qmx = 0. + !do kk = k-1,LH,-1 + do kk = k+1,LH !lzhang + if (Qls(kk).gt.0.) then + Qmx = max(Qmx,Qls(kk)) + else + exit + end if + end do + + F = F0_ls / (1. + F0_ls*B0_ls*XL_ls/(Qmx*cdt/Td_ls)) + if (F.lt.0.01) F = 0.01 +!----------------------------------------------------------------------------- +! The following is to convert Q(k) from kgH2O/m3/sec to mm/sec in order +! to use the Harvard formula. Convert back to mixing ratio by multiplying +! by rhoa. Multiply by pdog gives kg/m2/s of precip. Divide by density +! of water (=1000 kg/m3) gives m/s of precip and multiply by 1000 gives +! units of mm/s (omit the multiply and divide by 1000). +!----------------------------------------------------------------------------- + + Qd = Qmx /rhoa(i,k,j)*pdog(i,k,j) + if (Qd.ge.50.) then + B = 0. + else + B = Qd * 0.1 + end if + BT = B * cdt + if (BT.gt.10.) BT = 10. + +! Adjust du level: + do n = 1, nbins + DC(n) = chem(i,k,j,nv) * F * (1.-exp(-BT)) + if (DC(n).lt.0.) DC(n) = 0. + chem(i,k,j,nv) = chem(i,k,j,nv)-DC(n) + if (chem(i,k,j,nv) .lt. 1.0E-32) & + chem(i,k,j,nv) = 1.0E-32 + var_rmv(i,j,nv) = var_rmv(i,j,nv)+DC(n)*pdog(i,k,j)/cdt !ug/m2/s + end do + + end if + end if ! if ls washout >>> +#if 0 +!----------------------------------------------------------------------------- +! (3) CONVECTIVE RAINOUT: +! Tracer loss by rainout = dd0 * F * exp(-B*dt) +! where B = precipitation frequency, +! F = fraction of grid box covered by precipitating clouds. +!----------------------------------------------------------------------------- + + if (qcv(k) .gt. 0.) then + F = F0_cv / (1. + F0_cv*B0_cv*XL_cv/(Qcv(k)*cdt/Td_cv)) + B = B0_cv + BT = B * Td_cv + if (BT.gt.10.) BT = 10. !< Avoid overflow > + +! Adjust du level: + do n = 1, nbins + effRemoval = data%alpha(nv) + DC(n) = chem(i,k,j,nv) * F * effRemoval * (1.-exp(-BT)) + if (DC(n).lt.0.) DC(n) = 0. + chem(i,k,j,nv) = chem(i,k,j,nv)-DC(n) + if (chem(i,k,j,nv) .lt. 1.0E-32) chem(i,k,j,nv) = 1.0E-32 + end do + +!------ Flux down: unit is kg. Including both ls and cv. + do n = 1, nbins + Fd(k,n) = Fd(k,n) + DC(n)*pdog(i,k,j) + end do + + end if ! if Qcv > 0 >>> + +!----------------------------------------------------------------------------- +! (4) CONVECTIVE WASHOUT: +! Occurs when rain at this level is less than above. +!----------------------------------------------------------------------------- + + !if (k.gt.LH .and. Qcv(k).ge.0.) then + if (k.lt.LH .and. Qcv(k).ge.0.) then !lzhang + !if (Qcv(k).lt.Qcv(k-1)) then + if (Qcv(k).lt.Qcv(k+1)) then !lzhang +!----- Find a maximum F overhead until the level where Qls<0. + Qmx = 0. + !do kk = k-1, LH, -1 + do kk = k+1, LH !lzhang + if (Qcv(kk).gt.0.) then + Qmx = max(Qmx,Qcv(kk)) + else + exit + end if + end do + + F = F0_cv / (1. + F0_cv*B0_cv*XL_cv/(Qmx*cdt/Td_cv)) + if (F.lt.0.01) F = 0.01 +!----------------------------------------------------------------------------- +! The following is to convert Q(k) from kgH2O/m3/sec to mm/sec in order +! to use the Harvard formula. Convert back to mixing ratio by multiplying +! by rhoa. Multiply by pdog gives kg/m2/s of precip. Divide by density +! of water (=1000 kg/m3) gives m/s of precip and multiply by 1000 gives +! units of mm/s (omit the multiply and divide by 1000). +!----------------------------------------------------------------------------- + + Qd = Qmx / rhoa(i,k,j)*pdog(i,k,j) + if (Qd.ge.50.) then + B = 0. + else + B = Qd * 0.1 + end if + BT = B * cdt + if (BT.gt.10.) BT = 10. + +! Adjust du level: + do n = 1, nbins + DC(n) = chem(i,k,j,nv) * F * (1.-exp(-BT)) + if (DC(n).lt.0.) DC(n) = 0. + chem(i,k,j,nv) = chem(i,k,j,nv)-DC(n) + if (chem(i,k,j,nv) .lt. 1.0E-32) & + chem(i,k,j,nv) = 1.0E-32 + var_rmv(i,j,nv) = var_rmv(i,j,nv)+DC(n)*pdog(i,k,j)/cdt !ug/m2/s + end do + + end if + end if ! if cv washout >>> +#endif +!----------------------------------------------------------------------------- +! (5) RE-EVAPORATION. Assume that SO2 is re-evaporated as SO4 since it +! has been oxidized by H2O2 at the level above. +!----------------------------------------------------------------------------- +! Add in the flux from above, which will be subtracted if reevaporation occurs + !if(k .gt. LH) then + if(k .lt. LH) then !lzhang + do n = 1, nbins + !Fd(k,n) = Fd(k,n) + Fd(k-1,n) + Fd(k,n) = Fd(k,n) + Fd(k+1,n) !lzhang + end do + +! Is there evaporation in the currect layer? + if (-dqcond(i,k,j) .lt. 0.) then +! Fraction evaporated = H2O(k)evap / H2O(next condensation level). + !if (-dqcond(i,k-1,j) .gt. 0.) then + if (-dqcond(i,k+1,j) .gt. 0.) then !lzhang + + A = abs( dqcond(i,k,j) * pdog(i,k,j) & + !/ ( dqcond(i,k-1,j) * pdog(i,k-1,j)) ) + / ( dqcond(i,k+1,j) * pdog(i,k+1,j)) ) !lzhang + if (A .gt. 1.) A = 1. + +! Adjust tracer in the level + do n = 1, nbins + !DC(n) = Fd(k-1,n) / pdog(i,k,j) * A + DC(n) = Fd(k+1,n) / pdog(i,k,j) * A !lzhang + chem(i,k,j,nv) = chem(i,k,j,nv) + DC(n) + chem(i,k,j,nv) = max(chem(i,k,j,nv),1.e-32) +! Adjust the flux out of the bottom of the layer + Fd(k,n) = Fd(k,n) - DC(n)*pdog(i,k,j) + end do + + endif + endif ! if -moistq < 0 + endif + end do ! k + + do n = 1, nbins + !var_rmv(i,j,nv) = var_rmv(i,j,nv)+Fd(k2,n)/cdt !lzhang + var_rmv(i,j,nv) = var_rmv(i,j,nv)+Fd(k1,n)/cdt ! ug/m2/s + end do + + end do big_i_loop ! i + end do ! j + end do !nv for num_chem + + deallocate(fd,DC,stat=ios) +! if (chem_rc_test((ios .ne. 0), msg="Failed to deallocate memory", & +! file=__FILE__, line=__LINE__, rc=rc)) return + + end subroutine WetRemovalGOCART + +end module dep_wet_ls_mod diff --git a/physics/smoke/dust_data_mod.F90 b/physics/smoke/dust_data_mod.F90 new file mode 100755 index 000000000..9e9713e22 --- /dev/null +++ b/physics/smoke/dust_data_mod.F90 @@ -0,0 +1,111 @@ +!>\file dust_data_mod.F90 +!! This file contains the data for the dust flux schemes. + +module dust_data_mod + + use rrfs_smoke_data + use machine , only : kind_phys + use rrfs_smoke_config, only : p_dust_1, p_dust_2, p_dust_3, p_dust_4, p_dust_5, & + p_edust1, p_edust2, p_edust3, p_edust4, p_edust5 + + + implicit none + + integer, parameter :: ndust = 5 + integer, parameter :: ndcls = 3 + integer, parameter :: ndsrc = 1 + integer, parameter :: maxstypes = 100 + integer, parameter :: nsalt = 9 + + real(kind_phys), parameter :: dyn_visc = 1.5E-5 + + ! -- dust parameters + ! never used: integer, dimension(ndust), parameter :: ipoint = (/ 3, 2, 2, 2, 2 /) + real(kind_phys), dimension(ndust), parameter :: den_dust = (/ 2500., 2650., 2650., 2650., 2650. /) + real(kind_phys), dimension(ndust), parameter :: reff_dust = (/ 0.73D-6, 1.4D-6, 2.4D-6, 4.5D-6, 8.0D-6 /) + real(kind_phys), dimension(ndust), parameter :: frac_s = (/ 0.1, 0.25, 0.25, 0.25, 0.25 /) + real(kind_phys), dimension(ndust), parameter :: lo_dust = (/ 0.1D-6, 1.0D-6, 1.8D-6, 3.0D-6, 6.0D-6 /) + real(kind_phys), dimension(ndust), parameter :: up_dust = (/ 1.0D-6, 1.8D-6, 3.0D-6, 6.0D-6,10.0D-6 /) + ! never used: real(kind_phys), dimension(ndust, 12) :: ch_dust = 0.8e-09_kind_phys + + ! -- default dust parameters + ! -- AFWA & GOCART + ! -----------+----------+-----------+ + ! Parameter | FIM-Chem | HRRR-Chem | + ! -----------+----------+-----------+ + ! alpha | 1.0 | 0.5 | + ! gamma | 1.6 | 1.0 | + ! -----------+----------+-----------+ + ! Never used: + ! real(kind_phys), parameter :: afwa_alpha = 0.2 + ! real(kind_phys), parameter :: afwa_gamma = 1.3 + ! real(kind_phys), parameter :: gocart_alpha = 0.3 + ! real(kind_phys), parameter :: gocart_gamma = 1.3 + ! -- FENGSHA + ! Never used: + ! real(kind_phys), parameter :: fengsha_alpha = 0.3 + ! real(kind_phys), parameter :: fengsha_gamma = 1.3 + ! -- FENGSHA threshold velocities based on Dale A. Gillette's data + integer, parameter :: fengsha_maxstypes = 13 +! real(kind_phys), dimension(fengsha_maxstypes) :: dust_uthres = & +! (/ 0.065, & ! Sand - 1 +! 0.20, & ! Loamy Sand - 2 +! 0.52, & ! Sandy Loam - 3 +! 0.50, & ! Silt Loam - 4 +! 0.50, & ! Silt - 5 +! 0.60, & ! Loam - 6 +! 0.73, & ! Sandy Clay Loam - 7 +! 0.73, & ! Silty Clay Loam - 8 +! 0.80, & ! Clay Loam - 9 +! 0.95, & ! Sandy Clay - 10 +! 0.95, & ! Silty Clay - 11 +! 1.00, & ! Clay - 12 +! 9.999 /) ! Other - 13 +! dust_uthres = 0.065, 0.18, 0.27, 0.30, 0.35, 0.38, 0.35, 0.41, 0.41, +! 0.45,0.50,0.45,9999.0 + real(kind_phys), dimension(fengsha_maxstypes), parameter :: dust_uthres = & + (/ 0.065, & ! Sand - 1 + 0.18, & ! Loamy Sand - 2 + 0.27, & ! Sandy Loam - 3 + 0.30, & ! Silt Loam - 4 + 0.35, & ! Silt - 5 + 0.38, & ! Loam - 6 + 0.35, & ! Sandy Clay Loam - 7 + 0.41, & ! Silty Clay Loam - 8 + 0.41, & ! Clay Loam - 9 + 0.45, & ! Sandy Clay - 10 + 0.50, & ! Silty Clay - 11 + 0.45, & ! Clay - 12 + 9999.0 /) ! Other - 13 + ! -- FENGSHA uses precalculated drag partition from ASCAT. See: Prigent et al. (2012,2015) + integer, parameter :: dust_calcdrag = 1 + + real(kind_phys), parameter :: dust_alpha = 2.2 + real(kind_phys), parameter :: dust_gamma = 1.0 + + + ! -- sea salt parameters + integer, dimension(nsalt), parameter :: spoint = (/ 1, 2, 2, 2, 2, 2, 3, 3, 3 /) ! 1 Clay, 2 Silt, 3 Sand + real(kind_phys), dimension(nsalt), parameter :: reff_salt = & + (/ 0.71D-6, 1.37D-6, 2.63D-6, 5.00D-6, 9.50D-6, 18.1D-6, 34.5D-6, 65.5D-6, 125.D-6 /) + real(kind_phys), dimension(nsalt), parameter :: den_salt = & + (/ 2500., 2650., 2650., 2650., 2650., 2650., 2650., 2650., 2650. /) + real(kind_phys), dimension(nsalt), parameter :: frac_salt = & + (/ 1., 0.2, 0.2, 0.2, 0.2, 0.2, 0.333, 0.333, 0.333 /) + + + ! -- soil vagatation parameters + integer, parameter :: max_soiltyp = 30 + real(kind_phys), dimension(max_soiltyp), parameter :: & + maxsmc = (/ 0.421, 0.464, 0.468, 0.434, 0.406, 0.465, & + 0.404, 0.439, 0.421, 0.000, 0.000, 0.000, & + 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, & + 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, & + 0.000, 0.000, 0.000, 0.000, 0.000, 0.000 /) + + ! -- other soil parameters + ! never used: real(kind_phys), dimension(maxstypes) :: porosity + + public + +end module dust_data_mod diff --git a/physics/smoke/dust_fengsha_mod.F90 b/physics/smoke/dust_fengsha_mod.F90 new file mode 100755 index 000000000..fbf87aa56 --- /dev/null +++ b/physics/smoke/dust_fengsha_mod.F90 @@ -0,0 +1,601 @@ +!>\file dust_fengsha_mod.F90 +!! This file contains the FENGSHA dust scheme. + +module dust_fengsha_mod +! +! This module developed by Barry Baker (NOAA ARL) +! For serious questions contact barry.baker@noaa.gov +! +! 07/16/2019 - Adapted for NUOPC/GOCART, R. Montuoro +! 02/01/2020 - Adapted for FV3/CCPP, Haiqin Li + + use rrfs_smoke_data + use machine , only : kind_phys + use dust_data_mod + + implicit none + + private + + public :: gocart_dust_fengsha_driver + +contains + + subroutine gocart_dust_fengsha_driver(data, dt, & + chem,rho_phy,smois,p8w,ssm, & + isltyp,vegfra,snowh,xland,area,g,emis_dust, & + ust,znt,clay,sand,rdrag,uthr, & + num_emis_dust,num_moist,num_chem,num_soil_layers, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) + IMPLICIT NONE + type(smoke_data), intent(inout) :: data + INTEGER, INTENT(IN ) :: & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + num_emis_dust,num_moist,num_chem,num_soil_layers + INTEGER,DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: isltyp + REAL(kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), INTENT(INOUT) :: chem + REAL(kind_phys), DIMENSION( ims:ime, 1, jms:jme,num_emis_dust),OPTIONAL, INTENT(INOUT) :: emis_dust + REAL(kind_phys), DIMENSION( ims:ime, num_soil_layers, jms:jme ), INTENT(IN) :: smois + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: ssm + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: vegfra, & + snowh, & + xland, & + area, & + ust, & + znt, & + clay, & + sand, & + rdrag, & + uthr + REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN ) :: & + p8w, & + rho_phy + REAL(kind_phys), INTENT(IN) :: dt,g + + ! Local variables + + integer :: nmx,smx,i,j,k,imx,jmx,lmx + integer,dimension (1,1) :: ilwi + real(kind_phys), DIMENSION (1,1) :: erodtot + REAL(kind_phys), DIMENSION (1,1) :: gravsm + REAL(kind_phys), DIMENSION (1,1) :: drylimit + real(kind_phys), DIMENSION (5) :: tc,bems + real(kind_phys), dimension (1,1) :: airden,airmas,ustar + real(kind_phys), dimension (1) :: dxy + real(kind_phys), dimension (3) :: massfrac + real(kind_phys) :: conver,converi + real(kind_phys) :: R + + ! threshold values + conver=1.e-9 + converi=1.e9 + + ! Number of dust bins + + imx=1 + jmx=1 + lmx=1 + nmx=ndust + smx=nsalt + + k=kts + do j=jts,jte + do i=its,ite + + ! Don't do dust over water!!! + + ilwi(1,1)=0 + if(xland(i,j).lt.1.5)then + ilwi(1,1)=1 + + ! Total concentration at lowest model level. This is still hardcoded for 5 bins. + + ! if(config_flags%chem_opt == 2 .or. config_flags%chem_opt == 11 ) then + ! tc(:)=1.e-16*conver + ! else + tc(1)=chem(i,kts,j,p_dust_1)*conver + tc(2)=chem(i,kts,j,p_dust_2)*conver + tc(3)=chem(i,kts,j,p_dust_3)*conver + tc(4)=chem(i,kts,j,p_dust_4)*conver + tc(5)=chem(i,kts,j,p_dust_5)*conver + ! endif + + ! Air mass and density at lowest model level. + + airmas(1,1)=-(p8w(i,kts+1,j)-p8w(i,kts,j))*area(i,j)/g + airden(1,1)=rho_phy(i,kts,j) + ustar(1,1)=ust(i,j) + dxy(1)=area(i,j) + + ! Mass fractions of clay, silt, and sand. + massfrac(1)=clay(i,j) + massfrac(2)=1-(clay(i,j)+sand(i,j)) + massfrac(3)=sand(i,j) + + + ! Total erodibility. + + erodtot(1,1) = ssm(i,j) ! SUM(erod(i,j,:)) + + ! Don't allow roughness lengths greater than 20 cm to be lofted. + ! This kludge accounts for land use types like urban areas and + ! forests which would otherwise show up as high dust emitters. + ! This is a placeholder for a more widely accepted kludge + ! factor in the literature, which reduces lofting for rough areas. + ! Forthcoming... + + IF (znt(i,j) .gt. 0.2) then + ilwi(1,1)=0 + endif + + ! limit where there is lots of vegetation + if (vegfra(i,j) .gt. .17) then + ilwi(1,1) = 0 + endif + + ! limit where there is snow on the ground + if (snowh(i,j) .gt. 0) then + ilwi(1,1) = 0 + endif + + ! Do not allow areas with bedrock, lava, or land-ice to loft + + IF (isltyp(i,j) .eq. 15 .or. isltyp(i,j) .eq. 16. .or. & + isltyp(i,j) .eq. 18) then + ilwi(1,1)=0 + ENDIF + IF (isltyp(i,j) .eq. 0)then + ilwi(1,1)=0 + endif + if(ilwi(1,1) == 0 ) cycle + + ! Calculate gravimetric soil moisture and drylimit. + gravsm(1,1)=100.*smois(i,1,j)/((1.-maxsmc(isltyp(i,j)))*(2.65*(1.-clay(i,j))+2.50*clay(i,j))) + drylimit(1,1)=14.0*clay(i,j)*clay(i,j)+17.0*clay(i,j) + + ! get drag partition + ! FENGSHA uses the drag partition correction of MacKinnon et al 2004 + ! doi:10.1016/j.geomorph.2004.03.009 + if (dust_calcdrag .ne. 1) then + call fengsha_drag(data,znt(i,j),R) + else + ! use the precalculated version derived from ASCAT; Prigent et al. (2012,2015) + ! doi:10.1109/TGRS.2014.2338913 & doi:10.5194/amt-5-2703-2012 + ! pick only valid values + if (rdrag(i,j) > 0.) then + R = real(rdrag(i,j), kind=kind_phys) + else + cycle + endif + endif + + ! Call dust emission routine. + call source_dust(data, imx, jmx, lmx, nmx, smx, dt, tc, ustar, massfrac, & + erodtot, dxy, gravsm, airden, airmas, & + bems, g, drylimit, dust_alpha, dust_gamma, R, uthr(i,j)) + + ! if(config_flags%chem_opt == 2 .or. config_flags%chem_opt == 11 ) then + ! dustin(i,j,1:5)=tc(1:5)*converi + ! else + chem(i,kts,j,p_dust_1)=tc(1)*converi + chem(i,kts,j,p_dust_2)=tc(2)*converi + chem(i,kts,j,p_dust_3)=tc(3)*converi + chem(i,kts,j,p_dust_4)=tc(4)*converi + chem(i,kts,j,p_dust_5)=tc(5)*converi + ! endif + + ! chem(i,kts,j,p_dust_1)=tc(1)*converi + ! chem(i,kts,j,p_dust_2)=tc(2)*converi + ! chem(i,kts,j,p_dust_3)=tc(3)*converi + ! chem(i,kts,j,p_dust_4)=tc(4)*converi + ! chem(i,kts,j,p_dust_5)=tc(5)*converi + + ! For output diagnostics + + emis_dust(i,1,j,p_edust1)=bems(1) + emis_dust(i,1,j,p_edust2)=bems(2) + emis_dust(i,1,j,p_edust3)=bems(3) + emis_dust(i,1,j,p_edust4)=bems(4) + emis_dust(i,1,j,p_edust5)=bems(5) + endif + enddo + enddo + ! + + end subroutine gocart_dust_fengsha_driver + + + SUBROUTINE source_dust(data, imx, jmx, lmx, nmx, smx, dt1, tc, ustar, massfrac, & + erod, dxy, gravsm, airden, airmas, bems, g0, drylimit, alpha, & + gamma, R, uthres) + + ! **************************************************************************** + ! * Evaluate the source of each dust particles size bin by soil emission + ! * + ! * Input: + ! * EROD Fraction of erodible grid cell (-) + ! * GRAVSM Gravimetric soil moisture (g/g) + ! * DRYLIMIT Upper GRAVSM limit for air-dry soil (g/g) + ! * ALPHA Constant to fudge the total emission of dust (1/m) + ! * GAMMA Tuning constant for erodibility (-) + ! * DXY Surface of each grid cell (m2) + ! * AIRMAS Mass of air for each grid box (kg) + ! * AIRDEN Density of air for each grid box (kg/m3) + ! * USTAR Friction velocity (m/s) + ! * DT1 Time step (s) + ! * NMX Number of dust bins (-) + ! * SMX Number of saltation bins (-) + ! * IMX Number of I points (-) + ! * JMX Number of J points (-) + ! * LMX Number of L points (-) + ! * R Drag Partition (-) + ! * UTHRES FENGSHA Dry Threshold Velocities (m/s) + ! * + ! * Data: + ! * MASSFRAC Fraction of mass in each of 3 soil classes (-) + ! * SPOINT Pointer to 3 soil classes (-) + ! * DEN_DUST Dust density (kg/m3) + ! * DEN_SALT Saltation particle density (kg/m3) + ! * REFF_SALT Reference saltation particle diameter (m) + ! * REFF_DUST Reference dust particle diameter (m) + ! * LO_DUST Lower diameter limits for dust bins (m) + ! * UP_DUST Upper diameter limits for dust bins (m) + ! * FRAC_SALT Soil class mass fraction for saltation bins (-) + ! * + ! * Parameters: + ! * CMB Constant of proportionality (-) + ! * MMD_DUST Mass median diameter of dust (m) + ! * GSD_DUST Geometric standard deviation of dust (-) + ! * LAMBDA Side crack propagation length (m) + ! * CV Normalization constant (-) + ! * G0 Gravitational acceleration (m/s2) + ! * G Gravitational acceleration in cgs (cm/s2) + ! * + ! * Working: + ! * U_TS0 "Dry" threshold friction velocity (m/s) + ! * U_TS Moisture-adjusted threshold friction velocity (m/s) + ! * RHOA Density of air in cgs (g/cm3) + ! * DEN Dust density in cgs (g/cm3) + ! * DIAM Dust diameter in cgs (cm) + ! * DMASS Saltation mass distribution (-) + ! * DSURFACE Saltation surface area per unit mass (m2/kg) + ! * DS_REL Saltation surface area distribution (-) + ! * SALT Saltation flux (kg/m/s) + ! * DLNDP Dust bin width (-) + ! * EMIT Total vertical mass flux (kg/m2/s) + ! * EMIT_VOL Total vertical volume flux (m/s) + ! * DSRC Mass of emitted dust (kg/timestep/cell) + ! * + ! * Output: + ! * TC Total concentration of dust (kg/kg/timestep/cell) + ! * BEMS Source of each dust type (kg/timestep/cell) + ! * + ! **************************************************************************** + implicit none + type(smoke_data), intent(inout) :: data + + INTEGER, INTENT(IN) :: imx,jmx,lmx,nmx,smx + REAL(kind_phys), INTENT(IN) :: dt1 + REAL(kind_phys), INTENT(INOUT) :: tc(imx,jmx,lmx,nmx) + REAL(kind_phys), INTENT(IN) :: ustar(imx,jmx) + REAL(kind_phys), INTENT(IN) :: massfrac(3) + REAL(kind_phys), INTENT(IN) :: erod(imx,jmx) + REAL(kind_phys), INTENT(IN) :: dxy(jmx) + REAL(kind_phys), INTENT(IN) :: gravsm(imx,jmx) + REAL(kind_phys), INTENT(IN) :: airden(imx,jmx,lmx) + REAL(kind_phys), INTENT(IN) :: airmas(imx,jmx,lmx) + REAL(kind_phys), INTENT(OUT) :: bems(imx,jmx,nmx) + REAL(kind_phys), INTENT(IN) :: g0 + REAL(kind_phys), INTENT(IN) :: drylimit(imx,jmx) + !! Sandblasting mass efficiency, aka "fudge factor" (based on Tegen et al, + !! 2006 and Hemold et al, 2007) + ! + ! REAL, PARAMETER :: alpha=1.8E-8 ! (m^-1) + REAL(kind_phys), INTENT(IN) :: alpha + ! Experimental optional exponential tuning constant for erodibility. + ! 0 < gamma < 1 -> more relative impact by low erodibility regions. + REAL(kind_phys), INTENT(IN) :: gamma + REAL(kind_phys), INTENT(IN) :: R + REAL(kind_phys), INTENT(IN) :: uthres + + REAL(kind_phys) :: den(smx), diam(smx) + REAL(kind_phys) :: dvol(nmx), distr_dust(nmx), dlndp(nmx) + REAL(kind_phys) :: dsurface(smx), ds_rel(smx) + REAL(kind_phys) :: u_ts0, u_ts, dsrc, dmass, dvol_tot + REAL(kind_phys) :: salt,emit, emit_vol, stotal + REAL(kind_phys) :: rhoa, g + INTEGER :: i, j, n + + ! Sandblasting mass efficiency, beta. + ! Beta maxes out for clay fractions above 0.2 = betamax. + + REAL(kind_phys), PARAMETER :: betamax=5.25E-4 + REAL(kind_phys) :: beta + integer :: styp + + ! Constant of proportionality from Marticorena et al, 1997 (unitless) + ! Arguably more ~consistent~ fudge than alpha, which has many walnuts + ! sprinkled throughout the literature. - GC + + REAL(kind_phys), PARAMETER :: cmb=1.0 + ! REAL, PARAMETER :: cmb=2.61 ! from White,1979 + + ! Parameters used in Kok distribution function. Advise not to play with + ! these without the expressed written consent of someone who knows what + ! they're doing. - GC + + REAL(kind_phys), PARAMETER :: mmd_dust=3.4D-6 ! median mass diameter (m) + REAL(kind_phys), PARAMETER :: gsd_dust=3.0 ! geom. std deviation + REAL(kind_phys), PARAMETER :: lambda=12.0D-6 ! crack propagation length (m) + REAL(kind_phys), PARAMETER :: cv=12.62D-6 ! normalization constant + + ! Calculate saltation surface area distribution from sand, silt, and clay + ! mass fractions and saltation bin fraction. This will later become a + ! modifier to the total saltation flux. The reasoning here is that the + ! size and availability of saltators affects saltation efficiency. Based + ! on Eqn. (32) in Marticorena & Bergametti, 1995 (hereon, MB95). + + DO n=1,smx + dmass=massfrac(spoint(n))*frac_salt(n) + dsurface(n)=0.75*dmass/(den_salt(n)*reff_salt(n)) + ENDDO + + ! The following equation yields relative surface area fraction. It will only + ! work if you are representing the "full range" of all three soil classes. + ! For this reason alone, we have incorporated particle sizes that encompass + ! the clay class, to account for the its relative area over the basal + ! surface, even though these smaller bins would be unlikely to play any large + ! role in the actual saltation process. - GC + + stotal=SUM(dsurface(:)) + DO n=1,smx + ds_rel(n)=dsurface(n)/stotal + ENDDO + + ! Calculate total dust emission due to saltation of sand sized particles. + ! Begin by calculating DRY threshold friction velocity (u_ts0). Next adjust + ! u_ts0 for moisture to get threshold friction velocity (u_ts). Then + ! calculate saltation flux (salt) where ustar has exceeded u_ts. Finally, + ! calculate total dust emission (tot_emit), taking into account erodibility. + + ! Set DRY threshold friction velocity to input value + u_ts0 = uthres + + g = g0*1.0E2 + emit=0.0 + + DO n = 1, smx + den(n) = den_salt(n)*1.0D-3 ! (g cm^-3) + diam(n) = 2.0*reff_salt(n)*1.0D2 ! (cm) + DO i = 1,imx + DO j = 1,jmx + rhoa = airden(i,j,1)*1.0D-3 ! (g cm^-3) + + ! FENGSHA uses the 13 category soil type from the USDA + ! call calc_fengsha_styp(massfrac(1),massfrac(3),massfrac(2),styp) + ! Fengsha uses threshold velocities based on dale gilletes data + ! call fengsha_utst(styp,uthres,u_ts0) + + ! Friction velocity threshold correction function based on physical + ! properties related to moisture tension. Soil moisture greater than + ! dry limit serves to increase threshold friction velocity (making + ! it more difficult to loft dust). When soil moisture has not reached + ! dry limit, treat as dry + + IF (gravsm(i,j) > drylimit(i,j)) THEN + u_ts = MAX(0.0D+0,u_ts0*(sqrt(1.0+1.21*(gravsm(i,j)-drylimit(i,j))**0.68)) / R) + ELSE + u_ts = u_ts0 / R + END IF + + ! Calculate total vertical mass flux (note beta has units of m^-1) + ! Beta acts to tone down dust in areas with so few dust-sized particles that the + ! lofting efficiency decreases. Otherwise, super sandy zones would be huge dust + ! producers, which is generally not the case. Equation derived from wind-tunnel + ! experiments (see MB95). + + beta=10**(13.6*massfrac(1)-6.0) ! (unitless) + if (massfrac(1) <= 0.2) then + beta=10**(13.4*massfrac(1)-6.0) + else + beta = 2.E-4 + endif + + !--------------------------------------------------------------------- + ! formula of Draxler & Gillette (2001) Atmos. Environ. + ! F = K A (r/g) U* ( U*^2 - Ut*^2 ) + ! + ! where: + ! F = vertical emission flux [g/m**2-s] + ! K = constant 2.0E-04 [1/m] + ! A = 0~3.5 mean = 2.8 (fudge factor) + ! U* = friction velocity [m/s] + ! Ut* = threshold friction velocity [m/s] + ! + !-------------------------------------------------------------------- + + IF (ustar(i,j) .gt. u_ts) then + call fengsha_hflux(data,ustar(i,j),u_ts,beta, salt) + salt = alpha * cmb * ds_rel(n) * airden(i,j,1) / g0 * salt * (erod(i,j)**gamma) * beta + else + salt = 0. + endif + ! EROD is taken into account above + emit = emit + salt + END DO + END DO + END DO + + ! Now that we have the total dust emission, distribute into dust bins using + ! lognormal distribution (Dr. Jasper Kok, in press), and + ! calculate total mass emitted over the grid box over the timestep. + ! + ! In calculating the Kok distribution, we assume upper and lower limits to each bin. + ! For reff_dust=(/0.73D-6,1.4D-6,2.4D-6,4.5D-6,8.0D-6/) (default), + ! lower limits were ASSUMED at lo_dust=(/0.1D-6,1.0D-6,1.8D-6,3.0D-6,6.0D-6/) + ! upper limits were ASSUMED at up_dust=(/1.0D-6,1.8D-6,3.0D-6,6.0D-6,10.0D-6/) + ! These may be changed within module_data_gocart_dust.F, but make sure it is + ! consistent with reff_dust values. These values were taken from the original + ! GOCART bin configuration. We use them here to calculate dust bin width, dlndp. + ! dVol is the volume distribution. You know...if you were wondering. GC + + dvol_tot=0. + DO n=1,nmx + dlndp(n)=LOG(up_dust(n)/lo_dust(n)) + dvol(n)=(2.0*reff_dust(n)/cv)*(1.+ERF(LOG(2.0*reff_dust(n)/mmd_dust)/(SQRT(2.)*LOG(gsd_dust))))*& + EXP(-(2.0*reff_dust(n)/lambda)**3.0)*dlndp(n) + dvol_tot=dvol_tot+dvol(n) + ! Convert mass flux to volume flux + !emit_vol=emit/den_dust(n) ! (m s^-1) + END DO + DO n=1,nmx + distr_dust(n)=dvol(n)/dvol_tot + !print *,"distr_dust(",n,")=",distr_dust(n) + END DO + + ! Now distribute total vertical emission into dust bins and update concentration. + + DO n=1,nmx + DO i=1,imx + DO j=1,jmx + ! Calculate total mass emitted + dsrc = emit*distr_dust(n)*dxy(j)*dt1 ! (kg) + IF (dsrc < 0.0) dsrc = 0.0 + + ! Update dust mixing ratio at first model level. + tc(i,j,1,n) = tc(i,j,1,n) + dsrc / airmas(i,j,1) ! (kg/kg) + ! bems(i,j,n) = dsrc ! diagnostic + !bems(i,j,n) = 1000.*dsrc/(dxy(j)*dt1) ! diagnostic (g/m2/s) + bems(i,j,n) = 1.e+9*dsrc/(dxy(j)*dt1) ! diagnostic (ug/m2/s) !lzhang + END DO + END DO + END DO + + END SUBROUTINE source_dust + + subroutine fengsha_utst(data,styp,uth, ut) + implicit none + type(smoke_data), intent(inout) :: data + + integer, intent(in) :: styp + real(kind_phys), dimension(fengsha_maxstypes), intent(in) :: uth + real(kind_phys), intent(out) :: ut + ut = uth(styp) +! real (kind_phys) :: uth(13) = & +! (/ 0.08, & ! Sand - 1 +! 0.20, & ! Loamy Sand - 2 +! 0.30, & ! Sandy Loam - 3 +! 0.30, & ! Silt Loam - 4 +! 0.35, & ! Silt - 5 +! 0.60, & ! Loam - 6 +! 0.30, & ! Sandy Clay Loam - 7 +! 0.35, & ! Silty Clay Loam - 8 +! 0.45, & ! Clay Loam - 9 +! 0.45, & ! Sandy Clay - 10 +! 0.45, & ! Silty Clay - 11 +! 0.60, & ! Clay - 12 +! 9.999 /) ! Other - 13 + return + end subroutine fengsha_utst + + subroutine calc_fengsha_styp(data, clay, sand, silt, type) + implicit none + type(smoke_data), intent(inout) :: data + + !--------------------------------------------------------------- + ! Function: calculate soil type based on USDA definition. + ! Source: USDA soil texture calculator + ! + ! Defintion of soil types: + ! + ! + ! NOAH 1 2 3 4 5 6 7 8 9 10 11 12 + ! PX 1 2 3 4 - 5 6 7 8 9 10 11 + ! Soil "Sand" "Loamy Sand" "Sandy Loam" "Silt Loam" "Silt" "Loam" "Sandy Clay Loam" "Silt Clay Loam" "Clay Loam" "Sandy Clay" "Silty Clay" "Clay" + !--------------------------------------------------------------- + REAL(kind_phys), intent(in) :: clay, sand, silt + integer, intent(out) :: type + real(kind_phys) :: cly, snd, slt + + type = 0 + + snd = sand * 100. + cly = clay * 100. + slt = silt * 100. + if (slt+1.5*cly .lt. 15) type = 1 ! snd + if (slt+1.5*cly .ge. 15 .and.slt+1.5*cly .lt. 30) type = 2 ! loamy snd + if (cly .ge. 7 .and. cly .lt. 20 .and. snd .gt. 52 .and. slt+2*cly .ge. 30) type = 3 ! sndy loam (cond 1) + if (cly .lt. 7 .and. slt .lt. 50 .and. slt+2*cly .ge. 30) type = 3 ! sndy loam (cond 2) + if (slt .ge. 50 .and. cly .ge. 12 .and.cly .lt. 27 ) type = 4 ! slt loam (cond 1) + if (slt .ge. 50 .and. slt .lt. 80 .and.cly .lt. 12) type = 4 ! slt loam (cond 2) + if (slt .ge. 80 .and. cly .lt. 12) type = 5 ! slt + if (cly .ge. 7 .and. cly .lt. 27 .and.slt .ge. 28 .and. slt .lt. 50 .and.snd .le. 52) type = 6 ! loam + if (cly .ge. 20 .and. cly .lt. 35 .and.slt .lt. 28 .and. snd .gt. 45) type = 7 ! sndy cly loam + if (cly .ge. 27 .and. cly .lt. 40 .and.snd .lt. 20) type = 8 ! slt cly loam + if (cly .ge. 27 .and. cly .lt. 40 .and.snd .ge. 20 .and. snd .le. 45) type = 9 ! cly loam + if (cly .ge. 35 .and. snd .gt. 45) type = 10 ! sndy cly + if (cly .ge. 40 .and. slt .ge. 40) type = 11 ! slty cly + if (cly .ge. 40 .and. snd .le. 45 .and.slt .lt. 40) type = 12 ! clay + return + end subroutine calc_fengsha_styp + + subroutine fengsha_drag(data,z0,R) + implicit none + type(smoke_data), intent(inout) :: data + + real(kind_phys), intent(in) :: z0 + real(kind_phys), intent(out) :: R + real(kind_phys), parameter :: z0s = 1.0e-04 !Surface roughness for ideal bare surface [m] + ! ------------------------------------------------------------------------ + ! Function: Calculates the MacKinnon et al. 2004 Drag Partition Correction + ! + ! R = 1.0 - log(z0 / z0s) / log( 0.7 * (12255./z0s) ** 0.8) + ! + !-------------------------------------------------------------------------- + ! Drag partition correction. See MacKinnon et al. (2004), + ! doi:10.1016/j.geomorph.2004.03.009 + R = 1.0 - log(z0 / z0s) / log( 0.7 * (12255./z0s) ** 0.8) + + ! Drag partition correction. See Marticorena et al. (1997), + ! doi:10.1029/96JD02964 + !R = 1.0 - log(z0 / z0s) / log( 0.7 * (10./z0s) ** 0.8) + + return + end subroutine fengsha_drag + + subroutine fengsha_hflux(data,ust,utst, kvh, salt) + !--------------------------------------------------------------------- + ! Function: Calculates the Horizontal Saltation Flux, Q, and then + ! calculates the vertical flux. + ! + ! formula of Draxler & Gillette (2001) Atmos. Environ. + ! F = K A (r/g) U* ( U*^2 - Ut*^2 ) + ! + ! where: + ! F = vertical emission flux [g/m**2-s] + ! K = constant 2.0E-04 [1/m] + ! A = 0~3.5 mean = 2.8 (fudge factor) + ! U* = friction velocity [m/s] + ! Ut* = threshold friction velocity [m/s] + ! + !-------------------------------------------------------------------- + implicit none + type(smoke_data), intent(inout) :: data + real(kind_phys), intent(in) :: ust, & ! friction velocity + utst, & ! threshold friction velocity + kvh ! vertical to horizontal mass flux ratio + + real(kind_phys), intent(out) :: salt + real(kind_phys) :: Q + Q = ust * (ust * ust - utst * utst) + salt = Q ! sdep * kvh * Q + + return + end subroutine fengsha_hflux + + +end module dust_fengsha_mod diff --git a/physics/smoke/module_add_emiss_burn.F90 b/physics/smoke/module_add_emiss_burn.F90 new file mode 100755 index 000000000..da35535f7 --- /dev/null +++ b/physics/smoke/module_add_emiss_burn.F90 @@ -0,0 +1,226 @@ +!>\file module_add_emiss_burn.F90 +!! This file adds the biomass burning emissions to the smoke field. + +module module_add_emiss_burn +!RAR: significantly modified for the new BB emissions + use machine , only : kind_phys + use rrfs_smoke_data + use rrfs_smoke_config +CONTAINS + subroutine add_emis_burn(data,dtstep,ktau,dz8w,rho_phy,rel_hum, & + chem,julday,gmt,xlat,xlong, & + !luf_igbp,lu_fire1, & + vegtype,vfrac,peak_hr, & + time_int,ebu, & ! RAR + r_q,fhist,aod3d_smoke,aod3d_dust, & + ! nwfa,nifa, & + rainc,rainnc, swdown,smoke_forecast, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + +! USE module_configure, only: grid_config_rec_type +! USE module_state_description + IMPLICIT NONE + type(smoke_data), intent(inout) :: data + +! TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER, INTENT(IN ) :: ktau, julday, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + real(kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(INOUT ) :: chem + + real(kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(IN) :: ebu + + real(kind_phys), DIMENSION(ims:ime,jms:jme), INTENT(IN) :: xlat,xlong, rainc,rainnc,swdown, peak_hr, vfrac + real(kind_phys), DIMENSION(ims:ime,jms:jme), INTENT(OUT) :: r_q ! RAR: + real(kind_phys), DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: fhist ! RAR: + real(kind_phys), DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(OUT) :: aod3d_smoke, aod3d_dust ! RAR: + integer, DIMENSION(ims:ime,jms:jme), INTENT(IN) :: vegtype + + real(kind_phys), DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(IN) :: dz8w,rho_phy,rel_hum +! real(kind_phys), DIMENSION(ims:ime,1:nlcat,jms:jme), INTENT(IN) :: luf_igbp + +! real(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ) , & +! OPTIONAL, INTENT(INOUT ) :: nwfa,nifa ! RAR: + + real(kind_phys), INTENT(IN) :: dtstep, gmt + real(kind_phys), INTENT(IN) :: time_int ! RAR: time in seconds since start of simulation + logical, INTENT(IN) :: smoke_forecast + + integer :: i,j,k,n,m + real(kind_phys) :: conv_rho, conv, ext2, dm_smoke, daero_num_wfa, daero_num_ifa !, lu_sum1_5, lu_sum12_14 + !real(kind_phys) :: ebumax +! CHARACTER (LEN=80) :: message + + INTEGER, PARAMETER :: kfire_max=35 ! max vertical level for BB plume rise + ! Diameters and standard deviations for emissions + ! the diameters are the volume (mass) geometric mean diameters, following MADE_SORGAM + real(kind_phys), PARAMETER :: dgvem_i= 0.08E-6 !0.03E-6 ! [ m ] + real(kind_phys), PARAMETER :: sgem_i = 1.8 !1.7 + + ! *** Accumulation mode: + real(kind_phys), PARAMETER :: dgvem_j= 0.3E-6 ! [ m ] + real(kind_phys), PARAMETER :: sgem_j = 2.0 + + ! *** Coarse mode + real(kind_phys), PARAMETER :: dgvem_c= 6.0E-6 ! [ m ] + real(kind_phys), PARAMETER :: sgem_c= 2.2 + real(kind_phys), PARAMETER :: pic= 3.14159 + + ! RAR: factors for getting number emissions rate from mass emissions rate following made_sorgam + real(kind_phys), PARAMETER :: fact_numn= 1.e-9*6.0/pic*exp(4.5*log(sgem_i)**2)/dgvem_i**3 ! Aitken mode + real(kind_phys), PARAMETER :: fact_numa= 1.e-9*6.0/pic*exp(4.5*log(sgem_j)**2)/dgvem_j**3 ! accumulation mode + real(kind_phys), PARAMETER :: fact_numc= 1.e-9*6.0/pic*exp(4.5*log(sgem_c)**2)/dgvem_c**3 ! coarse mode + + real(kind_phys), PARAMETER :: dens_oc_aer=1.4e3, dens_ec_aer=1.7e3 ! kg/m3 +! real(kind_phys), PARAMETER :: rinti=2.1813936e-8, cx=2.184936* 3600, timeq_max=3600.*24. ! constants for the diurnal cycle calculations + real(kind_phys), PARAMETER :: ax1=531., cx1=7800. ! For cropland, urban and small fires +! real(kind_phys), PARAMETER :: rinti=2.1813936e-8, ax2=3200., const2=100., coef2=10.6712963e-4, cx=2.184936* 3600, timeq_max=3600.*24. + real(kind_phys), PARAMETER :: rinti=2.1813936e-8, ax2=3400., const2=130., coef2=10.6712963e-4, cx2=7200., timeq_max=3600.*24. ! New parameters + real(kind_phys), PARAMETER :: sc_me= 4.0, ab_me=0.5 ! m2/g, scattering and absorption efficiency for smoke + +! Parameters used for the wfa and ifa in mp physics per Trude E. (NCAR) +! Water friendly: radius: 0.04 micron, standard deviation: 1.8, kappa (for hygroscopic growth): 0.2, real index of refraction: 1.53, imaginary index of refraction: 1e-7 +! Ice friendly: radius: 0.4 micron, standard deviation: 1.8, kappa : 0.04, real index of refraction: 1.56, imaginary index of refraction: 3e-3 + + ! real, parameter :: cx = 2.184936 * 3600., rinti = 2.1813936e-8 , ax = 2000.6038 + ! bx_bburn = 20.041288 * 3600., RAR: this depends on the vegetation class, location (local time) etc. + real(kind_phys) :: timeq, dt1,dt2,dtm ! For BB emis. diurnal cycle calculation + + timeq= gmt*3600. + real(time_int,4) + timeq= mod(timeq,timeq_max) + +! Main loops to add BB emissions + do j=jts,jte + do i=its,ite + !if( luf_igbp(i,17,j)>0.99 .OR. ebu(i,1,j,p_ebu_smoke) < 1.e-6) cycle ! no BB emissions or water pixels + if( (1.-vfrac (i,j))>0.99 .OR. ebu(i,1,j) < 1.e-6) cycle ! no BB emissions or water pixels + + ! RAR: the decrease in the BB emissions after >18 hrs of forecast, the decrease occurs at night. The decrease occurs at night. + IF (time_int>64800. .AND. swdown(i,j)<.1 .AND. fhist(i,j)>.75 ) THEN + fhist(i,j)= 0.75 + ENDIF + + IF (time_int>129600. .AND. swdown(i,j)<.1 .AND. fhist(i,j)>.5 ) THEN ! After 36 hr forecast + fhist(i,j)= 0.5 + ENDIF + + IF ( (rainc(i,j) + rainnc(i,j))>=10. .AND. fhist(i,j)>.3 ) THEN ! If it rains more than 1cm, then the BB emissions are reduced + fhist(i,j)= 0.3 + ENDIF + +! RAR: Grasslands (29% of ther western HRRR CONUS domain) probably also need to be added below, check this later +! RAR: In the HRRR CONUS domain (western part) crop 11%, 2% cropland/natural vegetation and 0.4% urban of pixels +!.OR. lu_index(i,j)==14) then ! Croplands(12), Urban and Built-Up(13), cropland/natural vegetation (14) mosaic in MODI-RUC vegetation classes +! Peak hours for the fire activity depending on the latitude +! if (xlong(i,j)<-130.) then max_ti= 24.041288* 3600. ! peak at 24 UTC, fires in Alaska +! elseif (xlong(i,j)<-100.) then max_ti= 22.041288* 3600. ! peak at 22 UTC, fires in the western US +! elseif (xlong(i,j)<-70.) then ! peak at 20 UTC, fires in the eastern US, max_ti= 20.041288* 3600. +! else max_ti= 18.041288* 3600. +! endif + + !IF ( lu_fire1(i,j)>0.9 ) then !Ag, urban fires, bare land etc. + IF ( vegtype(i,j)==12 .or. vegtype(i,j)==13 ) then !Ag, urban fires, bare land etc. + ! these fires will have exponentially decreasing diurnal cycle, these fires decrease 55% in 2 hours, end in 5 hours + r_q(i,j) = rinti* ax1 * exp(- (time_int**2)/(cx1**2) ) + ELSE + ! RAR: Gaussian profile for wildfires + dt1= abs(timeq - peak_hr(i,j)) + dt2= timeq_max - peak_hr(i,j) + timeq ! peak hour is always <86400. + dtm= MIN(dt1,dt2) + r_q(i,j) = rinti*( ax2 * exp(- dtm**2/(2.*cx2**2) ) + const2 - coef2*timeq ) + ENDIF + + r_q(i,j) = fhist(i,j)* max(0.,r_q(i,j)*timeq_max) + + !IF (swdown(i,j)<.1) THEN + ! r_q(i,j)= MIN(0.5,r_q(i,j)) ! lower BB emissions at night + !ENDIF + + !IF (.NOT. config_flags%bb_dcycle) THEN + !IF (.NOT. bb_dcycle) THEN + ! r_q(i,j)= fhist(i,j) ! no diurnal cycle + !END IF + + !IF (.NOT. smoke_forecast) THEN + r_q(i,j)= 1. + !END IF + + do k=kts,kfire_max + conv= r_q(i,j)*dtstep/(rho_phy(i,k,j)* dz8w(i,k,j)) + + ! RAR: in this case tracer_1 is fire emitted CO + ! conv_rho=r_q*4.828e-4/rho_phy(i,k,j)*dtstep/(dz8w(i,k,j)*60.) + ! chem(i,k,j,p_tracer_1) = chem(i,k,j,p_tracer_1) + ebu(i,k,j,p_ebu_co)*conv_rho + +! dm_oc_bb = conv* ebu(i,k,j,p_ebu_oc) ! Assume that BB primary PM25 is mostly OC, 1.25 is OM/OC ratio +! dm_p25_bb= conv* ebu(i,k,j,p_ebu_pm25) +! dm_ec_bb = conv* ebu(i,k,j,p_ebu_bc) +! dm_smk = conv* ebu(i,k,j,p_ebu_smoke) + !IF (k==kts) THEN ! Partition takes place here to avoid double counting of smold. and flam. BB emiss. + ! C11= (1.-flam_frac(i,j))*r_q(i,j) + !ELSE + ! C11= flam_frac(i,j)*r_q(i,j) + !ENDIF + dm_smoke= conv*ebu(i,k,j) +! print*,'hli dm_smoke',dm_smoke,conv,ebu(i,k,j,p_ebu_smoke) + + chem(i,k,j,p_smoke) = chem(i,k,j,p_smoke) + dm_smoke + chem(i,k,j,p_smoke) = MIN(chem(i,k,j,p_smoke),5.e+3) + + if (ktau<1000 .and. dbg_opt) then + ! if ( k==kts ) then + ! WRITE(6,*) 'add_emiss_burn: ktau,gmt,dtstep,time_int ',ktau,gmt,dtstep,time_int + ! WRITE(*,*) 'add_emiss_burn: i,j,xlat(i,j),xlong(i,j) ',i,j,xlat(i,j),xlong(i,j) + !WRITE(*,*) 'add_emiss_burn: luf_igbp(i,:,j) ',luf_igbp(i,:,j) + !WRITE(*,*) 'add_emiss_burn: lu_fire1(i,j) ',lu_fire1(i,j) + ! WRITE(6,*) 'add_emiss_burn: timeq,peak_hr(i,j),fhist(i,j),r_q(i,j) ',timeq,peak_hr(i,j),fhist(i,j),r_q(i,j) + ! WRITE(*,*) 'add_emiss_burn: rainc(i,j),rainnc(i,j) ', rainc(i,j),rainnc(i,j) + ! endif + if ( k==kts .OR. k==kfire_max ) then + WRITE(6,*) 'add_emiss_burn: i,j,k ',i,j,k + WRITE(6,*) 'add_emiss_burn: rho_phy(i,k,j),dz8w(i,k,j),conv ',rho_phy(i,k,j),dz8w(i,k,j),conv + WRITE(6,*) 'add_emiss_burn: ebu(i,k,j),dm_smoke ', ebu(i,k,j),dm_smoke + endif + endif + + enddo + enddo + enddo + + ext2= sc_me + ab_me + do j=jts,jte + do k=kts,kte + do i=its,ite + + ! Check for NaNs, negative and too large numbers + IF (.NOT. (chem(i,k,j,p_smoke)>=0. .AND. chem(i,k,j,p_smoke)<1.1e+4)) THEN + chem(i,k,j,p_smoke)=1.e-16 + END IF + + aod3d_smoke(i,k,j)= 1.e-6* ext2* chem(i,k,j,p_smoke )*rho_phy(i,k,j)*dz8w(i,k,j) + aod3d_dust (i,k,j)= 1.e-6* ext2* chem(i,k,j,p_dust_1)*rho_phy(i,k,j)*dz8w(i,k,j) + enddo + enddo + enddo + + IF ( ktau<2000 .and. dbg_opt ) then + WRITE(*,*) 'add_emis_burn: i,j,k,ext2 ',i,j,k,ext2 + WRITE(*,*) 'add_emis_burn: rel_hum(its,kts,jts),rel_hum(ite,kfire_max,jte) ',rel_hum(its,kts,jts),rel_hum(ite,kfire_max,jte) + WRITE(*,*) 'add_emis_burn: aod3d_smoke(its,kts,jts),aod3d_smoke(ite,kfire_max,jte) ',aod3d_smoke(its,kts,jts),aod3d_smoke(ite,kfire_max,jte) + WRITE(*,*) 'add_emis_burn: aod3d_dust(its,kts,jts),aod3d_dust(ite,kfire_max,jte) ',aod3d_dust(its,kts,jts),aod3d_dust(ite,kfire_max,jte) + END IF + +! CASE DEFAULT +! call wrf_debug(15,'nothing done with burn emissions for chem array') +! END SELECT emiss_select + + END subroutine add_emis_burn + +END module module_add_emiss_burn diff --git a/physics/smoke/module_plumerise1.F90 b/physics/smoke/module_plumerise1.F90 new file mode 100755 index 000000000..47bb4e74a --- /dev/null +++ b/physics/smoke/module_plumerise1.F90 @@ -0,0 +1,220 @@ +!>\file module_plumerise1.F90 +!! This file is the fire plume rise driver. + + module module_plumerise1 + + use rrfs_smoke_data + use machine , only : kind_phys + real(kind=kind_phys),parameter :: p1000mb = 100000. ! p at 1000mb (pascals) +!- Implementing the fire radiative power (FRP) methodology for biomass burning +!- emissions and convective energy estimation. +!- Saulo Freitas, Gabriel Pereira (INPE/UFJS, Brazil) +!- Ravan Ahmadov, Georg Grell (NOAA, USA) +!- The flag "plumerise_flag" defines the method: +!- =1 => original method +!- =2 => FRP based +!------------------------------------------------------------------------- +! +! use module_zero_plumegen_coms +! integer, parameter :: nveg_agreg = 4 +! integer, parameter :: tropical_forest = 1 +! integer, parameter :: boreal_forest = 2 +! integer, parameter :: savannah = 3 + +! integer, parameter :: grassland = 4 +! real(kind_phys), dimension(nveg_agreg) :: firesize,mean_fct +! character(len=20), parameter :: veg_name(nveg_agreg) = (/ & +! 'Tropical-Forest', & +! 'Boreal-Forest ', & +! 'Savanna ', & +! 'Grassland ' /) +! character(len=20), parameter :: spc_suf(nveg_agreg) = (/ & +! 'agtf' , & ! trop forest +! 'agef' , & ! extratrop forest +! 'agsv' , & ! savanna +! 'aggr' /) ! grassland + +CONTAINS +subroutine ebu_driver ( data,flam_frac,ebb_smoke,ebu, & + t_phy,q_vap, & ! RAR: moist is replaced with q_vap + rho_phy,vvel,u_phy,v_phy,p_phy, & + z_at_w,z,ktau,g,con_cp,con_rd, & ! scale_fire_emiss is part of config_flags + plume_frp, k_min, k_max, & ! RAR: + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, errmsg, errflg) + + use rrfs_smoke_config + use plume_data_mod + USE module_zero_plumegen_coms + USE module_smoke_plumerise + IMPLICIT NONE + type(smoke_data), intent(inout) :: data + + REAL(kind_phys), PARAMETER :: frp_threshold= 1.e+7 ! Minimum FRP (Watts) to have plume rise + + real(kind=kind_phys), DIMENSION( ims:ime, jms:jme, 2 ), INTENT(IN ) :: plume_frp ! RAR: FRP etc. array + +! TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + character(*), intent(inout) :: errmsg + integer, intent(inout) :: errflg + INTEGER, INTENT(IN ) :: ktau, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte +! real(kind=kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & +! INTENT(IN ) :: moist + real(kind=kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT ) :: ebu + + real(kind=kind_phys), INTENT(IN ) :: g, con_cp, con_rd + real(kind=kind_phys), DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: ebb_smoke + real(kind=kind_phys), DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: flam_frac + +! real(kind=kind_phys), DIMENSION( ims:ime, 1, jms:jme ), & +! INTENT(IN ) :: ebu_in +! real(kind=kind_phys), DIMENSION( ims:ime, jms:jme ), & +! INTENT(IN ) :: & +! mean_fct_agtf,mean_fct_agef,& +! mean_fct_agsv,mean_fct_aggr,firesize_agtf,firesize_agef, & +! firesize_agsv,firesize_aggr + + real(kind=kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: t_phy,z,z_at_w,vvel,u_phy,v_phy,rho_phy,p_phy,q_vap ! RAR + ! real(kind=kind_phys), INTENT(IN ) :: dtstep + +! Local variables... + INTEGER :: nv, i, j, k, kp1, kp2 + INTEGER, DIMENSION(ims:ime, jms:jme), INTENT (OUT) :: k_min, k_max ! Min and max ver. levels for BB injection spread + !real(kind_phys), dimension (num_ebu) :: eburn_in + !real(kind_phys), dimension (kte,num_ebu) :: eburn_out + real(kind_phys), dimension (kte) :: u_in ,v_in ,w_in ,theta_in ,pi_in, rho_phyin ,qv_in ,zmid, z_lev + real(kind=kind_phys) :: dz_plume, cpor, con_rocp + + !INTEGER, PARAMETER :: kfire_max=30 +! real(kind_phys), dimension(nveg_agreg) :: firesize,mean_fct +! real(kind_phys) :: sum, ffirs, ratio +! real(kind_phys),save,dimension(its:ite,jts:jte) :: ffirs +! nspecies=num_ebu +! write(0,*)'plumerise' + +! RAR: +! if (config_flags%biomass_burn_opt == BIOMASSB_SMOKE) then +! do j=jts,jte: +! do i=its,ite +! ebu(i,kts,j,p_ebu_smoke)= ebb_smoke(i,j) +! ebu(i,kts,j,p_ebu_no) = ebu_in(i,1,j,p_ebu_in_no) +! ebu(i,kts,j,p_ebu_co) = ebu_in(i,1,j,p_ebu_in_co) +! ebu(i,kts,j,p_ebu_so2) = ebu_in(i,1,j,p_ebu_in_so2) +! ebu(i,kts,j,p_ebu_dms) = ebu_in(i,1,j,p_ebu_in_dms) +! ebu(i,kts,j,p_ebu_oc) = ebu_in(i,1,j,p_ebu_in_oc) +! ebu(i,kts,j,p_ebu_bc) = ebu_in(i,1,j,p_ebu_in_bc) +! ebu(i,kts,j,p_ebu_pm25) = ebu_in(i,1,j,p_ebu_in_pm25) +! ebu(i,kts,j,p_ebu_pm10) = ebu_in(i,1,j,p_ebu_in_pm10) +! enddo +! enddo + cpor =con_cp/con_rd + con_rocp=con_rd/con_cp + + IF ( dbg_opt .and. ktau<2000) then + WRITE(*,*) 'module_plumerise1: its,ite,jts,jte ', its,ite,jts,jte + WRITE(*,*) 'module_plumerise1: ims,ime,jms,jme ', ims,ime,jms,jme + !WRITE(*,*) 'module_plumerise1: p_ebu_smoke,num_ebu: ', p_ebu_smoke,num_ebu + WRITE(*,*) 'module_plumerise1: maxval(ebu(:,kts,:)) ', maxval(ebu(:,kts,:)) + END IF + !endif + +! RAR: setting to zero the ebu emissions at the levels k>1, this is necessary when the plumerise is called, so the emissions at k>1 are updated + !do nv=1,num_ebu + do j=jts,jte + do k=kts+1,kte + do i=its,ite + ebu(i,k,j)=0. + enddo + enddo + enddo + !enddo + +! For now the flammable fraction is constant, based on the namelist. The next +! step to use LU index and meteorology to parameterize it +! IF (ktau==2) THEN + do j=jts,jte + do i=its,ite + flam_frac(i,j)= 0. + if (plume_frp(i,j,1) > frp_threshold) then + flam_frac(i,j)= 0.9 + end if + enddo + enddo + ! ENDIF + + +! RAR: new FRP based approach +!check_pl: IF (config_flags%plumerise_flag == 2 ) THEN ! if the namelist option is set for plumerise +! Haiqin: plumerise_flag is added to the namelist options +!check_pl: IF (do_plumerise) THEN ! if the namelist option is set for plumerise + do j=jts,jte + do i=its,ite + ! k_min(i,j)=0 + ! k_max(i,j)=0 + +! check_frp: if (.NOT.do_plumerise) then ! namelist option +! ebu(i,kts,j)= ebb_smoke(i,j) +! else + + do k=kts,kte + u_in(k)= u_phy(i,k,j) + v_in(k)= v_phy(i,k,j) + w_in(k)= vvel(i,k,j) + qv_in(k)= q_vap(i,k,j) ! RAR: moist(i,k,j,p_qv) + !pi_in(k)= cp*(p_phy(i,k,j)/p1000mb)**rcp + pi_in(k)= con_cp*(p_phy(i,k,j)/p1000mb)**con_rocp + zmid(k)= z(i,k,j)-z_at_w(i,kts,j) + z_lev(k)= z_at_w(i,k,j)-z_at_w(i,kts,j) + rho_phyin(k)= rho_phy(i,k,j) + theta_in(k)= t_phy(i,k,j)/pi_in(k)*con_cp + !theta_in(k)= t_phy(i,k,j)/pi_in(k)*cp + enddo + + IF (dbg_opt .and. ktau<2000) then + WRITE(*,*) 'module_plumerise1: i,j ',i,j + WRITE(*,*) 'module_plumerise1: plume_frp(i,j,:) ',plume_frp(i,j,:) + WRITE(*,*) 'module_plumerise1: ebu(i,kts,j) ',ebu(i,kts,j) + WRITE(*,*) 'module_plumerise1: u_in(10),v_in(10),w_in(kte),qv_in(10),pi_in(10) ',u_in(10),v_in(10),w_in(kte),qv_in(10),pi_in(10) + WRITE(*,*) 'module_plumerise1: zmid(kte),z_lev(kte),rho_phyin(kte),theta_in(kte) ',zmid(kte),z_lev(kte),rho_phyin(kte),theta_in(kte) + WRITE(*,*) 'module_plumerise1: t_phy(i,kte,j),pi_in(kte)',t_phy(i,kte,j),pi_in(kte) + END IF + +! RAR: the plume rise calculation step: + CALL plumerise(data,kte,1,1,1,1,1,1, & + !firesize,mean_fct, & + !num_ebu, eburn_in, eburn_out, & + u_in, v_in, w_in, theta_in ,pi_in, & + rho_phyin, qv_in, zmid, z_lev, & + plume_frp(i,j,1), k_min(i,j), & + k_max(i,j), ktau, dbg_opt, g, con_cp, & + con_rd, cpor, errmsg, errflg ) + !k_max(i,j), ktau, config_flags%debug_chem ) + if(errflg/=0) return + + kp1= k_min(i,j) + kp2= k_max(i,j) + dz_plume= z_at_w(i,kp2,j) - z_at_w(i,kp1,j) + + do k=kp1,kp2-1 + ebu(i,k,j)= flam_frac(i,j)* ebb_smoke(i,j)* (z_at_w(i,k+1,j)-z_at_w(i,k,j))/dz_plume + enddo + ebu(i,kts,j)= (1.-flam_frac(i,j))* ebb_smoke(i,j) + + IF ( dbg_opt .and. ktau<2000) then + WRITE(*,*) 'module_plumerise1: i,j ',i,j + WRITE(*,*) 'module_plumerise1: k_min(i,j), k_max(i,j) ',k_min(i,j), k_max(i,j) + END IF +! endif check_frp + enddo + enddo + +! ENDIF check_pl + +end subroutine ebu_driver + +END module module_plumerise1 diff --git a/physics/smoke/module_smoke_plumerise.F90 b/physics/smoke/module_smoke_plumerise.F90 new file mode 100755 index 000000000..247b09f92 --- /dev/null +++ b/physics/smoke/module_smoke_plumerise.F90 @@ -0,0 +1,2376 @@ +!>\file module_smoke_plumerise.F90 +!! This file contains the fire plume rise module. + +!------------------------------------------------------------------------- +!- 12 April 2016 +!- Implementing the fire radiative power (FRP) methodology for biomass burning +!- emissions and convective energy estimation. +!- Saulo Freitas, Gabriel Pereira (INPE/UFJS, Brazil) +!- Ravan Ahmadov, Georg Grell (NOAA, USA) +!- The flag "plumerise_flag" defines the method: +!- =1 => original method +!- =2 => FRP based +!------------------------------------------------------------------------- +module module_smoke_plumerise + + use machine , only : kind_phys + use rrfs_smoke_data + use rrfs_smoke_config, only : FIRE_OPT_GBBEPx, FIRE_OPT_MODIS + use plume_data_mod, only : num_frp_plume, p_frp_hr, p_frp_std, & + !tropical_forest, boreal_forest, savannah, grassland, & + wind_eff + USE module_zero_plumegen_coms + + !real(kind=kind_phys),parameter :: rgas=r_d + !real(kind=kind_phys),parameter :: cpor=cp/r_d +CONTAINS + +! RAR: + subroutine plumerise(data,m1,m2,m3,ia,iz,ja,jz, & +! firesize,mean_fct, & + ! nspecies,eburn_in,eburn_out, & + up,vp,wp,theta,pp,dn0,rv,zt_rams,zm_rams, & + frp_inst,k1,k2, ktau, dbg_opt, g, cp, rgas, & + cpor, errmsg, errflg ) + + implicit none + type(smoke_data), intent(inout) :: data + + LOGICAL, INTENT (IN) :: dbg_opt + +! INTEGER, PARAMETER :: ihr_frp=1, istd_frp=2!, imean_fsize=3, istd_fsize=4 ! RAR: + +! integer, intent(in) :: PLUMERISE_flag + real(kind=kind_phys) :: frp_inst ! This is the instantenous FRP, at a given time step + real(kind=kind_phys) :: g, cp, rgas, cpor + + integer :: ng,m1,m2,m3,ia,iz,ja,jz,ibcon,mynum,i,j,k,imm,ixx,ispc !,nspecies + + INTEGER, INTENT (IN) :: ktau + INTEGER, INTENT (OUT) :: k1,k2 + character(*), intent(inout) :: errmsg + integer, intent(inout) :: errflg + +! integer :: ncall = 0 + integer :: kmt +! real(kind=kind_phys),dimension(m1,nspecies), intent(inout) :: eburn_out +! real(kind=kind_phys),dimension(nspecies), intent(in) :: eburn_in + + real(kind=kind_phys), dimension(m1,m2,m3) :: up, vp, wp,theta,pp,dn0,rv + real(kind=kind_phys), dimension(m1) :: zt_rams,zm_rams + real(kind=kind_phys) :: burnt_area,dzi,FRP ! RAR: + real(kind=kind_phys), dimension(2) :: ztopmax + real(kind=kind_phys) :: q_smold_kgm2 + + REAL(kind_phys), PARAMETER :: frp_threshold= 1.e+7 ! Minimum FRP (Watts) to have plume rise + +! From plumerise1.F routine + integer, parameter :: iveg_ag=1 +! integer, parameter :: tropical_forest = 1 +! integer, parameter :: boreal_forest = 2 +! integer, parameter :: savannah = 3 +! integer, parameter :: grassland = 4 +! real(kind=kind_phys), dimension(nveg_agreg) :: firesize,mean_fct + + INTEGER, PARAMETER :: wind_eff = 1 + + type(plumegen_coms), pointer :: coms + +! integer:: iloop + !REAL(kind=kind_phys), INTENT (IN) :: convert_smold_to_flam + + !Fator de conversao de unidades + !!fcu=1. !=> kg [gas/part] /kg [ar] + !!fcu =1.e+12 !=> ng [gas/part] /kg [ar] + !!real(kind=kind_phys),parameter :: fcu =1.e+6 !=> mg [gas/part] /kg [ar] + !---------------------------------------------------------------------- + ! indexacao para o array "plume(k,i,j)" + ! k + ! 1 => area media (m^2) dos focos em biomas floresta dentro do gribox i,j + ! 2 => area media (m^2) dos focos em biomas savana dentro do gribox i,j + ! 3 => area media (m^2) dos focos em biomas pastagem dentro do gribox i,j + ! 4 => desvio padrao da area media (m^2) dos focos : floresta + ! 5 => desvio padrao da area media (m^2) dos focos : savana + ! 6 => desvio padrao da area media (m^2) dos focos : pastagem + ! 7 a 9 => sem uso + !10(=k_CO_smold) => parte da emissao total de CO correspondente a fase smoldering + !11, 12 e 13 => este array guarda a relacao entre + ! qCO( flaming, floresta) e a quantidade total emitida + ! na fase smoldering, isto e; + ! qCO( flaming, floresta) = plume(11,i,j)*plume(10,i,j) + ! qCO( flaming, savana ) = plume(12,i,j)*plume(10,i,j) + ! qCO( flaming, pastagem) = plume(13,i,j)*plume(10,i,j) + !20(=k_PM25_smold),21,22 e 23 o mesmo para PM25 + ! + !24-n1 => sem uso + !---------------------------------------------------------------------- +! print *,' Plumerise_scalar 1',ncall + coms => get_thread_coms() + if (ktau==2) then + call coms%set_to_zero() + endif + +IF (frp_inst there is not emission with + !- plume rise => cycle + + do k = 1,m1 ! loop over vertical grid + coms%ucon (k)=up(k,i,j) ! u wind + coms%vcon (k)=vp(k,i,j) ! v wind + !coms%wcon (k)=wp(k,i,j) ! w wind + coms%thtcon(k)=theta(k,i,j) ! pot temperature + coms%picon (k)=pp(k,i,j) ! exner function + !coms%tmpcon(k)=coms%thtcon(k)*coms%picon(k)/cp ! temperature (K) + !coms%dncon (k)=dn0(k,i,j) ! dry air density (basic state) + !coms%prcon (k)=(coms%picon(k)/cp)**cpor*p00 ! pressure (Pa) + coms%rvcon (k)=rv(k,i,j) ! water vapor mixing ratio + coms%zcon (k)=zt_rams(k) ! termod-point height + coms%zzcon (k)=zm_rams(k) ! W-point height + enddo + +! do ispc=2,nspecies + ! eburn_out(1,ispc) = eburn_in(ispc) ! eburn_in is the emissions at the 1st level +! eburn_out(2:m1,ispc)= 0. ! RAR: k>1 are used from eburn_out +! enddo + + !- get envinronmental state (temp, water vapor mix ratio, ...) + call get_env_condition(coms,1,m1,kmt,wind_eff,ktau,g,cp,rgas,cpor,errmsg,errflg) + if(errflg/=0) return + + !- loop over the four types of aggregate biomes with fires for plumerise version 1 + !- for plumerise version 2, there is exist only one loop + ! iloop=1 +! IF (PLUMERISE_flag == 1) iloop=nveg_agreg + + !lp_veg: do iveg_ag=1,iloop + FRP = max(1000.,frp_inst) + + !- loop over the minimum and maximum heat fluxes/FRP + lp_minmax: do imm=1,2 + if(imm==1 ) then + burnt_area = 0.7* 0.00021* FRP ! - 0.5*plume_fre(istd_fsize)) + elseif(imm==2 ) then + burnt_area = 1.3* 0.00021* FRP + endif + burnt_area= max(1.0e4,burnt_area) + + IF (dbg_opt .AND. ktau<2000) THEN + WRITE(*,*) 'plumerise: m1,ktau ', m1,ktau + WRITE(*,*) 'plumerise: imm, FRP,burnt_area ', imm, FRP,burnt_area + ! WRITE(*,*) 'convert_smold_to_flam ',convert_smold_to_flam + WRITE(*,*) 'plumerise: zcon ', coms%zcon + WRITE(*,*) 'plumerise: zzcon ', coms%zzcon + END IF + + IF (dbg_opt .AND. ktau<2000) then + WRITE(*,*) 'plumerise: imm ', imm + WRITE(*,*) 'plumerise: burnt_area ',burnt_area + END IF + + !- get fire properties (burned area, plume radius, heating rates ...) + call get_fire_properties(coms,imm,iveg_ag,burnt_area,FRP,errmsg,errflg) + if(errflg/=0) return + + !------ generates the plume rise ------ + call makeplume (coms,kmt,ztopmax(imm),ixx,imm) + + IF (dbg_opt .AND. ktau<2000) then + WRITE(*,*) 'plumerise after makeplume: imm,kmt,ztopmax(imm) ',imm,kmt,ztopmax(imm) + END IF + + enddo lp_minmax + + !- define o dominio vertical onde a emissao flaming ira ser colocada + call set_flam_vert(ztopmax,k1,k2,nkp,coms%zzcon) !,W_VMD,VMD) + + ! IF (ktau<2000) then + ! WRITE(6,*) 'module_chem_plumerise_scalar: eburn_out(:,3) ', eburn_out(:,3) + ! END IF + + !- thickness of the vertical layer between k1 and k2 eta levels (lower and upper bounds for the injection height ) + !dzi= 1./(coms%zzcon(k2)-coms%zzcon(k1)) ! RAR: k2>=k1+1 + + !- emission during flaming phase is evenly distributed between levels k1 and k2 + !do k=k1,k2 + ! do ispc= 2,nspecies + ! eburn_out(k,ispc)= dzi* eburn_in(ispc) + ! enddo + !enddo + + IF (dbg_opt .AND. ktau<2000) then + WRITE(*,*) 'plumerise after set_flam_vert: nkp,k1,k2, ', nkp,k1,k2 + WRITE(*,*) 'plumerise after set_flam_vert: dzi ', dzi + !WRITE(*,*) 'plumerise after set_flam_vert: eburn_in(2) ', eburn_in(2) + !WRITE(*,*) 'plumerise after set_flam_vert: eburn_out(:,2) ',eburn_out(:,2) + END IF + +! enddo lp_veg ! sub-grid vegetation, currently it's aggregated + +end subroutine plumerise +!------------------------------------------------------------------------- + +subroutine get_env_condition(coms,k1,k2,kmt,wind_eff,ktau,g,cp,rgas,cpor,errmsg,errflg) + +!se module_zero_plumegen_coms +!use rconstants +implicit none +type(plumegen_coms), pointer :: coms +real(kind=kind_phys) :: g,cp,rgas,cpor +integer :: k1,k2,k,kcon,klcl,kmt,nk,nkmid,i +real(kind=kind_phys),parameter :: p1000mb = 100000. ! p at 1000mb (pascals) +real(kind=kind_phys),parameter :: p00=p1000mb +real(kind=kind_phys) :: znz,themax,tlll,plll,rlll,zlll,dzdd,dzlll,tlcl,plcl,dzlcl,dummy +!integer :: n_setgrid = 0 +integer :: wind_eff,ktau +character(*), intent(inout) :: errmsg +integer, intent(inout) :: errflg + +if(ktau==2) then + ! n_setgrid = 1 + call set_grid(coms) ! define vertical grid of plume model + ! coms%zt(k) = thermo and water levels + ! coms%zm(k) = dynamical levels +endif + +znz=coms%zcon(k2) +errflg=1 +do k=nkp,1,-1 + if(coms%zt(k).lt.znz) then + errflg=0 + exit + endif +enddo +if(errflg/=0) then + errmsg=' envir stop 12' + return +endif +!-srf-mb +kmt=min(k,nkp-1) + +nk=k2-k1+1 +!call htint(nk, coms%wcon,coms%zzcon,kmt,wpe,coms%zt,errmsg,errflg) +!if(errflg/=0) return + call htint(nk, coms%ucon,coms%zcon,kmt,coms%upe,coms%zt,errmsg,errflg) + if(errflg/=0) return + call htint(nk, coms%vcon,coms%zcon,kmt,coms%vpe,coms%zt,errmsg,errflg) + if(errflg/=0) return + call htint(nk,coms%thtcon,coms%zcon,kmt,coms%the ,coms%zt,errmsg,errflg) + if(errflg/=0) return + call htint(nk, coms%rvcon,coms%zcon,kmt,coms%qvenv,coms%zt,errmsg,errflg) + if(errflg/=0) return +do k=1,kmt + coms%qvenv(k)=max(coms%qvenv(k),1e-8) +enddo + +coms%pke(1)=coms%picon(1) +do k=1,kmt + coms%thve(k)=coms%the(k)*(1.+.61*coms%qvenv(k)) ! virtual pot temperature +enddo +do k=2,kmt + coms%pke(k)=coms%pke(k-1)-g*2.*(coms%zt(k)-coms%zt(k-1)) & ! exner function + /(coms%thve(k)+coms%thve(k-1)) +enddo +do k=1,kmt + coms%te(k) = coms%the(k)*coms%pke(k)/cp ! temperature (K) + coms%pe(k) = (coms%pke(k)/cp)**cpor*p00 ! pressure (Pa) + coms%dne(k)= coms%pe(k)/(rgas*coms%te(k)*(1.+.61*coms%qvenv(k))) ! dry air density (kg/m3) +! print*,'ENV=',coms%qvenv(k)*1000., coms%te(k)-273.15,coms%zt(k) +!-srf-mb + coms%vel_e(k) = sqrt(coms%upe(k)**2+coms%vpe(k)**2) !-env wind (m/s) + !print*,'k,coms%vel_e(k),coms%te(k)=',coms%vel_e(k),coms%te(k) +enddo + +!-ewe - env wind effect +if(wind_eff < 1) coms%vel_e(1:kmt) = 0. + +!-use este para gerar o RAMS.out +! ------- print environment state +!print*,'k,coms%zt(k),coms%pe(k),coms%te(k)-273.15,coms%qvenv(k)*1000' +!do k=1,kmt +! write(*,100) k,coms%zt(k),coms%pe(k),coms%te(k)-273.15,coms%qvenv(k)*1000. +! 100 format(1x,I5,4f20.12) +!enddo +!stop 333 + + +!--------- nao eh necessario este calculo +!do k=1,kmt +! call thetae(coms%pe(k),coms%te(k),coms%qvenv(k),coms%thee(k)) +!enddo + + +!--------- converte press de Pa para kPa para uso modelo de plumerise +do k=1,kmt + coms%pe(k) = coms%pe(k)*1.e-3 +enddo + +return +end subroutine get_env_condition + +!------------------------------------------------------------------------- + +subroutine set_grid(coms) +!use module_zero_plumegen_coms +implicit none +type(plumegen_coms), pointer :: coms +integer :: k,mzp + +coms%dz=100. ! set constant grid spacing of plume grid model(meters) + +mzp=nkp +coms%zt(1) = coms%zsurf +coms%zm(1) = coms%zsurf +coms%zt(2) = coms%zt(1) + 0.5*coms%dz +coms%zm(2) = coms%zm(1) + coms%dz +do k=3,mzp + coms%zt(k) = coms%zt(k-1) + coms%dz ! thermo and water levels + coms%zm(k) = coms%zm(k-1) + coms%dz ! dynamical levels +enddo +!print*,coms%zsurf +!Print*,coms%zt(:) +do k = 1,mzp-1 + coms%dzm(k) = 1. / (coms%zt(k+1) - coms%zt(k)) +enddo +coms%dzm(mzp)=coms%dzm(mzp-1) + +do k = 2,mzp + coms%dzt(k) = 1. / (coms%zm(k) - coms%zm(k-1)) +enddo +coms%dzt(1) = coms%dzt(2) * coms%dzt(2) / coms%dzt(3) + +! coms%dzm(1) = 0.5/coms%dz +! coms%dzm(2:mzp) = 1./coms%dz +return +end subroutine set_grid +!------------------------------------------------------------------------- + + SUBROUTINE set_flam_vert(ztopmax,k1,k2,nkp,zzcon) !,W_VMD,VMD) + + REAL(kind=kind_phys) , INTENT(IN) :: ztopmax(2) + INTEGER , INTENT(OUT) :: k1,k2 + + ! plumegen_coms + INTEGER , INTENT(IN) :: nkp + REAL(kind=kind_phys) , INTENT(IN) :: zzcon(nkp) + + INTEGER imm,k + INTEGER, DIMENSION(2) :: k_lim + + !- version 2 +! REAL(kind=kind_phys) , INTENT(IN) :: W_VMD(nkp,2) +! REAL(kind=kind_phys) , INTENT(OUT) :: VMD(nkp,2) +! real(kind=kind_phys) w_thresold,xxx +! integer k_initial,k_final,ko,kk4,kl + + !- version 1 + DO imm=1,2 + ! checar + ! do k=1,m1-1 + DO k=1,nkp-1 + IF(zzcon(k) > ztopmax(imm)) EXIT + ENDDO + k_lim(imm) = k + ENDDO + k1= MIN(MAX(4,k_lim(1)),51) + k2= MIN(51,k_lim(2)) ! RAR: the model doesn't simulate very high injection heights, so it's safe to assume maximum heigh of 12km AGL for HRRR grid + + IF (k2 <= k1) THEN + !print*,'1: ztopmax k=',ztopmax(1), k1 + !print*,'2: ztopmax k=',ztopmax(2), k2 + k2= k1+1 ! RAR: I added k1+1 + ENDIF + + !- version 2 + !- vertical mass distribution + !- +! w_thresold = 1. +! DO imm=1,2 + +! VMD(1:nkp,imm)= 0. +! xxx=0. +! k_initial= 0 +! k_final = 0 + + !- define range of the upper detrainemnt layer +! do ko=nkp-10,2,-1 + +! if(w_vmd(ko,imm) < w_thresold) cycle + +! if(k_final==0) k_final=ko + +! if(w_vmd(ko,imm)-1. > w_vmd(ko-1,imm)) then +! k_initial=ko +! exit +! endif + +! enddo + !- if there is a non zero depth layer, make the mass vertical distribution +! if(k_final > 0 .and. k_initial > 0) then + +! k_initial=int((k_final+k_initial)*0.5) + + !- parabolic vertical distribution between k_initial and k_final +! kk4 = k_final-k_initial+2 +! do ko=1,kk4-1 +! kl=ko+k_initial-1 +! VMD(kl,imm) = 6.* float(ko)/float(kk4)**2 * (1. - float(ko)/float(kk4)) +! enddo +! if(sum(VMD(1:NKP,imm)) .ne. 1.) then +! xxx= ( 1.- sum(VMD(1:NKP,imm)) )/float(k_final-k_initial+1) +! do ko=k_initial,k_final +! VMD(ko,imm) = VMD(ko,imm)+ xxx !- values between 0 and 1. +! enddo + ! print*,'new mass=',sum(mass)*100.,xxx + !pause +! endif +! endif !k_final > 0 .and. k_initial > + +! ENDDO + + END SUBROUTINE set_flam_vert +!------------------------------------------------------------------------- + +subroutine get_fire_properties(coms,imm,iveg_ag,burnt_area,FRP,errmsg,errflg) +!use module_zero_plumegen_coms +implicit none +type(plumegen_coms), pointer :: coms +integer :: moist, i, icount,imm,iveg_ag !,plumerise_flag +real(kind=kind_phys):: bfract, effload, heat, hinc ,burnt_area,heat_fluxW,FRP +real(kind=kind_phys), dimension(2,4) :: heat_flux +integer, intent(inout) :: errflg +character(*), intent(inout) :: errmsg +INTEGER, parameter :: use_last = 0 +!real(kind=kind_phys), parameter :: beta = 5.0 !ref.: Wooster et al., 2005 +REAL(kind=kind_phys), parameter :: beta = 0.88 !ref.: Paugam et al., 2015 + +data heat_flux/ & +!--------------------------------------------------------------------- +! heat flux !IGBP Land Cover ! +! min ! max !Legend and ! reference +! kW/m^2 !description ! +!-------------------------------------------------------------------- +30.0, 80.0, &! Tropical Forest ! igbp 2 & 4 +30.0, 80.0, &! Boreal(kind=kind_phys) forest ! igbp 1 & 3 +4.4, 23.0, &! cerrado/woody savanna | igbp 5 thru 9 +3.3, 3.3 /! Grassland/cropland ! igbp 10 thru 17 +!-------------------------------------------------------------------- +!-- fire at surface +! +!coms%area = 20.e+4 ! area of burn, m^2 +coms%area = burnt_area! area of burn, m^2 + +!IF ( PLUMERISE_flag == 1) THEN +! !fluxo de calor para o bioma +! heat_fluxW = heat_flux(imm,iveg_ag) * 1000. ! converte para W/m^2 + +!ELSEIF ( PLUMERISE_flag == 2) THEN + ! "beta" factor converts FRP to convective energy + heat_fluxW = beta*(FRP/coms%area)/0.55 ! in W/m^2 +! FIXME: These five lines were not in the known-working version. Delete them? +! if(coms%area<1e-6) then +! heat_fluxW = 0 +! else +! heat_fluxW = beta*(FRP/coms%area)/0.55 ! in W/m^2 +! endif + +!ENDIF + +coms%mdur = 53 ! duration of burn, minutes +coms%bload = 10. ! total loading, kg/m**2 +moist = 10 ! fuel moisture, %. average fuel moisture,percent dry +coms%maxtime =coms%mdur+2 ! model time, min +!heat = 21.e6 !- joules per kg of fuel consumed +!heat = 15.5e6 !joules/kg - cerrado +heat = 19.3e6 !joules/kg - floresta em alta floresta (mt) +!coms%alpha = 0.1 !- entrainment constant +coms%alpha = 0.05 !- entrainment constant + +!-------------------- printout ---------------------------------------- + +!!WRITE ( * , * ) ' SURFACE =', COMS%ZSURF, 'M', ' LCL =', COMS%ZBASE, 'M' +! +!PRINT*,'=======================================================' +!print * , ' FIRE BOUNDARY CONDITION :' +!print * , ' DURATION OF BURN, MINUTES =',COMS%MDUR +!print * , ' AREA OF BURN, HA =',COMS%AREA*1.e-4 +!print * , ' HEAT FLUX, kW/m^2 =',heat_fluxW*1.e-3 +!print * , ' TOTAL LOADING, KG/M**2 =',COMS%BLOAD +!print * , ' FUEL MOISTURE, % =',MOIST !average fuel moisture,percent dry +!print * , ' MODEL TIME, MIN. =',COMS%MAXTIME +! +! +! +! ******************** fix up inputs ********************************* +! + +!IF (MOD (COMS%MAXTIME, 2) .NE.0) COMS%MAXTIME = COMS%MAXTIME+1 !make coms%maxtime even + +COMS%MAXTIME = COMS%MAXTIME * 60 ! and put in seconds +! +COMS%RSURF = SQRT (COMS%AREA / 3.14159) !- entrainment surface radius (m) + +COMS%FMOIST = MOIST / 100. !- fuel moisture fraction +! +! +! calculate the energy flux and water content at lboundary. +! fills heating() on a minute basis. could ask for a file at this po +! in the program. whatever is input has to be adjusted to a one +! minute timescale. +! + + DO I = 1, ntime !- make sure of energy release + COMS%HEATING (I) = 0.0001 !- avoid possible divide by 0 + enddo +! + COMS%TDUR = COMS%MDUR * 60. !- number of seconds in the burn + + bfract = 1. !- combustion factor + + EFFLOAD = COMS%BLOAD * BFRACT !- patchy burning + +! spread the burning evenly over the interval +! except for the first few minutes for stability + ICOUNT = 1 +! + if(COMS%MDUR > NTIME) then + errmsg = 'Increase time duration (ntime) in min - see file "module_zero_plumegen_coms.F90"' + errflg = 1 + return + endif + + DO WHILE (ICOUNT.LE.COMS%MDUR) +! COMS%HEATING (ICOUNT) = HEAT * EFFLOAD / COMS%TDUR ! W/m**2 +! COMS%HEATING (ICOUNT) = 80000. * 0.55 ! W/m**2 + + COMS%HEATING (ICOUNT) = heat_fluxW * 0.55 ! W/m**2 (0.55 converte para energia convectiva) + ICOUNT = ICOUNT + 1 + ENDDO +! ramp for 5 minutes + IF(use_last /= 1) THEN + + HINC = COMS%HEATING (1) / 4. + COMS%HEATING (1) = 0.1 + COMS%HEATING (2) = HINC + COMS%HEATING (3) = 2. * HINC + COMS%HEATING (4) = 3. * HINC + ELSE + IF(imm==1) THEN + HINC = COMS%HEATING (1) / 4. + COMS%HEATING (1) = 0.1 + COMS%HEATING (2) = HINC + COMS%HEATING (3) = 2. * HINC + COMS%HEATING (4) = 3. * HINC + ELSE + HINC = (COMS%HEATING (1) - heat_flux(imm-1,iveg_ag) * 1000. *0.55)/ 4. + COMS%HEATING (1) = heat_flux(imm-1,iveg_ag) * 1000. *0.55 + 0.1 + COMS%HEATING (2) = COMS%HEATING (1)+ HINC + COMS%HEATING (3) = COMS%HEATING (2)+ HINC + COMS%HEATING (4) = COMS%HEATING (3)+ HINC + ENDIF + ENDIF + +return +end subroutine get_fire_properties +!------------------------------------------------------------------------------- +! +SUBROUTINE MAKEPLUME (coms,kmt,ztopmax,ixx,imm) +! +! ********************************************************************* +! +! EQUATION SOURCE--Kessler Met.Monograph No. 32 V.10 (K) +! Alan Weinstein, JAS V.27 pp 246-255. (W), +! Ogura and Takahashi, Monthly Weather Review V.99,pp895-911 (OT) +! Roger Pielke,Mesoscale Meteorological Modeling,Academic Press,1984 +! Originally developed by: Don Latham (USFS) +! +! +! ************************ VARIABLE ID ******************************** +! +! DT=COMPUTING TIME INCREMENT (SEC) +! DZ=VERTICAL INCREMENT (M) +! LBASE=LEVEL ,CLOUD BASE +! +! CONSTANTS: +! G = GRAVITATIONAL ACCELERATION 9.80796 (M/SEC/SEC). +! R = DRY AIR GAS CONSTANT (287.04E6 JOULE/KG/DEG K) +! CP = SPECIFIC HT. (1004 JOULE/KG/DEG K) +! HEATCOND = HEAT OF CONDENSATION (2.5E6 JOULE/KG) +! HEATFUS = HEAT OF FUSION (3.336E5 JOULE/KG) +! HEATSUBL = HEAT OF SUBLIMATION (2.83396E6 JOULE/KG) +! EPS = RATIO OF MOL.WT. OF WATER VAPOR TO THAT OF DRY AIR (0.622) +! DES = DIFFERENCE BETWEEN VAPOR PRESSURE OVER WATER AND ICE (MB) +! TFREEZE = FREEZING TEMPERATURE (K) +! +! +! PARCEL VALUES: +! T = TEMPERATURE (K) +! TXS = TEMPERATURE EXCESS (K) +! QH = HYDROMETEOR WATER CONTENT (G/G DRY AIR) +! QHI = HYDROMETEOR ICE CONTENT (G/G DRY AIR) +! QC = WATER CONTENT (G/G DRY AIR) +! QVAP = WATER VAPOR MIXING RATIO (G/G DRY AIR) +! QSAT = SATURATION MIXING RATIO (G/G DRY AIR) +! RHO = DRY AIR DENSITY (G/M**3) MASSES = RHO*Q'S IN G/M**3 +! ES = SATURATION VAPOR PRESSURE (kPa) +! +! ENVIRONMENT VALUES: +! TE = TEMPERATURE (K) +! PE = PRESSURE (kPa) +! QVENV = WATER VAPOR (G/G) +! RHE = RELATIVE HUMIDITY FRACTION (e/esat) +! DNE = dry air density (kg/m^3) +! +! HEAT VALUES: +! HEATING = HEAT OUTPUT OF FIRE (WATTS/M**2) +! MDUR = DURATION OF BURN, MINUTES +! +! W = VERTICAL VELOCITY (M/S) +! RADIUS=ENTRAINMENT RADIUS (FCN OF Z) +! RSURF = ENTRAINMENT RADIUS AT GROUND (SIMPLE PLUME, TURNER) +! ALPHA = ENTRAINMENT CONSTANT +! MAXTIME = TERMINATION TIME (MIN) +! +! +!********************************************************************** +!********************************************************************** +!use module_zero_plumegen_coms +implicit none +!logical :: endspace +type(plumegen_coms), pointer :: coms +character (len=10) :: varn +integer :: izprint, iconv, itime, k, kk, kkmax, deltak,ilastprint,kmt & + ,ixx,nrectotal,i_micro,n_sub_step +real(kind=kind_phys) :: vc, g, r, cp, eps, & + tmelt, heatsubl, heatfus, heatcond, tfreeze, & + ztopmax, wmax, rmaxtime, es, esat, heat,dt_save !ESAT_PR, +character (len=2) :: cixx +! Set threshold to be the same as dz=100., the constant grid spacing of plume grid model(meters) found in set_grid() + REAL(kind=kind_phys) :: DELZ_THRESOLD = 100. + + INTEGER :: imm + +! real(kind=kind_phys), external:: esat_pr! +! +! ******************* SOME CONSTANTS ********************************** +! +! XNO=10.0E06 median volume diameter raindrop (K table 4) +! VC = 38.3/(XNO**.125) mean volume fallspeed eqn. (K) +! +parameter (vc = 5.107387) +parameter (g = 9.80796, r = 287.04, cp = 1004., eps = 0.622, tmelt = 273.3) +parameter (heatsubl = 2.834e6, heatfus = 3.34e5, heatcond = 2.501e6) +parameter (tfreeze = 269.3) +! +coms%tstpf = 2.0 !- timestep factor +coms%viscosity = 500.!- coms%viscosity constant (original value: 0.001) + +nrectotal=150 +! +!*************** PROBLEM SETUP AND INITIAL CONDITIONS ***************** +coms%mintime = 1 +ztopmax = 0. +coms%ztop = 0. + coms%time = 0. + coms%dt = 1. + wmax = 1. +kkmax = 10 +deltaK = 20 +ilastprint=0 +COMS%L = 1 ! COMS%L initialization + +!--- initialization +CALL INITIAL(coms,kmt) + +!--- initial print fields: +izprint = 0 ! if = 0 => no printout +!if (izprint.ne.0) then +! write(cixx(1:2),'(i2.2)') ixx +! open(2, file = 'debug.'//cixx//'.dat') +! open(19,file='plumegen9.'//cixx//'.gra', & +! form='unformatted',access='direct',status='unknown', & +! recl=4*nrectotal) !PC +! recl=1*nrectotal) !sx6 e tupay +! call printout (izprint,nrectotal) +! ilastprint=2 +!endif + +! ******************* model evolution ****************************** +rmaxtime = float(coms%maxtime) +! +!print * ,' TIME=',coms%time,' RMAXTIME=',rmaxtime +!print*,'=======================================================' + DO WHILE (COMS%TIME.LE.RMAXTIME) !beginning of time loop + +! do itime=1,120 + +!-- set model top integration + coms%nm1 = min(kmt, kkmax + deltak) +!sam 81 format('nm1=',I0,' from kmt=',I0,' kkmax=',I0,' deltak=',I0) +!sam write(0,81) coms%nm1,kmt,kkmax,deltak +!-- set timestep + !coms%dt = (coms%zm(2)-coms%zm(1)) / (coms%tstpf * wmax) + coms%dt = min(5.,(coms%zm(2)-coms%zm(1)) / (coms%tstpf * wmax)) + +!-- elapsed time, sec + coms%time = coms%time+coms%dt +!-- elapsed time, minutes + coms%mintime = 1 + int (coms%time) / 60 + wmax = 1. !no zeroes allowed. +!************************** BEGIN SPACE LOOP ************************** + +!-- zerout all model tendencies + call tend0_plumerise(coms) + +!-- bounday conditions (k=1) + COMS%L=1 + call lbound(coms) + +!-- dynamics for the level k>1 +!-- W advection +! call vel_advectc_plumerise(COMS%NM1,COMS%WC,COMS%WT,COMS%DNE,COMS%DZM) + call vel_advectc_plumerise(COMS%NM1,COMS%WC,COMS%WT,COMS%RHO,COMS%DZM) + +!-- scalars advection 1 + call scl_advectc_plumerise(coms,'SC',COMS%NM1) + +!-- scalars advection 2 + !call scl_advectc_plumerise2(coms,'SC',COMS%NM1) + +!-- scalars entrainment, adiabatic + call scl_misc(coms,COMS%NM1) + +!-- scalars dinamic entrainment + call scl_dyn_entrain(COMS%NM1,nkp,coms%wbar,coms%w,coms%adiabat,coms%alpha,coms%radius,coms%tt,coms%t,coms%te,coms%qvt,coms%qv,coms%qvenv,coms%qct,coms%qc,coms%qht,coms%qh,coms%qit,coms%qi,& + coms%vel_e,coms%vel_p,coms%vel_t,coms%rad_p,coms%rad_t) + +!-- gravity wave damping using Rayleigh friction layer fot COMS%T + call damp_grav_wave(1,coms%nm1,deltak,coms%dt,coms%zt,coms%zm,coms%w,coms%t,coms%tt,coms%qv,coms%qh,coms%qi,coms%qc,coms%te,coms%pe,coms%qvenv) + +!-- microphysics +! goto 101 ! bypass microphysics + dt_save=coms%dt + n_sub_step=3 + coms%dt=coms%dt/float(n_sub_step) + + do i_micro=1,n_sub_step +!-- sedim ? + call fallpart(coms,COMS%NM1) +!-- microphysics + coms%L=2 + do while(coms%L<=coms%nm1-1) + !do L=2,coms%nm1-1 + COMS%WBAR = 0.5*(coms%W(COMS%L)+coms%W(COMS%L-1)) + ES = ESAT_PR (COMS%T(COMS%L)) !BLOB SATURATION VAPOR PRESSURE, EM KPA + COMS%QSAT(COMS%L) = (EPS * ES) / (COMS%PE(COMS%L) - ES) !BLOB SATURATION LWC G/G DRY AIR + COMS%EST (COMS%L) = ES +!sam if(.not.coms%pe(coms%L)>0 .or. .not. coms%T(coms%L)>200) then +!sam 1304 format('(1304) bad input to rho at L=',I0,' with pe=',F12.5,' T=',F12.5) +!sam write(0,1304) coms%L,coms%PE(coms%L),coms%T(coms%L) +!sam endif + COMS%RHO (COMS%L) = 3483.8 * COMS%PE (COMS%L) / COMS%T (COMS%L) ! AIR PARCEL DENSITY , G/M**3 +!srf18jun2005 +! IF (COMS%W(COMS%L) .ge. 0.) COMS%DQSDZ = (COMS%QSAT(COMS%L ) - COMS%QSAT(COMS%L-1)) / (COMS%ZT(COMS%L ) -COMS%ZT(COMS%L-1)) +! IF (COMS%W(COMS%L) .lt. 0.) COMS%DQSDZ = (COMS%QSAT(COMS%L+1) - COMS%QSAT(COMS%L )) / (COMS%ZT(COMS%L+1) -COMS%ZT(COMS%L )) + IF (COMS%W(COMS%L) .ge. 0.) then + COMS%DQSDZ = (COMS%QSAT(COMS%L+1) - COMS%QSAT(COMS%L-1)) / (COMS%ZT(COMS%L+1 )-COMS%ZT(COMS%L-1)) + ELSE + COMS%DQSDZ = (COMS%QSAT(COMS%L+1) - COMS%QSAT(COMS%L-1)) / (COMS%ZT(COMS%L+1) -COMS%ZT(COMS%L-1)) + ENDIF + + call waterbal(coms) + coms%L=coms%L+1 + enddo + enddo + coms%dt=dt_save +! + 101 continue +! +!-- W-viscosity for stability + call visc_W(coms,coms%nm1,deltak,kmt) + +!-- update scalars + call update_plumerise(coms,coms%nm1,'S') + + call hadvance_plumerise(1,coms%nm1,coms%dt,COMS%WC,COMS%WT,COMS%W,coms%mintime) + +!-- Buoyancy + call buoyancy_plumerise(COMS%NM1, COMS%T, COMS%TE, COMS%QV, COMS%QVENV, COMS%QH, COMS%QI, COMS%QC, COMS%WT, COMS%SCR1) + +!-- Entrainment + call entrainment(coms,COMS%NM1,COMS%W,COMS%WT,COMS%RADIUS,COMS%ALPHA) + +!-- update W + call update_plumerise(coms,coms%nm1,'W') + + call hadvance_plumerise(2,coms%nm1,coms%dt,COMS%WC,COMS%WT,COMS%W,coms%mintime) + + +!-- misc + do k=2,coms%nm1 +! coms%pe esta em kpa - esat do rams esta em mbar = 100 Pa = 0.1 kpa +! es = 0.1*esat (coms%t(k)) !blob saturation vapor pressure, em kPa +! rotina do plumegen calcula em kPa + es = esat_pr (coms%t(k)) !blob saturation vapor pressure, em kPa + coms%qsat(k) = (eps * es) / (coms%pe(k) - es) !blob saturation lwc g/g dry air + coms%est (k) = es + coms%txs (k) = coms%t(k) - coms%te(k) +!sam if(.not.coms%pe(K)>0 .or. .not. coms%T(K)>200) then +!sam 1305 format('(1305) bad input to rho at K=',I0,' with pe=',F12.5,' T=',F12.5) +!sam write(0,1305) K,coms%PE(K),coms%T(K) +!sam endif + coms%rho (k) = 3483.8 * coms%pe (k) / coms%t (k) ! air parcel density , g/m**3 + ! no pressure diff with radius + if((abs(coms%wc(k))).gt.wmax) wmax = abs(coms%wc(k)) ! keep wmax largest w + enddo + +! Gravity wave damping using Rayleigh friction layer for W + call damp_grav_wave(2,coms%nm1,deltak,coms%dt,coms%zt,coms%zm,coms%w,coms%t,coms%tt,coms%qv,coms%qh,coms%qi,coms%qc,coms%te,coms%pe,coms%qvenv) +!--- + !- update radius + do k=2,coms%nm1 + coms%radius(k) = coms%rad_p(k) + enddo + !-- try to find the plume top (above surface height) + kk = 1 + DO WHILE (coms%w (kk) .GT. 1.) + kk = kk + 1 + coms%ztop = coms%zm(kk) + !print*,'W=',coms%w (kk) + ENDDO + ! + coms%ztop_(coms%mintime) = coms%ztop + ztopmax = MAX (coms%ztop, ztopmax) + kkmax = MAX (kk , kkmax ) + !print * ,'ztopmax=', coms%mintime,'mn ',coms%ztop_(coms%mintime), ztopmax + + ! + ! if the solution is going to a stationary phase, exit + IF(coms%mintime > 10) THEN + ! if(coms%mintime > 20) then + ! if( abs(coms%ztop_(coms%mintime)-coms%ztop_(coms%mintime-10)) < COMS%DZ ) exit + IF( ABS(coms%ztop_(coms%mintime)-coms%ztop_(coms%mintime-10)) < DELZ_THRESOLD) then + !- determine W parameter to determine the VMD + !do k=2,coms%nm1 + ! W_VMD(k,imm) = coms%w(k) + !enddo + EXIT ! finish the integration + ENDIF + ENDIF + + ! if(ilastprint == coms%mintime) then + ! call printout (izprint,nrectotal) + ! ilastprint = coms%mintime+1 + ! endif + + +ENDDO !do next timestep + +!print * ,' ztopmax=',ztopmax,'m',coms%mintime,'mn ' +!print*,'=======================================================' +! +!the last printout +!if (izprint.ne.0) then +! call printout (izprint,nrectotal) +! close (2) +! close (19) +!endif + +RETURN +END SUBROUTINE MAKEPLUME +!------------------------------------------------------------------------------- +! +SUBROUTINE BURN(COMS, EFLUX, WATER) +! +!- calculates the energy flux and water content at lboundary +!use module_zero_plumegen_coms +implicit none +type(plumegen_coms), pointer :: coms +!real(kind=kind_phys), parameter :: HEAT = 21.E6 !Joules/kg +!real(kind=kind_phys), parameter :: HEAT = 15.5E6 !Joules/kg - cerrado +real(kind=kind_phys), parameter :: HEAT = 19.3E6 !Joules/kg - floresta em Alta Floresta (MT) +real(kind=kind_phys) :: eflux,water +! +! The emission factor for water is 0.5. The water produced, in kg, +! is then fuel mass*0.5 + (moist/100)*mass per square meter. +! The fire burns for DT out of TDUR seconds, the total amount of +! fuel burned is AREA*COMS%BLOAD*(COMS%DT/TDUR) kg. this amount of fuel is +! considered to be spread over area AREA and so the mass burned per +! unit area is COMS%BLOAD*(COMS%DT/TDUR), and the rate is COMS%BLOAD/TDUR. +! +IF (COMS%TIME.GT.COMS%TDUR) THEN !is the burn over? + EFLUX = 0.000001 !prevent a potential divide by zero + WATER = 0. + RETURN +ELSE +! + EFLUX = COMS%HEATING (COMS%MINTIME) ! Watts/m**2 +! WATER = EFLUX * (COMS%DT / HEAT) * (0.5 + COMS%FMOIST) ! kg/m**2 + WATER = EFLUX * (COMS%DT / HEAT) * (0.5 + COMS%FMOIST) /0.55 ! kg/m**2 + WATER = WATER * 1000. ! g/m**2 +! +! print*,'BURN:',coms%time,EFLUX/1.e+9 +ENDIF +! +RETURN +END SUBROUTINE BURN +!------------------------------------------------------------------------------- +! +SUBROUTINE LBOUND (coms) +! +! ********** BOUNDARY CONDITIONS AT ZSURF FOR PLUME AND CLOUD ******** +! +! source of equations: J.S. Turner Buoyancy Effects in Fluids +! Cambridge U.P. 1973 p.172, +! G.A. Briggs Plume Rise, USAtomic Energy Commissio +! TID-25075, 1969, P.28 +! +! fundamentally a point source below ground. at surface, this produces +! a velocity w(1) and temperature T(1) which vary with time. There is +! also a water load which will first saturate, then remainder go into +! QC(1). +! EFLUX = energy flux at ground,watt/m**2 for the last DT +! +!use module_zero_plumegen_coms +implicit none +type(plumegen_coms), pointer :: coms +real(kind=kind_phys), parameter :: g = 9.80796, r = 287.04, cp = 1004.6, eps = 0.622,tmelt = 273.3 +real(kind=kind_phys), parameter :: tfreeze = 269.3, pi = 3.14159, e1 = 1./3., e2 = 5./3. +real(kind=kind_phys) :: es, esat, eflux, water, pres, c1, c2, f, zv, denscor, xwater !,ESAT_PR +! real(kind=kind_phys), external:: esat_pr! + +! +COMS%QH (1) = COMS%QH (2) !soak up hydrometeors +COMS%QI (1) = COMS%QI (2) +COMS%QC (1) = 0. !no cloud here +! +! + CALL BURN (COMS, EFLUX, WATER) +! +! calculate parameters at boundary from a virtual buoyancy point source +! + PRES = COMS%PE (1) * 1000. !need pressure in N/m**2 + + C1 = 5. / (6. * COMS%ALPHA) !alpha is entrainment constant + + C2 = 0.9 * COMS%ALPHA + + F = EFLUX / (PRES * CP * PI) + + F = G * R * F * COMS%AREA !buoyancy flux + + ZV = C1 * COMS%RSURF !virtual boundary height + + COMS%W (1) = C1 * ( (C2 * F) **E1) / ZV**E1 !boundary velocity + + DENSCOR = C1 * F / G / (C2 * F) **E1 / ZV**E2 !density correction + + COMS%T (1) = COMS%TE (1) / (1. - DENSCOR) !temperature of virtual plume at zsurf + +! + COMS%WC(1) = COMS%W(1) + COMS%VEL_P(1) = 0. + coms%rad_p(1) = coms%rsurf + + !COMS%SC(1) = COMS%SCE(1)+F/1000.*coms%dt ! gas/particle (g/g) + +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! match dw/dz,dt/dz at the boundary. F is conserved. +! + !COMS%WBAR = COMS%W (1) * (1. - 1. / (6. * ZV) ) + !COMS%ADVW = COMS%WBAR * COMS%W (1) / (3. * ZV) + !COMS%ADVT = COMS%WBAR * (5. / (3. * ZV) ) * (DENSCOR / (1. - DENSCOR) ) + !COMS%ADVC = 0. + !COMS%ADVH = 0. + !COMS%ADVI = 0. + !COMS%ADIABAT = - COMS%WBAR * G / CP + COMS%VTH (1) = - 4. + COMS%VTI (1) = - 3. + COMS%TXS (1) = COMS%T (1) - COMS%TE (1) + + COMS%VISC (1) = COMS%VISCOSITY + +!sam if(.not.coms%pe(1)>0 .or. .not. coms%T(1)>200) then +!sam 1306 format('(1306) bad input to rho at 1=',I0,' with pe=',F12.5,' T=',F12.5) +!sam write(0,1306) 1,coms%PE(1),coms%T(1) +!sam endif + COMS%RHO (1) = 3483.8 * COMS%PE (1) / COMS%T (1) !air density at level 1, g/m**3 + + XWATER = WATER / max(1e-20, COMS%W (1) * COMS%DT * COMS%RHO (1) ) !firewater mixing ratio + + COMS%QV (1) = XWATER + COMS%QVENV (1) !plus what's already there + + +! COMS%PE esta em kPa - ESAT do RAMS esta em mbar = 100 Pa = 0.1 kPa +! ES = 0.1*ESAT (COMS%T(1)) !blob saturation vapor pressure, em kPa +! rotina do plumegen ja calcula em kPa + ES = ESAT_PR (COMS%T(1)) !blob saturation vapor pressure, em kPa + + COMS%EST (1) = ES + COMS%QSAT (1) = (EPS * ES) / max(1e-20, COMS%PE (1) - ES) !blob saturation lwc g/g dry air + + IF (COMS%QV (1) .gt. COMS%QSAT (1) ) THEN + COMS%QC (1) = COMS%QV (1) - COMS%QSAT (1) + COMS%QC (1) !remainder goes into cloud drops + COMS%QV (1) = COMS%QSAT (1) + ENDIF +! + CALL WATERBAL (COMS) +! +RETURN +END SUBROUTINE LBOUND +!------------------------------------------------------------------------------- +! +SUBROUTINE INITIAL (coms,kmt) +! +! ************* SETS UP INITIAL CONDITIONS FOR THE PROBLEM ************ +!use module_zero_plumegen_coms +implicit none +type(plumegen_coms), pointer :: coms +real(kind=kind_phys), parameter :: tfreeze = 269.3 +integer :: isub, k, n1, n2, n3, lbuoy, itmp, isubm1 ,kmt +real(kind=kind_phys) :: xn1, xi, es, esat!,ESAT_PR +! +COMS%N=kmt +! initialize temperature structure,to the end of equal spaced sounding, + do k = 1, COMS%N + COMS%TXS (k) = 0.0 + COMS%W (k) = 0.0 + COMS%T (k) = COMS%TE(k) !blob set to environment + COMS%WC(k) = 0.0 + COMS%WT(k) = 0.0 + COMS%QV(k) = COMS%QVENV (k) !blob set to environment + COMS%VTH(k) = 0. !initial rain velocity = 0 + COMS%VTI(k) = 0. !initial ice velocity = 0 + COMS%QH(k) = 0. !no rain + COMS%QI(k) = 0. !no ice + COMS%QC(k) = 0. !no cloud drops +! COMS%PE esta em kPa - ESAT do RAMS esta em mbar = 100 Pa = 0.1 kPa +! ES = 0.1*ESAT (COMS%T(k)) !blob saturation vapor pressure, em kPa +! rotina do plumegen calcula em kPa + ES = ESAT_PR (COMS%T(k)) !blob saturation vapor pressure, em kPa + COMS%EST (k) = ES + COMS%QSAT (k) = (.622 * ES) / (COMS%PE (k) - ES) !saturation lwc g/g +!sam if(.not.coms%pe(k)>0 .or. .not. coms%T(k)>200) then +!sam 1307 format('(1307) bad input to rho at k=',I0,' with pe=',F12.5,' T=',F12.5) +!sam write(0,1307) k,coms%PE(k),coms%T(k) +!sam endif + COMS%RHO (k) = 3483.8 * COMS%PE (k) / COMS%T (k) !dry air density g/m**3 + COMS%VEL_P(k) = 0. + coms%rad_p(k) = 0. + enddo + +! Initialize the entrainment radius, Turner-style plume + coms%radius(1) = coms%rsurf + do k=2,COMS%N + coms%radius(k) = coms%radius(k-1)+(6./5.)*coms%alpha*(coms%zt(k)-coms%zt(k-1)) + enddo +! Initialize the entrainment radius, Turner-style plume + coms%radius(1) = coms%rsurf + coms%rad_p(1) = coms%rsurf + DO k=2,COMS%N + coms%radius(k) = coms%radius(k-1)+(6./5.)*coms%alpha*(coms%zt(k)-coms%zt(k-1)) + coms%rad_p(k) = coms%radius(k) + ENDDO + +! Initialize the viscosity + COMS%VISC (1) = COMS%VISCOSITY + do k=2,COMS%N + !COMS%VISC (k) = COMS%VISCOSITY!max(1.e-3,coms%visc(k-1) - 1.* COMS%VISCOSITY/float(nkp)) + COMS%VISC (k) = max(1.e-3,coms%visc(k-1) - 1.* COMS%VISCOSITY/float(nkp)) + enddo +!-- Initialize gas/concentration + !DO k =10,20 + ! COMS%SC(k) = 20. + !ENDDO + !stop 333 + + CALL LBOUND(COMS) + +RETURN +END SUBROUTINE INITIAL +!------------------------------------------------------------------------------- +! +subroutine damp_grav_wave(ifrom,nm1,deltak,dt,zt,zm,w,t,tt,qv,qh,qi,qc,te,pe,qvenv) +implicit none +integer nm1,ifrom,deltak +real(kind=kind_phys) dt +real(kind=kind_phys), dimension(nm1) :: w,t,tt,qv,qh,qi,qc,te,pe,qvenv,dummy,zt,zm + +if(ifrom==1) then + call friction(ifrom,nm1,deltak,dt,zt,zm,t,tt ,te) +!call friction(ifrom,nm1,dt,zt,zm,qv,coms%qvt,qvenv) + return +endif + +dummy(:) = 0. +if(ifrom==2) call friction(ifrom,nm1,deltak,dt,zt,zm,w,dummy ,dummy) +!call friction(ifrom,nm1,dt,zt,zm,qi,coms%qit ,dummy) +!call friction(ifrom,nm1,dt,zt,zm,qh,coms%qht ,dummy) +!call friction(ifrom,nm1,dt,zt,zm,qc,coms%qct ,dummy) +return +end subroutine damp_grav_wave +!------------------------------------------------------------------------------- +! +subroutine friction(ifrom,nm1,deltak,dt,zt,zm,var1,vart,var2) +implicit none +real(kind=kind_phys), dimension(nm1) :: var1,var2,vart,zt,zm +integer k,nfpt,kf,nm1,ifrom,deltak +real(kind=kind_phys) zmkf,ztop,distim,c1,c2,dt + +!nfpt=50 +!kf = nm1 - nfpt +!kf = nm1 - int(deltak/2) + kf = nm1 - int(deltak) + +zmkf = zm(kf) !old: float(kf )*coms%dz +ztop = zm(nm1) +!distim = min(4.*dt,200.) +!distim = 60. + distim = min(3.*dt,60.) + +c1 = 1. / (distim * (ztop - zmkf)) +c2 = dt * c1 + +if(ifrom == 1) then + do k = nm1,2,-1 + if (zt(k) .le. zmkf) cycle + vart(k) = vart(k) + c1 * (zt(k) - zmkf)*(var2(k) - var1(k)) + enddo +elseif(ifrom == 2) then + do k = nm1,2,-1 + if (zt(k) .le. zmkf) cycle + var1(k) = var1(k) + c2 * (zt(k) - zmkf)*(var2(k) - var1(k)) + enddo +endif +return +end subroutine friction +!------------------------------------------------------------------------------- +! +subroutine vel_advectc_plumerise(m1,wc,wt,rho,dzm) + +implicit none +integer :: k,m1 +real(kind=kind_phys), dimension(m1) :: wc,wt,flxw,dzm,rho +real(kind=kind_phys), dimension(m1) :: dn0 ! var local +real(kind=kind_phys) :: c1z + +!dzm(:)= 1./coms%dz + +dn0(1:m1)=rho(1:m1)*1.e-3 ! converte de cgs para mks + +flxw(1) = wc(1) * dn0(1) + +do k = 2,m1-1 + flxw(k) = wc(k) * .5 * (dn0(k) + dn0(k+1)) +enddo + +! Compute advection contribution to W tendency + +c1z = .5 + +do k = 2,m1-2 + + wt(k) = wt(k) & + + c1z * dzm(k) / (dn0(k) + dn0(k+1)) * ( & + (flxw(k) + flxw(k-1)) * (wc(k) + wc(k-1)) & + - (flxw(k) + flxw(k+1)) * (wc(k) + wc(k+1)) & + + (flxw(k+1) - flxw(k-1)) * 2.* wc(k) ) + +enddo + +return +end subroutine vel_advectc_plumerise +!------------------------------------------------------------------------------- +! +subroutine hadvance_plumerise(iac,m1,dt,wc,wt,wp,mintime) + +implicit none +integer :: k,iac +integer :: m1,mintime +real(kind=kind_phys), dimension(m1) :: dummy, wc,wt,wp +real(kind=kind_phys) eps,dt +! It is here that the Asselin filter is applied. For the velocities +! and pressure, this must be done in two stages, the first when +! IAC=1 and the second when IAC=2. + + +eps = .2 +if(mintime == 1) eps=0.5 + +! For both IAC=1 and IAC=2, call PREDICT for U, V, W, and P. +! +call predict_plumerise(m1,wc,wp,wt,dummy,iac,2.*dt,eps) +!print*,'mintime',mintime,eps +!do k=1,m1 +! print*,'W-HAD',k,wc(k),wp(k),wt(k) +!enddo +return +end subroutine hadvance_plumerise +!------------------------------------------------------------------------------- +! +subroutine predict_plumerise(npts,ac,ap,fa,af,iac,dtlp,epsu) +implicit none +integer :: npts,iac,m +real(kind=kind_phys) :: epsu,dtlp +real(kind=kind_phys), dimension(*) :: ac,ap,fa,af + +! For IAC=3, this routine moves the arrays AC and AP forward by +! 1 time level by adding in the prescribed tendency. It also +! applies the Asselin filter given by: + +! {AC} = AC + EPS * (AP - 2 * AC + AF) + +! where AP,AC,AF are the past, current and future time levels of A. +! All IAC=1 does is to perform the {AC} calculation without the AF +! term present. IAC=2 completes the calculation of {AC} by adding +! the AF term only, and advances AC by filling it with input AP +! values which were already updated in ACOUSTC. +! + +if (iac .eq. 1) then + do m = 1,npts + ac(m) = ac(m) + epsu * (ap(m) - 2. * ac(m)) + enddo + return +elseif (iac .eq. 2) then + do m = 1,npts + af(m) = ap(m) + ap(m) = ac(m) + epsu * af(m) + enddo +!elseif (iac .eq. 3) then +! do m = 1,npts +! af(m) = ap(m) + dtlp * fa(m) +! enddo +! if (ngrid .eq. 1 .and. ipara .eq. 0) call cyclic(nzp,nxp,nyp,af,'T') +! do m = 1,npts +! ap(m) = ac(m) + epsu * (ap(m) - 2. * ac(m) + af(m)) +! enddo +endif + +do m = 1,npts + ac(m) = af(m) +enddo +return +end subroutine predict_plumerise +!------------------------------------------------------------------------------- +! +subroutine buoyancy_plumerise(m1, T, TE, QV, QVENV, QH, QI, QC, WT, scr1) +implicit none +integer :: k,m1 +real(kind=kind_phys), parameter :: g = 9.8, eps = 0.622, gama = 0.5 ! mass virtual coeff. +real(kind=kind_phys), dimension(m1) :: T, TE, QV, QVENV, QH, QI, QC, WT, scr1 +real(kind=kind_phys) :: TV,TVE,QWTOTL,umgamai +real(kind=kind_phys), parameter :: mu = 0.15 + +!- orig +umgamai = 1./(1.+gama) ! compensa a falta do termo de aceleracao associado `as + ! das pertubacoes nao-hidrostaticas no campo de pressao + +!- new ! Siesbema et al, 2004 +!umgamai = 1./(1.-2.*mu) + +do k = 2,m1-1 + + TV = T(k) * (1. + (QV(k) /EPS))/(1. + QV(k) ) !blob virtual temp. + TVE = TE(k) * (1. + (QVENV(k)/EPS))/(1. + QVENV(k)) !and environment + + QWTOTL = QH(k) + QI(k) + QC(k) ! QWTOTL*G is drag +!- orig + !scr1(k)= G*( umgamai*( TV - TVE) / TVE - QWTOTL) + scr1(k)= G* umgamai*( (TV - TVE) / TVE - QWTOTL) + + !if(k .lt. 10)print*,'BT',k,TV,TVE,TVE,QWTOTL +enddo + +do k = 2,m1-2 + wt(k) = wt(k)+0.5*(scr1(k)+scr1(k+1)) +! print*,'W-BUO',k,wt(k),scr1(k),scr1(k+1) +enddo + +end subroutine buoyancy_plumerise +!------------------------------------------------------------------------------- +! +subroutine ENTRAINMENT(coms,m1,w,wt,radius,ALPHA) +implicit none +type(plumegen_coms), pointer :: coms +integer :: k,m1 +real(kind=kind_phys), dimension(m1) :: w,wt,radius +REAL(kind=kind_phys) DMDTM,WBAR,RADIUS_BAR,umgamai,DYN_ENTR,ALPHA +real(kind=kind_phys), parameter :: mu = 0.15 ,gama = 0.5 ! mass virtual coeff. + +!- new - Siesbema et al, 2004 +!umgamai = 1./(1.-2.*mu) + +!- orig +!umgamai = 1 +umgamai = 1./(1.+gama) ! compensa a falta do termo de aceleracao associado `as + ! das pertubacoes nao-hidrostaticas no campo de pressao + +! +!-- ALPHA/RADIUS(COMS%L) = (1/M)DM/COMS%DZ (W 14a) + do k=2,m1-1 + +!-- for W: WBAR is only W(k) +! WBAR=0.5*(W(k)+W(k-1)) + WBAR=W(k) + RADIUS_BAR = 0.5*(RADIUS(k) + RADIUS(k-1)) +! orig + !DMDTM = 2. * ALPHA * ABS (WBAR) / RADIUS_BAR != (1/M)DM/COMS%DT + DMDTM = umgamai * 2. * ALPHA * ABS (WBAR) / RADIUS_BAR != (1/M)DM/COMS%DT + +!-- DMDTM*W(COMS%L) entrainment, + wt(k) = wt(k) - DMDTM*ABS (WBAR) + !print*,'W-ENTR=',k,w(k),- DMDTM*ABS (WBAR) + + !if(COMS%VEL_P (k) - COMS%VEL_E (k) > 0.) cycle + + !- dynamic entrainment + DYN_ENTR = (2./3.1416)*0.5*ABS (COMS%VEL_P(k)-COMS%VEL_E(k)+COMS%VEL_P(k-1)-COMS%VEL_E(k-1)) /RADIUS_BAR + + wt(k) = wt(k) - DYN_ENTR*ABS (WBAR) + + !- entraiment acceleration for output only + !dwdt_entr(k) = - DMDTM*ABS (WBAR)- DYN_ENTR*ABS (WBAR) + enddo +end subroutine ENTRAINMENT +!------------------------------------------------------------------------------- +! +subroutine scl_advectc_plumerise(coms,varn,mzp) +!use module_zero_plumegen_coms +implicit none +type(plumegen_coms), pointer :: coms +integer :: mzp +character(len=*) :: varn +real(kind=kind_phys) :: dtlto2 +integer :: k + +! wp => w +!- Advect scalars + dtlto2 = .5 * coms%dt +! coms%vt3dc(1) = (coms%w(1) + coms%wc(1)) * dtlto2 * coms%dne(1) + coms%vt3dc(1) = (coms%w(1) + coms%wc(1)) * dtlto2 * coms%rho(1)*1.e-3!converte de CGS p/ MKS + coms%vt3df(1) = .5 * (coms%w(1) + coms%wc(1)) * dtlto2 * coms%dzm(1) + + do k = 2,mzp +! coms%vt3dc(k) = (coms%w(k) + coms%wc(k)) * dtlto2 *.5 * (coms%dne(k) + coms%dne(k+1)) + coms%vt3dc(k) = (coms%w(k) + coms%wc(k)) * dtlto2 *.5 * (coms%rho(k) + coms%rho(k+1))*1.e-3 + coms%vt3df(k) = (coms%w(k) + coms%wc(k)) * dtlto2 *.5 * coms%dzm(k) + !print*,'coms%vt3df-coms%vt3dc',k,coms%vt3dc(k),coms%vt3df(k) + enddo + + +!-srf-24082005 +! do k = 1,mzp-1 + do k = 1,mzp + coms%vctr1(k) = (coms%zt(k+1) - coms%zm(k)) * coms%dzm(k) + coms%vctr2(k) = (coms%zm(k) - coms%zt(k)) * coms%dzm(k) +! coms%vt3dk(k) = coms%dzt(k) / coms%dne(k) + coms%vt3dk(k) = coms%dzt(k) /(coms%rho(k)*1.e-3) + !print*,'Coms%Vt3dk',k,coms%dzt(k) , coms%dne(k) + enddo + +! scalarp => scalar_tab(coms%n,ngrid)%var_p +! scalart => scalar_tab(coms%n,ngrid)%var_t + +!- temp advection tendency (COMS%TT) + coms%scr1=COMS%T + call fa_zc_plumerise(mzp & + ,COMS%T ,coms%scr1 (1) & + ,coms%vt3dc (1) ,coms%vt3df (1) & + ,coms%vt3dg (1) ,coms%vt3dk (1) & + ,coms%vctr1,coms%vctr2 ) + + call advtndc_plumerise(mzp,COMS%T,coms%scr1(1),COMS%TT,coms%dt) + +!- water vapor advection tendency (COMS%QVT) + coms%scr1=COMS%QV + call fa_zc_plumerise(mzp & + ,COMS%QV ,coms%scr1 (1) & + ,coms%vt3dc (1) ,coms%vt3df (1) & + ,coms%vt3dg (1) ,coms%vt3dk (1) & + ,coms%vctr1,coms%vctr2 ) + + call advtndc_plumerise(mzp,COMS%QV,coms%scr1(1),COMS%QVT,coms%dt) + +!- liquid advection tendency (COMS%QCT) + coms%scr1=COMS%QC + call fa_zc_plumerise(mzp & + ,COMS%QC ,coms%scr1 (1) & + ,coms%vt3dc (1) ,coms%vt3df (1) & + ,coms%vt3dg (1) ,coms%vt3dk (1) & + ,coms%vctr1,coms%vctr2 ) + + call advtndc_plumerise(mzp,COMS%QC,coms%scr1(1),COMS%QCT,coms%dt) + +!- ice advection tendency (COMS%QIT) + coms%scr1=COMS%QI + call fa_zc_plumerise(mzp & + ,COMS%QI ,coms%scr1 (1) & + ,coms%vt3dc (1) ,coms%vt3df (1) & + ,coms%vt3dg (1) ,coms%vt3dk (1) & + ,coms%vctr1,coms%vctr2 ) + + call advtndc_plumerise(mzp,COMS%QI,coms%scr1(1),COMS%QIT,coms%dt) + +!- hail/rain advection tendency (COMS%QHT) +! if(ak1 > 0. .or. ak2 > 0.) then + + coms%scr1=COMS%QH + call fa_zc_plumerise(mzp & + ,COMS%QH ,coms%scr1 (1) & + ,coms%vt3dc (1) ,coms%vt3df (1) & + ,coms%vt3dg (1) ,coms%vt3dk (1) & + ,coms%vctr1,coms%vctr2 ) + + call advtndc_plumerise(mzp,COMS%QH,coms%scr1(1),COMS%QHT,coms%dt) +! endif + !- horizontal wind advection tendency (COMS%VEL_T) + coms%scr1=COMS%VEL_P + call fa_zc_plumerise(mzp & + ,COMS%VEL_P ,coms%scr1 (1) & + ,coms%vt3dc (1) ,coms%vt3df (1) & + ,coms%vt3dg (1) ,coms%vt3dk (1) & + ,coms%vctr1,coms%vctr2 ) + + call advtndc_plumerise(mzp,COMS%VEL_P,coms%scr1(1),COMS%VEL_T,coms%dt) + + !- vertical radius transport + + coms%scr1=coms%rad_p + call fa_zc_plumerise(mzp & + ,coms%rad_p ,coms%scr1 (1) & + ,coms%vt3dc (1) ,coms%vt3df (1) & + ,coms%vt3dg (1) ,coms%vt3dk (1) & + ,coms%vctr1,coms%vctr2 ) + + call advtndc_plumerise(mzp,coms%rad_p,coms%scr1(1),coms%rad_t,coms%dt) + + + return +! +!- gas/particle advection tendency (COMS%SCT) +! if(varn == 'SC')return + coms%scr1=COMS%SC + call fa_zc_plumerise(mzp & + ,COMS%SC ,coms%scr1 (1) & + ,coms%vt3dc (1) ,coms%vt3df (1) & + ,coms%vt3dg (1) ,coms%vt3dk (1) & + ,coms%vctr1,coms%vctr2 ) + + call advtndc_plumerise(mzp,COMS%SC,coms%scr1(1),COMS%SCT,coms%dt) + + +return +end subroutine scl_advectc_plumerise +!------------------------------------------------------------------------------- +! +subroutine fa_zc_plumerise(m1,scp,scr1,vt3dc,vt3df,vt3dg,vt3dk,vctr1,vctr2) + +implicit none +integer :: m1,k +real(kind=kind_phys) :: dfact +real(kind=kind_phys), dimension(m1) :: scp,scr1,vt3dc,vt3df,vt3dg,vt3dk +real(kind=kind_phys), dimension(m1) :: vctr1,vctr2 + +dfact = .5 + +! Compute scalar flux VT3DG + do k = 1,m1-1 + vt3dg(k) = vt3dc(k) & + * (vctr1(k) * scr1(k) & + + vctr2(k) * scr1(k+1) & + + vt3df(k) * (scr1(k) - scr1(k+1))) + enddo + +! Modify fluxes to retain positive-definiteness on scalar quantities. +! If a flux will remove 1/2 quantity during a timestep, +! reduce to first order flux. This will remain positive-definite +! under the assumption that ABS(CFL(i)) + ABS(CFL(i-1)) < 1.0 if +! both fluxes are evacuating the box. + +do k = 1,m1-1 + if (vt3dc(k) .gt. 0.) then + if (vt3dg(k) * vt3dk(k) .gt. dfact * scr1(k)) then + vt3dg(k) = vt3dc(k) * scr1(k) + endif + elseif (vt3dc(k) .lt. 0.) then + if (-vt3dg(k) * vt3dk(k+1) .gt. dfact * scr1(k+1)) then + vt3dg(k) = vt3dc(k) * scr1(k+1) + endif + endif + +enddo + +! Compute flux divergence +do k = 2,m1-1 + scr1(k) = scr1(k) & + + vt3dk(k) * ( vt3dg(k-1) - vt3dg(k) & + + scp (k) * ( vt3dc(k) - vt3dc(k-1))) +enddo +return +end subroutine fa_zc_plumerise +!------------------------------------------------------------------------------- +! +subroutine advtndc_plumerise(m1,scp,sca,sct,dtl) +implicit none +integer :: m1,k +real(kind=kind_phys) :: dtl,dtli +real(kind=kind_phys), dimension(m1) :: scp,sca,sct + +dtli = 1. / dtl +do k = 2,m1-1 + sct(k) = sct(k) + (sca(k)-scp(k)) * dtli +enddo +return +end subroutine advtndc_plumerise +!------------------------------------------------------------------------------- +! +subroutine tend0_plumerise(coms) +implicit none +type(plumegen_coms), pointer :: coms + coms%wt(1:coms%nm1) = 0. + coms%tt(1:coms%nm1) = 0. +coms%qvt(1:coms%nm1) = 0. +coms%qct(1:coms%nm1) = 0. +coms%qht(1:coms%nm1) = 0. +coms%qit(1:coms%nm1) = 0. +coms%vel_t(1:coms%nm1) = 0. +coms%rad_t(1:coms%nm1) = 0. +!coms%sct(1:coms%nm1) = 0. +end subroutine tend0_plumerise + +! **************************************************************** + +subroutine scl_misc(coms,m1) +!use module_zero_plumegen_coms +implicit none +type(plumegen_coms), pointer :: coms +real(kind=kind_phys), parameter :: g = 9.81, cp=1004. +integer m1,k +real(kind=kind_phys) dmdtm + + do k=2,m1-1 + COMS%WBAR = 0.5*(COMS%W(k)+COMS%W(k-1)) +!-- dry adiabat + COMS%ADIABAT = - COMS%WBAR * G / CP +! +!-- entrainment + DMDTM = 2. * COMS%ALPHA * ABS (COMS%WBAR) / COMS%RADIUS (k) != (1/M)DM/COMS%DT + +!-- tendency temperature = adv + adiab + entrainment + COMS%TT(k) = COMS%TT(K) + COMS%ADIABAT - DMDTM * ( COMS%T (k) - COMS%TE (k) ) + +!-- tendency water vapor = adv + entrainment + COMS%QVT(K) = COMS%QVT(K) - DMDTM * ( COMS%QV (k) - COMS%QVENV (k) ) + + COMS%QCT(K) = COMS%QCT(K) - DMDTM * ( COMS%QC (k) ) + COMS%QHT(K) = COMS%QHT(K) - DMDTM * ( COMS%QH (k) ) + COMS%QIT(K) = COMS%QIT(K) - DMDTM * ( COMS%QI (k) ) + + !-- tendency horizontal speed = adv + entrainment + COMS%VEL_T(K) = COMS%VEL_T(K) - DMDTM * ( COMS%VEL_P (k) - COMS%VEL_E (k) ) + + !-- tendency horizontal speed = adv + entrainment + coms%rad_t(K) = coms%rad_t(K) + 0.5*DMDTM*(6./5.)*COMS%RADIUS (k) +!-- tendency gas/particle = adv + entrainment +! COMS%SCT(K) = COMS%SCT(K) - DMDTM * ( COMS%SC (k) - COMS%SCE (k) ) + +enddo +end subroutine scl_misc +! **************************************************************** + + SUBROUTINE scl_dyn_entrain(m1,nkp,wbar,w,adiabat,alpha,radius,tt,t,te,qvt,qv,qvenv,qct,qc,qht,qh,qit,qi,& + vel_e,vel_p,vel_t,rad_p,rad_t) + implicit none + + INTEGER , INTENT(IN) :: m1 + + ! plumegen_coms + INTEGER , INTENT(IN) :: nkp + REAL(kind=kind_phys) , INTENT(INOUT) :: wbar + REAL(kind=kind_phys) , INTENT(IN) :: w(nkp) + REAL(kind=kind_phys) , INTENT(INOUT) :: adiabat + REAL(kind=kind_phys) , INTENT(IN) :: alpha + REAL(kind=kind_phys) , INTENT(IN) :: radius(nkp) + REAL(kind=kind_phys) , INTENT(INOUT) :: tt(nkp) + REAL(kind=kind_phys) , INTENT(IN) :: t(nkp) + REAL(kind=kind_phys) , INTENT(IN) :: te(nkp) + REAL(kind=kind_phys) , INTENT(INOUT) :: qvt(nkp) + REAL(kind=kind_phys) , INTENT(IN) :: qv(nkp) + REAL(kind=kind_phys) , INTENT(IN) :: qvenv(nkp) + REAL(kind=kind_phys) , INTENT(INOUT) :: qct(nkp) + REAL(kind=kind_phys) , INTENT(IN) :: qc(nkp) + REAL(kind=kind_phys) , INTENT(INOUT) :: qht(nkp) + REAL(kind=kind_phys) , INTENT(IN) :: qh(nkp) + REAL(kind=kind_phys) , INTENT(INOUT) :: qit(nkp) + REAL(kind=kind_phys) , INTENT(IN) :: qi(nkp) + + REAL(kind=kind_phys) , INTENT(IN) :: vel_e(nkp) + REAL(kind=kind_phys) , INTENT(IN) :: vel_p(nkp) + REAL(kind=kind_phys) , INTENT(INOUT) :: vel_t(nkp) + REAL(kind=kind_phys) , INTENT(INOUT) :: rad_T(nkp) + REAL(kind=kind_phys) , INTENT(IN) :: rad_p(nkp) + + real(kind=kind_phys), parameter :: g = 9.81, cp=1004., pi=3.1416 + + integer k + real(kind=kind_phys) dmdtm + + DO k=2,m1-1 + ! + !-- tendency horizontal radius from dyn entrainment + !rad_t(K) = rad_t(K) + (vel_e(k)-vel_p(k)) /pi + rad_t(K) = rad_t(K) + ABS((vel_e(k)-vel_p(k)))/pi + + !-- entrainment + !DMDTM = (2./3.1416) * (VEL_E (k) - VEL_P (k)) / RADIUS (k) + DMDTM = (2./3.1416) * ABS(VEL_E (k) - VEL_P (k)) / RADIUS (k) + + !-- tendency horizontal speed from dyn entrainment + VEL_T(K) = VEL_T(K) - DMDTM * ( VEL_P (k) - VEL_E (k) ) + + ! if(VEL_P (k) - VEL_E (k) > 0.) cycle + + !-- tendency temperature from dyn entrainment + TT(k) = TT(K) - DMDTM * ( T (k) - TE (k) ) + + !-- tendency water vapor from dyn entrainment + QVT(K) = QVT(K) - DMDTM * ( QV (k) - QVENV (k) ) + + QCT(K) = QCT(K) - DMDTM * ( QC (k) ) + QHT(K) = QHT(K) - DMDTM * ( QH (k) ) + QIT(K) = QIT(K) - DMDTM * ( QI (k) ) + + !-- tendency gas/particle from dyn entrainment + ! COMS%SCT(K) = COMS%SCT(K) - DMDTM * ( SC (k) - COMS%SCE (k) ) + + ENDDO + END SUBROUTINE scl_dyn_entrain + +! **************************************************************** + +subroutine visc_W(coms,m1,deltak,kmt) +!use module_zero_plumegen_coms +implicit none +type(plumegen_coms), pointer :: coms +integer m1,k,deltak,kmt,m2 +real(kind=kind_phys) dz1t,dz1m,dz2t,dz2m,d2wdz,d2tdz ,d2qvdz ,d2qhdz ,d2qcdz ,d2qidz ,d2scdz, & + d2vel_pdz,d2rad_dz +!sam real(kind=kind_phys) :: old_tt +logical, save, volatile :: printed = .false. + + +!srf--- 17/08/2005 +!m2=min(m1+deltak,kmt) +m2=min(m1,kmt) + +!do k=2,m1-1 +do k=2,m2-1 + DZ1T = 0.5*(COMS%ZT(K+1)-COMS%ZT(K-1)) + DZ2T = COMS%VISC (k) / (DZ1T * DZ1T) + DZ1M = 0.5*(COMS%ZM(K+1)-COMS%ZM(K-1)) + DZ2M = COMS%VISC (k) / (DZ1M * DZ1M) + D2WDZ = (COMS%W (k + 1) - 2 * COMS%W (k) + COMS%W (k - 1) ) * DZ2M + D2TDZ = (COMS%T (k + 1) - 2 * COMS%T (k) + COMS%T (k - 1) ) * DZ2T + D2QVDZ = (COMS%QV (k + 1) - 2 * COMS%QV (k) + COMS%QV (k - 1) ) * DZ2T + D2QHDZ = (COMS%QH (k + 1) - 2 * COMS%QH (k) + COMS%QH (k - 1) ) * DZ2T + D2QCDZ = (COMS%QC (k + 1) - 2 * COMS%QC (k) + COMS%QC (k - 1) ) * DZ2T + D2QIDZ = (COMS%QI (k + 1) - 2 * COMS%QI (k) + COMS%QI (k - 1) ) * DZ2T + !D2SCDZ = (COMS%SC (k + 1) - 2 * COMS%SC (k) + COMS%SC (k - 1) ) * DZ2T + d2vel_pdz=(coms%vel_p (k + 1) - 2 * coms%vel_p (k) + coms%vel_p (k - 1) ) * DZ2T + d2rad_dz =(coms%rad_p (k + 1) - 2 * coms%rad_p (k) + coms%rad_p (k - 1) ) * DZ2T + + COMS%WT(k) = COMS%WT(k) + D2WDZ +!sam old_tt=coms%tt(k) + COMS%TT(k) = COMS%TT(k) + D2TDZ +!sam if(.not. coms%tt(k)>-10 .and. .not. printed) then +!sam 1924 format("(1924) visc_W Bad TT at k=",I0," TT=",F12.5," old_TT=",F12.5," d2tdz=",F12.5," visc=",F12.5) +!sam 1925 format("(1925) T = ",F12.5,",",F12.5,",",F12.5," ZT=",F12.5,",",F12.5) +!sam write(0,1924) k, COMS%TT(k), old_TT, d2tdz, coms%visc(k) +!sam write(0,1925) coms%T(k-1),coms%T(k),coms%T(k+1),coms%ZT(k-1),coms%ZT(k+1) +!sam printed = .true. +!sam endif + COMS%QVT(k) = COMS%QVT(k) + D2QVDZ + COMS%QCT(k) = COMS%QCT(k) + D2QCDZ + COMS%QHT(k) = COMS%QHT(k) + D2QHDZ + COMS%QIT(k) = COMS%QIT(k) + D2QIDZ + coms%vel_t(k) = coms%vel_t(k) + d2vel_pdz + coms%rad_t(k) = coms%rad_t(k) + d2rad_dz + !COMS%SCT(k) = COMS%SCT(k) + D2SCDZ + !print*,'W-COMS%VISC=',k,D2WDZ +enddo + +end subroutine visc_W + +! **************************************************************** + +subroutine update_plumerise(coms,m1,varn) +!use module_zero_plumegen_coms +implicit none +type(plumegen_coms), pointer :: coms +integer m1,k +character(len=*) :: varn +!sam real(kind_phys) :: old_t + +if(varn == 'W') then + + do k=2,m1-1 + COMS%W(k) = COMS%W(k) + COMS%WT(k) * COMS%DT + enddo + return + +else +do k=2,m1-1 +!sam old_t = coms%t(k) + COMS%T(k) = COMS%T(k) + COMS%TT(k) * COMS%DT +!sam if(.not. coms%t(k)>200) then +!sam 1921 format("(1921) update_plumerise Bad T at k=",I0," T=",F12.5," old_T=",F12.5," TT=",F12.5," DT=",F12.5) +!sam write(0,1921) k, COMS%T(k), old_T, coms%tt(k), coms%dt +!sam endif + + COMS%QV(k) = COMS%QV(k) + COMS%QVT(k) * COMS%DT + + COMS%QC(k) = COMS%QC(k) + COMS%QCT(k) * COMS%DT !cloud drops travel with air + COMS%QH(k) = COMS%QH(k) + COMS%QHT(k) * COMS%DT + COMS%QI(k) = COMS%QI(k) + COMS%QIT(k) * COMS%DT +! COMS%SC(k) = COMS%SC(k) + COMS%SCT(k) * COMS%DT + +!srf---18jun2005 + COMS%QV(k) = max(0., COMS%QV(k)) + COMS%QC(k) = max(0., COMS%QC(k)) + COMS%QH(k) = max(0., COMS%QH(k)) + COMS%QI(k) = max(0., COMS%QI(k)) + + COMS%VEL_P(k) = COMS%VEL_P(k) + COMS%VEL_T(k) * COMS%DT + coms%rad_p(k) = coms%rad_p(k) + coms%rad_t(k) * COMS%DT +! COMS%SC(k) = max(0., COMS%SC(k)) + + enddo +endif +end subroutine update_plumerise +!------------------------------------------------------------------------------- +! +subroutine fallpart(coms,m1) +!use module_zero_plumegen_coms +implicit none +type(plumegen_coms), pointer :: coms +integer m1,k +real(kind=kind_phys) vtc, dfhz,dfiz,dz1 +!srf================================== +! verificar se o gradiente esta correto +! +!srf================================== +! +! XNO=1.E7 [m**-4] median volume diameter raindrop,Kessler +! VC = 38.3/(XNO**.125), median volume fallspeed eqn., Kessler +! for ice, see (OT18), use F0=0.75 per argument there. coms%rho*q +! values are in g/m**3, velocities in m/s + +real(kind=kind_phys), PARAMETER :: VCONST = 5.107387, EPS = 0.622, F0 = 0.75 +real(kind=kind_phys), PARAMETER :: G = 9.81, CP = 1004. +! +do k=2,m1-1 +!sam if(.not. coms%rho(k)>1e-20) then +!sam 33 format('(33) Bad density at k=',I0,' rho=',F12.5,' T=',F12.5,' PE=',F12.5,' test=',I0) +!sam write(0,33) k,coms%rho(k),coms%T(k),coms%PE(k),coms%testval +!sam endif + VTC = VCONST * COMS%RHO (k) **.125 ! median volume fallspeed (KTable4) + +! hydrometeor assembly velocity calculations (K Table4) +! COMS%VTH(k)=-VTC*COMS%QH(k)**.125 !median volume fallspeed, water + COMS%VTH (k) = - 4. !small variation with coms%qh + + COMS%VHREL = COMS%W (k) + COMS%VTH (k) !relative to surrounding cloud + +! rain ventilation coefficient for evaporation + COMS%CVH(k) = 1.6 + 0.57E-3 * (ABS (COMS%VHREL) ) **1.5 +! +! COMS%VTI(k)=-VTC*F0*COMS%QI(k)**.125 !median volume fallspeed,ice + COMS%VTI (k) = - 3. !small variation with coms%qi + + COMS%VIREL = COMS%W (k) + COMS%VTI (k) !relative to surrounding cloud +! +! ice ventilation coefficient for sublimation + COMS%CVI(k) = 1.6 + 0.57E-3 * (ABS (COMS%VIREL) ) **1.5 / F0 +! +! + IF (COMS%VHREL.GE.0.0) THEN + DFHZ=COMS%QH(k)*(COMS%RHO(k )*COMS%VTH(k )-COMS%RHO(k-1)*COMS%VTH(k-1))/COMS%RHO(k-1) + ELSE + DFHZ=COMS%QH(k)*(COMS%RHO(k+1)*COMS%VTH(k+1)-COMS%RHO(k )*COMS%VTH(k ))/COMS%RHO(k) + ENDIF + ! + ! + IF (COMS%VIREL.GE.0.0) THEN + DFIZ=COMS%QI(k)*(COMS%RHO(k )*COMS%VTI(k )-COMS%RHO(k-1)*COMS%VTI(k-1))/COMS%RHO(k-1) + ELSE + DFIZ=COMS%QI(k)*(COMS%RHO(k+1)*COMS%VTI(k+1)-COMS%RHO(k )*COMS%VTI(k ))/COMS%RHO(k) + ENDIF + + DZ1=COMS%ZM(K)-COMS%ZM(K-1) + + coms%qht(k) = coms%qht(k) - DFHZ / DZ1 !hydrometeors don't + coms%qit(k) = coms%qit(k) - DFIZ / DZ1 !nor does ice? hail, what about + +enddo +end subroutine fallpart + +! ********************************************************************* +SUBROUTINE WATERBAL(coms) +implicit none +type(plumegen_coms), pointer :: coms + +!use module_zero_plumegen_coms +! + +IF (COMS%QC (COMS%L) .LE.1.0E-10) COMS%QC (COMS%L) = 0. !DEFEAT UNDERFLOW PROBLEM +IF (COMS%QH (COMS%L) .LE.1.0E-10) COMS%QH (COMS%L) = 0. +IF (COMS%QI (COMS%L) .LE.1.0E-10) COMS%QI (COMS%L) = 0. +! +CALL EVAPORATE(COMS) !vapor to cloud,cloud to vapor +! +CALL SUBLIMATE(COMS) !vapor to ice +! +CALL GLACIATE(COMS) !rain to ice + +CALL MELT(COMS) !ice to rain +! +!if(ak1 > 0. .or. ak2 > 0.) & +CALL CONVERT(COMS) !(auto)conversion and accretion +!CALL CONVERT2 () !(auto)conversion and accretion +! + +RETURN +END SUBROUTINE WATERBAL +! ********************************************************************* +SUBROUTINE EVAPORATE(coms) +! +!- evaporates cloud,rain and ice to saturation +! +!use module_zero_plumegen_coms +implicit none +type(plumegen_coms), pointer :: coms +! +! XNO=10.0E06 +! HERC = 1.93*1.E-6*XN035 !evaporation constant +! +real(kind=kind_phys), PARAMETER :: HERC = 5.44E-4, CP = 1.004, HEATCOND = 2.5E3 +real(kind=kind_phys), PARAMETER :: HEATSUBL = 2834., TMELT = 273., TFREEZE = 269.3 + +real(kind=kind_phys), PARAMETER :: FRC = HEATCOND / CP, SRC = HEATSUBL / CP + +real(kind=kind_phys) :: evhdt, evidt, evrate, evap, sd, quant, dividend, divisor, devidt + +! +! +SD = COMS%QSAT (COMS%L) - COMS%QV (COMS%L) !vapor deficit +IF (SD.EQ.0.0) RETURN +!IF (abs(SD).lt.1.e-7) RETURN + + +EVHDT = 0. +EVIDT = 0. +!evrate =0.; evap=0.; sd=0.0; quant=0.0; dividend=0.0; divisor=0.0; devidt=0.0 + +EVRATE = ABS (COMS%WBAR * COMS%DQSDZ) !evaporation rate (Kessler 8.32) +EVAP = EVRATE * COMS%DT !what we can get in DT + + +IF (SD.LE.0.0) THEN ! condense. SD is negative + + IF (EVAP.GE.ABS (SD) ) THEN !we get it all + + COMS%QC (COMS%L) = COMS%QC (COMS%L) - SD !deficit,remember? + COMS%QV (COMS%L) = COMS%QSAT(COMS%L) !set the vapor to saturation + COMS%T (COMS%L) = COMS%T (COMS%L) - SD * FRC !heat gained through condensation + !per gram of dry air + RETURN + + ELSE + + COMS%QC (COMS%L) = COMS%QC (COMS%L) + EVAP !get what we can in DT + COMS%QV (COMS%L) = COMS%QV (COMS%L) - EVAP !remove it from the vapor + COMS%T (COMS%L) = COMS%T (COMS%L) + EVAP * FRC !get some heat + + RETURN + + ENDIF +! +ELSE !SD is positive, need some water +! +! not saturated. saturate if possible. use everything in order +! cloud, rain, ice. SD is positive + + IF (EVAP.LE.COMS%QC (COMS%L) ) THEN !enough cloud to last DT +! + + IF (SD.LE.EVAP) THEN !enough time to saturate + + COMS%QC (COMS%L) = COMS%QC (COMS%L) - SD !remove cloud + COMS%QV (COMS%L) = COMS%QSAT (COMS%L) !saturate + COMS%T (COMS%L) = COMS%T (COMS%L) - SD * FRC !cool the parcel + RETURN !done +! + + ELSE !not enough time + + SD = SD-EVAP !use what there is + COMS%QV (COMS%L) = COMS%QV (COMS%L) + EVAP !add vapor + COMS%T (COMS%L) = COMS%T (COMS%L) - EVAP * FRC !lose heat + COMS%QC (COMS%L) = COMS%QC (COMS%L) - EVAP !lose cloud + !go on to rain. + ENDIF +! + ELSE !not enough cloud to last DT +! + IF (SD.LE.COMS%QC (COMS%L) ) THEN !but there is enough to sat + + COMS%QV (COMS%L) = COMS%QSAT (COMS%L) !use it + COMS%QC (COMS%L) = COMS%QC (COMS%L) - SD + COMS%T (COMS%L) = COMS%T (COMS%L) - SD * FRC + RETURN + + ELSE !not enough to sat + SD = SD-COMS%QC (COMS%L) + COMS%QV (COMS%L) = COMS%QV (COMS%L) + COMS%QC (COMS%L) + COMS%T (COMS%L) = COMS%T (COMS%L) - COMS%QC (COMS%L) * FRC + COMS%QC (COMS%L) = 0.0 !all gone + + ENDIF !on to rain + ENDIF !finished with cloud +! +! but still not saturated, so try to use some rain +! this is tricky, because we only have time DT to evaporate. if there +! is enough rain, we can evaporate it for dt. ice can also sublimate +! at the same time. there is a compromise here.....use rain first, then +! ice. saturation may not be possible in one DT time. +! rain evaporation rate (W12),(OT25),(K Table 4). evaporate rain first +! sd is still positive or we wouldn't be here. + + + IF (COMS%QH (COMS%L) > 1.E-10) THEN + +!srf-25082005 +! QUANT = ( COMS%QC (COMS%L) + COMS%QV (COMS%L) - COMS%QSAT (COMS%L) ) * COMS%RHO (COMS%L) !g/m**3 + QUANT = ( COMS%QSAT (COMS%L)- COMS%QC (COMS%L) - COMS%QV (COMS%L) ) * COMS%RHO (COMS%L) !g/m**3 +! + EVHDT = (COMS%DT * HERC * (QUANT) * (COMS%QH (COMS%L) * COMS%RHO (COMS%L) ) **.65) / COMS%RHO (COMS%L) +! rain evaporation in time DT + + IF (EVHDT.LE.COMS%QH (COMS%L) ) THEN !enough rain to last DT + + IF (SD.LE.EVHDT) THEN !enough time to saturate + COMS%QH (COMS%L) = COMS%QH (COMS%L) - SD !remove rain + COMS%QV (COMS%L) = COMS%QSAT (COMS%L) !saturate + COMS%T (COMS%L) = COMS%T (COMS%L) - SD * FRC !cool the parcel + + RETURN !done +! + ELSE !not enough time + SD = SD-EVHDT !use what there is + COMS%QV (COMS%L) = COMS%QV (COMS%L) + EVHDT !add vapor + COMS%T (COMS%L) = COMS%T (COMS%L) - EVHDT * FRC !lose heat + COMS%QH (COMS%L) = COMS%QH (COMS%L) - EVHDT !lose rain + + ENDIF !go on to ice. +! + ELSE !not enough rain to last DT +! + IF (SD.LE.COMS%QH (COMS%L) ) THEN !but there is enough to sat + COMS%QV (COMS%L) = COMS%QSAT (COMS%L) !use it + COMS%QH (COMS%L) = COMS%QH (COMS%L) - SD + COMS%T (COMS%L) = COMS%T (COMS%L) - SD * FRC + RETURN +! + ELSE !not enough to sat + SD = SD-COMS%QH (COMS%L) + COMS%QV (COMS%L) = COMS%QV (COMS%L) + COMS%QH (COMS%L) + COMS%T (COMS%L) = COMS%T (COMS%L) - COMS%QH (COMS%L) * FRC + COMS%QH (COMS%L) = 0.0 !all gone + + ENDIF !on to ice +! + + ENDIF !finished with rain +! +! +! now for ice +! equation from (OT); correction factors for units applied +! + ENDIF + IF (COMS%QI (COMS%L) .LE.1.E-10) RETURN !no ice there +! + DIVIDEND = ( (1.E6 / COMS%RHO (COMS%L) ) **0.475) * (SD / COMS%QSAT (COMS%L) & + - 1) * (COMS%QI (COMS%L) **0.525) * 1.13 + DIVISOR = 7.E5 + 4.1E6 / (10. * COMS%EST (COMS%L) ) + + DEVIDT = - COMS%CVI(COMS%L) * DIVIDEND / DIVISOR !rate of change + + EVIDT = DEVIDT * COMS%DT !what we could get +! +! logic here is identical to rain. could get fancy and make subroutine +! but duplication of code is easier. God bless the screen editor. +! + + IF (EVIDT.LE.COMS%QI (COMS%L) ) THEN !enough ice to last DT +! + + IF (SD.LE.EVIDT) THEN !enough time to saturate + COMS%QI (COMS%L) = COMS%QI (COMS%L) - SD !remove ice + COMS%QV (COMS%L) = COMS%QSAT (COMS%L) !saturate + COMS%T (COMS%L) = COMS%T (COMS%L) - SD * SRC !cool the parcel + + RETURN !done +! + + ELSE !not enough time + + SD = SD-EVIDT !use what there is + COMS%QV (COMS%L) = COMS%QV (COMS%L) + EVIDT !add vapor + COMS%T (COMS%L) = COMS%T (COMS%L) - EVIDT * SRC !lose heat + COMS%QI (COMS%L) = COMS%QI (COMS%L) - EVIDT !lose ice + + ENDIF !go on,unsatisfied +! + ELSE !not enough ice to last DT +! + IF (SD.LE.COMS%QI (COMS%L) ) THEN !but there is enough to sat + + COMS%QV (COMS%L) = COMS%QSAT (COMS%L) !use it + COMS%QI (COMS%L) = COMS%QI (COMS%L) - SD + COMS%T (COMS%L) = COMS%T (COMS%L) - SD * SRC + + RETURN +! + ELSE !not enough to sat + SD = SD-COMS%QI (COMS%L) + COMS%QV (COMS%L) = COMS%QV (COMS%L) + COMS%QI (COMS%L) + COMS%T (COMS%L) = COMS%T (COMS%L) - COMS%QI (COMS%L) * SRC + COMS%QI (COMS%L) = 0.0 !all gone + + ENDIF !on to better things + !finished with ice + ENDIF +! +ENDIF !finished with the SD decision +! +RETURN +! +END SUBROUTINE EVAPORATE +! +! ********************************************************************* +SUBROUTINE CONVERT (coms) +! +!- ACCRETION AND AUTOCONVERSION +! +implicit none +type(plumegen_coms), pointer :: coms + +!use module_zero_plumegen_coms +! +real(kind=kind_phys), PARAMETER :: AK1 = 0.001 !conversion rate constant +real(kind=kind_phys), PARAMETER :: AK2 = 0.0052 !collection (accretion) rate +real(kind=kind_phys), PARAMETER :: TH = 0.5 !Kessler threshold +integer, PARAMETER :: iconv = 1 !- Kessler conversion (=0) + +!real(kind=kind_phys), parameter :: ANBASE = 50.!*1.e+6 !Berry-number at cloud base #/m^3(maritime) + real(kind=kind_phys), parameter :: ANBASE =100000.!*1.e+6 !Berry-number at cloud base #/m^3(continental) +!real(kind=kind_phys), parameter :: BDISP = 0.366 !Berry--size dispersion (maritime) + real(kind=kind_phys), parameter :: BDISP = 0.146 !Berry--size dispersion (continental) +real(kind=kind_phys), parameter :: TFREEZE = 269.3 !ice formation temperature +! +real(kind=kind_phys) :: accrete, con, q, h, bc1, bc2, total + + +IF (COMS%T (COMS%L) .LE. TFREEZE) RETURN !process not allowed above ice +! +IF (COMS%QC (COMS%L) .EQ. 0. ) RETURN + +ACCRETE = 0. +CON = 0. +Q = COMS%RHO (COMS%L) * COMS%QC (COMS%L) +H = COMS%RHO (COMS%L) * COMS%QH (COMS%L) +! +! selection rules +! +! +IF (COMS%QH (COMS%L) .GT. 0. ) ACCRETE = AK2 * Q * (H**.875) !accretion, Kessler +! +IF (ICONV.NE.0) THEN !select Berry or Kessler +! +!old BC1 = 120. +!old BC2 = .0266 * ANBASE * 60. +!old CON = BDISP * Q * Q * Q / (BC1 * Q * BDISP + BC2) + + CON = Q*Q*Q*BDISP/(60.*(5.*Q*BDISP+0.0366*ANBASE)) +! +ELSE +! +! CON = AK1 * (Q - TH) !Kessler autoconversion rate +! +! IF (CON.LT.0.0) CON = 0.0 !havent reached threshold + + CON = max(0.,AK1 * (Q - TH)) ! versao otimizada +! +ENDIF +! +! +TOTAL = (CON + ACCRETE) * COMS%DT / COMS%RHO (COMS%L) + +! +IF (TOTAL.LT.COMS%QC (COMS%L) ) THEN +! + COMS%QC (COMS%L) = COMS%QC (COMS%L) - TOTAL + COMS%QH (COMS%L) = COMS%QH (COMS%L) + TOTAL !no phase change involved + RETURN +! +ELSE +! + COMS%QH (COMS%L) = COMS%QH (COMS%L) + COMS%QC (COMS%L) !uses all there is + COMS%QC (COMS%L) = 0.0 +! +ENDIF +! +RETURN +! +END SUBROUTINE CONVERT +! +!********************************************************************** +! +SUBROUTINE SUBLIMATE(coms) +! +implicit none +type(plumegen_coms), pointer :: coms + +! ********************* VAPOR TO ICE (USE EQUATION OT22)*************** +!use module_zero_plumegen_coms +! +real(kind=kind_phys), PARAMETER :: EPS = 0.622, HEATFUS = 334., HEATSUBL = 2834., CP = 1.004 +real(kind=kind_phys), PARAMETER :: SRC = HEATSUBL / CP, FRC = HEATFUS / CP, TMELT = 273.3 +real(kind=kind_phys), PARAMETER :: TFREEZE = 269.3 + +real(kind=kind_phys) ::dtsubh, dividend,divisor, subl +! +DTSUBH = 0. +! +!selection criteria for sublimation +IF (COMS%T (COMS%L) .GT. TFREEZE ) RETURN +IF (COMS%QV (COMS%L) .LE. COMS%QSAT (COMS%L) ) RETURN +! +! from (OT); correction factors for units applied +! + DIVIDEND = ( (1.E6 / COMS%RHO (COMS%L) ) **0.475) * (COMS%QV (COMS%L) / COMS%QSAT (COMS%L) & + - 1) * (COMS%QI (COMS%L) **0.525) * 1.13 + DIVISOR = 7.E5 + 4.1E6 / (10. * COMS%EST (COMS%L) ) +! + + DTSUBH = ABS (DIVIDEND / DIVISOR) !sublimation rate + SUBL = DTSUBH * COMS%DT !and amount possible +! +! again check the possibilities +! +IF (SUBL.LT.COMS%QV (COMS%L) ) THEN +! + COMS%QV (COMS%L) = COMS%QV (COMS%L) - SUBL !lose vapor + COMS%QI (COMS%L) = COMS%QI (COMS%L) + SUBL !gain ice + COMS%T (COMS%L) = COMS%T (COMS%L) + SUBL * SRC !energy change, warms air + + RETURN +! +ELSE +! + COMS%QI (COMS%L) = COMS%QV (COMS%L) !use what there is + COMS%T (COMS%L) = COMS%T (COMS%L) + COMS%QV (COMS%L) * SRC !warm the air + COMS%QV (COMS%L) = 0.0 +! +ENDIF +! +RETURN +END SUBROUTINE SUBLIMATE +! +! ********************************************************************* +! +SUBROUTINE GLACIATE (coms) +! +! *********************** CONVERSION OF RAIN TO ICE ******************* +! uses equation OT 16, simplest. correction from W not applied, but +! vapor pressure differences are supplied. +! +!use module_zero_plumegen_coms +! +implicit none +type(plumegen_coms), pointer :: coms +real(kind=kind_phys), PARAMETER :: HEATFUS = 334., CP = 1.004, EPS = 0.622, HEATSUBL = 2834. +real(kind=kind_phys), PARAMETER :: FRC = HEATFUS / CP, FRS = HEATSUBL / CP, TFREEZE = 269.3 +real(kind=kind_phys), PARAMETER :: GLCONST = 0.025 !glaciation time constant, 1/sec +real(kind=kind_phys) dfrzh +! + + DFRZH = 0. !rate of mass gain in ice +! +!selection rules for glaciation +IF (COMS%QH (COMS%L) .LE. 0. ) RETURN +IF (COMS%QV (COMS%L) .LT. COMS%QSAT (COMS%L) ) RETURN +IF (COMS%T (COMS%L) .GT. TFREEZE ) RETURN +! +! NT=TMELT-COMS%T(COMS%L) +! IF (NT.GT.50) NT=50 +! + + DFRZH = COMS%DT * GLCONST * COMS%QH (COMS%L) ! from OT(16) +! +IF (DFRZH.LT.COMS%QH (COMS%L) ) THEN +! + COMS%QI (COMS%L) = COMS%QI (COMS%L) + DFRZH + COMS%QH (COMS%L) = COMS%QH (COMS%L) - DFRZH + COMS%T (COMS%L) = COMS%T (COMS%L) + FRC * DFRZH !warms air + + + RETURN +! +ELSE +! + COMS%QI (COMS%L) = COMS%QI (COMS%L) + COMS%QH (COMS%L) + COMS%T (COMS%L) = COMS%T (COMS%L) + FRC * COMS%QH (COMS%L) + COMS%QH (COMS%L) = 0.0 + + !print*,'8',coms%l,coms%qi(coms%l), COMS%QH (COMS%L) +! +ENDIF +! +RETURN +! +END SUBROUTINE GLACIATE +! +! +! ********************************************************************* +SUBROUTINE MELT(coms) +! +! ******************* MAKES WATER OUT OF ICE ************************** +!use module_zero_plumegen_coms +! +implicit none +type(plumegen_coms), pointer :: coms + +real(kind=kind_phys), PARAMETER :: FRC = 332.27, TMELT = 273., F0 = 0.75 !ice velocity factor +real(kind=kind_phys) DTMELT +! + DTMELT = 0. !conversion,ice to rain +! +!selection rules +IF (COMS%QI (COMS%L) .LE. 0.0 ) RETURN +IF (COMS%T (COMS%L) .LT. TMELT) RETURN +! + !OT(23,24) + DTMELT = COMS%DT * (2.27 / COMS%RHO (COMS%L) ) * COMS%CVI(COMS%L) * (COMS%T (COMS%L) - TMELT) * ( (COMS%RHO(COMS%L) & + * COMS%QI (COMS%L) * 1.E-6) **0.525) * (F0** ( - 0.42) ) + !after Mason,1956 +! +! check the possibilities +! +IF (DTMELT.LT.COMS%QI (COMS%L) ) THEN +! + COMS%QH (COMS%L) = COMS%QH (COMS%L) + DTMELT + COMS%QI (COMS%L) = COMS%QI (COMS%L) - DTMELT + COMS%T (COMS%L) = COMS%T (COMS%L) - FRC * DTMELT !cools air + + RETURN +! +ELSE +! + COMS%QH (COMS%L) = COMS%QH (COMS%L) + COMS%QI (COMS%L) !get all there is to get + COMS%T (COMS%L) = COMS%T (COMS%L) - FRC * COMS%QI (COMS%L) + COMS%QI (COMS%L) = 0.0 +! +ENDIF +! +RETURN +! +END SUBROUTINE MELT + +SUBROUTINE htint (nzz1, vctra, eleva, nzz2, vctrb, elevb, errmsg, errflg) + IMPLICIT NONE + INTEGER, INTENT(IN ) :: nzz1 + INTEGER, INTENT(IN ) :: nzz2 + REAL(kind=kind_phys), INTENT(IN ) :: vctra(nzz1) + REAL(kind=kind_phys), INTENT(OUT) :: vctrb(nzz2) + REAL(kind=kind_phys), INTENT(IN ) :: eleva(nzz1) + REAL(kind=kind_phys), INTENT(IN ) :: elevb(nzz2) + character(*), intent(inout) :: errmsg + integer, intent(inout) :: errflg + INTEGER :: l + INTEGER :: k + INTEGER :: kk + REAL(kind=kind_phys) :: wt + + l=1 + + DO k=1,nzz2 + DO + IF ( (elevb(k) < eleva(1)) .OR. & + ((elevb(k) >= eleva(l)) .AND. (elevb(k) <= eleva(l+1))) ) THEN + wt = (elevb(k)-eleva(l))/(eleva(l+1)-eleva(l)) + vctrb(k) = vctra(l)+(vctra(l+1)-vctra(l))*wt + EXIT + ELSE IF ( elevb(k) > eleva(nzz1)) THEN + wt = (elevb(k)-eleva(nzz1))/(eleva(nzz1-1)-eleva(nzz1)) + vctrb(k) = vctra(nzz1)+(vctra(nzz1-1)-vctra(nzz1))*wt + EXIT + END IF + + l=l+1 + IF(l == nzz1) THEN + PRINT *,'htint:nzz1',nzz1 + DO kk=1,l + PRINT*,'kk,eleva(kk),elevb(kk)',kk,eleva(kk),elevb(kk) + END DO + errmsg='htint assertion failure (see print for details)' + errflg=1 + END IF + END DO + END DO +END SUBROUTINE htint +!----------------------------------------------------------------------------- +FUNCTION ESAT_PR (TEM) +! +! ******* Vapor Pressure A.L. Buck JAM V.20 p.1527. (1981) *********** +! +real(kind=kind_phys), PARAMETER :: CI1 = 6.1115, CI2 = 22.542, CI3 = 273.48 +real(kind=kind_phys), PARAMETER :: CW1 = 6.1121, CW2 = 18.729, CW3 = 257.87, CW4 = 227.3 +real(kind=kind_phys), PARAMETER :: TMELT = 273.3 + +real(kind=kind_phys) ESAT_PR +real(kind=kind_phys) temc , tem,esatm +! +! formulae from Buck, A.L., JAM 20,1527-1532 +! custom takes esat wrt water always. formula for h2o only +! good to -40C so: +! +! +TEMC = TEM - TMELT +IF (TEMC<= - 40.0) then + ESATM = CI1 * EXP (CI2 * TEMC / (TEMC + CI3) ) !ice, millibars + ESAT_PR = ESATM / 10. !kPa + + RETURN +ENDIF +! +ESATM = CW1 * EXP ( ( (CW2 - (TEMC / CW4) ) * TEMC) / (TEMC + CW3)) + +ESAT_PR = ESATM / 10. !kPa +RETURN +END function ESAT_PR +! ****************************************************************** + +! ------------------------------------------------------------------------ +END Module module_smoke_plumerise diff --git a/physics/smoke/module_zero_plumegen_coms.F90 b/physics/smoke/module_zero_plumegen_coms.F90 new file mode 100755 index 000000000..622d6a813 --- /dev/null +++ b/physics/smoke/module_zero_plumegen_coms.F90 @@ -0,0 +1,195 @@ +!>\file module_zero_plumegen_coms.F90 +!! This module initilizes variables for the fire plume rise scheme. + +module module_zero_plumegen_coms + + use machine , only : kind_phys + + implicit none + integer, parameter :: nkp = 200, ntime = 200 + + type plumegen_coms + real(kind=kind_phys),dimension(nkp) :: w,t,qv,qc,qh,qi,sc, & ! blob + vth,vti,rho,txs, & + est,qsat! never used: ,qpas,qtotal + + real(kind=kind_phys),dimension(nkp) :: wc,wt,tt,qvt,qct,qht,qit,sct + real(kind=kind_phys),dimension(nkp) :: dzm,dzt,zm,zt,vctr1,vctr2 & + ,vt3dc,vt3df,vt3dk,vt3dg,scr1 + + real(kind=kind_phys),dimension(nkp) :: pke,the,thve,thee,pe,te,qvenv,dne ! environment at plume grid ! never used: rhe, sce + real(kind=kind_phys),dimension(nkp) :: ucon,vcon,thtcon ,rvcon,picon,tmpcon & ! never used: wcon, dncon, prcon + ,zcon,zzcon ! environment at RAMS grid ! never used: scon + + real(kind=kind_phys) :: DZ,DQSDZ,VISC(nkp),VISCOSITY,TSTPF + integer :: N,NM1,L + ! + real(kind=kind_phys) :: CVH(nkp),CVI(nkp),ADIABAT,& + WBAR,VHREL,VIREL ! advection + ! Never used: ADVW,ADVT,ADVV,ADVC,ADVH,ADVI,ALAST(10) + + ! + real(kind=kind_phys) :: ZSURF,ZTOP ! never used: ZBASE + ! never used: integer :: LBASE + ! + real(kind=kind_phys) :: AREA,RSURF,ALPHA,RADIUS(nkp) ! entrain + ! + real(kind=kind_phys) :: HEATING(ntime),FMOIST,BLOAD ! heating + ! + real(kind=kind_phys) :: DT,TIME,TDUR + integer :: MINTIME,MDUR,MAXTIME + ! + !REAL(kind=kind_phys),DIMENSION(nkp,2) :: W_VMD,VMD + REAL(kind=kind_phys) :: upe (nkp) + REAL(kind=kind_phys) :: vpe (nkp) + REAL(kind=kind_phys) :: vel_e (nkp) + + REAL(kind=kind_phys) :: vel_p (nkp) + REAL(kind=kind_phys) :: rad_p (nkp) + REAL(kind=kind_phys) :: vel_t (nkp) + REAL(kind=kind_phys) :: rad_t (nkp) + + REAL(kind=kind_phys) :: ztop_(ntime) + integer :: testval + contains + procedure :: set_to_zero => plumegen_coms_zero + end type plumegen_coms + + interface plumegen_coms + procedure :: plumegen_coms_constructor + end interface plumegen_coms + + type(plumegen_coms), private, target :: private_thread_coms + logical, private :: mzpc_initialized = .false. + +!$OMP THREADPRIVATE(private_thread_coms) +!$OMP THREADPRIVATE(mzpc_initialized) + +contains + + function get_thread_coms() result(coms) + implicit none + class(plumegen_coms), pointer :: coms + if(.not.mzpc_initialized) then + private_thread_coms = plumegen_coms() + mzpc_initialized = .true. + endif + coms => private_thread_coms + end function get_thread_coms + + type(plumegen_coms) function plumegen_coms_constructor() result(this) + implicit none + call plumegen_coms_zero(this) + this%testval=3314 + end function plumegen_coms_constructor + + subroutine plumegen_coms_zero(this) + implicit none + class(plumegen_coms) :: this + + this%w=0.0 + this%t=0.0 + this%qv=0.0 + this%qc=0.0 + this%qh=0.0 + this%qi=0.0 + this%sc=0.0 + this%vth=0.0 + this%vti=0.0 + this%rho=0.0 + this%txs=0.0 + this%est=0.0 + this%qsat=0.0 + !this%qpas=0.0 + !this%qtotal=0.0 + this%wc=0.0 + this%wt=0.0 + this%tt=0.0 + this%qvt=0.0 + this%qct=0.0 + this%qht=0.0 + this%qit=0.0 + this%sct=0.0 + this%dzm=0.0 + this%dzt=0.0 + this%zm=0.0 + this%zt=0.0 + this%vctr1=0.0 + this%vctr2=0.0 + this%vt3dc=0.0 + this%vt3df=0.0 + this%vt3dk=0.0 + this%vt3dg=0.0 + this%scr1=0.0 + this%pke=0.0 + this%the=0.0 + this%thve=0.0 + this%thee=0.0 + this%pe=0.0 + this%te=0.0 + this%qvenv=0.0 + !this%rhe=0.0 + this%dne=0.0 + !this%sce=0.0 + this%ucon=0.0 + this%vcon=0.0 + !this%wcon=0.0 + this%thtcon =0.0 + this%rvcon=0.0 + this%picon=0.0 + this%tmpcon=0.0 + !this%dncon=0.0 + !this%prcon=0.0 + this%zcon=0.0 + this%zzcon=0.0 + !this%scon=0.0 + this%dz=0.0 + this%dqsdz=0.0 + this%visc=0.0 + this%viscosity=0.0 + this%tstpf=0.0 + !this%advw=0.0 + !this%advt=0.0 + !this%advv=0.0 + !this%advc=0.0 + !this%advh=0.0 + !this%advi=0.0 + this%cvh=0.0 + this%cvi=0.0 + this%adiabat=0.0 + this%wbar=0.0 + !this%alast=0.0 + this%vhrel=0.0 + this%virel=0.0 + this%zsurf=0.0 + !this%zbase=0.0 + this%ztop=0.0 + this%area=0.0 + this%rsurf=0.0 + this%alpha=0.0 + this%radius=0.0 + this%heating=0.0 + this%fmoist=0.0 + this%bload=0.0 + this%dt=0.0 + this%time=0.0 + this%tdur=0.0 + this%ztop_=0.0 + this%upe =0.0 + this%vpe =0.0 + this%vel_e =0.0 + this%vel_p =0.0 + this%rad_p =0.0 + this%vel_t =0.0 + this%rad_t =0.0 + !this%W_VMD=0.0 + !this%VMD=0.0 + this%n=0 + this%nm1=0 + this%l=0 + !this%lbase=0 + this%mintime=0 + this%mdur=0 + this%maxtime=0 + end subroutine plumegen_coms_zero +end module module_zero_plumegen_coms diff --git a/physics/smoke/plume_data_mod.F90 b/physics/smoke/plume_data_mod.F90 new file mode 100755 index 000000000..3d4b21c37 --- /dev/null +++ b/physics/smoke/plume_data_mod.F90 @@ -0,0 +1,52 @@ +!>\file plume_data_mod.F90 +!! This file contains data for the fire plume rise module. + +module plume_data_mod + + use machine , only : kind_phys + + implicit none + + ! -- FRP parameters + integer, dimension(0:20), parameter :: & + catb = (/ & + 0, & + 2, 1, 2, 1, & !floresta tropical 2 and 4 / extra trop fores 1,3,5 + 2, 3, 3, 3, 3, & !cerrado/woody savanna :6 a 9 + 4, 4, 4, 4, 4, 0, 4, 0, 0, 0, 0 & !pastagem/lavouras: 10 ... + /) + + real(kind=kind_phys), dimension(0:4), parameter :: & + flaming = (/ & + 0.00, & ! + 0.45, & ! % biomass burned at flaming phase : tropical forest igbp 2 and 4 + 0.45, & ! % biomass burned at flaming phase : extratropical forest igbp 1 , 3 and 5 + 0.75, & ! % biomass burned at flaming phase : cerrado/woody savanna igbp 6 to 9 + 0.00 & ! % biomass burned at flaming phase : pastagem/lavoura: igbp 10 a 17 + /) + + real(kind=kind_phys), dimension(0:20), parameter :: & + msize= (/ & + 0.00021, & !0near water,1Evergreen needleleaf,2EvergreenBroadleaf,!3Deciduous Needleleaf,4Deciduous Broadleaf + 0.00021, 0.00021, 0.00021, 0.00021, & !5Mixed forest,6Closed shrublands,7Open shrublands,8Woody savannas,9Savannas, + 0.00023, 0.00022, 0.00022, 0.00022, 0.00029, &! 10Grassland,11Permanent wetlands,12cropland,13'Urban and Built-Up' + 0.00029, 0.00021, 0.00026, 0.00021, 0.00026, &!14cropland/natural vegetation mosaic,15Snow and ice,16Barren or sparsely vegetated + 0.00021, 0.00021, 0.00021, 0.00021, 0.00021, 0.00021 & !17Water,18Wooded Tundra,19Mixed Tundra,20Bare Ground Tundra + /) + + ! -- FRP buffer indices + integer, parameter :: p_frp_hr = 1 + integer, parameter :: p_frp_std = 2 + integer, parameter :: num_frp_plume = 2 + + ! -- plumerise parameters + integer, parameter :: tropical_forest = 1 + integer, parameter :: boreal_forest = 2 + integer, parameter :: savannah = 3 + integer, parameter :: grassland = 4 + integer, parameter :: nveg_agreg = 4 + integer, parameter :: wind_eff = 1 + + public + +end module plume_data_mod diff --git a/physics/smoke/rrfs_smoke_config.F90 b/physics/smoke/rrfs_smoke_config.F90 new file mode 100755 index 000000000..43b3aee14 --- /dev/null +++ b/physics/smoke/rrfs_smoke_config.F90 @@ -0,0 +1,127 @@ +!>\file rrfs_smoke_config.F90 +!! This file contains the configuration for RRFS-Smoke. +! +! Haiqin.Li@noaa.gov +! 06/2021 +! constant parameters and chemistry configurations and tracers +! (This will be splited into three subroutines for configuration, constant and tracers later) +! 06/2021 move configuration into chem nml +! +module rrfs_smoke_config + + use machine , only : kind_phys + + implicit none + + !-- constant paramters + real(kind=kind_phys), parameter :: epsilc = 1.e-12 + + !-- chemistyr module configurations + integer :: chem_opt = 1 + integer :: kemit = 1 + integer :: dust_opt = 5 + integer :: dmsemis_opt = 1 + integer :: seas_opt = 2 + integer :: biomass_burn_opt=1 + logical :: do_plumerise = .true. + integer :: addsmoke_flag = 1 + integer :: plumerisefire_frq=60 ! Let's add to the namelist + integer :: chem_conv_tr = 0 + integer :: aer_ra_feedback=1 !0 + integer :: aer_ra_frq = 60 + integer :: wetdep_ls_opt = 1 + integer :: drydep_opt = 1 + logical :: bb_dcycle = .false. + logical :: smoke_forecast = .false. + logical :: aero_ind_fdb = .false. + logical :: dbg_opt = .true. + + real(kind=kind_phys), parameter :: depo_fact=0. + integer, parameter :: CHEM_OPT_GOCART= 1 + INTEGER, PARAMETER :: gocartracm_kpp = 301 + integer, parameter :: chem_tune_tracers = 20 + integer, parameter :: DUST_OPT_NONE = 0 + integer, parameter :: SEAS_OPT_NONE = 0 + ! -- DMS emissions + integer, parameter :: DMSE_OPT_NONE = 0 + integer, parameter :: DMSE_OPT_ENABLE = 1 + ! -- subgrid convective transport + integer, parameter :: CTRA_OPT_NONE = 0 + integer, parameter :: CTRA_OPT_GRELL = 2 + ! -- large scale wet deposition + integer, parameter :: WDLS_OPT_NONE = 0 + integer, parameter :: WDLS_OPT_GSD = 1 + integer, parameter :: WDLS_OPT_NGAC = 2 + + ! -- + integer, parameter :: call_chemistry = 1 + integer, parameter :: num_moist=3, num_chem=20, num_emis_seas=5, num_emis_dust=5 + integer, parameter :: num_emis_ant = 7 + + integer, parameter :: SEAS_OPT_DEFAULT = 1 + + integer, parameter :: DUST_OPT_GOCART = 1 + integer, parameter :: DUST_OPT_AFWA = 3 + integer, parameter :: DUST_OPT_FENGSHA = 5 + + ! -- biomass burning emissions + integer, parameter :: BURN_OPT_ENABLE = 1 + integer, parameter :: FIRE_OPT_MODIS = 1 + integer, parameter :: FIRE_OPT_GBBEPx = 2 + + ! -- hydrometeors + integer, parameter :: p_qv=1 + integer, parameter :: p_qc=2 + integer, parameter :: p_qi=3 + ! -- set pointers to predefined atmospheric tracers + ! -- FV3 GFDL microphysics + integer, parameter :: p_atm_shum = 1 + integer, parameter :: p_atm_cldq = 2 + integer, parameter :: p_atm_o3mr = 7 + + integer :: numgas = 0 + + real(kind=kind_phys) :: wetdep_ls_alpha(chem_tune_tracers)=-999. + + !-- tracers + integer, parameter :: p_so2=1 + integer, parameter :: p_sulf=2 + integer, parameter :: p_dms=3 + integer, parameter :: p_msa=4 + integer, parameter :: p_p25=5, p_smoke=5 + integer, parameter :: p_bc1=6 + integer, parameter :: p_bc2=7 + integer, parameter :: p_oc1=8 + integer, parameter :: p_oc2=9 + integer, parameter :: p_dust_1=10 + integer, parameter :: p_dust_2=11 + integer, parameter :: p_dust_3=12 + integer, parameter :: p_dust_4=13 + integer, parameter :: p_dust_5=14 + integer, parameter :: p_seas_1=15 + integer, parameter :: p_seas_2=16 + integer, parameter :: p_seas_3=17 + integer, parameter :: p_seas_4=18 + integer, parameter :: p_seas_5=19 + integer, parameter :: p_p10 =20 + + integer, parameter :: p_edust1=1,p_edust2=2,p_edust3=3,p_edust4=4,p_edust5=5 + integer, parameter :: p_eseas1=1,p_eseas2=2,p_eseas3=3,p_eseas4=4,p_eseas5=5 + + integer :: p_ho=0,p_h2o2=0,p_no3=0 + + ! constants + real(kind=kind_phys), PARAMETER :: airmw = 28.97 + real(kind=kind_phys), PARAMETER :: mw_so2_aer = 64.066 + real(kind=kind_phys), PARAMETER :: mw_so4_aer = 96.066 + real(kind=kind_phys), parameter :: smw = 32.00 + real(kind=kind_phys), parameter :: mwdry = 28. +! d is the molecular weight of dry air (28.966), w/d = 0.62197, and +! (d - w)/d = 0.37803 +! http://atmos.nmsu.edu/education_and_outreach/encyclopedia/humidity.htm + + ! -- fire options +! integer, parameter :: num_plume_data = 1 + + +end module diff --git a/physics/smoke/rrfs_smoke_data.F90 b/physics/smoke/rrfs_smoke_data.F90 new file mode 100755 index 000000000..cb9cc25e6 --- /dev/null +++ b/physics/smoke/rrfs_smoke_data.F90 @@ -0,0 +1,651 @@ +!>\file rrfs_smoke_data.F90 +!! This file contains data for the RRFS-Smoke modules. + +module rrfs_smoke_data + use machine , only : kind_phys + implicit none + INTEGER, PARAMETER :: dep_seasons = 5 + INTEGER, PARAMETER :: nlu = 25 + + type wesely_pft + integer :: npft + integer :: months + INTEGER, pointer :: seasonal_wes(:,:,:,:) => NULL() + contains + final :: wesely_pft_destructor + end type wesely_pft + + interface wesely_pft + procedure :: wesely_pft_constructor + end interface wesely_pft + +!-------------------------------------------------- +! many of these parameters will depend on the RADM mechanism! +! if you change it, lets talk about it and get it done!!! +!-------------------------------------------------- + + REAL(kind_phys), parameter :: small_value = 1.e-36 + REAL(kind_phys), parameter :: large_value = 1.e36 + +!-------------------------------------------------- +! following currently hardwired to USGS +!-------------------------------------------------- + integer, parameter :: isice_temp = 24 + integer, parameter :: iswater_temp = 16 + integer, parameter :: wrf2mz_lt_map(nlu) = (/ 1, 2, 2, 2, 2, & + 4, 3, 3, 3, 3, & + 4, 5, 4, 5, 6, & + 7, 9, 6, 8, 9, & + 6, 6, 8, 0, 0 /) + real(kind_phys), parameter :: wh2o = 18.0153 + real(kind_phys), parameter :: wpan = 121.04793 + real(kind_phys), PARAMETER :: KARMAN=0.4 + INTEGER, parameter :: luse2usgs(21) = (/14,13,12,11,15,8,9,10,10,7, & + 17,4,1,5,24,19,16,21,22,23,16 /) + character(len=4), parameter :: mminlu = 'USGS' + + ! integer, parameter :: pan_seasons = 5 + ! integer, parameter :: pan_lands = 11 + + type smoke_data + ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! Taken from dep_simple_mod + INTEGER :: ixxxlu(nlu) + REAL(KIND_PHYS) :: kpart(nlu) + REAL(KIND_PHYS) :: rac(nlu,dep_seasons), rclo(nlu,dep_seasons), rcls(nlu,dep_seasons) + REAL(KIND_PHYS) :: rgso(nlu,dep_seasons), rgss(nlu,dep_seasons) + REAL(KIND_PHYS) :: ri(nlu,dep_seasons), rlu(nlu,dep_seasons) + ! REAL(KIND_PHYS) :: ri_pan(pan_seasons,pan_lands) + ! never used: real(kind_phys) :: c0_pan(pan_lands) + ! never used: real(kind_phys) :: k_pan (pan_lands) + + ! never used: integer :: month + REAL(KIND_PHYS) :: dratio(1000), hstar(1000), hstar4(1000) + REAL(KIND_PHYS) :: f0(1000), dhr(1000), scpr23(1000) + + ! Note: scpr23 is only read, never written + + ! never used: type(wesely_pft) :: seasonal_pft + + ! never used: logical, pointer :: is_aerosol(:) => NULL() + + ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! Taken from dep_wet_ls_mod + real(kind_phys), dimension(:), pointer :: alpha => NULL() + contains + final :: smoke_data_destructor + procedure :: dep_init + end type smoke_data + + interface smoke_data + procedure :: smoke_data_constructor + end interface smoke_data + + type(smoke_data), target, private :: private_thread_data + logical, private :: rrfs_smoke_data_initialized = .false. + + !$OMP THREADPRIVATE(private_thread_data) + !$OMP THREADPRIVATE(rrfs_smoke_data_initialized) + +contains + + function get_thread_smoke_data() result(data) + implicit none + class(smoke_data), pointer :: data + if(.not. rrfs_smoke_data_initialized) then + private_thread_data = smoke_data() + rrfs_smoke_data_initialized = .true. + endif + data => private_thread_data + end function get_thread_smoke_data + + subroutine wesely_pft_destructor(this) + implicit none + type(wesely_pft) :: this + if(associated(this%seasonal_wes)) then + deallocate(this%seasonal_wes) + nullify(this%seasonal_wes) + endif + end subroutine wesely_pft_destructor + + function wesely_pft_constructor() result(this) + implicit none + class(wesely_pft), pointer :: this + nullify(this%seasonal_wes) + end function wesely_pft_constructor + + function smoke_data_constructor() result(this) + implicit none + type(smoke_data) :: this + ! These are never used: + ! this%c0_pan = (/ 0.000, 0.006, 0.002, 0.009, 0.015, & + ! 0.006, 0.000, 0.000, 0.000, 0.002, 0.002 /) + ! this%k_pan = (/ 0.000, 0.010, 0.005, 0.004, 0.003, & + ! 0.005, 0.000, 0.000, 0.000, 0.075, 0.002 /) + ! this%month = 0 + ! this%seasonal_pft = wesely_pft() + ! nullify(this%is_aerosol) + nullify(this%alpha) + ! This is not called in the original non-thread-safe code: + ! call this%dep_init() + end function smoke_data_constructor + + subroutine smoke_data_destructor(this) + implicit none + type(smoke_data) :: this + if(associated(this%alpha)) then + deallocate(this%alpha) + nullify(this%alpha) + endif + ! Never used: + ! if(associated(this%is_aerosol)) then + ! deallocate(this%is_aerosol) + ! nullify(this%is_aerosolo) + ! endif + end subroutine smoke_data_destructor + + +! SUBROUTINE dep_init( id, numgas, mminlu_loc, & +! ips, ipe, jps, jpe, ide, jde ) + SUBROUTINE dep_init(this,errmsg,errflg) + ! Lifted out of dep_simple_mod, this initializes + ! member variables that were module variables in + ! that module. +!-- + implicit none + class(smoke_data) :: this + character(*), intent(inout) :: errmsg + integer, intent(inout) :: errflg + +!-------------------------------------------------- +! .. Scalar Arguments .. +!-------------------------------------------------- + ! Unused: + ! integer, intent(in) :: numgas + ! integer, intent(in) :: ips, ipe, jps, jpe + ! integer, intent(in) :: ide, jde + ! mmin_lu_loc had no definition, but is also unused + +!-------------------------------------------------- +! .. Local Scalars +!-------------------------------------------------- + INTEGER :: iland, iseason, l + integer :: iprt + integer :: astat + integer :: ncid + integer :: dimid + integer :: varid + integer :: cpos, slen + integer :: lon_e, lat_e + integer :: iend, jend + integer :: chem_opt + integer, allocatable :: input_wes_seasonal(:,:,:,:) + REAL(KIND_PHYS) :: sc + character(len=128) :: err_msg + character(len=128) :: filename + character(len=3) :: id_num +!-------------------------------------------------- +! .. Local Arrays +!-------------------------------------------------- + REAL(KIND_PHYS) :: dat1(nlu,dep_seasons), dat2(nlu,dep_seasons), & + dat3(nlu,dep_seasons), dat4(nlu,dep_seasons), & + dat5(nlu,dep_seasons), dat6(nlu,dep_seasons), & + dat7(nlu,dep_seasons) + ! REAL(KIND_PHYS) :: dat8(pan_seasons,pan_lands) + chem_opt = chem_opt + +!-------------------------------------------------- +! .. Data Statements .. +! THIS%RI for stomatal resistance +! data ((this%ri(ILAND,ISEASON),ILAND=1,nlu),ISEASON=1,dep_seasons)/0.10E+11, & + DATA ((dat1(iland,iseason),iland=1,nlu),iseason=1,dep_seasons)/0.10E+11, & + 0.60E+02, 0.60E+02, 0.60E+02, 0.60E+02, 0.70E+02, 0.12E+03, & + 0.12E+03, 0.12E+03, 0.12E+03, 0.70E+02, 0.13E+03, 0.70E+02, & + 0.13E+03, 0.10E+03, 0.10E+11, 0.80E+02, 0.10E+03, 0.10E+11, & + 0.80E+02, 0.10E+03, 0.10E+03, 0.10E+11, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.12E+03, 0.10E+11, 0.10E+11, & + 0.70E+02, 0.25E+03, 0.50E+03, 0.10E+11, 0.10E+11, 0.50E+03, & + 0.10E+11, 0.10E+11, 0.50E+03, 0.50E+03, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.12E+03, 0.10E+11, & + 0.10E+11, 0.70E+02, 0.25E+03, 0.50E+03, 0.10E+11, 0.10E+11, & + 0.50E+03, 0.10E+11, 0.10E+11, 0.50E+03, 0.50E+03, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.70E+02, 0.40E+03, 0.80E+03, 0.10E+11, & + 0.10E+11, 0.80E+03, 0.10E+11, 0.10E+11, 0.80E+03, 0.80E+03, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.12E+03, 0.12E+03, & + 0.12E+03, 0.12E+03, 0.14E+03, 0.24E+03, 0.24E+03, 0.24E+03, & + 0.12E+03, 0.14E+03, 0.25E+03, 0.70E+02, 0.25E+03, 0.19E+03, & + 0.10E+11, 0.16E+03, 0.19E+03, 0.10E+11, 0.16E+03, 0.19E+03, & + 0.19E+03, 0.10E+11, 0.10E+11, 0.10E+11/ +! .. + IF (nlu/=25) THEN + errmsg='number of land use classifications not correct ' + errflg=1 + return + END IF + IF (dep_seasons/=5) THEN + errmsg='number of dep_seasons not correct ' + errflg=1 + return + END IF + +! SURFACE RESISTANCE DATA FOR DEPOSITION MODEL OF +! M. L. WESELY, ATMOSPHERIC ENVIRONMENT 23 (1989) 1293-1304 + +! Seasonal categories: +! 1: midsummer with lush vegetation +! 2: autumn with unharvested cropland +! 3: late autumn with frost, no snow +! 4: winter, snow on ground and subfreezing +! 5: transitional spring with partially green short annuals + +! Land use types: +! USGS type Wesely type +! 1: Urban and built-up land 1 +! 2: Dryland cropland and pasture 2 +! 3: Irrigated cropland and pasture 2 +! 4: Mix. dry/irrg. cropland and pasture 2 +! 5: Cropland/grassland mosaic 2 +! 6: Cropland/woodland mosaic 4 +! 7: Grassland 3 +! 8: Shrubland 3 +! 9: Mixed shrubland/grassland 3 +! 10: Savanna 3, always summer +! 11: Deciduous broadleaf forest 4 +! 12: Deciduous needleleaf forest 5, autumn and winter modi +! 13: Evergreen broadleaf forest 4, always summer +! 14: Evergreen needleleaf forest 5 +! 15: Mixed Forest 6 +! 16: Water Bodies 7 +! 17: Herbaceous wetland 9 +! 18: Wooded wetland 6 +! 19: Barren or sparsely vegetated 8 +! 20: Herbaceous Tundra 9 +! 21: Wooded Tundra 6 +! 22: Mixed Tundra 6 +! 23: Bare Ground Tundra 8 +! 24: Snow or Ice -, always winter +! 25: No data 8 + + +! Order of data: +! | +! | seasonal category +! \|/ +! ---> landuse type +! 1 2 3 4 5 6 7 8 9 +! THIS%RLU for outer surfaces in the upper canopy + DO iseason = 1, dep_seasons + this%ri(1:nlu,iseason) = dat1(1:nlu,iseason) + END DO +! data ((this%rlu(ILAND,ISEASON),ILAND=1,25),ISEASON=1,5)/0.10E+11, & + DATA ((dat2(iland,iseason),iland=1,nlu),iseason=1,dep_seasons)/0.10E+11, & + 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, & + 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, & + 0.20E+04, 0.20E+04, 0.10E+11, 0.25E+04, 0.20E+04, 0.10E+11, & + 0.25E+04, 0.20E+04, 0.20E+04, 0.10E+11, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.90E+04, 0.90E+04, 0.90E+04, 0.90E+04, 0.90E+04, & + 0.90E+04, 0.90E+04, 0.90E+04, 0.20E+04, 0.90E+04, 0.90E+04, & + 0.20E+04, 0.40E+04, 0.80E+04, 0.10E+11, 0.90E+04, 0.80E+04, & + 0.10E+11, 0.90E+04, 0.80E+04, 0.80E+04, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.90E+04, 0.90E+04, 0.90E+04, 0.90E+04, & + 0.90E+04, 0.90E+04, 0.90E+04, 0.90E+04, 0.20E+04, 0.90E+04, & + 0.90E+04, 0.20E+04, 0.40E+04, 0.80E+04, 0.10E+11, 0.90E+04, & + 0.80E+04, 0.10E+11, 0.90E+04, 0.80E+04, 0.80E+04, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.20E+04, 0.60E+04, 0.90E+04, 0.10E+11, & + 0.90E+04, 0.90E+04, 0.10E+11, 0.90E+04, 0.90E+04, 0.90E+04, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.40E+04, 0.40E+04, & + 0.40E+04, 0.40E+04, 0.40E+04, 0.40E+04, 0.40E+04, 0.40E+04, & + 0.20E+04, 0.40E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.30E+04, & + 0.10E+11, 0.40E+04, 0.30E+04, 0.10E+11, 0.40E+04, 0.30E+04, & + 0.30E+04, 0.10E+11, 0.10E+11, 0.10E+11/ + DO iseason = 1, dep_seasons + this%rlu(1:nlu,iseason) = dat2(1:nlu,iseason) + END DO +! THIS%RAC for transfer that depends on canopy height and density +! data ((this%rac(ILAND,ISEASON),ILAND=1,25),ISEASON=1,5)/0.10E+03, & + DATA ((dat3(iland,iseason),iland=1,nlu),iseason=1,dep_seasons)/0.10E+03, & + 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+04, 0.10E+03, & + 0.10E+03, 0.10E+03, 0.10E+03, 0.20E+04, 0.20E+04, 0.20E+04, & + 0.20E+04, 0.20E+04, 0.00E+00, 0.30E+03, 0.20E+04, 0.00E+00, & + 0.30E+03, 0.20E+04, 0.20E+04, 0.00E+00, 0.00E+00, 0.00E+00, & + 0.10E+03, 0.15E+03, 0.15E+03, 0.15E+03, 0.15E+03, 0.15E+04, & + 0.10E+03, 0.10E+03, 0.10E+03, 0.10E+03, 0.15E+04, 0.20E+04, & + 0.20E+04, 0.20E+04, 0.17E+04, 0.00E+00, 0.20E+03, 0.17E+04, & + 0.00E+00, 0.20E+03, 0.17E+04, 0.17E+04, 0.00E+00, 0.00E+00, & + 0.00E+00, 0.10E+03, 0.10E+02, 0.10E+02, 0.10E+02, 0.10E+02, & + 0.10E+04, 0.10E+03, 0.10E+03, 0.10E+03, 0.10E+03, 0.10E+04, & + 0.20E+04, 0.20E+04, 0.20E+04, 0.15E+04, 0.00E+00, 0.10E+03, & + 0.15E+04, 0.00E+00, 0.10E+03, 0.15E+04, 0.15E+04, 0.00E+00, & + 0.00E+00, 0.00E+00, 0.10E+03, 0.10E+02, 0.10E+02, 0.10E+02, & + 0.10E+02, 0.10E+04, 0.10E+02, 0.10E+02, 0.10E+02, 0.10E+02, & + 0.10E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.15E+04, 0.00E+00, & + 0.50E+02, 0.15E+04, 0.00E+00, 0.50E+02, 0.15E+04, 0.15E+04, & + 0.00E+00, 0.00E+00, 0.00E+00, 0.10E+03, 0.50E+02, 0.50E+02, & + 0.50E+02, 0.50E+02, 0.12E+04, 0.80E+02, 0.80E+02, 0.80E+02, & + 0.10E+03, 0.12E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.15E+04, & + 0.00E+00, 0.20E+03, 0.15E+04, 0.00E+00, 0.20E+03, 0.15E+04, & + 0.15E+04, 0.00E+00, 0.00E+00, 0.00E+00/ + DO iseason = 1, dep_seasons + this%rac(1:nlu,iseason) = dat3(1:nlu,iseason) + END DO +! THIS%RGSS for ground surface SO2 +! data ((this%rgss(ILAND,ISEASON),ILAND=1,25),ISEASON=1,5)/0.40E+03, & + DATA ((dat4(iland,iseason),iland=1,nlu),iseason=1,dep_seasons)/0.40E+03, & + 0.15E+03, 0.15E+03, 0.15E+03, 0.15E+03, 0.50E+03, 0.35E+03, & + 0.35E+03, 0.35E+03, 0.35E+03, 0.50E+03, 0.50E+03, 0.50E+03, & + 0.50E+03, 0.10E+03, 0.10E+01, 0.10E+01, 0.10E+03, 0.10E+04, & + 0.10E+01, 0.10E+03, 0.10E+03, 0.10E+04, 0.10E+03, 0.10E+04, & + 0.40E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.50E+03, & + 0.35E+03, 0.35E+03, 0.35E+03, 0.35E+03, 0.50E+03, 0.50E+03, & + 0.50E+03, 0.50E+03, 0.10E+03, 0.10E+01, 0.10E+01, 0.10E+03, & + 0.10E+04, 0.10E+01, 0.10E+03, 0.10E+03, 0.10E+04, 0.10E+03, & + 0.10E+04, 0.40E+03, 0.15E+03, 0.15E+03, 0.15E+03, 0.15E+03, & + 0.50E+03, 0.35E+03, 0.35E+03, 0.35E+03, 0.35E+03, 0.50E+03, & + 0.50E+03, 0.50E+03, 0.50E+03, 0.20E+03, 0.10E+01, 0.10E+01, & + 0.20E+03, 0.10E+04, 0.10E+01, 0.20E+03, 0.20E+03, 0.10E+04, & + 0.10E+03, 0.10E+04, 0.10E+03, 0.10E+03, 0.10E+03, 0.10E+03, & + 0.10E+03, 0.10E+03, 0.10E+03, 0.10E+03, 0.10E+03, 0.10E+03, & + 0.10E+03, 0.10E+03, 0.50E+03, 0.10E+03, 0.10E+03, 0.10E+01, & + 0.10E+03, 0.10E+03, 0.10E+04, 0.10E+03, 0.10E+03, 0.10E+03, & + 0.10E+04, 0.10E+03, 0.10E+04, 0.50E+03, 0.15E+03, 0.15E+03, & + 0.15E+03, 0.15E+03, 0.50E+03, 0.35E+03, 0.35E+03, 0.35E+03, & + 0.35E+03, 0.50E+03, 0.50E+03, 0.50E+03, 0.50E+03, 0.20E+03, & + 0.10E+01, 0.10E+01, 0.20E+03, 0.10E+04, 0.10E+01, 0.20E+03, & + 0.20E+03, 0.10E+04, 0.10E+03, 0.10E+04/ + DO iseason = 1, dep_seasons + this%rgss(1:nlu,iseason) = dat4(1:nlu,iseason) + END DO +! THIS%RGSO for ground surface O3 +! data ((this%rgso(ILAND,ISEASON),ILAND=1,25),ISEASON=1,5)/0.30E+03, & + DATA ((dat5(iland,iseason),iland=1,nlu),iseason=1,dep_seasons)/0.30E+03, & + 0.15E+03, 0.15E+03, 0.15E+03, 0.15E+03, 0.20E+03, 0.20E+03, & + 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, & + 0.20E+03, 0.30E+03, 0.20E+04, 0.10E+04, 0.30E+03, 0.40E+03, & + 0.10E+04, 0.30E+03, 0.30E+03, 0.40E+03, 0.35E+04, 0.40E+03, & + 0.30E+03, 0.15E+03, 0.15E+03, 0.15E+03, 0.15E+03, 0.20E+03, & + 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, & + 0.20E+03, 0.20E+03, 0.30E+03, 0.20E+04, 0.80E+03, 0.30E+03, & + 0.40E+03, 0.80E+03, 0.30E+03, 0.30E+03, 0.40E+03, 0.35E+04, & + 0.40E+03, 0.30E+03, 0.15E+03, 0.15E+03, 0.15E+03, 0.15E+03, & + 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, & + 0.20E+03, 0.20E+03, 0.20E+03, 0.30E+03, 0.20E+04, 0.10E+04, & + 0.30E+03, 0.40E+03, 0.10E+04, 0.30E+03, 0.30E+03, 0.40E+03, & + 0.35E+04, 0.40E+03, 0.60E+03, 0.35E+04, 0.35E+04, 0.35E+04, & + 0.35E+04, 0.35E+04, 0.35E+04, 0.35E+04, 0.35E+04, 0.35E+04, & + 0.35E+04, 0.35E+04, 0.20E+03, 0.35E+04, 0.35E+04, 0.20E+04, & + 0.35E+04, 0.35E+04, 0.40E+03, 0.35E+04, 0.35E+04, 0.35E+04, & + 0.40E+03, 0.35E+04, 0.40E+03, 0.30E+03, 0.15E+03, 0.15E+03, & + 0.15E+03, 0.15E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, & + 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.30E+03, & + 0.20E+04, 0.10E+04, 0.30E+03, 0.40E+03, 0.10E+04, 0.30E+03, & + 0.30E+03, 0.40E+03, 0.35E+04, 0.40E+03/ + DO iseason = 1, dep_seasons + this%rgso(1:nlu,iseason) = dat5(1:nlu,iseason) + END DO +! THIS%RCLS for exposed surfaces in the lower canopy SO2 +! data ((this%rcls(ILAND,ISEASON),ILAND=1,25),ISEASON=1,5)/0.10E+11, & + DATA ((dat6(iland,iseason),iland=1,nlu),iseason=1,dep_seasons)/0.10E+11, & + 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, & + 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, & + 0.20E+04, 0.20E+04, 0.10E+11, 0.25E+04, 0.20E+04, 0.10E+11, & + 0.25E+04, 0.20E+04, 0.20E+04, 0.10E+11, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.90E+04, 0.90E+04, 0.90E+04, 0.90E+04, 0.90E+04, & + 0.90E+04, 0.90E+04, 0.90E+04, 0.20E+04, 0.90E+04, 0.90E+04, & + 0.20E+04, 0.20E+04, 0.40E+04, 0.10E+11, 0.90E+04, 0.40E+04, & + 0.10E+11, 0.90E+04, 0.40E+04, 0.40E+04, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, & + 0.90E+04, 0.90E+04, 0.90E+04, 0.90E+04, 0.20E+04, 0.90E+04, & + 0.90E+04, 0.20E+04, 0.30E+04, 0.60E+04, 0.10E+11, 0.90E+04, & + 0.60E+04, 0.10E+11, 0.90E+04, 0.60E+04, 0.60E+04, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.90E+04, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, & + 0.90E+04, 0.90E+04, 0.20E+04, 0.20E+03, 0.40E+03, 0.10E+11, & + 0.90E+04, 0.40E+03, 0.10E+11, 0.90E+04, 0.40E+03, 0.40E+03, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.40E+04, 0.40E+04, & + 0.40E+04, 0.40E+04, 0.40E+04, 0.40E+04, 0.40E+04, 0.40E+04, & + 0.20E+04, 0.40E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.30E+04, & + 0.10E+11, 0.40E+04, 0.30E+04, 0.10E+11, 0.40E+04, 0.30E+04, & + 0.30E+04, 0.10E+11, 0.10E+11, 0.10E+11/ + DO iseason = 1, dep_seasons + this%rcls(1:nlu,iseason) = dat6(1:nlu,iseason) + END DO +! THIS%RCLO for exposed surfaces in the lower canopy O3 +! data ((this%rclo(ILAND,ISEASON),ILAND=1,25),ISEASON=1,5)/0.10E+11, & + DATA ((dat7(iland,iseason),iland=1,nlu),iseason=1,dep_seasons)/0.10E+11, & + 0.10E+04, 0.10E+04, 0.10E+04, 0.10E+04, 0.10E+04, 0.10E+04, & + 0.10E+04, 0.10E+04, 0.10E+04, 0.10E+04, 0.10E+04, 0.10E+04, & + 0.10E+04, 0.10E+04, 0.10E+11, 0.10E+04, 0.10E+04, 0.10E+11, & + 0.10E+04, 0.10E+04, 0.10E+04, 0.10E+11, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.40E+03, 0.40E+03, 0.40E+03, 0.40E+03, 0.40E+03, & + 0.40E+03, 0.40E+03, 0.40E+03, 0.10E+04, 0.40E+03, 0.40E+03, & + 0.10E+04, 0.10E+04, 0.60E+03, 0.10E+11, 0.40E+03, 0.60E+03, & + 0.10E+11, 0.40E+03, 0.60E+03, 0.60E+03, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.10E+04, 0.10E+04, 0.10E+04, 0.10E+04, & + 0.40E+03, 0.40E+03, 0.40E+03, 0.40E+03, 0.10E+04, 0.40E+03, & + 0.40E+03, 0.10E+04, 0.10E+04, 0.60E+03, 0.10E+11, 0.80E+03, & + 0.60E+03, 0.10E+11, 0.80E+03, 0.60E+03, 0.60E+03, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+04, 0.10E+04, 0.10E+04, & + 0.10E+04, 0.40E+03, 0.10E+04, 0.10E+04, 0.10E+04, 0.10E+04, & + 0.40E+03, 0.40E+03, 0.10E+04, 0.15E+04, 0.60E+03, 0.10E+11, & + 0.80E+03, 0.60E+03, 0.10E+11, 0.80E+03, 0.60E+03, 0.60E+03, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+04, 0.10E+04, & + 0.10E+04, 0.10E+04, 0.50E+03, 0.50E+03, 0.50E+03, 0.50E+03, & + 0.10E+04, 0.50E+03, 0.15E+04, 0.10E+04, 0.15E+04, 0.70E+03, & + 0.10E+11, 0.60E+03, 0.70E+03, 0.10E+11, 0.60E+03, 0.70E+03, & + 0.70E+03, 0.10E+11, 0.10E+11, 0.10E+11/ + + DO iseason = 1, dep_seasons + this%rclo(1:nlu,iseason) = dat7(1:nlu,iseason) + END DO + + ! data ((dat8(iseason,iland),iseason=1,pan_seasons),iland=1,pan_lands) / & + ! 1.e36, 60., 120., 70., 130., 100.,1.e36,1.e36, 80., 100., 150., & + ! 1.e36,1.e36,1.e36,1.e36, 250., 500.,1.e36,1.e36,1.e36,1.e36,1.e36, & + ! 1.e36,1.e36,1.e36,1.e36, 250., 500.,1.e36,1.e36,1.e36,1.e36,1.e36, & + ! 1.e36,1.e36,1.e36,1.e36, 400., 800.,1.e36,1.e36,1.e36,1.e36,1.e36, & + ! 1.e36, 120., 240., 140., 250., 190.,1.e36,1.e36, 160., 200., 300. / + ! this%ri_pan(:,:) = dat8(:,:) + +!-------------------------------------------------- +! Initialize parameters +!-------------------------------------------------- + this%hstar = 0. + this%hstar4 = 0. + this%dhr = 0. + this%f0 = 0. + this%dratio = 1.0 ! FIXME: IS THIS RIGHT? + this%scpr23 = 1.0 ! FIXME: IS THIS RIGHT? + +!-------------------------------------------------- +! HENRY''S LAW COEFFICIENTS +! Effective Henry''s law coefficient at pH 7 +! [KH298]=mole/(l atm) +!-------------------------------------------------- + +! DATA FOR AEROSOL PARTICLE DEPOSITION FOR THE MODEL OF +! J. W. ERISMAN, A. VAN PUL AND P. WYERS +! ATMOSPHERIC ENVIRONMENT 28 (1994), 2595-2607 + +! vd = (u* / k) * CORRECTION FACTORS + +! CONSTANT K FOR LANDUSE TYPES: +! urban and built-up land + this%kpart(1) = 500. +! dryland cropland and pasture + this%kpart(2) = 500. +! irrigated cropland and pasture + this%kpart(3) = 500. +! mixed dryland/irrigated cropland and past + this%kpart(4) = 500. +! cropland/grassland mosaic + this%kpart(5) = 500. +! cropland/woodland mosaic + this%kpart(6) = 100. +! grassland + this%kpart(7) = 500. +! shrubland + this%kpart(8) = 500. +! mixed shrubland/grassland + this%kpart(9) = 500. +! savanna + this%kpart(10) = 500. +! deciduous broadleaf forest + this%kpart(11) = 100. +! deciduous needleleaf forest + this%kpart(12) = 100. +! evergreen broadleaf forest + this%kpart(13) = 100. +! evergreen needleleaf forest + this%kpart(14) = 100. +! mixed forest + this%kpart(15) = 100. +! water bodies + this%kpart(16) = 500. +! herbaceous wetland + this%kpart(17) = 500. +! wooded wetland + this%kpart(18) = 500. +! barren or sparsely vegetated + this%kpart(19) = 500. +! herbaceous tundra + this%kpart(20) = 500. +! wooded tundra + this%kpart(21) = 100. +! mixed tundra + this%kpart(22) = 500. +! bare ground tundra + this%kpart(23) = 500. +! snow or ice + this%kpart(24) = 500. +! Comments: + this%kpart(25) = 500. +! Erisman et al. (1994) give +! k = 500 for low vegetation and k = 100 for forests. + +! For desert k = 500 is taken according to measurements +! on bare soil by +! J. Fontan, A. Lopez, E. Lamaud and A. Druilhet (1997) +! Vertical Flux Measurements of the Submicronic Aerosol Particles +! and Parametrisation of the Dry Deposition Velocity +! in: Biosphere-Atmosphere Exchange of Pollutants +! and Trace Substances +! Editor: S. Slanina. Springer-Verlag Berlin, Heidelberg, 1997 +! pp. 381-390 + +! For coniferous forest the Erisman value of k = 100 is taken. +! Measurements of Erisman et al. (1997) in a coniferous forest +! in the Netherlands, lead to values of k between 20 and 38 +! (Atmospheric Environment 31 (1997), 321-332). +! However, these high values of vd may be reached during +! instable cases. The eddy correlation measurements +! of Gallagher et al. (1997) made during the same experiment +! show for stable cases (L>0) values of k between 200 and 250 +! at minimum (Atmospheric Environment 31 (1997), 359-373). +! Fontan et al. (1997) found k = 250 in a forest +! of maritime pine in southwestern France. + +! For gras, model calculations of Davidson et al. support +! the value of 500. +! C. I. Davidson, J. M. Miller and M. A. Pleskov +! The Influence of Surface Structure on Predicted Particles +! Dry Deposition to Natural Gras Canopies +! Water, Air, and Soil Pollution 18 (1982) 25-43 + +! Snow covered surface: The experiment of Ibrahim et al. (1983) +! gives k = 436 for 0.7 um diameter particles. +! The deposition velocity of Milford and Davidson (1987) +! gives k = 154 for continental sulfate aerosol. +! M. Ibrahim, L. A. Barrie and F. Fanaki +! Atmospheric Environment 17 (1983), 781-788 + +! J. B. Milford and C. I. Davidson +! The Sizes of Particulate Sulfate and Nitrate in the Atmosphere +! - A Review +! JAPCA 37 (1987), 125-134 +! no data +! WRITE (0,*) ' return from rcread ' +! ********************************************************* + +! Simplified landuse scheme for deposition and biogenic emission +! subroutines +! (ISWATER and ISICE are already defined elsewhere, +! therefore water and ice are not considered here) + +! 1 urban or bare soil +! 2 agricultural +! 3 grassland +! 4 deciduous forest +! 5 coniferous and mixed forest +! 6 other natural landuse categories + + + IF (mminlu=='OLD ') THEN + this%ixxxlu(1) = 1 + this%ixxxlu(2) = 2 + this%ixxxlu(3) = 3 + this%ixxxlu(4) = 4 + this%ixxxlu(5) = 5 + this%ixxxlu(6) = 5 + this%ixxxlu(7) = 0 + this%ixxxlu(8) = 6 + this%ixxxlu(9) = 1 + this%ixxxlu(10) = 6 + this%ixxxlu(11) = 0 + this%ixxxlu(12) = 4 + this%ixxxlu(13) = 6 + END IF + IF (mminlu=='USGS') THEN + this%ixxxlu(1) = 1 + this%ixxxlu(2) = 2 + this%ixxxlu(3) = 2 + this%ixxxlu(4) = 2 + this%ixxxlu(5) = 2 + this%ixxxlu(6) = 4 + this%ixxxlu(7) = 3 + this%ixxxlu(8) = 6 + this%ixxxlu(9) = 3 + this%ixxxlu(10) = 6 + this%ixxxlu(11) = 4 + this%ixxxlu(12) = 5 + this%ixxxlu(13) = 4 + this%ixxxlu(14) = 5 + this%ixxxlu(15) = 5 + this%ixxxlu(16) = 0 + this%ixxxlu(17) = 6 + this%ixxxlu(18) = 4 + this%ixxxlu(19) = 1 + this%ixxxlu(20) = 6 + this%ixxxlu(21) = 4 + this%ixxxlu(22) = 6 + this%ixxxlu(23) = 1 + this%ixxxlu(24) = 0 + this%ixxxlu(25) = 1 + END IF + IF (mminlu=='SiB ') THEN + this%ixxxlu(1) = 4 + this%ixxxlu(2) = 4 + this%ixxxlu(3) = 4 + this%ixxxlu(4) = 5 + this%ixxxlu(5) = 5 + this%ixxxlu(6) = 6 + this%ixxxlu(7) = 3 + this%ixxxlu(8) = 6 + this%ixxxlu(9) = 6 + this%ixxxlu(10) = 6 + this%ixxxlu(11) = 1 + this%ixxxlu(12) = 2 + this%ixxxlu(13) = 6 + this%ixxxlu(14) = 1 + this%ixxxlu(15) = 0 + this%ixxxlu(16) = 0 + this%ixxxlu(17) = 1 + END IF + + END SUBROUTINE dep_init +end module rrfs_smoke_data diff --git a/physics/smoke/rrfs_smoke_lsdep_wrapper.F90 b/physics/smoke/rrfs_smoke_lsdep_wrapper.F90 new file mode 100644 index 000000000..1fd7a2d3f --- /dev/null +++ b/physics/smoke/rrfs_smoke_lsdep_wrapper.F90 @@ -0,0 +1,323 @@ +!>\file rrfs_smoke_lsdep_wrapper.F90 +!! This file is RRFS-smoke large-scale wet deposition wrapper with CCPP +!! Haiqin.Li@noaa.gov 04/2021 + + module rrfs_smoke_lsdep_wrapper + + use machine , only : kind_phys + use rrfs_smoke_config + use dep_wet_ls_mod + use dust_data_mod + use rrfs_smoke_data + + implicit none + + private + + public :: rrfs_smoke_lsdep_wrapper_run + +contains + +!>\defgroup rrfs_smoke_lsdep_wrapper GSD Chem driver Module +!> \ingroup gsd_chem_group +!! This is the GSD Chem driver Module +!! \section arg_table_rrfs_smoke_lsdep_wrapper_run Argument Table +!! \htmlinclude rrfs_smoke_lsdep_wrapper_run.html +!! +!>\section rrfs_smoke_lsdep_wrapper GSD Chemistry Scheme General Algorithm +!> @{ + subroutine rrfs_smoke_lsdep_wrapper_run(im, kte, kme, ktau, dt, & + rain_cpl, rainc_cpl, g, & + pr3d, ph3d,phl3d, prl3d, tk3d, us3d, vs3d, spechum, & + w, dqdt, ntrac,ntsmoke,ntdust, & + gq0,qgrs,wetdep_ls_opt_in, & + errmsg,errflg) + + implicit none + + + integer, intent(in) :: im,kte,kme,ktau + integer, intent(in) :: ntrac,ntsmoke,ntdust + real(kind_phys),intent(in) :: dt,g + + integer, parameter :: ids=1,jds=1,jde=1, kds=1 + integer, parameter :: ims=1,jms=1,jme=1, kms=1 + integer, parameter :: its=1,jts=1,jte=1, kts=1 + + real(kind_phys), dimension(:), intent(in) :: rain_cpl, rainc_cpl + real(kind_phys), dimension(:,:), intent(in) :: ph3d, pr3d + real(kind_phys), dimension(:,:), intent(in) :: phl3d, prl3d, tk3d, & + us3d, vs3d, spechum, w, dqdt + real(kind_phys), dimension(:,:,:), intent(inout) :: gq0, qgrs + integer, intent(in) :: wetdep_ls_opt_in + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + real(kind_phys), dimension(1:im, 1:kme,jms:jme) :: rri, t_phy, u_phy, v_phy, & + p_phy, z_at_w, dz8w, p8w, t8w, rho_phy, vvel, dqdti + + real(kind_phys), dimension(ims:im, jms:jme) :: rcav, rnav + +!>- vapor & chemistry variables + real(kind_phys), dimension(ims:im, kms:kme, jms:jme, 1:num_moist) :: moist + real(kind_phys), dimension(ims:im, kms:kme, jms:jme, 1:num_chem ) :: chem + real(kind_phys), dimension(ims:im, jms:jme, 1:num_chem ) :: var_rmv + + integer :: ide, ime, ite, kde + + real(kind_phys) :: dtstep + real(kind_phys), dimension(1:num_chem) :: ppm2ugkg + + type(smoke_data), pointer :: data + +!>-- local variables + integer :: i, j, jp, k, kp, n + + data=>get_thread_smoke_data() + + errmsg = '' + errflg = 0 + + wetdep_ls_opt = wetdep_ls_opt_in + !print*,'hli wetdep_ls_opt',wetdep_ls_opt + + ! -- set domain + ide=im + ime=im + ite=im + kde=kte + + ! -- volume to mass fraction conversion table (ppm -> ug/kg) + ppm2ugkg = 1._kind_phys + !ppm2ugkg(p_so2 ) = 1.e+03_kind_phys * mw_so2_aer / mwdry + ppm2ugkg(p_sulf) = 1.e+03_kind_phys * mw_so4_aer / mwdry + + ! -- initialize large-sacle wet depostion + if (ktau==1) then + call dep_wet_ls_init(data) + endif + + ! -- set control flags + + ! -- compute accumulated large-scale and convective rainfall since last call + if (ktau > 1) then + dtstep = call_chemistry * dt + else + dtstep = dt + end if + + ! -- compute incremental convective and large-scale rainfall + do i=its,ite + rcav(i,1)=max(rainc_cpl(i)*1000. , 0.) ! meter to mm + rnav(i,1)=max((rain_cpl(i)-rainc_cpl(i))*1000., 0.) ! meter to mm + enddo + +!!! + +!>- get ready for chemistry run + call rrfs_smoke_prep_lsdep(data,ktau,dtstep, & + pr3d,ph3d,phl3d,tk3d,prl3d,us3d,vs3d,spechum,w, dqdt, & + rri,t_phy,u_phy,v_phy,p_phy,rho_phy,dz8w,p8w, & + t8w,dqdti,z_at_w,vvel,g, & + ntsmoke,ntdust, & + ntrac,gq0,num_chem, num_moist, & + ppm2ugkg,moist,chem, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) + + ! -- ls wet deposition + select case (wetdep_ls_opt) + case (WDLS_OPT_GSD) + call wetdep_ls(data,dt,chem,rnav,moist,rho_phy,var_rmv, & + num_moist,num_chem,p_qc,p_qi,dz8w,vvel, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) + case (WDLS_OPT_NGAC) + call WetRemovalGOCART(data,its,ite, jts,jte, kts,kte, 1,1, dt, & + num_chem,var_rmv,chem,p_phy,t_phy, & + rho_phy,dqdti,rcav,rnav, g, & + ims,ime, jms,jme, kms,kme) + !if (chem_rc_check(localrc, msg="Failure in NGAC wet removal scheme", & + ! file=__FILE__, line=__LINE__, rc=rc)) return + case default + ! -- no further option implemented + end select + + + ! -- put chem stuff back into tracer array + do k=kts,kte + do i=its,ite + gq0(i,k,ntsmoke)=ppm2ugkg(p_oc1 ) * max(epsilc,chem(i,k,1,p_oc1)) + gq0(i,k,ntdust )=ppm2ugkg(p_dust_1) * max(epsilc,chem(i,k,1,p_dust_1)) + enddo + enddo + + do k=kts,kte + do i=its,ite + qgrs(i,k,ntsmoke)=gq0(i,k,ntsmoke) + qgrs(i,k,ntdust )=gq0(i,k,ntdust ) + enddo + enddo + + +! + end subroutine rrfs_smoke_lsdep_wrapper_run +!> @} + + subroutine rrfs_smoke_prep_lsdep(data,ktau,dtstep, & + pr3d,ph3d,phl3d,tk3d,prl3d,us3d,vs3d,spechum,w,dqdt, & + rri,t_phy,u_phy,v_phy,p_phy,rho_phy,dz8w,p8w, & + t8w,dqdti,z_at_w,vvel,g, & + ntsmoke,ntdust, & + ntrac,gq0,num_chem, num_moist, & + ppm2ugkg,moist,chem, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) + implicit none + type(smoke_data), intent(inout) :: data + + !Chem input configuration + integer, intent(in) :: ktau + real(kind=kind_phys), intent(in) :: dtstep,g + + !FV3 input variables + integer, intent(in) :: ntrac,ntsmoke,ntdust + real(kind=kind_phys), dimension(ims:ime, kms:kme), intent(in) :: pr3d,ph3d + real(kind=kind_phys), dimension(ims:ime, kts:kte), intent(in) :: & + phl3d,tk3d,prl3d,us3d,vs3d,spechum,w,dqdt + real(kind=kind_phys), dimension(ims:ime, kts:kte,ntrac), intent(in) :: gq0 + + + !GSD Chem variables + integer,intent(in) :: num_chem, num_moist + integer,intent(in) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + real(kind_phys), dimension(num_chem), intent(in) :: ppm2ugkg + + real(kind_phys), dimension(ims:ime, kms:kme, jms:jme), intent(out) :: & + rri, t_phy, u_phy, v_phy, p_phy, rho_phy, dz8w, p8w, t8w, vvel, dqdti + real(kind_phys), dimension(ims:ime, kms:kme, jms:jme, num_moist), intent(out) :: moist + real(kind_phys), dimension(ims:ime, kms:kme, jms:jme, num_chem), intent(out) :: chem + + real(kind_phys), dimension(ims:ime, kms:kme, jms:jme), intent(out) :: z_at_w + + ! -- local variables +! real(kind=kind_phys), dimension(ims:ime, kms:kme, jms:jme) :: p_phy + real(kind_phys) :: factor,factor2,pu,pl,aln,pwant + real(kind_phys) :: xhour,xmin,xlonn,xtime,real_time + real(kind_phys), DIMENSION (1,1) :: sza,cosszax + integer i,ip,j,jp,k,kp,kk,kkp,nv,jmax,jmaxi,l,ll,n,ndystep,ixhour + + ! -- initialize output arrays + rri = 0._kind_phys + t_phy = 0._kind_phys + u_phy = 0._kind_phys + v_phy = 0._kind_phys + p_phy = 0._kind_phys + rho_phy = 0._kind_phys + dz8w = 0._kind_phys + p8w = 0._kind_phys + t8w = 0._kind_phys + vvel = 0._kind_phys + dqdti = 0._kind_phys + moist = 0._kind_phys + chem = 0._kind_phys + z_at_w = 0._kind_phys + + + do j=jts,jte + jp = j - jts + 1 + do i=its,ite + ip = i - its + 1 + z_at_w(i,kts,j)=max(0.,ph3d(ip,1)/g) + enddo + enddo + + do j=jts,jte + jp = j - jts + 1 + do k=kts,kte + kp = k - kts + 1 + do i=its,ite + ip = i - its + 1 + dz8w(i,k,j)=abs(ph3d(ip,kp+1)-ph3d(ip,kp))/g + z_at_w(i,k+1,j)=z_at_w(i,k,j)+dz8w(i,k,j) + enddo + enddo + enddo + + do j=jts,jte + jp = j - jts + 1 + do k=kts,kte+1 + kp = k - kts + 1 + do i=its,ite + ip = i - its + 1 + p8w(i,k,j)=pr3d(ip,kp) + enddo + enddo + enddo + + do j=jts,jte + jp = j - jts + 1 + do k=kts,kte+1 + kk=min(k,kte) + kkp = kk - kts + 1 + do i=its,ite + ip = i - its + 1 + dz8w(i,k,j)=z_at_w(i,kk+1,j)-z_at_w(i,kk,j) + t_phy(i,k,j)=tk3d(ip,kkp) + p_phy(i,k,j)=prl3d(ip,kkp) + u_phy(i,k,j)=us3d(ip,kkp) + dqdti(i,k,j)=dqdt(ip,kkp) + v_phy(i,k,j)=vs3d(ip,kkp) + rho_phy(i,k,j)=p_phy(i,k,j)/(287.04*t_phy(i,k,j)*(1.+.608*spechum(ip,kkp))) + rri(i,k,j)=1./rho_phy(i,k,j) + vvel(i,k,j)=-w(ip,kkp)*rri(i,k,j)/g + moist(i,k,j,:)=0. + moist(i,k,j,1)=gq0(ip,kkp,p_atm_shum) + if (t_phy(i,k,j) > 265.) then + moist(i,k,j,2)=gq0(ip,kkp,p_atm_cldq) + moist(i,k,j,3)=0. + if (moist(i,k,j,2) < 1.e-8) moist(i,k,j,2)=0. + else + moist(i,k,j,2)=0. + moist(i,k,j,3)=gq0(ip,kkp,p_atm_cldq) + if(moist(i,k,j,3) < 1.e-8)moist(i,k,j,3)=0. + endif + !-- + enddo + enddo + enddo + + do j=jts,jte + do k=2,kte + do i=its,ite + t8w(i,k,j)=.5*(t_phy(i,k,j)+t_phy(i,k-1,j)) + enddo + enddo + enddo + + ! -- only used in phtolysis.... + do j=jts,jte + do i=its,ite + t8w(i,1,j)=t_phy(i,1,j) + t8w(i,kte+1,j)=t_phy(i,kte,j) + enddo + enddo + + + do k=kms,kte + do i=ims,ime + chem(i,k,jts,p_oc1 )=max(epsilc,gq0(i,k,ntsmoke)/ppm2ugkg(p_oc1)) + chem(i,k,jts,p_dust_1)=max(epsilc,gq0(i,k,ntdust )/ppm2ugkg(p_dust_1)) + enddo + enddo + + + end subroutine rrfs_smoke_prep_lsdep +!> @} + end module rrfs_smoke_lsdep_wrapper diff --git a/physics/smoke/rrfs_smoke_lsdep_wrapper.meta b/physics/smoke/rrfs_smoke_lsdep_wrapper.meta new file mode 100755 index 000000000..23c71fce8 --- /dev/null +++ b/physics/smoke/rrfs_smoke_lsdep_wrapper.meta @@ -0,0 +1,208 @@ +[ccpp-table-properties] + name = rrfs_smoke_lsdep_wrapper + type = scheme + dependencies = dep_dry_gocart_mod.F90,dep_dry_mod.F90,dep_simple_mod.F90,dep_vertmx_mod.F90,dep_wet_ls_mod.F90,dust_data_mod.F90,dust_fengsha_mod.F90,module_add_emiss_burn.F90,module_plumerise1.F90,module_smoke_plumerise.F90,module_zero_plumegen_coms.F90,plume_data_mod.F90,rrfs_smoke_config.F90,rrfs_smoke_data.F90,seas_data_mod.F90,seas_mod.F90,seas_ngac_mod.F90 + +######################################################################## +[ccpp-arg-table] + name = rrfs_smoke_lsdep_wrapper_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[kte] + standard_name = vertical_layer_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in +[kme] + standard_name = vertical_interface_dimension + long_name = number of vertical levels plus one + units = count + dimensions = () + type = integer + intent = in +[ktau] + standard_name = index_of_timestep + long_name = current forecast iteration + units = index + dimensions = () + type = integer + intent = in +[dt] + standard_name = timestep_for_physics + long_name = physics time step + units = s + dimensions = () + type = real + kind = kind_phys + intent = in +[rain_cpl] + standard_name = lwe_thickness_of_precipitation_amount_on_dynamics_timestep + long_name = total rain at this time step + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[rainc_cpl] + standard_name = lwe_thickness_of_convective_precipitation_amount_on_dynamics_timestep + long_name = convective rain at this time step + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in +[pr3d] + standard_name = air_pressure_at_interface + long_name = air pressure at model layer interfaces + units = Pa + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = in +[ph3d] + 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 +[phl3d] + standard_name = geopotential + long_name = geopotential at model layer centers + units = m2 s-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[prl3d] + 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 +[tk3d] + standard_name = air_temperature_of_new_state + long_name = updated temperature + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[us3d] + standard_name = x_wind_of_new_state + long_name = updated x-direction wind + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[vs3d] + standard_name = y_wind_of_new_state + long_name = updated y-direction wind + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[spechum] + standard_name = specific_humidity_of_new_state + long_name = water vapor specific humidity updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[w] + 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 +[dqdt] + standard_name = instantaneous_water_vapor_specific_humidity_tendency_due_to_convection + long_name = instantaneous moisture tendency due to convection + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[ntrac] + standard_name = number_of_tracers + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = in +[ntsmoke] + standard_name = index_for_smoke_in_tracer_concentration_array + long_name = tracer index for smoke + units = index + dimensions = () + type = integer + intent = in +[ntdust] + standard_name = index_for_dust_in_tracer_concentration_array + long_name = tracer index for dust + units = index + dimensions = () + type = integer + intent = in +[gq0] + standard_name = tracer_concentration_of_new_state + long_name = tracer concentration updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = inout +[qgrs] + standard_name = tracer_concentration + long_name = model layer mean tracer concentration + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = inout +[wetdep_ls_opt_in] + standard_name = control_for_smoke_wet_deposition + long_name = rrfs smoke large scale wet deposition option + units = index + 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 diff --git a/physics/smoke/rrfs_smoke_postpbl.F90 b/physics/smoke/rrfs_smoke_postpbl.F90 new file mode 100755 index 000000000..f83aaf795 --- /dev/null +++ b/physics/smoke/rrfs_smoke_postpbl.F90 @@ -0,0 +1,59 @@ +!>\file rrfs_smoke_postpbl.F90 +!! This file is CCPP RRFS smoke postpbl driver +!! Haiqin.Li@noaa.gov 03/2022 + + module rrfs_smoke_postpbl + + use machine , only : kind_phys + use rrfs_smoke_config + + implicit none + + private + + public :: rrfs_smoke_postpbl_run + +contains + +!>\defgroup rrfs_smoke_postpbl GSD Chem emission driver Module +!> \ingroup gsd_chem_group +!! This is the GSD Chem emission driver Module +!! \section arg_table_rrfs_smoke_postpbl_run Argument Table +!! \htmlinclude rrfs_smoke_postpbl_run.html +!! +!>\section rrfs_smoke_postpbl GSD Chemistry Scheme General Algorithm +!> @{ + subroutine rrfs_smoke_postpbl_run(ite, kte, ntsmoke, ntdust, ntrac, & + qgrs, chem3d, errmsg, errflg) + + implicit none + + + integer, intent(in) :: ite,kte,ntsmoke,ntdust,ntrac + + integer, parameter :: its=1,kts=1 + + real(kind_phys), dimension(:,:,:), intent(inout) :: qgrs + real(kind_phys), dimension(:,:,:), intent(inout) :: chem3d + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + +!>-- local variables + integer :: i, k + + errmsg = '' + errflg = 0 + + !--- put smoke stuff back into tracer array + + do k=kts,kte + do i=its,ite + qgrs(i,k,ntsmoke)= chem3d(i,k,1) + qgrs(i,k,ntdust )= chem3d(i,k,2) + enddo + enddo + + end subroutine rrfs_smoke_postpbl_run + +!> @} + end module rrfs_smoke_postpbl diff --git a/physics/smoke/rrfs_smoke_postpbl.meta b/physics/smoke/rrfs_smoke_postpbl.meta new file mode 100755 index 000000000..99aae69f2 --- /dev/null +++ b/physics/smoke/rrfs_smoke_postpbl.meta @@ -0,0 +1,75 @@ +[ccpp-table-properties] + name = rrfs_smoke_wrapper + type = scheme + dependencies = dep_dry_gocart_mod.F90,dep_dry_mod.F90,dep_simple_mod.F90,dep_vertmx_mod.F90,dep_wet_ls_mod.F90,dust_data_mod.F90,dust_fengsha_mod.F90,module_add_emiss_burn.F90,module_plumerise1.F90,module_smoke_plumerise.F90,module_zero_plumegen_coms.F90,plume_data_mod.F90,rrfs_smoke_config.F90,rrfs_smoke_data.F90,seas_data_mod.F90,seas_mod.F90,seas_ngac_mod.F90 + +######################################################################## +[ccpp-arg-table] + name = rrfs_smoke_wrapper_run + type = scheme +[ite] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[kte] + standard_name = vertical_layer_dimension + long_name = vertical layer dimension + units = count + dimensions = () + type = integer + intent = in +[ntsmoke] + standard_name = index_for_smoke_in_tracer_concentration_array + long_name = tracer index for smoke + units = index + dimensions = () + type = integer + intent = in +[ntdust] + standard_name = index_for_dust_in_tracer_concentration_array + long_name = tracer index for dust + units = index + dimensions = () + type = integer + intent = in +[ntrac] + standard_name = number_of_tracers + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = in +[qgrs] + standard_name = tracer_concentration + long_name = model layer mean tracer concentration + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = inout +[chem3d] + standard_name = chem3d_mynn_pbl_transport + long_name = mynn pbl transport of smoke and dust + units = various + dimensions = (horizontal_loop_extent,vertical_layer_dimension,2) + type = real + kind = kind_phys + intent = inout +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out diff --git a/physics/smoke/rrfs_smoke_wrapper.F90 b/physics/smoke/rrfs_smoke_wrapper.F90 new file mode 100755 index 000000000..ac32e1ad4 --- /dev/null +++ b/physics/smoke/rrfs_smoke_wrapper.F90 @@ -0,0 +1,750 @@ +!>\file rrfs_smoke_wrapper.F90 +!! This file is CCPP RRFS smoke driver +!! Haiqin.Li@noaa.gov 02/2021 + + module rrfs_smoke_wrapper + + use machine , only : kind_phys + use rrfs_smoke_config + use dust_data_mod + use seas_mod, only : gocart_seasalt_driver + use dust_fengsha_mod,only : gocart_dust_fengsha_driver + use plume_data_mod + use module_plumerise1 !plume_rise_mod + use module_add_emiss_burn + use dep_dry_mod + use rrfs_smoke_data + + implicit none + + private + + public :: rrfs_smoke_wrapper_run + +contains + +!>\defgroup rrfs_smoke_wrapper GSD Chem emission driver Module +!> \ingroup gsd_chem_group +!! This is the GSD Chem emission driver Module +!! \section arg_table_rrfs_smoke_wrapper_run Argument Table +!! \htmlinclude rrfs_smoke_wrapper_run.html +!! +!>\section rrfs_smoke_wrapper GSD Chemistry Scheme General Algorithm +!> @{ + subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, & + u10m, v10m, ustar, rlat, rlon, tskin, pb2d, t2m, dpt2m, & + pr3d, ph3d,phl3d, prl3d, tk3d, us3d, vs3d, spechum, w, & + nsoil, smc, vegtype, soiltyp, sigmaf, dswsfc, zorl,snow, & + julian, idat, rain_cpl, rainc_cpl, exch, hf2d, g, pi, con_cp, con_rd, & + dust12m_in, emi_in, smoke_GBBEPx, ntrac, qgrs, gq0, chem3d, tile_num, & + ntsmoke, ntdust, imp_physics, imp_physics_thompson, & + nwfa, nifa, emanoc, & + emdust, emseas, ebb_smoke_hr, frp_hr, frp_std_hr, & + coef_bb, ebu_smoke,fhist, min_fplume, max_fplume, hwp, & + smoke_ext, dust_ext, & + seas_opt_in, dust_opt_in, biomass_burn_opt_in, drydep_opt_in, & + do_plumerise_in, plumerisefire_frq_in, addsmoke_flag_in, & + smoke_forecast_in, aero_ind_fdb_in,dbg_opt_in,errmsg,errflg) + + implicit none + + + integer, intent(in) :: im,kte,kme,ktau,nsoil,tile_num,jdate(8),idat(8) + integer, intent(in) :: ntrac, ntsmoke, ntdust + real(kind_phys),intent(in) :: dt, julian, g, pi, con_cp, con_rd + logical, intent(in) :: smoke_forecast_in,aero_ind_fdb_in,dbg_opt_in + + integer, parameter :: ids=1,jds=1,jde=1, kds=1 + integer, parameter :: ims=1,jms=1,jme=1, kms=1 + integer, parameter :: its=1,jts=1,jte=1, kts=1 + + integer, dimension(:), intent(in) :: land, vegtype, soiltyp + real(kind_phys), dimension(:,:), intent(in) :: smc + real(kind_phys), dimension(:,:,:), intent(in) :: dust12m_in + real(kind_phys), dimension(:,:,:), intent(in) :: smoke_GBBEPx + real(kind_phys), dimension(:,:), intent(in) :: emi_in + real(kind_phys), dimension(:), intent(in) :: u10m, v10m, ustar, dswsfc, & + garea, rlat,rlon, tskin, pb2d, sigmaf, zorl, snow, & + rain_cpl, rainc_cpl, hf2d, t2m, dpt2m + real(kind_phys), dimension(:,:), intent(in) :: ph3d, pr3d + real(kind_phys), dimension(:,:), intent(in) :: phl3d, prl3d, tk3d, & + us3d, vs3d, spechum, exch, w + real(kind_phys), dimension(:,:,:), intent(inout) :: qgrs, gq0 + real(kind_phys), dimension(:,:,:), intent(inout) :: chem3d + real(kind_phys), dimension(:), intent(inout) :: emdust, emseas, emanoc + real(kind_phys), dimension(:), intent(inout) :: ebb_smoke_hr, frp_hr, frp_std_hr + real(kind_phys), dimension(:), intent(inout) :: coef_bb, fhist + real(kind_phys), dimension(:,:), intent(inout) :: ebu_smoke + real(kind_phys), dimension(:), intent(inout) :: max_fplume, min_fplume + real(kind_phys), dimension(:), intent( out) :: hwp + real(kind_phys), dimension(:,:), intent(out) :: smoke_ext, dust_ext + real(kind_phys), dimension(:,:), intent(inout) :: nwfa, nifa + integer, intent(in ) :: imp_physics, imp_physics_thompson + integer, intent(in) :: seas_opt_in, dust_opt_in, biomass_burn_opt_in, & + drydep_opt_in, plumerisefire_frq_in, addsmoke_flag_in + logical, intent(in ) :: do_plumerise_in + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + real(kind_phys), dimension(ims:im, kms:kme, jms:jme) :: ebu + real(kind_phys), dimension(1:im, 1:kme,jms:jme) :: rri, t_phy, u_phy, v_phy, & + p_phy, z_at_w, dz8w, p8w, t8w, rho_phy, vvel, zmid, exch_h + + real(kind_phys), dimension(ims:im, jms:jme) :: u10, v10, ust, tsk, & + xland, xlat, xlong, dxy, pbl, hfx, rcav, rnav + +!>- sea salt & chemistry variables + real(kind_phys), dimension(ims:im, kms:kme, jms:jme, 1:num_moist) :: moist + real(kind_phys), dimension(ims:im, kms:kme, jms:jme, 1:num_chem ) :: chem + real(kind_phys), dimension(ims:im, 1, jms:jme, 1:num_emis_seas ) :: emis_seas + real(kind_phys), dimension(ims:im, jms:jme, 1:num_chem ) :: dry_fall + real(kind_phys), dimension(ims:im, jms:jme) :: seashelp + + integer :: ide, ime, ite, kde, julday + +!>- dust & chemistry variables + real(kind_phys), dimension(ims:im, jms:jme) :: ssm, rdrag, uthr, snowh ! fengsha dust + real(kind_phys), dimension(ims:im, jms:jme) :: vegfrac, rmol, swdown, znt, clayf, sandf + real(kind_phys), dimension(ims:im, nsoil, jms:jme) :: smois + real(kind_phys), dimension(ims:im, 1:1, jms:jme, 1:num_emis_dust) :: emis_dust + integer, dimension(ims:im, jms:jme) :: isltyp, ivgtyp + +!>- plume variables + ! -- buffers + real(kind_phys), dimension(ims:im, jms:jme) :: ebu_in + real(kind_phys), dimension(ims:im, jms:jme, num_frp_plume ) :: plume_frp + real(kind_phys), dimension(ims:im, jms:jme ) :: coef_bb_dc, flam_frac, & + fire_hist, peak_hr + real(kind_phys), dimension(ims:im,kms:kme,jms:jme ) :: aod3d_smoke, aod3d_dust + integer, dimension(ims:im, jms:jme ) :: min_fplume2, max_fplume2 + real(kind_phys) :: dtstep + logical :: call_plume, scale_fire_emiss +!>- optical variables + real(kind_phys), dimension(ims:im, kms:kme, jms:jme) :: rel_hum + +!>-- anthropogentic variables +! real(kind_phys), dimension(ims:im, kms:kemit, jms:jme, 1:num_emis_ant) :: emis_ant + real(kind_phys), dimension(ims:im) :: emis_anoc + + real(kind_phys), dimension(ims:im, kms:kme, jms:jme) :: ac3, ahno3, anh3, asulf, cor3, h2oai, h2oaj, nu3 + real(kind_phys), dimension(ims:im, jms:jme) :: dep_vel_o3, e_co + + real(kind_phys) :: gmt + real(kind_phys), dimension(1:num_chem) :: ppm2ugkg + +!> -- parameter to caluclate wfa&ifa (m) + real(kind_phys), parameter :: mean_diameter1= 4.E-8, sigma1=1.8 + real(kind_phys), parameter :: mean_diameter2= 1.E-6, sigma2=1.8 + real(kind_phys), parameter :: kappa_oc = 0.2 + real(kind_phys), parameter :: kappa_dust = 0.04 + real(kind_phys) :: fact_wfa, fact_ifa +!> -- aerosol density (kg/m3) + real(kind_phys), parameter :: density_dust= 2.6e+3, density_sulfate=1.8e+3 + real(kind_phys), parameter :: density_oc = 1.4e+3, density_seasalt=2.2e+3 + + real(kind_phys) :: daero_emis_wfa, daero_emis_ifa +!>-- local variables + real(kind_phys), dimension(im) :: wdgust, snoweq + integer :: current_month, current_hour + real(kind_phys) :: curr_secs + real(kind_phys) :: factor, factor2, factor3 + integer :: nbegin, nv, nvv + integer :: i, j, jp, k, kp, n + + type(smoke_data), pointer :: data + + data => get_thread_smoke_data() + + errmsg = '' + errflg = 0 + +!>-- options to turn on/off sea-salt, dust, plume-rising + seas_opt = seas_opt_in + dust_opt = dust_opt_in + biomass_burn_opt = biomass_burn_opt_in + drydep_opt = drydep_opt_in + do_plumerise = do_plumerise_in + plumerisefire_frq = plumerisefire_frq_in + addsmoke_flag = addsmoke_flag_in + smoke_forecast = smoke_forecast_in + aero_ind_fdb = aero_ind_fdb_in + dbg_opt = dbg_opt_in + + !print*,'hli ktau',ktau + ! -- set domain + ide=im + ime=im + ite=im + kde=kte + + h2oai = 0. + h2oaj = 0. + nu3 = 0. + ac3 = 0. + cor3 = 0. + asulf = 0. + ahno3 = 0. + anh3 = 0. + e_co = 0. + dep_vel_o3 = 0. + + min_fplume2 = 0 + max_fplume2 = 0 + emis_seas = 0. + emis_dust = 0. + peak_hr = 0. + flam_frac = 0. + aod3d_smoke = 0. + aod3d_dust = 0. + + rcav = 0. + rnav = 0. + + curr_secs = ktau * dt + current_month=jdate(2) + current_hour =jdate(5)+1 + gmt = real(idat(5)) + julday = int(julian) + + ! -- volume to mass fraction conversion table (ppm -> ug/kg) + ppm2ugkg = 1._kind_phys + ppm2ugkg(p_sulf) = 1.e+03_kind_phys * mw_so4_aer / mwdry + + ! -- compute incremental convective and large-scale rainfall + do i=its,ite + rcav(i,1)=max(rainc_cpl(i)*1000. , 0.) ! meter to mm + rnav(i,1)=max((rain_cpl(i)-rainc_cpl(i))*1000., 0.) ! meter to mm + coef_bb_dc(i,1) = coef_bb(i) + fire_hist (i,1) = fhist (i) + enddo + + + ! plumerise frequency in minutes set up by the namelist input + call_plume = (biomass_burn_opt == BURN_OPT_ENABLE) .and. (plumerisefire_frq > 0) + if (call_plume) & + call_plume = (mod(int(curr_secs), max(1, 60*plumerisefire_frq)) == 0) & + .or. (ktau == 2) + + !scale_fire_emiss = .false. + + ! -- compute accumulated large-scale and convective rainfall since last call + if (ktau > 1) then + dtstep = call_chemistry * dt + else + dtstep = dt + end if + +!>- get ready for chemistry run + call rrfs_smoke_prep( & + ktau, current_month, current_hour, & + u10m,v10m,ustar,land,garea,rlat,rlon,tskin, & + pr3d,ph3d,phl3d,tk3d,prl3d,us3d,vs3d,spechum,exch,w, & + nsoil,smc,vegtype,soiltyp,sigmaf,dswsfc,zorl, & + snow,dust12m_in,emi_in,smoke_GBBEPx, & + hf2d, pb2d, g, pi, & + u10,v10,ust,tsk,xland,xlat,xlong,dxy, & + rri,t_phy,u_phy,v_phy,p_phy,rho_phy,dz8w,p8w, & + t8w,exch_h, & + z_at_w,vvel,zmid, & + ntrac,gq0, & + num_chem, num_moist, ppm2ugkg, & + ntsmoke, ntdust, & + moist,chem,plume_frp,ebu_in, & + ebb_smoke_hr, frp_hr, frp_std_hr, emis_anoc, & + smois,ivgtyp,isltyp,vegfrac,rmol,swdown,znt,hfx,pbl, & + snowh,clayf,rdrag,sandf,ssm,uthr,rel_hum, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) + +! Make this global, calculate at 1st time step only +!>-- for plumerise -- +!IF (ktau==1) THEN + do j=jts,jte + do i=its,ite + if (xlong(i,j)<-130.) then + peak_hr(i,j)= 0.0* 3600. ! peak at 24 UTC, fires in Alaska + elseif(xlong(i,j)<-115.) then + peak_hr(i,j)= 23.0* 3600. + elseif (xlong(i,j)<-100.) then + peak_hr(i,j)= 22.0* 3600. ! peak at 22 UTC, fires in the western US + elseif (xlong(i,j)<-85.) then + peak_hr(i,j)= 21.0* 3600. + elseif (xlong(i,j)<-70.) then ! peak at 20 UTC, fires in the eastern US + peak_hr(i,j)= 20.0* 3600. + else + peak_hr(i,j)= 19.0* 3600. + endif + enddo + enddo +!END IF + + IF (ktau==1) THEN + ebu = 0. + do j=jts,jte + do i=its,ite + ebu(i,kts,j)= ebu_in(i,j) + do k=kts+1,kte + ebu(i,k,j)= 0. + enddo + enddo + enddo + ELSE + do k=kts,kte + do i=its,ite + ebu(i,k,1)=ebu_smoke(i,k) + enddo + enddo + ENDIF + + +!>- compute sea-salt + ! -- compute sea salt + if (seas_opt >= SEAS_OPT_DEFAULT) then + call gocart_seasalt_driver(ktau,dt,rri,t_phy,moist, & + u_phy,v_phy,chem,rho_phy,dz8w,u10,v10,ust,p8w,tsk, & + xland,xlat,xlong,dxy,g,emis_seas,pi, & + seashelp,num_emis_seas,num_moist,num_chem,seas_opt, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) + endif + + !-- compute dust + select case (dust_opt) + case (DUST_OPT_FENGSHA) + ! Set at compile time in dust_data_mod: + call gocart_dust_fengsha_driver(data,dt,chem,rho_phy,smois,p8w,ssm, & + isltyp,vegfrac,snowh,xland,dxy,g,emis_dust,ust,znt, & + clayf,sandf,rdrag,uthr, & + num_emis_dust,num_moist,num_chem,nsoil, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) + end select + + ! compute wild-fire plumes + !-- to add a namelist option to turn on/off plume raising + !--- replace plumerise_driver with HRRR-smoke 05/10/2021 + !-- /scratch2/BMC/ap-fc/Ravan/rapid-refresh/WRFV3.9/smoke + ! Every hour (per namelist) the ebu_driver is called to calculate ebu, but + ! the plumerise is controlled by the namelist option of plumerise_flag + if (call_plume) then +! WRITE(*,*) 'plumerise is called at ktau= ',ktau + call ebu_driver ( & + data,flam_frac,ebu_in,ebu, & + t_phy,moist(:,:,:,p_qv), & + rho_phy,vvel,u_phy,v_phy,p_phy, & + z_at_w,zmid,ktau,g,con_cp,con_rd, & + plume_frp, min_fplume2, max_fplume2, & ! new approach + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, errmsg, errflg ) + if(errflg/=0) return + end if + + ! -- add biomass burning emissions at every timestep + if (addsmoke_flag == 1) then + call add_emis_burn(data,dtstep,ktau,dz8w,rho_phy,rel_hum,chem, & + julday,gmt,xlat,xlong, & + ivgtyp, vegfrac, peak_hr, & ! RAR + curr_secs,ebu, & + coef_bb_dc,fire_hist,aod3d_smoke,aod3d_dust, & + ! scalar(ims,kms,jms,P_QNWFA),scalar(ims,kms,jms,P_QNIFA), ! & + rcav, rnav,swdown,smoke_forecast, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + endif +! WRITE(*,*) 'after add_emis_burn at ktau= ',ktau + + !>-- compute dry deposition + if (drydep_opt == 1) then + call dry_dep_driver(data,ktau,dt,julday,current_month,t_phy,p_phy, & + moist,p8w,rmol,rri,gmt,t8w,rcav, & + chem,rho_phy,dz8w,exch_h,hfx, & + ivgtyp,tsk,swdown,vegfrac,pbl,ust,znt,zmid,z_at_w, & + xland,xlat,xlong,h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3, & + anh3,dry_fall,dep_vel_o3,g, & + e_co,kemit,snowh,numgas, & + num_chem,num_moist, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) + endif +! WRITE(*,*) 'dry depostion is done at ktau= ',ktau + + do k=kts,kte + do i=its,ite + ebu_smoke(i,k)=ebu(i,k,1) + enddo + enddo + + +!---- diagnostic output of hourly wildfire potential (07/2021) + hwp = 0. + do i=its,ite + wdgust(i)=1.68*sqrt(us3d(i,1)**2+vs3d(i,1)**2) + snoweq(i)=max((25.-snow(i)*1000.)/25.,0.) + !hwp(i)=44.09*wdgust(i)**1.82*max(0.,t2m(i)-dpt2m(i))**0.61*max(0.,1.-smc(i,1))**14.0*snoweq(i)*sigmaf(i) + hwp(i)=44.09*wdgust(i)**1.82*(t2m(i)-dpt2m(i))**0.61*(1.-smc(i,1))**14.0*snoweq(i)*sigmaf(i) + enddo + +!---- diagnostic output of smoke & dust optical extinction (12/2021) + do k=kts,kte + do i=its,ite + smoke_ext(i,k) = aod3d_smoke(i,k,1) + dust_ext (i,k) = aod3d_dust (i,k,1) + enddo + enddo +!------------------------------------- +!---- put smoke stuff back into tracer array + do k=kts,kte + do i=its,ite + gq0(i,k,ntsmoke )=ppm2ugkg(p_smoke ) * max(epsilc,chem(i,k,1,p_smoke)) ! + gq0(i,k,ntdust )=ppm2ugkg(p_dust_1) * max(epsilc,chem(i,k,1,p_dust_1)) + enddo + enddo + + do k=kts,kte + do i=its,ite + qgrs(i,k,ntsmoke )= gq0(i,k,ntsmoke ) + qgrs(i,k,ntdust )= gq0(i,k,ntdust ) + chem3d(i,k,1 )= gq0(i,k,ntsmoke ) + chem3d(i,k,2 )= gq0(i,k,ntdust ) + enddo + enddo +!------------------------------------- +!-- to output for diagnostics +! WRITE(*,*) 'rrfs nwfa/nifa 1 at ktau= ',ktau + do i = 1, im + emseas (i) = emis_seas (i,1,1,1)*1.e+9 ! size bin 1 sea salt emission: ug/m2/s + emdust (i) = emis_dust (i,1,1,1) ! size bin 1 dust emission : ug/m2/s + emanoc (i) = emis_anoc (i) ! anthropogenic organic carbon: ug/m2/s + coef_bb (i) = coef_bb_dc (i,1) + fhist (i) = fire_hist (i,1) + min_fplume (i) = real(min_fplume2(i,1)) + max_fplume (i) = real(max_fplume2(i,1)) + enddo + +! WRITE(*,*) 'rrfs nwfa/nifa 2 at ktau= ',ktau +!-- to provide real aerosol emission for Thompson MP + if (imp_physics == imp_physics_thompson .and. aero_ind_fdb) then + fact_wfa = 1.e-9*6.0/pi*exp(4.5*log(sigma1)**2)/mean_diameter1**3 + fact_ifa = 1.e-9*6.0/pi*exp(4.5*log(sigma2)**2)/mean_diameter2**3 + + do i = its, ite + do k = kts, kte + if (k==1)then + daero_emis_wfa =(emanoc(i)+ebu_smoke(i,k))/density_oc + emseas(i)/density_seasalt + else + daero_emis_wfa = ebu_smoke(i,k)/density_oc + endif + daero_emis_wfa = kappa_oc* daero_emis_wfa*fact_wfa*rri(i,k,1)/dz8w(i,k,1) ! consider using dust tracer + + nwfa(i,k) = nwfa(i,k) + daero_emis_wfa*dt + nifa(i,k) = gq0(i,k,ntdust)/density_dust*fact_ifa*kappa_dust ! Check the formula + + if(land(i).eq.1)then + nwfa(i,k) = nwfa(i,k)*(1 - 0.10*dt/86400.) !-- mimicking dry deposition + else + nwfa(i,k) = nwfa(i,k)*(1 - 0.05*dt/86400.) !-- mimicking dry deposition + endif + enddo + enddo + endif +! WRITE(*,*) 'rrfs smoke wrapper is done at ktau= ',ktau + + end subroutine rrfs_smoke_wrapper_run + + subroutine rrfs_smoke_prep( & + ktau,current_month,current_hour, & + u10m,v10m,ustar,land,garea,rlat,rlon,ts2d, & + pr3d,ph3d,phl3d,tk3d,prl3d,us3d,vs3d,spechum,exch,w, & + nsoil,smc,vegtype,soiltyp,sigmaf,dswsfc,zorl, & + snow_cpl,dust12m_in,emi_in,smoke_GBBEPx, & + hf2d, pb2d, g, pi, & + u10,v10,ust,tsk,xland,xlat,xlong,dxy, & + rri,t_phy,u_phy,v_phy,p_phy,rho_phy,dz8w,p8w, & + t8w,exch_h, & + z_at_w,vvel,zmid, & + ntrac,gq0, & + num_chem, num_moist, ppm2ugkg, & + ntsmoke, ntdust, & + !num_emis_ant, & + !emis_ant, & + moist,chem,plume_frp,ebu_in, & + ebb_smoke_hr, frp_hr, frp_std_hr, emis_anoc, & + smois,ivgtyp,isltyp,vegfrac,rmol,swdown,znt,hfx,pbl, & + snowh,clayf,rdrag,sandf,ssm,uthr,rel_hum, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) + + !Chem input configuration + integer, intent(in) :: ktau, current_month, current_hour + + !FV3 input variables + integer, intent(in) :: nsoil + integer, dimension(ims:ime), intent(in) :: land, vegtype, soiltyp + integer, intent(in) :: ntrac + real(kind=kind_phys), intent(in) :: g, pi + real(kind=kind_phys), dimension(ims:ime), intent(in) :: & + u10m, v10m, ustar, garea, rlat, rlon, ts2d, sigmaf, dswsfc, & + zorl, snow_cpl, pb2d, hf2d + real(kind=kind_phys), dimension(ims:ime, nsoil), intent(in) :: smc + real(kind=kind_phys), dimension(ims:ime, 12, 5), intent(in) :: dust12m_in + real(kind=kind_phys), dimension(ims:ime, 24, 3), intent(in) :: smoke_GBBEPx + real(kind=kind_phys), dimension(ims:ime, 1), intent(in) :: emi_in + real(kind=kind_phys), dimension(ims:ime, kms:kme), intent(in) :: pr3d,ph3d + real(kind=kind_phys), dimension(ims:ime, kts:kte), intent(in) :: & + phl3d,tk3d,prl3d,us3d,vs3d,spechum,exch,w + real(kind=kind_phys), dimension(ims:ime, kts:kte,ntrac), intent(in) :: gq0 + + + !GSD Chem variables + !integer,intent(in) :: num_emis_ant + integer,intent(in) :: num_chem, num_moist, ntsmoke, ntdust + integer,intent(in) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + + !real(kind_phys), dimension(ims:ime, kms:kemit, jms:jme, num_emis_ant), intent(inout) :: emis_ant + real(kind_phys), dimension(num_chem), intent(in) :: ppm2ugkg + real(kind_phys), dimension(ims:ime, jms:jme),intent(out) :: ebu_in + real(kind_phys), dimension(ims:ime, jms:jme, num_frp_plume), intent(out) :: plume_frp + + integer,dimension(ims:ime, jms:jme), intent(out) :: isltyp, ivgtyp + real(kind_phys), dimension(ims:ime, kms:kme, jms:jme), intent(out) :: & + rri, t_phy, u_phy, v_phy, p_phy, rho_phy, dz8w, p8w, t8w, vvel, & + zmid, exch_h, rel_hum + real(kind_phys), dimension(ims:ime, jms:jme), intent(out) :: & + u10, v10, ust, tsk, xland, xlat, xlong, dxy, vegfrac, rmol, swdown, znt, & + pbl, hfx, snowh, clayf, rdrag, sandf, ssm, uthr + real(kind_phys), dimension(ims:ime, kms:kme, jms:jme, num_moist), intent(out) :: moist + real(kind_phys), dimension(ims:ime, kms:kme, jms:jme, num_chem), intent(out) :: chem + + real(kind_phys), dimension(ims:ime, kms:kme, jms:jme), intent(out) :: z_at_w + real(kind_phys), dimension(ims:ime, nsoil, jms:jme), intent(out) :: smois + real(kind_phys), dimension(ims:ime), intent(inout) :: ebb_smoke_hr, frp_hr, frp_std_hr + real(kind_phys), dimension(ims:ime), intent(inout) :: emis_anoc + !real(kind_phys), dimension(ims:ime, jms:jme, num_plume_data) :: plume + real(kind_phys), parameter :: conv_frp = 1.e+06_kind_phys ! FRP conversion factor, MW to W + real(kind_phys), parameter :: frpc = 1._kind_phys ! FRP conversion factor (Regional) + + ! -- local variables + integer i,ip,j,jp,k,kp,kk,kkp,nv,l,ll,n + + ! -- initialize fire emissions + !plume = 0._kind_phys + plume_frp = 0._kind_phys + ebu_in = 0._kind_phys + ebb_smoke_hr = 0._kind_phys + emis_anoc = 0._kind_phys + + ! -- initialize output arrays + isltyp = 0._kind_phys + ivgtyp = 0._kind_phys + rri = 0._kind_phys + t_phy = 0._kind_phys + u_phy = 0._kind_phys + v_phy = 0._kind_phys + p_phy = 0._kind_phys + rho_phy = 0._kind_phys + dz8w = 0._kind_phys + p8w = 0._kind_phys + t8w = 0._kind_phys + vvel = 0._kind_phys + zmid = 0._kind_phys + exch_h = 0._kind_phys + u10 = 0._kind_phys + v10 = 0._kind_phys + ust = 0._kind_phys + tsk = 0._kind_phys + xland = 0._kind_phys + xlat = 0._kind_phys + xlong = 0._kind_phys + dxy = 0._kind_phys + vegfrac = 0._kind_phys + rmol = 0._kind_phys + swdown = 0._kind_phys + znt = 0._kind_phys + hfx = 0._kind_phys + pbl = 0._kind_phys + snowh = 0._kind_phys + clayf = 0._kind_phys + rdrag = 0._kind_phys + sandf = 0._kind_phys + ssm = 0._kind_phys + uthr = 0._kind_phys + moist = 0._kind_phys + chem = 0._kind_phys + z_at_w = 0._kind_phys + rel_hum = 0._kind_phys + + do i=its,ite + u10 (i,1)=u10m (i) + v10 (i,1)=v10m (i) + tsk (i,1)=ts2d (i) + ust (i,1)=ustar(i) + dxy (i,1)=garea(i) + xland(i,1)=real(land(i)) + xlat (i,1)=rlat(i)*180./pi + xlong(i,1)=rlon(i)*180./pi + swdown(i,1)=dswsfc(i) + znt (i,1)=zorl(i)*0.01 + hfx (i,1)=hf2d(i) + pbl (i,1)=pb2d(i) + snowh(i,1)=snow_cpl(i)*0.001 + clayf(i,1)=dust12m_in(i,current_month,1) + rdrag(i,1)=dust12m_in(i,current_month,2) + sandf(i,1)=dust12m_in(i,current_month,3) + ssm (i,1)=dust12m_in(i,current_month,4) + uthr (i,1)=dust12m_in(i,current_month,5) + ivgtyp (i,1)=vegtype(i) + isltyp (i,1)=soiltyp(i) + vegfrac(i,1)=sigmaf (i) + enddo + + rmol=0. + + do k=1,nsoil + do j=jts,jte + do i=its,ite + smois(i,k,j)=smc(i,k) + enddo + enddo + enddo + + !if (ktau <= 1) then + ! emis_ant = 0. + ! !emis_vol = 0. + !end if + + do j=jts,jte + jp = j - jts + 1 + do i=its,ite + ip = i - its + 1 + z_at_w(i,kts,j)=max(0.,ph3d(ip,1)/g) + enddo + enddo + + do j=jts,jte + jp = j - jts + 1 + do k=kts,kte + kp = k - kts + 1 + do i=its,ite + ip = i - its + 1 + dz8w(i,k,j)=abs(ph3d(ip,kp+1)-ph3d(ip,kp))/g + z_at_w(i,k+1,j)=z_at_w(i,k,j)+dz8w(i,k,j) + enddo + enddo + enddo + + do j=jts,jte + jp = j - jts + 1 + do k=kts,kte+1 + kp = k - kts + 1 + do i=its,ite + ip = i - its + 1 + p8w(i,k,j)=pr3d(ip,kp) + enddo + enddo + enddo + + do j=jts,jte + jp = j - jts + 1 + do k=kts,kte+1 + kk=min(k,kte) + kkp = kk - kts + 1 + do i=its,ite + ip = i - its + 1 + dz8w(i,k,j)=z_at_w(i,kk+1,j)-z_at_w(i,kk,j) + t_phy(i,k,j)=tk3d(ip,kkp) + p_phy(i,k,j)=prl3d(ip,kkp) + u_phy(i,k,j)=us3d(ip,kkp) + v_phy(i,k,j)=vs3d(ip,kkp) + rho_phy(i,k,j)=p_phy(i,k,j)/(287.04*t_phy(i,k,j)*(1.+.608*spechum(ip,kkp))) + rri(i,k,j)=1./rho_phy(i,k,j) + vvel(i,k,j)=-w(ip,kkp)*rri(i,k,j)/g + moist(i,k,j,:)=0. + moist(i,k,j,1)=gq0(ip,kkp,p_atm_shum) + if (t_phy(i,k,j) > 265.) then + moist(i,k,j,2)=gq0(ip,kkp,p_atm_cldq) + moist(i,k,j,3)=0. + if (moist(i,k,j,2) < 1.e-8) moist(i,k,j,2)=0. + else + moist(i,k,j,2)=0. + moist(i,k,j,3)=gq0(ip,kkp,p_atm_cldq) + if(moist(i,k,j,3) < 1.e-8)moist(i,k,j,3)=0. + endif + rel_hum(i,k,j) = .95 + rel_hum(i,k,j) = MIN( .95, moist(i,k,j,1) / & + (3.80*exp(17.27*(t_phy(i,k,j)-273.)/ & + (t_phy(i,k,j)-36.))/(.01*p_phy(i,k,j)))) + rel_hum(i,k,j)=max(0.1,rel_hum(i,k,j)) + !-- + zmid(i,k,j)=phl3d(ip,kkp)/g + enddo + enddo + enddo + + ! -- the imported atmospheric heat diffusivity is only available up to kte-1 + do k=kts,kte-1 + do i=its,ite + exch_h(i,k,1)=exch(i,k) + enddo + enddo + + do j=jts,jte + do k=2,kte + do i=its,ite + t8w(i,k,j)=.5*(t_phy(i,k,j)+t_phy(i,k-1,j)) + enddo + enddo + enddo + + ! -- only used in phtolysis.... + do j=jts,jte + do i=its,ite + t8w(i,1,j)=t_phy(i,1,j) + t8w(i,kte+1,j)=t_phy(i,kte,j) + enddo + enddo + + ! -- anthropogenic organic carbon + do i=its,ite + emis_anoc(i) = emi_in(i,1) + enddo + + ! select case (plumerise_flag) + ! case (FIRE_OPT_GBBEPx) + do j=jts,jte + do i=its,ite + ebb_smoke_hr(i) = smoke_GBBEPx(i,current_hour,1) ! smoke + frp_hr (i) = smoke_GBBEPx(i,current_hour,2) ! frp + frp_std_hr (i) = smoke_GBBEPx(i,current_hour,3) ! std frp + ebu_in (i,j) = ebb_smoke_hr(i) + plume_frp(i,j,p_frp_hr ) = conv_frp* frp_hr (i) + plume_frp(i,j,p_frp_std ) = conv_frp* frp_std_hr (i) + enddo + enddo + ! case default + ! end select + + ! We will add a namelist variable, real :: flam_frac_global + + do k=kms,kte + do i=ims,ime + chem(i,k,jts,p_smoke )=max(epsilc,gq0(i,k,ntsmoke )/ppm2ugkg(p_smoke)) + chem(i,k,jts,p_dust_1)=max(epsilc,gq0(i,k,ntdust )/ppm2ugkg(p_dust_1)) + enddo + enddo + + + + end subroutine rrfs_smoke_prep + +!> @} + end module rrfs_smoke_wrapper diff --git a/physics/smoke/rrfs_smoke_wrapper.meta b/physics/smoke/rrfs_smoke_wrapper.meta new file mode 100755 index 000000000..ef46b04ea --- /dev/null +++ b/physics/smoke/rrfs_smoke_wrapper.meta @@ -0,0 +1,654 @@ +[ccpp-table-properties] + name = rrfs_smoke_wrapper + type = scheme + dependencies = dep_dry_gocart_mod.F90,dep_dry_mod.F90,dep_simple_mod.F90,dep_vertmx_mod.F90,dep_wet_ls_mod.F90,dust_data_mod.F90,dust_fengsha_mod.F90,module_add_emiss_burn.F90,module_plumerise1.F90,module_smoke_plumerise.F90,module_zero_plumegen_coms.F90,plume_data_mod.F90,rrfs_smoke_config.F90,rrfs_smoke_data.F90,seas_data_mod.F90,seas_mod.F90,seas_ngac_mod.F90 + +######################################################################## +[ccpp-arg-table] + name = rrfs_smoke_wrapper_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[kte] + standard_name = vertical_layer_dimension + long_name = vertical layer dimension + units = count + dimensions = () + type = integer + intent = in +[kme] + standard_name = vertical_interface_dimension + long_name = number of vertical levels plus one + units = count + dimensions = () + type = integer + intent = in +[ktau] + standard_name = index_of_timestep + long_name = current forecast iteration + units = index + dimensions = () + type = integer + intent = in +[dt] + standard_name = timestep_for_physics + long_name = physics time step + units = s + dimensions = () + type = real + kind = kind_phys + intent = in +[garea] + standard_name = cell_area + long_name = grid cell area + units = m2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[land] + standard_name = sea_land_ice_mask + long_name = landmask: sea/land/ice=0/1/2 + units = flag + dimensions = (horizontal_loop_extent) + type = integer + intent = in +[jdate] + standard_name = date_and_time_of_forecast_in_united_states_order + long_name = current forecast date and time + units = none + dimensions = (8) + type = integer + intent = in +[u10m] + standard_name = x_wind_at_10m + long_name = 10 meter u wind speed + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[v10m] + standard_name = y_wind_at_10m + long_name = 10 meter v wind speed + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[ustar] + standard_name = surface_friction_velocity + long_name = boundary layer parameter + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[rlat] + standard_name = latitude + long_name = latitude + units = radian + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[rlon] + standard_name = longitude + long_name = longitude + units = radian + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[tskin] + standard_name = surface_skin_temperature + long_name = surface skin temperature + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[pb2d] + standard_name = atmosphere_boundary_layer_thickness + long_name = PBL thickness + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[t2m] + standard_name = air_temperature_at_2m + long_name = 2 meter temperature + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[dpt2m] + standard_name = dewpoint_temperature_at_2m + long_name = 2 meter dewpoint temperature + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[pr3d] + standard_name = air_pressure_at_interface + long_name = air pressure at model layer interfaces + units = Pa + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = in +[ph3d] + 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 +[phl3d] + standard_name = geopotential + long_name = geopotential at model layer centers + units = m2 s-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[prl3d] + 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 +[tk3d] + standard_name = air_temperature_of_new_state + long_name = updated temperature + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[us3d] + standard_name = x_wind_of_new_state + long_name = updated x-direction wind + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[vs3d] + standard_name = y_wind_of_new_state + long_name = updated y-direction wind + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[spechum] + standard_name = specific_humidity_of_new_state + long_name = water vapor specific humidity updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[w] + 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 +[nsoil] + standard_name = vertical_dimension_of_soil + long_name = soil vertical layer dimension + units = count + dimensions = () + type = integer + intent = in +[smc] + standard_name = volume_fraction_of_condensed_water_in_soil + long_name = volumetric fraction of soil moisture + units = frac + dimensions = (horizontal_loop_extent,vertical_dimension_of_soil) + type = real + kind = kind_phys + intent = inout +[vegtype] + standard_name = vegetation_type_classification + long_name = vegetation type at each grid cell + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = in +[soiltyp] + standard_name = soil_type_classification + long_name = soil type at each grid cell + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = in +[sigmaf] + standard_name = bounded_vegetation_area_fraction + long_name = areal fractional cover of green vegetation bounded on the bottom + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[dswsfc] + standard_name = surface_downwelling_shortwave_flux + long_name = surface downwelling shortwave flux at current time + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[zorl] + standard_name = surface_roughness_length + long_name = surface roughness length in cm + units = cm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[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 = in +[julian] + standard_name = forecast_julian_day + long_name = julian day + units = days + dimensions = () + type = real + kind = kind_phys + intent = in +[idat] + standard_name = date_and_time_at_model_initialization_in_iso_order + long_name = initialization date and time + units = none + dimensions = (8) + type = integer + intent = in +[rain_cpl] + standard_name = lwe_thickness_of_precipitation_amount_on_dynamics_timestep + long_name = total rain at this time step + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[rainc_cpl] + standard_name = lwe_thickness_of_convective_precipitation_amount_on_dynamics_timestep + long_name = convective rain at this time step + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[exch] + standard_name = atmosphere_heat_diffusivity + long_name = diffusivity for heat + units = m2 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[hf2d] + standard_name = instantaneous_surface_upward_sensible_heat_flux + long_name = surface upward sensible heat flux valid for current call + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in +[pi] + standard_name = pi + long_name = ratio of a circle's circumference to its diameter + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[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_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 +[dust12m_in] + standard_name = fengsha_dust12m_input + long_name = fengsha dust input + units = various + dimensions = (horizontal_loop_extent,12,5) + type = real + kind = kind_phys + intent = in +[emi_in] + standard_name = anthropogenic_background_input + long_name = anthropogenic background input + units = various + dimensions = (horizontal_loop_extent,1) + type = real + kind = kind_phys + intent = in +[smoke_GBBEPx] + standard_name = emission_smoke_GBBEPx + long_name = emission fire GBBEPx + units = various + dimensions = (horizontal_loop_extent,24,3) + type = real + kind = kind_phys + intent = in +[ntrac] + standard_name = number_of_tracers + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = in +[qgrs] + standard_name = tracer_concentration + long_name = model layer mean tracer concentration + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = inout +[gq0] + standard_name = tracer_concentration_of_new_state + long_name = tracer concentration updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = inout +[chem3d] + standard_name = chem3d_mynn_pbl_transport + long_name = mynn pbl transport of smoke and dust + units = various + dimensions = (horizontal_loop_extent,vertical_layer_dimension,2) + type = real + kind = kind_phys + intent = inout +[tile_num] + standard_name = index_of_cubed_sphere_tile + long_name = tile number + units = none + dimensions = () + type = integer + intent = in +[ntsmoke] + standard_name = index_for_smoke_in_tracer_concentration_array + long_name = tracer index for smoke + units = index + dimensions = () + type = integer + intent = in +[ntdust] + standard_name = index_for_dust_in_tracer_concentration_array + long_name = tracer index for dust + units = index + dimensions = () + type = integer + intent = in +[imp_physics] + standard_name = control_for_microphysics_scheme + long_name = choice of microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[imp_physics_thompson] + standard_name = identifier_for_thompson_microphysics_scheme + long_name = choice of Thompson microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[nwfa] + standard_name = mass_number_concentration_of_hygroscopic_aerosols_of_new_state + long_name = number concentration of water-friendly aerosols + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[nifa] + standard_name = mass_number_concentration_of_nonhygroscopic_ice_nucleating_aerosols_of_new_state + long_name = number concentration of ice-friendly aerosols + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[emanoc] + standard_name = emission_of_anoc_for_thompson_mp + long_name = emission of anoc for thompson mp + units = ug m-2 s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[emdust] + standard_name = emission_of_dust_for_smoke + long_name = emission of dust for smoke + units = ug m-2 s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[emseas] + standard_name = emission_of_seas_for_smoke + long_name = emission of seas for smoke + units = ug m-2 s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[ebb_smoke_hr] + standard_name = surface_smoke_emission + long_name = emission of surface smoke + units = ug m-2 s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[frp_hr] + standard_name = frp_hourly + long_name = hourly fire radiative power + units = MW + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[frp_std_hr] + standard_name = frp_std_hourly + long_name = hourly stdandard deviation of fire radiative power + units = MW + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[coef_bb] + standard_name = coef_bb_dc + long_name = coef to estimate the fire emission + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[ebu_smoke] + standard_name = ebu_smoke + long_name = buffer of vertical fire emission + units = various + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[fhist] + standard_name = fire_hist + long_name = coefficient to scale the fire activity depending on the fire duration + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[min_fplume] + standard_name = minimum_fire_plume_sigma_pressure_level + long_name = minimum model level of fire plumerise + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[max_fplume] + standard_name = maximum_fire_plume_sigma_pressure_level + long_name = maximum model level of fire plumerise + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[hwp] + standard_name = hourly_wildfire_potential + long_name = rrfs hourly fire weather potential + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[smoke_ext] + standard_name = extinction_coefficient_in_air_due_to_smoke + long_name = extinction coefficient in air due to smoke + units = various + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[dust_ext] + standard_name = extinction_coefficient_in_air_due_to_dust + long_name = extinction coefficient in air due to dust + units = various + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[seas_opt_in] + standard_name = control_for_smoke_sea_salt + long_name = rrfs smoke sea salt emission option + units = index + dimensions = () + type = integer + intent = in +[dust_opt_in] + standard_name = control_for_smoke_dust + long_name = rrfs smoke dust chem option + units = index + dimensions = () + type = integer + intent = in +[biomass_burn_opt_in] + standard_name = control_for_smoke_biomass_burn + long_name = rrfs smoke biomass burning option + units = index + dimensions = () + type = integer + intent = in +[drydep_opt_in] + standard_name = control_for_smoke_dry_deposition + long_name = rrfs smoke dry deposition option + units = index + dimensions = () + type = integer + intent = in +[do_plumerise_in] + standard_name = do_smoke_plumerise + long_name = rrfs smoke plumerise option + units = index + dimensions = () + type = logical + intent = in +[plumerisefire_frq_in] + standard_name = smoke_plumerise_frequency + long_name = rrfs smoke add smoke option + units = min + dimensions = () + type = integer + intent = in +[addsmoke_flag_in] + standard_name = control_for_smoke_biomass_burning_emissions + long_name = rrfs smoke add smoke option + units = index + dimensions = () + type = integer + intent = in +[smoke_forecast_in] + standard_name = do_smoke_forecast + long_name = flag for rrfs smoke forecast + units = flag + dimensions = () + type = logical + intent = in +[aero_ind_fdb_in] + standard_name = do_smoke_aerosol_indirect_feedback + long_name = flag for rrfs wfa ifa emission + units = flag + dimensions = () + type = logical + intent = in +[dbg_opt_in] + standard_name = do_smoke_debug + long_name = flag for rrfs smoke plumerise debug + units = flag + dimensions = () + type = logical + intent = in +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out diff --git a/physics/smoke/seas_data_mod.F90 b/physics/smoke/seas_data_mod.F90 new file mode 100755 index 000000000..a6f451c39 --- /dev/null +++ b/physics/smoke/seas_data_mod.F90 @@ -0,0 +1,21 @@ +!>\file seas_data_mod.F90 +!! This file contains data for the sea salt emission modules. + +module seas_data_mod + + use machine , only : kind_phys + + ! -- parameters from NGAC v2.4.0 (rev. d48932c) + integer, parameter :: number_ss_bins = 5 + ! -- lower/upper particle radii (um) for each bin + real(kind=kind_phys), dimension(number_ss_bins), parameter :: ra = (/ 0.03, 0.1, 0.5, 1.5, 5.0 /) + real(kind=kind_phys), dimension(number_ss_bins), parameter :: rb = (/ 0.1, 0.5, 1.5, 5.0, 10.0 /) + ! -- global scaling factors for sea salt emissions (originally 0.875 in NGAC namelist) + !real(kind=kind_phys), dimension(number_ss_bins), parameter :: emission_scale = (/ 0.100, 0.100, 0.100, 0.100, 0.100 /) + real(kind=kind_phys), dimension(number_ss_bins), parameter :: emission_scale = (/ 1.0, 1.0, 1.0, 1.0, 1.0 /) + ! -- sea salt density + real(kind=kind_phys), dimension(number_ss_bins), parameter :: den_seas = (/ 2200., 2200., 2200., 2200., 2200. /) + ! -- particle effective radius (m) + real(kind=kind_phys), dimension(number_ss_bins), parameter :: reff_seas = (/ 0.079e-6, 0.316e-6, 1.119e-6, 2.818e-6, 7.772e-6 /) + +end module seas_data_mod diff --git a/physics/smoke/seas_mod.F90 b/physics/smoke/seas_mod.F90 new file mode 100755 index 000000000..85c861156 --- /dev/null +++ b/physics/smoke/seas_mod.F90 @@ -0,0 +1,431 @@ +!>\file seas_mod.F90 +!! This file contains the sea salt emission module. + +module seas_mod + + use machine , only : kind_phys +! use chem_rc_mod, only : chem_rc_test +! use chem_tracers_mod, only : p_seas_1, p_seas_2, p_seas_3, p_seas_4, p_seas_5, & +! p_eseas1, p_eseas2, p_eseas3, p_eseas4, p_eseas5, & +! config => chem_config + use seas_data_mod + use seas_ngac_mod + + implicit none + + integer, parameter :: SEAS_OPT_DEFAULT = 1 + integer, parameter :: CHEM_OPT_GOCART = 300 + integer, parameter :: chem_opt = 300 + + ! -- NGAC parameters + integer, parameter :: emission_scheme = 3 ! GEOSS 2012 + + private + + public :: SEAS_OPT_DEFAULT + + public :: gocart_seasalt_driver + +CONTAINS + + subroutine gocart_seasalt_driver(ktau,dt,alt,t_phy,moist,u_phy, & + v_phy,chem,rho_phy,dz8w,u10,v10,ustar,p8w,tsk, & + xland,xlat,xlong,area,g,emis_seas,pi, & + seashelp,num_emis_seas,num_moist,num_chem,seas_opt, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + INTEGER, INTENT(IN ) :: ktau,num_emis_seas,num_moist,num_chem, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte,seas_opt + REAL(kind=kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & + INTENT(IN ) :: moist + REAL(kind=kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(INOUT ) :: chem + REAL(kind=kind_phys), DIMENSION( ims:ime, 1, jms:jme,num_emis_seas), & + INTENT(OUT ) :: & + emis_seas + REAL(kind=kind_phys), DIMENSION( ims:ime , jms:jme ) , & + INTENT(IN ) :: & + u10, & + v10, & + ustar,tsk, & + xland, & + xlat, & + xlong,area + REAL(kind=kind_phys), DIMENSION( ims:ime , jms:jme ), & + INTENT(OUT ) :: seashelp + REAL(kind=kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ), & + INTENT(IN ) :: & + alt, & + t_phy, & + dz8w,p8w, & + u_phy,v_phy,rho_phy + + REAL(kind=kind_phys), INTENT(IN ) :: dt,g,pi +! + integer, parameter :: p_seas_1=15 + integer, parameter :: p_seas_2=16 + integer, parameter :: p_seas_3=17 + integer, parameter :: p_seas_4=18 + integer, parameter :: p_seas_5=19 + + integer, parameter :: p_eseas1=1 + integer, parameter :: p_eseas2=2 + integer, parameter :: p_eseas3=3 + integer, parameter :: p_eseas4=4 + integer, parameter :: p_eseas5=5 +! +! local variables +! + integer :: ipr,i,j,imx,jmx,lmx,n,rc,chem_config + integer,dimension (1,1) :: ilwi + real(kind=kind_phys) :: fsstemis, memissions, nemissions, tskin_c, ws10m + real(kind=kind_phys) :: delp + real(kind=kind_phys), DIMENSION (number_ss_bins) :: tc,bems + real(kind=kind_phys), dimension (1,1) ::w10m,airmas,tskin + real(kind=kind_phys), dimension (1) :: dxy + + real(kind=kind_phys), dimension(1,1,1) :: airmas1 + real(kind=kind_phys), dimension(1,1,1,number_ss_bins) :: tc1 + real(kind=kind_phys), dimension(1,1,number_ss_bins) :: bems1 + +! +! local parameters +! + real(kind=kind_phys), parameter :: conver = 1.e-9_kind_phys + real(kind=kind_phys), parameter :: converi = 1.e+9_kind_phys +! +! number of dust bins +! + imx=1 + jmx=1 + lmx=1 + + chem_config=CHEM_OPT_GOCART + + emis_seas = 0. + +! select case (config % chem_opt) + select case (chem_opt) + + case (304, 316, 317) + + seashelp(:,:)=0. + do j=jts,jte + do i=its,ite +! +! don't do dust over water!!! +! + if(xland(i,j).lt.0.5)then + ilwi(1,1)=0 + tc(1)=chem(i,kts,j,p_seas_1)*conver + tc(2)=1.e-30_kind_phys + tc(3)=chem(i,kts,j,p_seas_2)*conver + tc(4)=1.e-30_kind_phys + w10m(1,1)=sqrt(u10(i,j)*u10(i,j)+v10(i,j)*v10(i,j)) + tskin(1,1)=tsk(i,j) + delp = p8w(i,kts,j)-p8w(i,kts+1,j) + airmas(1,1)=area(i,j) * delp / g +! +! we don't trust the u10,v10 values, is model layers are very thin near surface +! + if(dz8w(i,kts,j).lt.12.)w10m=sqrt(u_phy(i,kts,j)*u_phy(i,kts,j)+v_phy(i,kts,j)*v_phy(i,kts,j)) +! + dxy(1)=area(i,j) + ipr=0 + + airmas1(1,1,1) = airmas(1,1) + tc1(1,1,1,:) = tc + bems1(1,1,:) = bems + call source_ss( imx, jmx, lmx, number_ss_bins, dt, tc1, pi, ilwi, dxy, w10m, airmas1, bems1,ipr) + tc = tc1(1,1,1,:) + chem(i,kts,j,p_seas_1)=(tc(1)+.75*tc(2))*converi + chem(i,kts,j,p_seas_2)=(tc(3)+.25*tc(2))*converi + seashelp(i,j)=tc(2)*converi + endif + enddo + enddo + + case default + + select case (seas_opt) + case (1) + ! -- original GOCART sea salt scheme + do j = jts, jte + do i = its, ite + + ! -- only use sea salt scheme over water + if (xland(i,j) < 0.5) then + + ! -- compute auxiliary variables + delp = p8w(i,kts,j)-p8w(i,kts+1,j) + if (dz8w(i,kts,j) < 12.) then + w10m = sqrt(u_phy(i,kts,j)*u_phy(i,kts,j)+v_phy(i,kts,j)*v_phy(i,kts,j)) + else + w10m = sqrt(u10(i,j)*u10(i,j)+v10(i,j)*v10(i,j)) + end if + + ilwi(1,1)=0 + tc = 0. + tskin(1,1)=tsk(i,j) + airmas(1,1)=area(i,j) * delp / g + dxy(1)=area(i,j) + ipr=0 + + airmas1(1,1,1) = airmas(1,1) + tc1(1,1,1,:) = tc + bems1(1,1,:) = bems + call source_ss( imx,jmx,lmx,number_ss_bins, dt, tc1, pi, ilwi, dxy, w10m, airmas1, bems1,ipr) + tc = tc1(1,1,1,:) + bems = bems1(1,1,:) + + ! -- add sea salt emission increments to existing airborne concentrations + chem(i,kts,j,p_seas_1) = chem(i,kts,j,p_seas_1) + tc(1)*converi + chem(i,kts,j,p_seas_2) = chem(i,kts,j,p_seas_2) + tc(2)*converi + chem(i,kts,j,p_seas_3) = chem(i,kts,j,p_seas_3) + tc(3)*converi + chem(i,kts,j,p_seas_4) = chem(i,kts,j,p_seas_4) + tc(4)*converi + chem(i,kts,j,p_seas_5) = chem(i,kts,j,p_seas_5) + tc(5)*converi + !print*,'hli tc(2),chem(i,kts,j,p_seas_2)',tc(2),chem(i,kts,j,p_seas_2) + + ! for output diagnostics + emis_seas(i,1,j,p_eseas1) = bems(1) + emis_seas(i,1,j,p_eseas2) = bems(2) + emis_seas(i,1,j,p_eseas3) = bems(3) + emis_seas(i,1,j,p_eseas4) = bems(4) + emis_seas(i,1,j,p_eseas5) = bems(5) + + end if + + end do + end do + + case (2) + ! -- NGAC sea salt scheme + do j = jts, jte + do i = its, ite + + ! -- only use sea salt scheme over water + if (xland(i,j) < 0.5) then + + ! -- compute auxiliary variables + delp = p8w(i,kts,j)-p8w(i,kts+1,j) + if (dz8w(i,kts,j) < 12.) then + ws10m = sqrt(u_phy(i,kts,j)*u_phy(i,kts,j)+v_phy(i,kts,j)*v_phy(i,kts,j)) + else + ws10m = sqrt(u10(i,j)*u10(i,j)+v10(i,j)*v10(i,j)) + end if + + ! -- compute NGAC SST correction + tskin_c = tsk(i,j) - 273.15 + tskin_c = min(max(tskin_c, -0.1), 36.0) ! temperature range (0, 36) C + + fsstemis = -1.107211 & + - tskin_c*(0.010681+0.002276*tskin_c) & + + 60.288927/(40.0 - tskin_c) + fsstemis = min(max(fsstemis, 0.0), 7.0) + + do n = 1, number_ss_bins + memissions = 0. + nemissions = 0. + call SeasaltEmission( ra(n), rb(n), emission_scheme, & + ws10m, ustar(i,j), pi, memissions, nemissions, rc ) +! if (chem_rc_test((rc /= 0), msg="Error in NGAC sea salt scheme", & +! file=__FILE__, line=__LINE__)) return + + bems(n) = emission_scale(n) * fsstemis * memissions + tc(n) = bems(n) * dt * g / delp + end do + + ! -- add sea salt emission increments to existing airborne concentrations + chem(i,kts,j,p_seas_1) = chem(i,kts,j,p_seas_1) + tc(1)*converi + chem(i,kts,j,p_seas_2) = chem(i,kts,j,p_seas_2) + tc(2)*converi + chem(i,kts,j,p_seas_3) = chem(i,kts,j,p_seas_3) + tc(3)*converi + chem(i,kts,j,p_seas_4) = chem(i,kts,j,p_seas_4) + tc(4)*converi + chem(i,kts,j,p_seas_5) = chem(i,kts,j,p_seas_5) + tc(5)*converi + + ! for output diagnostics kg/m2/s + emis_seas(i,1,j,p_eseas1) = bems(1) + emis_seas(i,1,j,p_eseas2) = bems(2) + emis_seas(i,1,j,p_eseas3) = bems(3) + emis_seas(i,1,j,p_eseas4) = bems(4) + emis_seas(i,1,j,p_eseas5) = bems(5) + end if + + end do + end do + + case default + ! -- no sea salt scheme + + end select + + end select + + end subroutine gocart_seasalt_driver + + SUBROUTINE source_ss(imx,jmx,lmx,nmx, dt1, tc, pi, & + ilwi, dxy, w10m, airmas, & + bems,ipr) + +! **************************************************************************** +! * Evaluate the source of each seasalt particles size classes (kg/m3) +! * by soil emission. +! * Input: +! * SSALTDEN Sea salt density (kg/m3) +! * DXY Surface of each grid cell (m2) +! * NDT1 Time step (s) +! * W10m Velocity at the anemometer level (10meters) (m/s) +! * +! * Output: +! * DSRC Source of each sea salt bins (kg/timestep/cell) +! * +! * +! * Number flux density: Original formula by Monahan et al. (1986) adapted +! * by Sunling Gong (JGR 1997 (old) and GBC 2003 (new)). The new version is +! * to better represent emission of sub-micron sea salt particles. +! +! * dFn/dr = c1*u10**c2/(r**A) * (1+c3*r**c4)*10**(c5*exp(-B**2)) +! * where B = (b1 -log(r))/b2 +! * see c_old, c_new, b_old, b_new below for the constants. +! * number fluxes are at 80% RH. +! * +! * To calculate the flux: +! * 1) Calculate dFn based on Monahan et al. (1986) and Gong (2003) +! * 2) Assume that wet radius r at 80% RH = dry radius r_d *frh +! * 3) Convert particles flux to mass flux : +! * dFM/dr_d = 4/3*pi*rho_d*r_d^3 *(dr/dr_d) * dFn/dr +! * = 4/3*pi*rho_d*r_d^3 * frh * dFn/dr +! * where rho_p is particle density [kg/m3] +! * The factor 1.e-18 is to convert in micro-meter r_d^3 +! **************************************************************************** + + + IMPLICIT NONE + + INTEGER, INTENT(IN) :: nmx,imx,jmx,lmx,ipr + INTEGER, INTENT(IN) :: ilwi(imx,jmx) + REAL(kind=kind_phys), INTENT(IN) :: dxy(jmx), w10m(imx,jmx), pi + REAL(kind=kind_phys), INTENT(IN) :: airmas(imx,jmx,lmx) + REAL(kind=kind_phys), INTENT(INOUT) :: tc(imx,jmx,lmx,nmx) + REAL(kind=kind_phys), INTENT(OUT) :: bems(imx,jmx,nmx) + + REAL(kind=kind_phys) :: c0(5), b0(2) +! REAL(kind=kind_phys), PARAMETER :: c_old(5)=(/1.373, 3.41, 0.057, 1.05, 1.190/) +! REAL(kind=kind_phys), PARAMETER :: c_new(5)=(/1.373, 3.41, 0.057, 3.45, 1.607/) + ! Change suggested by MC + REAL(kind=kind_phys), PARAMETER :: c_old(5)=(/1.373, 3.2, 0.057, 1.05, 1.190/) + REAL(kind=kind_phys), PARAMETER :: c_new(5)=(/1.373, 3.2, 0.057, 3.45, 1.607/) + REAL(kind=kind_phys), PARAMETER :: b_old(2)=(/0.380, 0.650/) + REAL(kind=kind_phys), PARAMETER :: b_new(2)=(/0.433, 0.433/) + REAL(kind=kind_phys), PARAMETER :: dr=5.0D-2 ! um + REAL(kind=kind_phys), PARAMETER :: theta=30.0 + ! Swelling coefficient frh (d rwet / d rd) +!!! REAL(kind=kind_phys), PARAMETER :: frh = 1.65 + REAL(kind=kind_phys), PARAMETER :: frh = 2.d0 + LOGICAL, PARAMETER :: old=.TRUE., new=.FALSE. + REAL(kind=kind_phys) :: rho_d, r0, r1, r, r_w, a, b, dfn, r_d, dfm, src + INTEGER :: i, j, n, nr, ir + REAL(kind=kind_phys) :: dt1,fudge_fac + + + REAL(kind=kind_phys) :: tcmw(nmx), ar(nmx), tcvv(nmx) + REAL(kind=kind_phys) :: ar_wetdep(nmx), kc(nmx) + CHARACTER(LEN=20) :: tcname(nmx), tcunits(nmx) + LOGICAL :: aerosol(nmx) + + + REAL(kind=kind_phys) :: tc1(imx,jmx,lmx,nmx) + REAL(kind=kind_phys), TARGET :: tcms(imx,jmx,lmx,nmx) ! tracer mass (kg; kgS for sulfur case) + REAL(kind=kind_phys), TARGET :: tcgm(imx,jmx,lmx,nmx) ! g/m3 + + !----------------------------------------------------------------------- + ! sea salt specific + !----------------------------------------------------------------------- +! REAL(kind=kind_phys), DIMENSION(nmx) :: ra, rb +! REAL(kind=kind_phys) :: ch_ss(nmx,12) + + !----------------------------------------------------------------------- + ! emissions (input) + !----------------------------------------------------------------------- + REAL(kind=kind_phys) :: e_an(imx,jmx,2,nmx), e_bb(imx,jmx,nmx), & + e_ac(imx,jmx,lmx,nmx) + + !----------------------------------------------------------------------- + ! diagnostics (budget) + !----------------------------------------------------------------------- +! ! tendencies per time step and process +! REAL(kind=kind_phys), TARGET :: bems(imx,jmx,nmx), bdry(imx,jmx,nmx), bstl(imx,jmx,nmx) +! REAL(kind=kind_phys), TARGET :: bwet(imx,jmx,nmx), bcnv(imx,jmx,nmx)! + +! ! integrated tendencies per process +! REAL(kind=kind_phys), TARGET :: tems(imx,jmx,nmx), tstl(imx,jmx,nmx) +! REAL(kind=kind_phys), TARGET :: tdry(imx,jmx,nmx), twet(imx,jmx,nmx), tcnv(imx,jmx,nmx) + + ! global mass balance per time step + REAL(kind=kind_phys) :: tmas0(nmx), tmas1(nmx) + REAL(kind=kind_phys) :: dtems(nmx), dttrp(nmx), dtdif(nmx), dtcnv(nmx) + REAL(kind=kind_phys) :: dtwet(nmx), dtdry(nmx), dtstl(nmx) + REAL(kind=kind_phys) :: dtems2(nmx), dttrp2(nmx), dtdif2(nmx), dtcnv2(nmx) + REAL(kind=kind_phys) :: dtwet2(nmx), dtdry2(nmx), dtstl2(nmx) + + ! detailed integrated budgets for individual emissions + REAL(kind=kind_phys), TARGET :: ems_an(imx,jmx,nmx), ems_bb(imx,jmx,nmx), ems_tp(imx,jmx) + REAL(kind=kind_phys), TARGET :: ems_ac(imx,jmx,lmx,nmx) + REAL(kind=kind_phys), TARGET :: ems_co(imx,jmx,nmx) + + ! executable statements +! decrease seasalt emissions (Colarco et al. 2010) +! + !fudge_fac= 1. !.5 + !fudge_fac= .5 !lzhang + fudge_fac= .25 !lzhang +! + DO n = 1,nmx + bems(:,:,n) = 0.0 + rho_d = den_seas(n) + r0 = ra(n)*frh + r1 = rb(n)*frh + r = r0 + nr = INT((r1-r0)/dr+.001) + DO ir = 1,nr + r_w = r + dr*0.5 + r = r + dr + IF (new) THEN + a = 4.7*(1.0 + theta*r_w)**(-0.017*r_w**(-1.44)) + c0 = c_new + b0 = b_new + ELSE + a = 3.0 + c0 = c_old + b0 = b_old + END IF + ! + b = (b0(1) - LOG10(r_w))/b0(2) + dfn = (c0(1)/r_w**a)*(1.0 + c0(3)*r_w**c0(4))* & + 10**(c0(5)*EXP(-(b**2))) + + r_d = r_w/frh*1.0D-6 ! um -> m + dfm = 4.0/3.0*pi*r_d**3*rho_d*frh*dfn*dr*dt1 ! 3600 !dt1 + DO i = 1,imx + DO j = 1,jmx +! IF (water(i,j) > 0.0) THEN + IF (ilwi(i,j) == 0) THEN +! src = dfm*dxy(j)*water(i,j)*w10m(i,j)**c0(2) + src = dfm*dxy(j)*w10m(i,j)**c0(2) +! src = ch_ss(n,dt(1)%mn)*dfm*dxy(j)*w10m(i,j)**c0(2) + tc(i,j,1,n) = tc(i,j,1,n) + fudge_fac*src/airmas(i,j,1) + ELSE + src = 0.0 + END IF + bems(i,j,n) = bems(i,j,n) + src*fudge_fac/(dxy(j)*dt1) !kg/m2/s + END DO ! i + END DO ! j + END DO ! ir + END DO ! n + + END SUBROUTINE source_ss + +end module seas_mod diff --git a/physics/smoke/seas_ngac_mod.F90 b/physics/smoke/seas_ngac_mod.F90 new file mode 100755 index 000000000..2158d808c --- /dev/null +++ b/physics/smoke/seas_ngac_mod.F90 @@ -0,0 +1,191 @@ +!>\file seas_ngac_mod.F90 +!! This file contains the ngac sea-salt module. + +!------------------------------------------------------------------------- +! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! +! Adapted by NOAA/GSD/ESRL ! +!------------------------------------------------------------------------- +!BOP +! +! !MODULE: seas_ngac_mod.F90 --- Calculate the Seasalt Emissions +! +! !INTERFACE: +! + + module seas_ngac_mod + +! !USES: + +! use chem_comm_mod, only : chem_comm_isroot + use machine , only : kind_phys + + implicit none + +! !PUBLIC TYPES: +! + PRIVATE + +! +! !PUBLIC MEMBER FUNCTIONS: +! + + PUBLIC SeasaltEmission + + +! !CONSTANTS + real(kind=kind_phys), parameter :: r80fac = 1.65 ! ratio of radius(RH=0.8)/radius(RH=0.) [Gerber] + real(kind=kind_phys), parameter :: rhop = 2200. ! dry seasalt density [kg m-3] + +! +! !DESCRIPTION: +! +! This module implements the sea salt aerosol emission parameterizations. +! For all variants, emissions are some function of wind speed (and possibly +! other dynamical parameters) and the sea salt particle radius. Here, +! we assume the model passes in dry radius (or dry radius of size bin edges). +! Output is the mass emission flux (kg m-2 s-1) into that radius bin. +! +! !REVISION HISTORY: +! +! 30Mar2010 Colarco First crack! +! +!EOP +!------------------------------------------------------------------------- +CONTAINS +! +! !IROUTINE: SeasaltEmission - Master driver to compute the sea salt emissions +! +! !INTERFACE: +! + subroutine SeasaltEmission ( rLow, rUp, method, w10m, ustar, pi, & + memissions, nemissions, rc ) + +! !DESCRIPTION: Calculates the seasalt mass emission flux every timestep. +! The particular method (algorithm) used for the calculation is based +! on the value of "method" passed on input. Mostly these algorithms are +! a function of wind speed and particle size (nominally at 80% RH). +! Routine is called once for each size bin, passing in the edge radii +! "rLow" and "rUp" (in dry radius, units of um). Returned in the emission +! mass flux [kg m-2 s-1]. A sub-bin assumption is made to break (possibly) +! large size bins into a smaller space. +! +! !USES: + + implicit NONE + +! !INPUT PARAMETERS: + + real(kind=kind_phys), intent(in) :: rLow, rUp ! Dry particle bin edge radii [um] + real(kind=kind_phys), intent(in) :: w10m ! 10-m wind speed [m s-1] + real(kind=kind_phys), intent(in) :: ustar ! friction velocity [m s-1] + real(kind=kind_phys), intent(in) :: pi ! ratio of a circle's circumference to its diameter + integer, intent(in) :: method ! Algorithm to use + +! !OUTPUT PARAMETERS: + + real(kind=kind_phys), intent(inout) :: memissions ! Mass Emissions Flux [kg m-2 s-1] + real(kind=kind_phys), intent(inout) :: nemissions ! Number Emissions Flux [# m-2 s-1] + integer, intent(out) :: rc ! Error return code: + ! 0 - all is well + ! 1 - +! !Local Variables + integer :: ir + real(kind=kind_phys) :: w ! Intermediary wind speed [m s-1] + real(kind=kind_phys) :: r, dr ! sub-bin radius spacing (dry, um) + real(kind=kind_phys) :: rwet, drwet ! sub-bin radius spacing (rh=80%, um) + real(kind=kind_phys) :: aFac, bFac, scalefac, rpow, exppow, wpow + + integer, parameter :: nr = 10 ! Number of (linear) sub-size bins + + character(len=*), parameter :: myname = 'SeasaltEmission' + +! Define the sub-bins (still in dry radius) + dr = (rUp - rLow)/nr + r = rLow + 0.5*dr + +! Loop over size bins + nemissions = 0. + memissions = 0. + + do ir = 1, nr + + rwet = r80fac * r + drwet = r80fac * dr + + select case(method) + + case(1) ! Gong 2003 + aFac = 4.7*(1.+30.*rwet)**(-0.017*rwet**(-1.44)) + bFac = (0.433-log10(rwet))/0.433 + scalefac = 1. + rpow = 3.45 + exppow = 1.607 + wpow = 3.41 + w = w10m + + case(2) ! Gong 1997 + aFac = 3. + bFac = (0.380-log10(rwet))/0.650 + scalefac = 1. + rpow = 1.05 + exppow = 1.19 + wpow = 3.41 + w = w10m + + case(3) ! GEOS5 2012 + aFac = 4.7*(1.+30.*rwet)**(-0.017*rwet**(-1.44)) + bFac = (0.433-log10(rwet))/0.433 + scalefac = 33.0e3 + rpow = 3.45 + exppow = 1.607 + wpow = 3.41 - 1. + w = ustar + + case default +! if(chem_comm_isroot()) print *, 'SeasaltEmission missing algorithm method' + rc = 1 + return + + end select + + +! Number emissions flux (# m-2 s-1) + nemissions = nemissions + SeasaltEmissionGong( rwet, drwet, w, scalefac, aFac, bFac, rpow, exppow, wpow ) +! Mass emissions flux (kg m-2 s-1) + scalefac = scalefac * 4./3.*pi*rhop*r**3.*1.e-18 + memissions = memissions + SeasaltEmissionGong( rwet, drwet, w, scalefac, aFac, bFac, rpow, exppow, wpow ) + + r = r + dr + + end do + + rc = 0 + + end subroutine SeasaltEmission + + +! Function to compute sea salt emissions following the Gong style +! parameterization. Functional form is from Gong 2003: +! dN/dr = scalefac * 1.373 * (w^wpow) * (r^-aFac) * (1+0.057*r^rpow) * 10^(exppow*exp(-bFac^2)) +! where r is the particle radius at 80% RH, dr is the size bin width at 80% RH, and w is the wind speed + + function SeasaltEmissionGong ( r, dr, w, scalefac, aFac, bFac, rpow, exppow, wpow ) + + real(kind=kind_phys), intent(in) :: r, dr ! Wet particle radius, bin width [um] + real(kind=kind_phys), intent(in) :: w ! Grid box mean wind speed [m s-1] (10-m or ustar wind) + real(kind=kind_phys), intent(in) :: scalefac, aFac, bFac, rpow, exppow, wpow + real(kind=kind_phys) :: SeasaltEmissionGong + +! Initialize + SeasaltEmissionGong = 0. + +! Particle size distribution function + SeasaltEmissionGong = scalefac * 1.373*r**(-aFac)*(1.+0.057*r**rpow) & + *10**(exppow*exp(-bFac**2.))*dr +! Apply wind speed function + SeasaltEmissionGong = w**wpow * SeasaltEmissionGong + + end function SeasaltEmissionGong + + + end module seas_ngac_mod diff --git a/physics/gscond.f b/physics/zhaocarr_gscond.f similarity index 99% rename from physics/gscond.f rename to physics/zhaocarr_gscond.f index 8756bc320..d35e08342 100644 --- a/physics/gscond.f +++ b/physics/zhaocarr_gscond.f @@ -1,4 +1,4 @@ -!> \file gscond.f +!> \file zhaocarr_gscond.f !! This file contains the subroutine that calculates grid-scale !! condensation and evaporation for use in Zhao and Carr (1997) !! \cite zhao_and_carr_1997 scheme. diff --git a/physics/gscond.meta b/physics/zhaocarr_gscond.meta similarity index 100% rename from physics/gscond.meta rename to physics/zhaocarr_gscond.meta diff --git a/physics/precpd.f b/physics/zhaocarr_precpd.f similarity index 99% rename from physics/precpd.f rename to physics/zhaocarr_precpd.f index 929d78f9c..16f0ba4f1 100644 --- a/physics/precpd.f +++ b/physics/zhaocarr_precpd.f @@ -1,4 +1,4 @@ -!> \file precpd.f +!> \file zhaocarr_precpd.f !! This file contains the subroutine that calculates precipitation !! processes from suspended cloud water/ice. diff --git a/physics/precpd.meta b/physics/zhaocarr_precpd.meta similarity index 100% rename from physics/precpd.meta rename to physics/zhaocarr_precpd.meta