diff --git a/CMakeLists.txt b/CMakeLists.txt index 16864dde8..9e59ca1ba 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -100,6 +100,8 @@ list(APPEND LIBS "ccpp") include(./CCPP_SCHEMES.cmake) # Set the sources: physics scheme caps include(./CCPP_CAPS.cmake) +# Create empty lists for schemes with special compiler flags +set(SCHEMES_SFX "") #------------------------------------------------------------------------------ if (${CMAKE_Fortran_COMPILER_ID} STREQUAL "GNU") @@ -111,10 +113,7 @@ if (${CMAKE_Fortran_COMPILER_ID} STREQUAL "GNU") SET_SOURCE_FILES_PROPERTIES(./physics/aer_cloud.F ./physics/wv_saturation.F ./physics/cldwat2m_micro.F ./physics/surface_perturbation.F90 PROPERTIES COMPILE_FLAGS "-fdefault-real-8 -fdefault-double-8") if (PROJECT STREQUAL "CCPP-FV3") if (DYN32) - set(CMAKE_Fortran_FLAGS_OPT32BIT ${CMAKE_Fortran_FLAGS}) - string(REPLACE "-fdefault-real-8" "" CMAKE_Fortran_FLAGS_OPT32BIT "${CMAKE_Fortran_FLAGS_OPT32BIT}") - SET_SOURCE_FILES_PROPERTIES(./physics/gfdl_fv_sat_adj.F90 - PROPERTIES COMPILE_FLAGS "${CMAKE_Fortran_FLAGS_OPT32BIT}") + message (FATAL_ERROR "The current build system does not allow building fast physics with 32-bit precision when the GNU compilers are used") endif (DYN32) endif (PROJECT STREQUAL "CCPP-FV3") elseif (${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") @@ -133,6 +132,7 @@ elseif (${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") ./physics/wv_saturation.F ./physics/cldwat2m_micro.F ./physics/surface_perturbation.F90 + ./physics/radiation_aerosols.f ./physics/cu_gf_deep.F90 ./physics/cu_gf_sh.F90 ./physics/module_bl_mynn.F90 @@ -141,11 +141,10 @@ elseif (${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") ./physics/module_MYNNSFC_wrapper.F90 ./physics/module_MYNNrad_pre.F90 ./physics/module_MYNNrad_post.F90 - PROPERTIES COMPILE_FLAGS "${CMAKE_Fortran_FLAGS} -r8 -ftz") - # Replace -xHost or -xCORE-AVX2 with -xCORE-AVX-I for certain files (following FV3/gfsphysics/makefile) - # for bit-for-bit reproducibility with non-CCPP builds. These may go in the future once the CCPP solution - # is fully accepted. - set(CMAKE_Fortran_FLAGS_LOPT1 ${CMAKE_Fortran_FLAGS}) + PROPERTIES COMPILE_FLAGS "-r8 -ftz") + + # Replace -xHost or -xCORE-AVX2 with -xCORE-AVX-I for certain files + set(CMAKE_Fortran_FLAGS_LOPT1 ${CMAKE_Fortran_FLAGS_OPT}) string(REPLACE "-xHOST" "-xCORE-AVX-I" CMAKE_Fortran_FLAGS_LOPT1 "${CMAKE_Fortran_FLAGS_LOPT1}") @@ -156,35 +155,34 @@ elseif (${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") CMAKE_Fortran_FLAGS_LOPT1 "${CMAKE_Fortran_FLAGS_LOPT1}") SET_SOURCE_FILES_PROPERTIES(./physics/radiation_aerosols.f - PROPERTIES COMPILE_FLAGS "${CMAKE_Fortran_FLAGS_LOPT1} -r8 -ftz") + PROPERTIES COMPILE_FLAGS "${CMAKE_Fortran_FLAGS_LOPT1}") + # Add all of the above files to the list of schemes with special compiler flags + list(APPEND SCHEMES_SFX ./physics/radiation_aerosols.f) + # Force consistent results of math calculations for MG microphysics; - # in Debug/Bitforbit) mode; without this flag, the results of the + # in Debug/Bitforbit mode; without this flag, the results of the # intrinsic gamma function are different for the non-CCPP and CCPP # version (on Theia with Intel 18). Note this is only required with # dynamic CCPP builds (hybrid, standalone), not with static CCPP builds. if (${CMAKE_BUILD_TYPE} MATCHES "Debug") SET_SOURCE_FILES_PROPERTIES(./physics/micro_mg2_0.F90 ./physics/micro_mg3_0.F90 - PROPERTIES COMPILE_FLAGS "${CMAKE_Fortran_FLAGS} -fimf-arch-consistency=true") + PROPERTIES COMPILE_FLAGS "-fimf-arch-consistency=true") + # Add all of the above files to the list of schemes with special compiler flags + list(APPEND SCHEMES_SFX ./physics/micro_mg2_0.F90 + ./physics/micro_mg3_0.F90) elseif (${CMAKE_BUILD_TYPE} MATCHES "Bitforbit") SET_SOURCE_FILES_PROPERTIES(./physics/micro_mg2_0.F90 ./physics/micro_mg3_0.F90 - PROPERTIES COMPILE_FLAGS "${CMAKE_Fortran_FLAGS} -fimf-arch-consistency=true") - endif (${CMAKE_BUILD_TYPE} MATCHES "Debug") - if (DYN32) - set(CMAKE_Fortran_FLAGS_OPT32BIT ${CMAKE_Fortran_FLAGS}) - string(REPLACE "-real-size 64" "-real-size 32" CMAKE_Fortran_FLAGS_OPT32BIT "${CMAKE_Fortran_FLAGS_OPT32BIT}") - string(REPLACE "-r8" "-r4" CMAKE_Fortran_FLAGS_OPT32BIT "${CMAKE_Fortran_FLAGS_OPT32BIT}") - SET_SOURCE_FILES_PROPERTIES(./physics/gfdl_fv_sat_adj.F90 - PROPERTIES COMPILE_FLAGS "${CMAKE_Fortran_FLAGS_OPT32BIT}") - endif (DYN32) - - # For CCPP acceptance: selective reduction of optimization flags, hopefully - # to be removed once established that this is not a reasonable approach. - if (TRANSITION) - # Replace "-no-prec-div -no-prec-sqrt" with "-prec-div -prec-sqrt", - # replace "CORE-AVX2" with "CORE-AVX-I" - set(CMAKE_Fortran_FLAGS_LOPT2 ${CMAKE_Fortran_FLAGS}) + PROPERTIES COMPILE_FLAGS "-fimf-arch-consistency=true") + # Add all of the above files to the list of schemes with special compiler flags + list(APPEND SCHEMES_SFX ./physics/micro_mg2_0.F90 + ./physics/micro_mg3_0.F90) + elseif (TRANSITION) + # Replace -xHost or -xCORE-AVX2 with -xCORE-AVX-I, -no-prec-div with -prec-div, and + # -no-prec-sqrt with -prec-sqrt for certain files for bit-for-bit reproducibility + # with non-CCPP builds. These may go in the future once the CCPP solution is fully accepted. + set(CMAKE_Fortran_FLAGS_LOPT2 ${CMAKE_Fortran_FLAGS_OPT}) string(REPLACE "-no-prec-div" "-prec-div" CMAKE_Fortran_FLAGS_LOPT2 "${CMAKE_Fortran_FLAGS_LOPT2}") @@ -197,21 +195,41 @@ elseif (${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") string(REPLACE "-axSSE4.2,AVX,CORE-AVX2" "-axSSE4.2,AVX,CORE-AVX-I" CMAKE_Fortran_FLAGS_LOPT2 "${CMAKE_Fortran_FLAGS_LOPT2}") - SET_SOURCE_FILES_PROPERTIES(./physics/module_gfdl_cloud_microphys.F90 + SET_SOURCE_FILES_PROPERTIES(./physics/micro_mg2_0.F90 + ./physics/micro_mg3_0.F90 + ./physics/aer_cloud.F + ./physics/cldmacro.F + ./physics/gfdl_fv_sat_adj.F90 + ./physics/module_gfdl_cloud_microphys.F90 ./physics/sflx.f ./physics/satmedmfvdif.F + ./physics/cs_conv.F90 + ./physics/gcm_shoc.F90 PROPERTIES COMPILE_FLAGS "${CMAKE_Fortran_FLAGS_LOPT2}") - # Replace "CORE-AVX2" with "CORE-AVX-I" - set(CMAKE_Fortran_FLAGS_LOPT3 ${CMAKE_Fortran_FLAGS}) - string(REPLACE "-xCORE-AVX2" "-xCORE-AVX-I" - CMAKE_Fortran_FLAGS_LOPT3 - "${CMAKE_Fortran_FLAGS_LOPT3}") - string(REPLACE "-axSSE4.2,AVX,CORE-AVX2" "-axSSE4.2,AVX,CORE-AVX-I" - CMAKE_Fortran_FLAGS_LOPT3 - "${CMAKE_Fortran_FLAGS_LOPT3}") - SET_SOURCE_FILES_PROPERTIES(./physics/gfdl_fv_sat_adj.F90 - PROPERTIES COMPILE_FLAGS "${CMAKE_Fortran_FLAGS_LOPT3}") - endif (TRANSITION) + # Add all of the above files to the list of schemes with special compiler flags + list(APPEND SCHEMES_SFX ./physics/micro_mg2_0.F90 + ./physics/micro_mg3_0.F90 + ./physics/aer_cloud.F + ./physics/cldmacro.F + ./physics/module_gfdl_cloud_microphys.F90 + ./physics/sflx.f + ./physics/satmedmfvdif.F + ./physics/cs_conv.F90 + ./physics/gcm_shoc.F90 + ./physics/gfdl_fv_sat_adj.F90) + endif (${CMAKE_BUILD_TYPE} MATCHES "Debug") + + # Remove files with special compiler flags from list of files with standard compiler flags + list(REMOVE_ITEM SCHEMES ${SCHEMES_SFX}) + # Assign standard compiler flags to all remaining schemes and caps + SET_SOURCE_FILES_PROPERTIES(${SCHEMES} ${CAPS} + PROPERTIES COMPILE_FLAGS "${CMAKE_Fortran_FLAGS_OPT}") + + # This has to come last: append 32-bit dynamics flags to certain files that are executed + # in the dynamics (fast physics part); this will overwrite any preceding -real-size 64 + if (DYN32) + SET_PROPERTY(SOURCE ./physics/gfdl_fv_sat_adj.F90 APPEND_STRING PROPERTY COMPILE_FLAGS " -real-size 32 ") + endif (DYN32) else (PROJECT STREQUAL "CCPP-FV3") SET_SOURCE_FILES_PROPERTIES(./physics/module_bfmicrophysics.f ./physics/rascnvv2.f ./physics/sflx.f ./physics/sfc_diff.f ./physics/sfc_diag.f PROPERTIES COMPILE_FLAGS -r8) @@ -228,10 +246,7 @@ elseif (${CMAKE_Fortran_COMPILER_ID} STREQUAL "PGI") SET_SOURCE_FILES_PROPERTIES(./physics/aer_cloud.F ./physics/wv_saturation.F ./physics/cldwat2m_micro.F ./physics/surface_perturbation.F90 PROPERTIES COMPILE_FLAGS "-r8") if (PROJECT STREQUAL "CCPP-FV3") if (DYN32) - set(CMAKE_Fortran_FLAGS_OPT32BIT ${CMAKE_Fortran_FLAGS}) - string(REPLACE "-r8" "-r4" CMAKE_Fortran_FLAGS_OPT32BIT "${CMAKE_Fortran_FLAGS_OPT32BIT}") - SET_SOURCE_FILES_PROPERTIES(./physics/gfdl_fv_sat_adj.F90 - PROPERTIES COMPILE_FLAGS "${CMAKE_Fortran_FLAGS_OPT32BIT}") + SET_PROPERTY(SOURCE ./physics/gfdl_fv_sat_adj.F90 APPEND_STRING PROPERTY COMPILE_FLAGS " -r4 ") endif (DYN32) endif (PROJECT STREQUAL "CCPP-FV3") else (${CMAKE_Fortran_COMPILER_ID} STREQUAL "GNU") @@ -241,21 +256,22 @@ else (${CMAKE_Fortran_COMPILER_ID} STREQUAL "GNU") endif (${CMAKE_Fortran_COMPILER_ID} STREQUAL "GNU") # The auto-generated caps can contain calls to physics schemes in -# which some of the arguments (pointers) are not associated. This is -# on purpose to avoid allocating fields that are not used inside the +# which some of the arguments (pointers, arrays) are not associated/allocated. +# This is on purpose to avoid allocating fields that are not used inside the # scheme if, for example, certain conditions are not met. To avoid # Fortran runtime errors, it is necessary to remove checks for pointers -# that are not associated from the caps ONLY. For the physics schemes, -# these checks can and should remain enabled. Overwriting the check flags -# explicitly works for Intel and GNU, but not for PGI. +# that are not associated and for array bounds from the caps ONLY. For the +# physics schemes, these checks can and should remain enabled. Overwriting +# the pointer check flags explicitly works for Intel and GNU, but not for PGI. if (${CMAKE_Fortran_COMPILER_ID} STREQUAL "GNU") - set_property(SOURCE ${CAPS} PROPERTY COMPILE_FLAGS "-fcheck=no-pointer") + set_property(SOURCE ${CAPS} PROPERTY COMPILE_FLAGS "-fcheck=no-pointer,no-bounds") elseif (${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") - set_property(SOURCE ${CAPS} PROPERTY COMPILE_FLAGS "-check nopointers") + set_property(SOURCE ${CAPS} PROPERTY COMPILE_FLAGS "-check nopointers,nobounds") elseif (${CMAKE_Fortran_COMPILER_ID} STREQUAL "PGI") if (CMAKE_Fortran_FLAGS MATCHES ".*chkptr.*") message (FATAL_ERROR "PGI compiler option chkptr cannot be used for CCPP physics") endif (CMAKE_Fortran_FLAGS MATCHES ".*chkptr.*") + set_property(SOURCE ${CAPS} PROPERTY COMPILE_FLAGS "-Mnobounds") endif (${CMAKE_Fortran_COMPILER_ID} STREQUAL "GNU") if (PROJECT STREQUAL "CCPP-FV3") @@ -280,7 +296,7 @@ endif (PROJECT STREQUAL "CCPP-FV3") #------------------------------------------------------------------------------ if(STATIC) - add_library(ccppphys STATIC ${SCHEMES} ${CAPS}) + add_library(ccppphys STATIC ${SCHEMES} ${SCHEMES_SFX} ${CAPS}) # Generate list of Fortran modules from defined sources foreach(source_f90 ${CAPS}) string(REGEX REPLACE ".F90" ".mod" tmp_module_f90 ${source_f90}) @@ -288,7 +304,7 @@ if(STATIC) list(APPEND MODULES_F90 ${CMAKE_CURRENT_BINARY_DIR}/../${module_f90}) endforeach() else(STATIC) - add_library(ccppphys ${SCHEMES} ${CAPS}) + add_library(ccppphys ${SCHEMES} ${SCHEMES_SFX} ${CAPS}) endif(STATIC) if (PROJECT STREQUAL "CCPP-FV3") @@ -297,9 +313,7 @@ elseif (PROJECT STREQUAL "CCPP-SCM") target_link_libraries(ccppphys LINK_PUBLIC ${LIBS} w3 sp bacio) endif (PROJECT STREQUAL "CCPP-FV3") set_target_properties(ccppphys PROPERTIES VERSION ${PROJECT_VERSION} - SOVERSION ${PROJECT_VERSION_MAJOR} - COMPILE_FLAGS "${CMAKE_Fortran_FLAGS}" - LINK_FLAGS "${CMAKE_Fortran_FLAGS}") + SOVERSION ${PROJECT_VERSION_MAJOR}) # DH* Hack for PGI compiler: rename objects in scheme cap object files for ISO_C compliancy, # this is only needed for dynamics builds - static build generates plain Fortran code. diff --git a/physics/GFS_PBL_generic.F90 b/physics/GFS_PBL_generic.F90 index f2168834e..15ed9b76f 100644 --- a/physics/GFS_PBL_generic.F90 +++ b/physics/GFS_PBL_generic.F90 @@ -38,6 +38,8 @@ end subroutine GFS_PBL_generic_pre_finalize !! | imp_physics_thompson | flag_for_thompson_microphysics_scheme | choice of Thompson microphysics scheme | flag | 0 | integer | | in | F | !! | imp_physics_wsm6 | flag_for_wsm6_microphysics_scheme | choice of WSM6 microphysics scheme | flag | 0 | integer | | in | F | !! | ltaerosol | flag_for_aerosol_physics | flag for aerosol physics | flag | 0 | logical | | in | F | +!! | hybedmf | flag_for_hedmf | flag for hybrid edmf pbl scheme (moninedmf) | flag | 0 | logical | | in | F | +!! | do_shoc | flag_for_shoc | flag for SHOC | flag | 0 | logical | | in | F | !! | satmedmf | flag_for_scale_aware_TKE_moist_EDMF_PBL | flag for scale-aware TKE moist EDMF PBL scheme | flag | 0 | logical | | in | F | !! | qgrs | tracer_concentration | model layer mean tracer concentration | kg kg-1 | 3 | real | kind_phys | in | F | !! | vdftra | vertically_diffused_tracer_concentration | tracer concentration diffused by PBL scheme | kg kg-1 | 3 | real | kind_phys | inout | F | @@ -48,7 +50,7 @@ end subroutine GFS_PBL_generic_pre_finalize subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, & ntqv, ntcw, ntiw, ntrw, ntsw, ntlnc, ntinc, ntwa, ntia, ntgl, ntoz, ntke, ntkev, & imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, & - ltaerosol, satmedmf, qgrs, vdftra, errmsg, errflg) + ltaerosol, hybedmf, do_shoc, satmedmf, qgrs, vdftra, errmsg, errflg) use machine, only : kind_phys @@ -57,7 +59,7 @@ subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, integer, intent(in) :: im, levs, nvdiff, ntrac integer, intent(in) :: ntqv, ntcw, ntiw, ntrw, ntsw, ntlnc, ntinc, ntwa, ntia, ntgl, ntoz, ntke, ntkev integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6 - logical, intent(in) :: ltaerosol, satmedmf + logical, intent(in) :: ltaerosol, hybedmf, do_shoc, satmedmf real(kind=kind_phys), dimension(im, levs, ntrac), intent(in) :: qgrs real(kind=kind_phys), dimension(im, levs, nvdiff), intent(inout) :: vdftra @@ -72,7 +74,8 @@ subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, errmsg = '' errflg = 0 - if(nvdiff == ntrac) then +!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 else if (imp_physics == imp_physics_wsm6) then @@ -186,6 +189,8 @@ end subroutine GFS_PBL_generic_post_finalize !! | hybedmf | flag_for_hedmf | flag for hybrid edmf pbl scheme (moninedmf) | flag | 0 | logical | | in | F | !! | do_shoc | flag_for_shoc | flag for SHOC | flag | 0 | logical | | in | F | !! | satmedmf | flag_for_scale_aware_TKE_moist_EDMF_PBL | flag for scale-aware TKE moist EDMF PBL scheme | flag | 0 | logical | | in | F | +!! | shinhong | flag_for_scale_aware_Shinhong_PBL | flag for scale-aware Shinhong PBL scheme | flag | 0 | logical | | in | F | +!! | do_ysu | flag_for_ysu | flag for YSU PBL scheme | flag | 0 | logical | | in | F | !! | dvdftra | tendency_of_vertically_diffused_tracer_concentration | updated tendency of the tracers due to vertical diffusion in PBL scheme | kg kg-1 s-1 | 3 | real | kind_phys | in | F | !! | dusfc1 | instantaneous_surface_x_momentum_flux | surface momentum flux in the x-direction valid for current call | Pa | 1 | real | kind_phys | in | F | !! | dvsfc1 | instantaneous_surface_y_momentum_flux | surface momentum flux in the y-direction valid for current call | Pa | 1 | real | kind_phys | in | F | @@ -229,7 +234,7 @@ end subroutine GFS_PBL_generic_post_finalize subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, & ntqv, ntcw, ntiw, ntrw, ntsw, ntlnc, ntinc, ntwa, ntia, ntgl, ntoz, ntke, ntkev, & imp_physics, imp_physics_gfdl, imp_physics_thompson, & - imp_physics_wsm6, ltaerosol, cplflx, lssav, ldiag3d, lsidea, hybedmf, do_shoc, satmedmf, & + imp_physics_wsm6, ltaerosol, cplflx, lssav, 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, & dqsfc_cpl, dusfci_cpl, dvsfci_cpl, dtsfci_cpl, dqsfci_cpl, dusfc_diag, dvsfc_diag, dtsfc_diag, dqsfc_diag, & @@ -243,7 +248,7 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, integer, intent(in) :: im, levs, nvdiff, ntrac integer, intent(in) :: ntqv, ntcw, ntiw, ntrw, ntsw, ntlnc, ntinc, ntwa, ntia, ntgl, ntoz, ntke, ntkev integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6 - logical, intent(in) :: ltaerosol, cplflx, lssav, ldiag3d, lsidea, hybedmf, do_shoc, satmedmf + logical, intent(in) :: ltaerosol, cplflx, lssav, ldiag3d, lsidea, hybedmf, do_shoc, satmedmf, shinhong, do_ysu real(kind=kind_phys), intent(in) :: dtf real(kind=kind_phys), dimension(im, levs, nvdiff), intent(in) :: dvdftra @@ -271,9 +276,9 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, errmsg = '' errflg = 0 !GJF: dvdftra is only used if nvdiff != ntrac or (nvdiff == ntrac .and. ) - if (nvdiff == ntrac .and. (hybedmf .or. do_shoc)) then + if (nvdiff == ntrac .and. (hybedmf .or. do_shoc .or. satmedmf)) then dqdt = dvdftra - elseif (nvdiff /= ntrac) then + elseif (nvdiff /= ntrac .and. .not. shinhong .and. .not. do_ysu) then if (imp_physics == imp_physics_wsm6) then ! WSM6 do k=1,levs diff --git a/physics/GFS_suite_interstitial.F90 b/physics/GFS_suite_interstitial.F90 index 8abe472b2..5606ed1f1 100644 --- a/physics/GFS_suite_interstitial.F90 +++ b/physics/GFS_suite_interstitial.F90 @@ -615,7 +615,9 @@ subroutine GFS_suite_interstitial_3_run (im, levs, nn, cscnv, satmedmf, trans_tr real(kind=kind_phys), dimension(im), intent(in) :: xlat real(kind=kind_phys), dimension(im, levs, ntrac), intent(in) :: gq0 - real(kind=kind_phys), dimension(im, levs), intent(inout) :: rhc, save_qc, save_qi + real(kind=kind_phys), dimension(im, levs), intent(inout) :: rhc, save_qc + ! save_qi is not allocated for Zhao-Carr MP + real(kind=kind_phys), dimension(:, :), intent(inout) :: save_qi real(kind=kind_phys), dimension(im, levs, nn), intent(inout) :: clw character(len=*), intent(out) :: errmsg @@ -829,7 +831,9 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, lgocart, tracers_t logical, intent(in) :: ltaerosol, lgocart real(kind=kind_phys), intent(in) :: con_pi, dtf - real(kind=kind_phys), dimension(im,levs), intent(in) :: save_qc, save_qi + real(kind=kind_phys), dimension(im,levs), intent(in) :: save_qc + ! save_qi is not allocated for Zhao-Carr MP + real(kind=kind_phys), dimension(:, :), intent(in) :: save_qi real(kind=kind_phys), dimension(im,levs,ntrac), intent(inout) :: gq0 real(kind=kind_phys), dimension(im,levs,nn), intent(inout) :: clw diff --git a/physics/cs_conv.F90 b/physics/cs_conv.F90 index 6a4ad57ba..0562acdf4 100644 --- a/physics/cs_conv.F90 +++ b/physics/cs_conv.F90 @@ -59,7 +59,9 @@ subroutine cs_conv_pre_run(im, levs, ntrac, ncld, q, clw1, clw2, & ! --- input/output real(r8), dimension(ntrac-ncld+2), intent(out) :: fswtr, fscav real(r8), dimension(im), intent(out) :: wcbmax - real(r8), dimension(im,levs), intent(out) :: save_q1,save_q2,save_q3 + real(r8), dimension(im,levs), intent(out) :: save_q1,save_q2 + ! save_q3 is not allocated for Zhao-Carr MP + real(r8), dimension(:,:), intent(out) :: save_q3 character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg diff --git a/physics/cu_gf_deep.F90 b/physics/cu_gf_deep.F90 index 9f857a0cb..a706e1cdf 100644 --- a/physics/cu_gf_deep.F90 +++ b/physics/cu_gf_deep.F90 @@ -6,9 +6,9 @@ module cu_gf_deep real(kind=kind_phys), parameter::r_v=461. real(kind=kind_phys), parameter :: tcrit=258. ! tuning constant for cloudwater/ice detrainment - real(kind=kind_phys), parameter:: c1=.002 ! .0005 + real(kind=kind_phys), parameter:: c1= 0.003 !.002 ! .0005 ! parameter to turn on or off evaporation of rainwater as done in sas - integer, parameter :: irainevap=1 + integer, parameter :: irainevap=0 ! max allowed fractional coverage (frh_thresh) real(kind=kind_phys), parameter::frh_thresh = .9 ! rh threshold. if fractional coverage ~ frh_thres, do not use cupa any further @@ -362,6 +362,8 @@ subroutine cu_gf_deep_run( & el2orc=xlv*xlv/(r_v*cp) evfact=.2 evfactl=.2 + !evfact=.0 ! for 4F5f + !evfactl=.4 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -370,11 +372,11 @@ subroutine cu_gf_deep_run( & ! ! ecmwf pgcon=0. - lambau(:)=5. - if(imid.eq.1)lambau(:)=5. + lambau(:)=2.0 + if(imid.eq.1)lambau(:)=2.0 ! here random must be between -1 and 1 if(nranflag == 1)then - lambau(:)=4.5+rand_mom(:) + lambau(:)=1.5+rand_mom(:) endif ! sas ! lambau=0. @@ -445,7 +447,7 @@ subroutine cu_gf_deep_run( & entr_rate(i)=7.e-5 - min(20.,float(csum(i))) * 3.e-6 if(xland1(i) == 0)entr_rate(i)=7.e-5 if(imid.eq.1)entr_rate(i)=3.e-4 - if(imid.eq.1)c1d(i,:)=c1 ! comment to test warm bias 08/14/17 +! if(imid.eq.1)c1d(i,:)=c1 ! comment to test warm bias 08/14/17 radius=.2/entr_rate(i) frh=min(1.,3.14*radius*radius/dx(i)/dx(i)) if(frh > frh_thresh)then @@ -756,10 +758,18 @@ subroutine cu_gf_deep_run( & ! ! calculate mass entrainment and detrainment ! + if(imid.eq.1)then + call get_lateral_massflux(itf,ktf, its,ite, kts,kte & + ,ierr,ktop,zo_cup,zuo,cd,entr_rate_2d & + ,up_massentro, up_massdetro ,up_massentr, up_massdetr & + ,'mid',kbcon,k22,up_massentru,up_massdetru,lambau) + else call get_lateral_massflux(itf,ktf, its,ite, kts,kte & ,ierr,ktop,zo_cup,zuo,cd,entr_rate_2d & ,up_massentro, up_massdetro ,up_massentr, up_massdetr & ,'deep',kbcon,k22,up_massentru,up_massdetru,lambau) + endif + ! ! note: ktop here already includes overshooting, ktopdby is without @@ -892,10 +902,27 @@ subroutine cu_gf_deep_run( & do i=its,itf if(ierr(i) /= 0) cycle ! do k=kbcon(i)+1,ktop(i)-1 - do k=jmin(i)+1,ktop(i)-1 - c1d(i,k)=c1 - enddo +!c do k=jmin(i)+1,ktop(i)-1 +!c c1d(i,k)=c1 +!c enddo !if(imid.eq.1)c1d(i,:)=0. +! do k=kts,ktop(i) +! if(po(i,k).gt.700.)then +! c1d(i,k)=0. +! elseif(po(i,k).gt.600.)then +! c1d(i,k)=0.001 +! elseif(po(i,k).gt.500.)then +! c1d(i,k)=0.002 +! elseif(po(i,k).gt.400.)then +! c1d(i,k)=0.003 +! elseif(po(i,k).gt.300.)then +! c1d(i,k)=0.004 +! elseif(po(i,k).gt.200.)then +! c1d(i,k)=0.005 +! endif +! enddo +! if(imid.eq.1)c1d(i,:)=0.003 + do k=ktop(i)+1,ktf hco(i,k)=heso_cup(i,k) dbyo(i,k)=0. @@ -1161,8 +1188,8 @@ subroutine cu_gf_deep_run( & endif if(zdo(i,ki+1).gt.0.)cdd(i,ki)= dd_massdetro(i,ki)/(dzo*zdo(i,ki+1)) enddo -! cbeg=po_cup(i,kbcon(i)) !850. -! cend=min(po_cup(i,ktop(i)),400.) +! cbeg=800. !po_cup(i,kbcon(i)) !850. +! cend=min(po_cup(i,ktop(i)),200.) ! cmid=.5*(cbeg+cend) !600. ! const_b=c1/((cmid*cmid-cbeg*cbeg)*(cbeg-cend)/(cend*cend-cbeg*cbeg)+cmid-cbeg) ! const_a=const_b*(cbeg-cend)/(cend*cend-cbeg*cbeg) @@ -1170,22 +1197,22 @@ subroutine cu_gf_deep_run( & ! do k=kbcon(i)+1,ktop(i)-1 ! c1d(i,k)=const_a*po_cup(i,k)*po_cup(i,k)+const_b*po_cup(i,k)+const_c ! c1d(i,k)=max(0.,c1d(i,k)) -! c1d(i,k)=c1 +!! c1d(i,k)=c1 ! enddo -! if(imid.eq.1)c1d(i,:)=0. -! do k=1,jmin(i) -! c1d(i,k)=0. -! enddo -! c1d(i,jmin(i)-2)=c1/40. -! if(imid.eq.1)c1d(i,jmin(i)-2)=c1/20. -! do k=jmin(i)-1,ktop(i) -! dz=zo_cup(i,ktop(i))-zo_cup(i,jmin(i)) -! c1d(i,k)=c1d(i,k-1)+c1*(zo_cup(i,k+1)-zo_cup(i,k))/dz -! c1d(i,k)=max(0.,c1d(i,k)) -! c1d(i,k)=min(.002,c1d(i,k)) -! enddo - - +!! if(imid.eq.1)c1d(i,:)=0. +!! do k=1,jmin(i) +!! c1d(i,k)=0. +!! enddo +!! c1d(i,jmin(i)-2)=c1/40. +!! if(imid.eq.1)c1d(i,jmin(i)-2)=c1/20. +!! do k=jmin(i)-1,ktop(i) +!! dz=zo_cup(i,ktop(i))-zo_cup(i,jmin(i)) +!! c1d(i,k)=c1d(i,k-1)+c1*(zo_cup(i,k+1)-zo_cup(i,k))/dz +!! c1d(i,k)=max(0.,c1d(i,k)) +!! c1d(i,k)=min(.002,c1d(i,k)) +!! enddo +! +! ! downdraft moist static energy + moisture budget do k=2,jmin(i)+1 dd_massentru(i,k-1)=dd_massentro(i,k-1)+lambau(i)*dd_massdetro(i,k-1) @@ -1621,16 +1648,16 @@ subroutine cu_gf_deep_run( & !-- take out cloud liquid water for detrainment detup=up_massdetro(i,k) dz=zo_cup(i,k)-zo_cup(i,k-1) -! if(k.lt.ktop(i) .and. k.ge.jmin(i)) then -! if(k.lt.ktop(i) .and. c1d(i,k).gt.0) then +!! if(k.lt.ktop(i) .and. k.ge.jmin(i)) then +!! if(k.lt.ktop(i) .and. c1d(i,k).gt.0) then if(k.lt.ktop(i)) then dellaqc(i,k) = zuo(i,k)*c1d(i,k)*qrco(i,k)*dz/dp*g else dellaqc(i,k)= detup*0.5*(qrco(i,k+1)+qrco(i,k)) *g/dp endif -! if(imid.eq.1) dellaqc(i,k)= detup*0.5*(qrco(i,k+1)+qrco(i,k)) *g/dp - if(k.eq.ktop(i))dellaqc(i,k)= detup*0.5*(qrco(i,k+1)+qrco(i,k)) *g/dp - !--- +!! if(imid.eq.1) dellaqc(i,k)= detup*0.5*(qrco(i,k+1)+qrco(i,k)) *g/dp +! if(k.eq.ktop(i))dellaqc(i,k)= detup*0.5*(qrco(i,k+1)+qrco(i,k)) *g/dp +! !--- g_rain= 0.5*(pwo (i,k)+pwo (i,k+1))*g/dp e_dn = -0.5*(pwdo(i,k)+pwdo(i,k+1))*g/dp*edto(i) ! pwdo < 0 and e_dn must > 0 !-- condensation source term = detrained + flux divergence of @@ -1939,7 +1966,7 @@ subroutine cu_gf_deep_run( & do k = ktop(i), 1, -1 rain = pwo(i,k) + edto(i) * pwdo(i,k) rn(i) = rn(i) + rain * xmb(i) * .001 * dtime - if(po(i,k).gt.700.)then + !if(po(i,k).gt.700.)then if(flg(i))then q1=qo(i,k)+(outq(i,k))*dtime t1=tn(i,k)+(outt(i,k))*dtime @@ -1964,7 +1991,7 @@ subroutine cu_gf_deep_run( & pre(i)=max(pre(i),0.) delqev(i) = delqev(i) + .001*dp*qevap(i)/g endif - endif ! 700mb + !endif ! 700mb endif enddo ! pre(i)=1000.*rn(i)/dtime @@ -3626,7 +3653,7 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & iprop,iall,i,k integer :: start_level(its:ite) real(kind=kind_phys) :: & - prop_ave,qrcb_h,bdsp,dp,rhoc,qrch,qaver, & + prop_ave,qrcb_h,bdsp,dp,rhoc,qrch,qaver,clwdet, & c0,dz,berryc0,q1,berryc real(kind=kind_phys) :: & denom, c0t @@ -3636,6 +3663,7 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & prop_b(kts:kte)=0 iall=0 c0=.002 + clwdet=100. bdsp=bdispm ! !--- no precip for small clouds @@ -3813,7 +3841,14 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & pw(i,k)=(qc(i,k)-qrch)*zu(i,k) if(pw(i,k).lt.0.)pw(i,k)=0. else +! create clw detrainment profile that depends on mass detrainment and +! in-cloud clw/ice +! + c1d(i,k)=clwdet*up_massdetr(i,k-1)*qrc(i,k-1) qrc(i,k)=(qc(i,k)-qrch)/(1.+(c1d(i,k)+c0t)*dz) + if(qrc(i,k).lt.0.)then ! hli new test 02/12/19 + qrc(i,k)=0. + endif pw(i,k)=c0t*dz*qrc(i,k)*zu(i,k) !-----srf-08aug2017-----begin ! pw(i,k)=(c1d(i,k)+c0)*dz*max(0.,qrc(i,k) -qrc_crit)! units kg[rain]/kg[air] @@ -3919,7 +3954,7 @@ subroutine rates_up_pdf(rand_vmas,ipr,name,ktop,ierr,p_cup,entr_rate_2d,hkbo,heo integer, dimension (its:ite) :: start_level ! zustart=.1 - dbythresh= 1. !.0.95 ! 0.85, 0.6 + dbythresh= 0.8 !.0.95 ! 0.85, 0.6 if(name == 'shallow' .or. name == 'mid') dbythresh=1. dby(:)=0. @@ -3969,6 +4004,7 @@ subroutine rates_up_pdf(rand_vmas,ipr,name,ktop,ierr,p_cup,entr_rate_2d,hkbo,heo kfinalzu=ktf-2 ktop(i)=kfinalzu 412 continue + kklev=min(kklev+3,ktop(i)-2) ! ! at least overshoot by one level ! @@ -4017,9 +4053,10 @@ subroutine get_zu_zd_pdf_fim(kklev,p,rand_vmas,zubeg,ipr,xland,zuh2,draft,ierr,k implicit none ! real(kind=kind_phys), parameter :: beta_deep=1.3,g_beta_deep=0.8974707 ! real(kind=kind_phys), parameter :: beta_deep=1.2,g_beta_deep=0.8974707 - real(kind=kind_phys), parameter :: beta_sh=2.5,g_beta_sh=1.329340 -! real(kind=kind_phys), parameter :: beta_mid=1.3,g_beta_mid=0.8974707 - real(kind=kind_phys), parameter :: beta_mid=2.2,g_beta_mid=0.8974707 +! real(kind=kind_phys), parameter :: beta_sh=2.5,g_beta_sh=1.329340 + real(kind=kind_phys), parameter :: beta_sh=2.2,g_beta_sh=0.8974707 + real(kind=kind_phys), parameter :: beta_mid=1.3,g_beta_mid=0.8974707 +! real(kind=kind_phys), parameter :: beta_mid=1.8,g_beta_mid=0.8974707 real(kind=kind_phys), parameter :: beta_dd=4.0,g_beta_dd=6. integer, intent(in) ::ipr,xland,kb,kklev,kt,kts,kte,ktf,kpbli,csum,pmin_lev real(kind=kind_phys), intent(in) ::max_mass,zubeg @@ -4064,6 +4101,7 @@ subroutine get_zu_zd_pdf_fim(kklev,p,rand_vmas,zubeg,ipr,xland,zuh2,draft,ierr,k lev_start=min(.9,.1+csum*.013) kb_adj=max(kb,2) tunning=max(p(kklev+1),.5*(p(kpbli)+p(kt))) + tunning=p(kklev) ! tunning=p(kklev+1) !p(kpbli+1) !p(kklev) !p(kt)+(p(kpbli)-p(kt))*lev_start ! tunning=.5*(p(kb_adj)+p(kt)) !p(kpbli+1) !p(kklev) !p(kt)+(p(kpbli)-p(kt))*lev_start trash=-p(kt)+p(kb_adj) @@ -4175,7 +4213,7 @@ subroutine get_zu_zd_pdf_fim(kklev,p,rand_vmas,zubeg,ipr,xland,zuh2,draft,ierr,k kb_adj=max(kb,2) tunning=.5*(p(kt)+p(kpbli)) !p(kt)+(p(kb_adj)-p(kt))*.9 !*.33 !new nov18 - tunning=p(kpbli) !p(kpbli+1) !p(kklev) !p(kt)+(p(kpbli)-p(kt))*lev_start +! tunning=p(kpbli) !p(kpbli+1) !p(kklev) !p(kt)+(p(kpbli)-p(kt))*lev_start !end new tunning =min(0.95, (tunning-p(kb_adj))/(p(kt)-p(kb_adj))) !=.6 tunning =max(0.02, tunning) @@ -4517,7 +4555,8 @@ subroutine get_lateral_massflux(itf,ktf, its,ite, kts,kte character *(*), intent (in) :: draft integer, intent(in):: itf,ktf, its,ite, kts,kte integer, intent(in) , dimension(its:ite) :: ierr,ktop,kbcon,k22 - real(kind=kind_phys), intent(in), optional , dimension(its:ite):: lambau + !real(kind=kind_phys), intent(in), optional , dimension(its:ite):: lambau + real(kind=kind_phys), intent(inout), optional , dimension(its:ite):: lambau real(kind=kind_phys), intent(in) , dimension(its:ite,kts:kte) :: zo_cup,zuo real(kind=kind_phys), intent(inout), dimension(its:ite,kts:kte) :: cd,entr_rate_2d real(kind=kind_phys), intent( out), dimension(its:ite,kts:kte) :: up_massentro, up_massdetro & @@ -4585,13 +4624,25 @@ subroutine get_lateral_massflux(itf,ktf, its,ite, kts,kte up_massentr (i,k-1)=up_massentro(i,k-1) up_massdetr (i,k-1)=up_massdetro(i,k-1) enddo - if(present(up_massentru) .and. present(up_massdetru))then - turn=maxloc(zuo(i,:),1) - do k=2,turn - up_massentru(i,k-1)=up_massentro(i,k-1)+.1*lambau(i)*up_massentro(i,k-1) - up_massdetru(i,k-1)=up_massdetro(i,k-1)+.1*lambau(i)*up_massentro(i,k-1) + if(present(up_massentru) .and. present(up_massdetru) .and. draft == 'deep')then + !turn=maxloc(zuo(i,:),1) + !do k=2,turn + ! up_massentru(i,k-1)=up_massentro(i,k-1)+.1*lambau(i)*up_massentro(i,k-1) + ! up_massdetru(i,k-1)=up_massdetro(i,k-1)+.1*lambau(i)*up_massentro(i,k-1) + !enddo + !do k=turn+1,ktf-1 + do k=2,ktf-1 + up_massentru(i,k-1)=up_massentro(i,k-1)+lambau(i)*up_massdetro(i,k-1) + up_massdetru(i,k-1)=up_massdetro(i,k-1)+lambau(i)*up_massdetro(i,k-1) + enddo + else if(present(up_massentru) .and. present(up_massdetru) .and. draft == 'shallow')then + do k=2,ktf-1 + up_massentru(i,k-1)=up_massentro(i,k-1)+lambau(i)*up_massdetro(i,k-1) + up_massdetru(i,k-1)=up_massdetro(i,k-1)+lambau(i)*up_massdetro(i,k-1) enddo - do k=turn+1,ktf-1 + else if(present(up_massentru) .and. present(up_massdetru) .and. draft == 'mid')then + lambau(i)=0. + do k=2,ktf-1 up_massentru(i,k-1)=up_massentro(i,k-1)+lambau(i)*up_massdetro(i,k-1) up_massdetru(i,k-1)=up_massdetro(i,k-1)+lambau(i)*up_massdetro(i,k-1) enddo @@ -4791,7 +4842,7 @@ subroutine get_cloud_top(name,ktop,ierr,p_cup,entr_rate_2d,hkbo,heo,heso_cup,z_c integer, dimension (its:ite) :: start_level integer,parameter :: find_ktop_option = 1 !0=original, 1=new - dbythresh=1. !0.95 ! the range of this parameter is 0-1, higher => lower + dbythresh=0.8 !0.95 ! the range of this parameter is 0-1, higher => lower ! overshoting (cheque aa0 calculation) ! rainfall is too sensible this parameter ! for now, keep =1. diff --git a/physics/cu_gf_driver.F90 b/physics/cu_gf_driver.F90 index e6b197e04..9cf3142a6 100644 --- a/physics/cu_gf_driver.F90 +++ b/physics/cu_gf_driver.F90 @@ -374,8 +374,7 @@ subroutine cu_gf_driver_run(tottracer,ntrac,garea,im,ix,km,dt,cactiv, & ierrs(:)=0 cuten(:)=0. cutenm(:)=0. - cutens(:)=1. - if(ishallow_g3.eq.0)cutens(:)=0. + cutens(:)=0. ierrc(:)=" " kbcon(:)=0 @@ -531,7 +530,7 @@ subroutine cu_gf_driver_run(tottracer,ntrac,garea,im,ix,km,dt,cactiv, & !> if ishallow_g3=1, call shallow: cup_gf_sh() ! ! print*,'hli bf shallow t2d',t2d - call cu_gf_sh_run ( & + call cu_gf_sh_run (us,vs, & ! input variables, must be supplied zo,t2d,q2d,ter11,tshall,qshall,p2d,psur,dhdt,kpbli, & rhoi,hfx,qfx,xlandi,ichoice_s,tcrit,dt, & @@ -539,13 +538,13 @@ subroutine cu_gf_driver_run(tottracer,ntrac,garea,im,ix,km,dt,cactiv, & ! turning off shallow convection for grid points zus,xmbs,kbcons,ktops,k22s,ierrs,ierrcs, & ! output tendencies - outts,outqs,outqcs,cnvwt,prets,cupclws, & + outts,outqs,outqcs,outus,outvs,cnvwt,prets,cupclws, & ! dimesnional variables itf,ktf,its,ite, kts,kte,ipr,tropics) do i=its,itf - if(xmbs(i).le.0.)cutens(i)=0. + if(xmbs(i).gt.0.)cutens(i)=1. enddo call neg_check('shallow',ipn,dt,qcheck,outqs,outts,outus,outvs, & outqcs,prets,its,ite,kts,kte,itf,ktf,ktops) @@ -779,8 +778,8 @@ subroutine cu_gf_driver_run(tottracer,ntrac,garea,im,ix,km,dt,cactiv, & t(i,k)=t(i,k)+dt*(cutens(i)*outts(i,k)+cutenm(i)*outtm(i,k)+outt(i,k)*cuten(i)) qv(i,k)=max(1.e-16,qv(i,k)+dt*(cutens(i)*outqs(i,k)+cutenm(i)*outqm(i,k)+outq(i,k)*cuten(i))) gdc(i,k,7)=sqrt(us(i,k)**2 +vs(i,k)**2) - us(i,k)=us(i,k)+outu(i,k)*cuten(i)*dt +outum(i,k)*cutenm(i)*dt - vs(i,k)=vs(i,k)+outv(i,k)*cuten(i)*dt +outvm(i,k)*cutenm(i)*dt + us(i,k)=us(i,k)+outu(i,k)*cuten(i)*dt +outum(i,k)*cutenm(i)*dt +outus(i,k)*cutens(i)*dt + vs(i,k)=vs(i,k)+outv(i,k)*cuten(i)*dt +outvm(i,k)*cutenm(i)*dt +outvs(i,k)*cutens(i)*dt !hj 10/11/2016: don't need gdc and gdc2 yet for gsm. !hli 08/18/2017: couple gdc to radiation diff --git a/physics/cu_gf_sh.F90 b/physics/cu_gf_sh.F90 index e2abdebb2..173de662e 100644 --- a/physics/cu_gf_sh.F90 +++ b/physics/cu_gf_sh.F90 @@ -41,7 +41,8 @@ ! ztexec,zqexec excess temperature and moisture for updraft module cu_gf_sh use machine , only : kind_phys - real(kind=kind_phys), parameter:: c1_shal=0.0015! .0005 + !real(kind=kind_phys), parameter:: c1_shal=0.0015! .0005 + real(kind=kind_phys), parameter:: c1_shal=0. !0.005! .0005 real(kind=kind_phys), parameter:: g =9.81 real(kind=kind_phys), parameter:: cp =1004. real(kind=kind_phys), parameter:: xlv=2.5e6 @@ -53,13 +54,13 @@ module cu_gf_sh subroutine cu_gf_sh_run ( & ! input variables, must be supplied - zo,t,q,z1,tn,qo,po,psur,dhdt,kpbl,rho, & + us,vs,zo,t,q,z1,tn,qo,po,psur,dhdt,kpbl,rho, & hfx,qfx,xland,ichoice,tcrit,dtime, & ! input variables. ierr should be initialized to zero or larger than zero for ! turning off shallow convection for grid points zuo,xmb_out,kbcon,ktop,k22,ierr,ierrc, & ! output tendencies - outt,outq,outqc,cnvwt,pre,cupclw, & + outt,outq,outqc,outu,outv,cnvwt,pre,cupclw, & ! dimesnional variables itf,ktf,its,ite, kts,kte,ipr,tropics) ! @@ -85,7 +86,7 @@ subroutine cu_gf_sh_run ( & ! pre = output precip real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (inout ) :: & - cnvwt,outt,outq,outqc,cupclw,zuo + cnvwt,outt,outq,outqc,cupclw,zuo,outu,outv real(kind=kind_phys), dimension (its:ite) & ,intent (out ) :: & xmb_out @@ -104,7 +105,7 @@ subroutine cu_gf_sh_run ( & ! real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (in ) :: & - t,po,tn,dhdt,rho + t,po,tn,dhdt,rho,us,vs real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (inout) :: & q,qo @@ -172,7 +173,7 @@ subroutine cu_gf_sh_run ( & ! dellaq = change of q per unit mass flux of cloud ensemble ! dellaqc = change of qc per unit mass flux of cloud ensemble - cd,dellah,dellaq,dellat,dellaqc + cd,dellah,dellaq,dellat,dellaqc,uc,vc,dellu,dellv,u_cup,v_cup ! aa0 cloud work function for downdraft ! aa0 = cloud work function without forcing effects @@ -184,7 +185,7 @@ subroutine cu_gf_sh_run ( & flux_tun,hkbo,xhkb, & rand_vmas,xmbmax,xmb, & cap_max,entr_rate, & - cap_max_increment + cap_max_increment,lambau integer, dimension (its:ite) :: & kstabi,xland1,kbmax,ktopx @@ -199,14 +200,16 @@ subroutine cu_gf_sh_run ( & real(kind=kind_phys) xff_shal(3),blqe,xkshal character*50 :: ierrc(its:ite) real(kind=kind_phys), dimension (its:ite,kts:kte) :: & - up_massentr,up_massdetr,up_massentro,up_massdetro - real(kind=kind_phys) :: c_up,x_add,qaver - real(kind=kind_phys), dimension (its:ite,kts:kte) :: dtempdz + up_massentr,up_massdetr,up_massentro,up_massdetro,up_massentru,up_massdetru + real(kind=kind_phys) :: c_up,x_add,qaver,dts,fp,fpi + real(kind=kind_phys), dimension (its:ite,kts:kte) :: c1d,dtempdz integer, dimension (its:ite,kts:kte) :: k_inv_layers integer, dimension (its:ite) :: start_level, pmin_lev start_level(:)=0 rand_vmas(:)=0. flux_tun=fluxtune + lambau(:)=2. + c1d(:,:)=0. do i=its,itf xland1(i)=int(xland(i)+.001) ! 1. ktopx(i)=0 @@ -232,6 +235,8 @@ subroutine cu_gf_sh_run ( & do i=its,itf up_massentro(i,k)=0. up_massdetro(i,k)=0. + up_massentru(i,k)=0. + up_massdetru(i,k)=0. z(i,k)=zo(i,k) xz(i,k)=zo(i,k) qrco(i,k)=0. @@ -315,6 +320,17 @@ subroutine cu_gf_sh_run ( & its,ite, kts,kte) do i=its,itf if(ierr(i).eq.0)then + u_cup(i,kts)=us(i,kts) + v_cup(i,kts)=vs(i,kts) + do k=kts+1,ktf + u_cup(i,k)=.5*(us(i,k-1)+us(i,k)) + v_cup(i,k)=.5*(vs(i,k-1)+vs(i,k)) + enddo + endif + enddo + + do i=its,itf + if(ierr(i).eq.0)then ! do k=kts,ktf if(zo_cup(i,k).gt.zkbmax+z1(i))then @@ -459,7 +475,7 @@ subroutine cu_gf_sh_run ( & call get_lateral_massflux(itf,ktf, its,ite, kts,kte & ,ierr,ktop,zo_cup,zuo,cd,entr_rate_2d & ,up_massentro, up_massdetro ,up_massentr, up_massdetr & - ,'shallow',kbcon,k22) + ,'shallow',kbcon,k22,up_massentru,up_massdetru,lambau) do k=kts,ktf do i=its,itf @@ -473,6 +489,10 @@ subroutine cu_gf_sh_run ( & enddo do i=its,itf if(ierr(i) /= 0) cycle + do k=1,start_level(i) + uc(i,k)=u_cup(i,k) + vc(i,k)=v_cup(i,k) + enddo do k=1,start_level(i)-1 hc(i,k)=he_cup(i,k) hco(i,k)=heo_cup(i,k) @@ -490,6 +510,12 @@ subroutine cu_gf_sh_run ( & hc(i,k)=(hc(i,k-1)*zu(i,k-1)-.5*up_massdetr(i,k-1)*hc(i,k-1)+ & up_massentr(i,k-1)*he(i,k-1)) / & (zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1)) + uc(i,k)=(uc(i,k-1)*zu(i,k-1)-.5*up_massdetr(i,k-1)*uc(i,k-1)+ & + up_massentr(i,k-1)*us(i,k-1)) / & + (zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1)) + vc(i,k)=(vc(i,k-1)*zu(i,k-1)-.5*up_massdetr(i,k-1)*vc(i,k-1)+ & + up_massentr(i,k-1)*vs(i,k-1))/ & + (zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1)) dby(i,k)=max(0.,hc(i,k)-hes_cup(i,k)) hco(i,k)=(hco(i,k-1)*zuo(i,k-1)-.5*up_massdetro(i,k-1)*hco(i,k-1)+ & up_massentro(i,k-1)*heo(i,k-1)) / & @@ -545,7 +571,14 @@ subroutine cu_gf_sh_run ( & dz=z_cup(i,k)-z_cup(i,k-1) ! cloud liquid water ! qrco(i,k)= (qco(i,k)-trash)/(1.+c0_shal*dz) - qrco(i,k)= (qco(i,k)-trash)/(1.+(c0_shal+c1_shal)*dz) +! qrco(i,k)= (qco(i,k)-trash)/(1.+(c0_shal+c1_shal)*dz) + qrco(i,k)= (qco(i,k)-trash)/(1.+c0_shal*dz) + c1d(i,k-1)=10.*up_massdetr(i,k-1)*.5*(qrco(i,k-1)+qrco(i,k)) + qrco(i,k)= qrco(i,k)-c1d(i,k-1)*dz*qrco(i,k) + if(qrco(i,k).lt.0.)then ! hli new test 02/12/19 + qrco(i,k)=0. + c1d(i,k-1)=1./dz + endif pwo(i,k)=c0_shal*dz*qrco(i,k)*zuo(i,k) ! cloud water vapor qco (i,k)= trash+qrco(i,k) @@ -570,6 +603,8 @@ subroutine cu_gf_sh_run ( & hc (i,k)=hes_cup (i,k) hco (i,k)=heso_cup(i,k) qco (i,k)=qeso_cup(i,k) + uc(i,k)=u_cup(i,k) + vc(i,k)=v_cup(i,k) qrco(i,k)=0. dby (i,k)=0. dbyo(i,k)=0. @@ -609,6 +644,9 @@ subroutine cu_gf_sh_run ( & do i=its,itf dellah(i,k)=0. dellaq(i,k)=0. + dellaqc(i,k)=0. + dellu (i,k)=0. + dellv (i,k)=0. enddo enddo ! @@ -653,6 +691,13 @@ subroutine cu_gf_sh_run ( & trash2=0. do i=its,itf if(ierr(i).eq.0)then + dp=100.*(po_cup(i,1)-po_cup(i,2)) + dellu(i,1)= -zuo(i,2)*(uc (i,2)-u_cup(i,2)) *g/dp + dellv(i,1)= -zuo(i,2)*(vc (i,2)-v_cup(i,2)) *g/dp + dellah(i,1)=-zuo(i,2)*(hco(i,2)-heo_cup(i,2))*g/dp + + dellaq (i,1)=-zuo(i,2)*(qco(i,2)-qo_cup(i,2))*g/dp + do k=k22(i),ktop(i) ! entrainment/detrainment for updraft entup=up_massentro(i,k) @@ -668,8 +713,8 @@ subroutine cu_gf_sh_run ( & !-- take out cloud liquid water for detrainment dz=zo_cup(i,k+1)-zo_cup(i,k) - if(k.lt.ktop(i) .and. c1_shal > 0)then - dellaqc(i,k)= zuo(i,k)*c1_shal*qrco(i,k)*dz/dp*g ! detup*0.5*(qrco(i,k+1)+qrco(i,k)) *g/dp + if(k.lt.ktop(i) .and. c1d(i,k) > 0)then + dellaqc(i,k)= zuo(i,k)*c1d(i,k)*qrco(i,k)*dz/dp*g ! detup*0.5*(qrco(i,k+1)+qrco(i,k)) *g/dp else dellaqc(i,k)=detup*0.5*(qrco(i,k+1)+qrco(i,k)) *g/dp ! dellaqc(i,k)= detup*qrco(i,k) *g/dp @@ -685,6 +730,11 @@ subroutine cu_gf_sh_run ( & dellaq(i,k) =-(zuo(i,k+1)*(qco(i,k+1)-qo_cup(i,k+1) ) - & zuo(i,k )*(qco(i,k )-qo_cup(i,k ) ) )*g/dp & - c_up - 0.5*(pwo (i,k)+pwo (i,k+1))*g/dp + dellu(i,k) =-(zuo(i,k+1)*(uc (i,k+1)-u_cup(i,k+1) ) - & + zuo(i,k )*(uc (i,k )-u_cup(i,k ) ) )*g/dp + dellv(i,k) =-(zuo(i,k+1)*(vc (i,k+1)-v_cup(i,k+1) ) - & + zuo(i,k )*(vc (i,k )-v_cup(i,k ) ) )*g/dp + enddo endif enddo @@ -826,6 +876,8 @@ subroutine cu_gf_sh_run ( & ktop (i)=0 xmb (i)=0. outt (i,:)=0. + outu (i,:)=0. + outv (i,:)=0. outq (i,:)=0. outqc(i,:)=0. else if(ierr(i).eq.0)then @@ -840,12 +892,46 @@ subroutine cu_gf_sh_run ( & outqc(i,k)= dellaqc(i,k)*xmb(i) pre (i) = pre(i)+pwo(i,k)*xmb(i) enddo + outt (i,1)= dellat (i,1)*xmb(i) + outq (i,1)= dellaq (i,1)*xmb(i) + outu(i,1)=dellu(i,1)*xmb(i) + outv(i,1)=dellv(i,1)*xmb(i) + do k=kts+1,ktop(i) + outu(i,k)=.25*(dellu(i,k-1)+2.*dellu(i,k)+dellu(i,k+1))*xmb(i) + outv(i,k)=.25*(dellv(i,k-1)+2.*dellv(i,k)+dellv(i,k+1))*xmb(i) + enddo + endif enddo +! +! since kinetic energy is being dissipated, add heating accordingly (from ecmwf) +! + do i=its,itf + if(ierr(i).eq.0) then + dts=0. + fpi=0. + do k=kts,ktop(i) + dp=(po_cup(i,k)-po_cup(i,k+1))*100. +!total ke dissiptaion estimate + dts= dts -(outu(i,k)*us(i,k)+outv(i,k)*vs(i,k))*dp/g +! fpi needed for calcualtion of conversion to pot. energyintegrated + fpi = fpi +sqrt(outu(i,k)*outu(i,k) + outv(i,k)*outv(i,k))*dp + enddo + if(fpi.gt.0.)then + do k=kts,ktop(i) + fp= sqrt((outu(i,k)*outu(i,k)+outv(i,k)*outv(i,k)))/fpi + outt(i,k)=outt(i,k)+fp*dts*g/cp + enddo + endif + endif + enddo ! ! done shallow !--------------------------done------------------------------ ! +! do k=1,30 +! print*,'hlisq',qco(1,k),qrco(1,k),pwo(1,k) +! enddo end subroutine cu_gf_sh_run end module cu_gf_sh diff --git a/physics/cu_ntiedtke.F90 b/physics/cu_ntiedtke.F90 new file mode 100644 index 000000000..1b28110b0 --- /dev/null +++ b/physics/cu_ntiedtke.F90 @@ -0,0 +1,3836 @@ +!> \file cu_ntiedtke.F90 +!! This file contains the CCPP-compliant new Tiedtke scheme which parameterize +!! Shallow, deep, and mid-level convections in the model +!! Please refer to Tiedtke (1989), Bechtold et al. (2004,2008, 2014), +!! Zhang et al. (2011), Zhang and Wang (2017, 2018) +!! +!########################################################### + +module cu_ntiedtke + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + use machine , only : kind_phys + ! DH* TODO - replace with arguments to subroutine calls, + ! this also requires redefining derived constants in the + ! parameter section below + use physcons, only:rd=>con_rd, rv=>con_rv, g=>con_g, & + & cpd=>con_cp, alv=>con_hvap, alf=>con_hfus + + implicit none + real(kind=kind_phys),private :: rcpd,vtmpc1,tmelt,als,t13, & + c1es,c2es,c3les,c3ies,c4les,c4ies,c5les,c5ies,zrg + + real(kind=kind_phys),private :: rovcp,r5alvcp,r5alscp,ralvdcp,ralsdcp,ralfdcp,rtwat,rtber,rtice + real(kind=kind_phys),private :: entrdd,cmfcmax,cmfcmin,cmfdeps,zdnoprc,cprcon + integer,private :: momtrans,p650 + + parameter( & + t13 = 0.333333333,& + rcpd=1.0/cpd, & + tmelt=273.16, & + zrg=1.0/g, & + c1es=610.78, & + c2es=c1es*rd/rv, & + c3les=17.2693882, & + c3ies=21.875, & + c4les=35.86, & + c4ies=7.66, & + als = alv+alf, & + c5les=c3les*(tmelt-c4les), & + c5ies=c3ies*(tmelt-c4ies), & + r5alvcp=c5les*alv*rcpd, & + r5alscp=c5ies*als*rcpd, & + ralvdcp=alv*rcpd, & + ralsdcp=als*rcpd, & + ralfdcp=alf*rcpd, & + rtwat=tmelt, & + rtber=tmelt-5., & + rtice=tmelt-23., & + vtmpc1=rv/rd-1.0, & + rovcp = rd*rcpd ) +! +! entrdd: average entrainment & detrainment rate for downdrafts +! ------ +! + parameter(entrdd = 2.0e-4) +! +! cmfcmax: maximum massflux value allowed for updrafts etc +! ------- +! + parameter(cmfcmax = 1.0) +! +! cmfcmin: minimum massflux value (for safety) +! ------- +! + parameter(cmfcmin = 1.e-10) +! +! cmfdeps: fractional massflux for downdrafts at lfs +! ------- +! + parameter(cmfdeps = 0.30) + +! zdnoprc: deep cloud is thicker than this height (Unit:Pa) +! + parameter(zdnoprc = 2.0e4) +! ------- +! +! cprcon: coefficient from cloud water to rain water +! + parameter(cprcon = 1.4e-3) +! ------- +! +! momtrans: momentum transport method +! ( 1 = IFS40r1 method; 2 = new method ) +! + parameter(momtrans = 2 ) +! ------- +! + logical :: isequil +! isequil: representing equilibrium and nonequilibrium convection +! ( .false. [default]; .true. [experimental]. Ref. Bechtold et al. 2014 JAS ) +! + parameter(isequil = .false. ) +! +!-------------------- +! switches for deep, mid, shallow convections, downdraft, and momemtum transport +! ------------------ + logical :: lmfpen,lmfmid,lmfscv,lmfdd,lmfdudv + parameter(lmfpen=.true.,lmfmid=.true.,lmfscv=.true.,lmfdd=.true.,lmfdudv=.true.) +!-------------------- +!#################### end of variables definition########################## +!----------------------------------------------------------------------- +! +contains +!> \brief Brief description of the subroutine +!! +!! \section arg_table_cu_ntiedtke_init Argument Table +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |----------------------|--------------------|------------------------------------------|-------|------|-----------|-----------|--------|----------| +!! | mpirank | mpi_rank | current MPI-rank | index | 0 | integer | | in | F | +!! | mpiroot | mpi_root | master MPI-rank | index | 0 | integer | | in | F | +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! + subroutine cu_ntiedtke_init(mpirank, mpiroot, errmsg, errflg) + + implicit none + + integer, intent(in) :: mpirank + integer, intent(in) :: mpiroot + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg + + ! DH* temporary + if (mpirank==mpiroot) then + write(0,*) ' -----------------------------------------------------------------------------------------------------------------------------' + write(0,*) ' --- WARNING --- the CCPP New Tiedtke convection scheme is currently under development, use at your own risk --- WARNING ---' + write(0,*) ' -----------------------------------------------------------------------------------------------------------------------------' + end if + ! *DH temporary + + end subroutine cu_ntiedtke_init + + +!> \brief Brief description of the subroutine +!! +!! \section arg_table_cu_ntiedtke_finalize Argument Table +!! + subroutine cu_ntiedtke_finalize() + end subroutine cu_ntiedtke_finalize +! +! Tiedtke cumulus scheme from WRF with small modifications +! This scheme includes both deep and shallow convections +!=================== +! +!! +!! \section arg_table_cu_ntiedtke_run Argument Table +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |----------------|-----------------------------------------------------------|----------------------------------------------------------|---------------|------|-----------|-----------|--------|----------| +!! | pu | x_wind_updated_by_physics | updated x-direction wind | m s-1 | 2 | real | kind_phys | inout | F | +!! | pv | y_wind_updated_by_physics | updated y-direction wind | m s-1 | 2 | real | kind_phys | inout | F | +!! | pt | air_temperature_updated_by_physics | updated temperature | K | 2 | real | kind_phys | inout | F | +!! | pqv | water_vapor_specific_humidity_updated_by_physics | water vapor specific humidity | kg kg-1 | 2 | real | kind_phys | inout | F | +!! | pqvf | moisture_tendency_due_to_dynamics | moisture tendency due to dynamics only | kg kg-1 s-1 | 2 | real | kind_phys | in | F | +!! | ptf | temperature_tendency_due_to_dynamics | temperature tendency due to dynamics only | K s-1 | 2 | real | kind_phys | in | F | +!! | clw | convective_transportable_tracers | array to contain cloud water and other tracers | kg kg-1 | 3 | real | kind_phys | inout | F | +!! | poz | geopotential | geopotential at model layer centers | m2 s-2 | 2 | real | kind_phys | in | F | +!! | pzz | geopotential_at_interface | geopotential at model layer interfaces | m2 s-2 | 2 | real | kind_phys | in | F | +!! | prsl | air_pressure | mean layer pressure | Pa | 2 | real | kind_phys | in | F | +!! | prsi | air_pressure_at_interface | air pressure at model layer interfaces | Pa | 2 | real | kind_phys | in | F | +!! | pomg | omega | layer mean vertical velocity | Pa s-1 | 2 | real | kind_phys | in | F | +!! | evap | kinematic_surface_upward_latent_heat_flux | kinematic surface upward latent heat flux | kg kg-1 m s-1 | 1 | real | kind_phys | in | F | +!! | hfx | kinematic_surface_upward_sensible_heat_flux | kinematic surface upward sensible heat flux | K m s-1 | 1 | real | kind_phys | in | F | +!! | zprecc | lwe_thickness_of_deep_convective_precipitation_amount | deep convective rainfall amount on physics timestep | m | 1 | real | kind_phys | out | F | +!! | lmask | sea_land_ice_mask | landmask: sea/land/ice=0/1/2 | flag | 1 | integer | | in | F | +!! | lq | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | +!! | ix | horizontal_dimension | horizontal dimension | count | 0 | integer | | in | F | +!! | km | vertical_dimension | vertical layer dimension | count | 0 | integer | | in | F | +!! | dt | time_step_for_physics | physics time step | s | 0 | real | kind_phys | in | F | +!! | dx | cell_size | size of the grid cell | m | 1 | real | kind_phys | in | F | +!! | kbot | vertical_index_at_cloud_base | index for cloud base | index | 1 | integer | | out | F | +!! | ktop | vertical_index_at_cloud_top | index for cloud top | index | 1 | integer | | out | F | +!! | kcnv | flag_deep_convection | deep convection: 0=no, 1=yes | flag | 1 | integer | | out | F | +!! | ktrac | number_of_total_tracers | number of total tracers | count | 0 | integer | | in | F | +!! | ud_mf | instantaneous_atmosphere_updraft_convective_mass_flux | (updraft mass flux) * delt | kg m-2 | 2 | real | kind_phys | out | F | +!! | dd_mf | instantaneous_atmosphere_downdraft_convective_mass_flux | (downdraft mass flux) * delt | kg m-2 | 2 | real | kind_phys | out | F | +!! | dt_mf | instantaneous_atmosphere_detrainment_convective_mass_flux | (detrainment mass flux) * delt | kg m-2 | 2 | real | kind_phys | out | F | +!! | cnvw | convective_cloud_water_mixing_ratio | convective cloud water | kg kg-1 | 2 | real | kind_phys | out | F | +!! | cnvc | convective_cloud_cover | convective cloud cover | frac | 2 | real | kind_phys | out | F | +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! +!----------------------------------------------------------------------- +! level 1 subroutine 'tiecnvn' +!----------------------------------------------------------------- + subroutine cu_ntiedtke_run(pu,pv,pt,pqv,pqvf,ptf,clw,poz,pzz,prsl,prsi,pomg, & + evap,hfx,zprecc,lmask,lq,ix,km,dt,dx,kbot,ktop,kcnv,& + ktrac,ud_mf,dd_mf,dt_mf,cnvw,cnvc,errmsg,errflg) +!----------------------------------------------------------------- +! this is the interface between the model and the mass +! flux convection module +!----------------------------------------------------------------- + implicit none +! in&out variables + integer, intent(in) :: lq, ix, km, ktrac + real(kind=kind_phys), intent(in ) :: dt + integer, dimension( lq ), intent(in) :: lmask + real(kind=kind_phys), dimension( lq ), intent(in ) :: evap, hfx, dx + real(kind=kind_phys), dimension( ix , km ), intent(inout) :: pu, pv, pt, pqv + real(kind=kind_phys), dimension( ix , km ), intent(in ) :: poz, prsl, pomg, pqvf, ptf + real(kind=kind_phys), dimension( ix , km+1 ), intent(in ) :: pzz, prsi + real(kind=kind_phys), dimension( ix , km, ktrac+2 ), intent(inout ) :: clw + + integer, dimension( lq ), intent(out) :: kbot, ktop, kcnv + real(kind=kind_phys), dimension( lq ), intent(out) :: zprecc + real(kind=kind_phys), dimension (lq,km), intent(out) :: ud_mf, dd_mf, dt_mf, cnvw, cnvc + +! error messages + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + +! local variables + real(kind=kind_phys) pum1(lq,km), pvm1(lq,km), ztt(lq,km), & + & ptte(lq,km), pqte(lq,km), pvom(lq,km), pvol(lq,km), & + & pverv(lq,km), pgeo(lq,km), pap(lq,km), paph(lq,km+1) + real(kind=kind_phys) pqhfl(lq), zqq(lq,km), & + & prsfc(lq), pssfc(lq), pcte(lq,km), & + & phhfl(lq), pgeoh(lq,km+1) + real(kind=kind_phys) ztp1(lq,km), zqp1(lq,km), ztu(lq,km), zqu(lq,km),& + & zlu(lq,km), zlude(lq,km), zmfu(lq,km), zmfd(lq,km), zmfude_rate(lq,km),& + & zqsat(lq,km), zrain(lq) + real(kind=kind_phys) pcen(lq,km,ktrac),ptenc(lq,km,ktrac) + + integer icbot(lq), ictop(lq), ktype(lq), lndj(lq) + logical locum(lq) +! + real(kind=kind_phys) ztmst,fliq,fice,ztc,zalf,tt + integer i,j,k,k1,n,km1 + real(kind=kind_phys) ztpp1 + real(kind=kind_phys) zew,zqs,zcor +! +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + km1 = km + 1 + ztmst=dt +! +! masv flux diagnostics. +! + do j=1,lq + zrain(j)=0.0 + locum(j)=.false. + prsfc(j)=0.0 + pssfc(j)=0.0 + pqhfl(j)=evap(j) + phhfl(j)=hfx(j) + pgeoh(j,km1)=pzz(j,1) + paph(j,km1)=prsi(j,1) + if(lmask(j).eq.1) then + lndj(j)=1 + else + lndj(j)=0 + end if + end do +! +! convert model variables for mflux scheme +! + do k=1,km + k1=km-k+1 + do j=1,lq + pcte(j,k1)=0.0 + pvom(j,k1)=0.0 + pvol(j,k1)=0.0 + ztp1(j,k1)=pt(j,k) + zqp1(j,k1)=pqv(j,k) + pum1(j,k1)=pu(j,k) + pvm1(j,k1)=pv(j,k) + pverv(j,k1)=pomg(j,k) + pgeo(j,k1)=poz(j,k) + pgeoh(j,k1)=pzz(j,k+1) + pap(j,k1)=prsl(j,k) + paph(j,k1)=prsi(j,k+1) + tt=ztp1(j,k1) + zew = foeewm(tt) + zqs = zew/pap(j,k1) + zqs = min(0.5,zqs) + zcor = 1./(1.-vtmpc1*zqs) + zqsat(j,k1)=zqs*zcor + pqte(j,k1)=pqvf(j,k) + zqq(j,k1) =pqte(j,k1) + ptte(j,k1)=ptf(j,k) + ztt(j,k1) =ptte(j,k1) + ud_mf(j,k1)=0. + dd_mf(j,k1)=0. + dt_mf(j,k1)=0. + cnvw(j,k1)=0. + cnvc(j,k1)=0. + end do + end do + + do n=1,ktrac + do k=1,km + k1=km-k+1 + do j=1,lq + pcen(j,k1,n) = clw(j,k,n+2) + ptenc(j,k1,n)= 0. + end do + end do + end do + +! print *, "pgeo=",pgeo(1,:) +! print *, "pgeoh=",pgeoh(1,:) +! print *, "pap=",pap(1,:) +! print *, "paph=",paph(1,:) +! print *, "ztp1=",ztp1(1,:) +! print *, "zqp1=",zqp1(1,:) +! print *, "pum1=",pum1(1,:) +! print *, "pvm1=",pvm1(1,:) +! print *, "pverv=",pverv(1,:) +! print *, "pqte=",pqte(1,:) +! print *, "ptte=",ptte(1,:) +! print *, "hfx=", pqhfl(1),phhfl(1),dx(1) +! +!----------------------------------------------------------------------- +!* 2. call 'cumastrn'(master-routine for cumulus parameterization) +! + call cumastrn & + & (lq, km, km1, km-1, ztp1, & + & zqp1, pum1, pvm1, pverv, zqsat,& + & pqhfl, ztmst, pap, paph, pgeo, & + & ptte, pqte, pvom, pvol, prsfc,& + & pssfc, locum, ktrac, pcen, ptenc,& + & ktype, icbot, ictop, ztu, zqu, & + & zlu, zlude, zmfu, zmfd, zrain,& + & pcte, phhfl, lndj, pgeoh, zmfude_rate, dx) +! +! to include the cloud water and cloud ice detrained from convection +! + do k=1,km + k1=km-k+1 + do j=1,lq + if(pcte(j,k1).gt.0.) then + fliq=foealfa(ztp1(j,k1)) + fice=1.0-fliq + clw(j,k,2)=clw(j,k,2)+fliq*pcte(j,k1)*ztmst + clw(j,k,1)=clw(j,k,1)+fice*pcte(j,k1)*ztmst + endif + end do + end do +! + do k=1,km + k1 = km-k+1 + do j=1,lq + pt(j,k) = ztp1(j,k1)+(ptte(j,k1)-ztt(j,k1))*ztmst + pqv(j,k)= zqp1(j,k1)+(pqte(j,k1)-zqq(j,k1))*ztmst + ud_mf(j,k)= zmfu(j,k1)*ztmst + dd_mf(j,k)= zmfd(j,k1)*ztmst + dt_mf(j,k)= zmfude_rate(j,k1)*ztmst + cnvw(j,k) = zlude(j,k1)*ztmst*g/(prsi(j,k)-prsi(j,k+1)) + cnvc(j,k) = 0.04 * log(1. + 675. * ud_mf(j,k)) + cnvc(j,k) = min(cnvc(j,k), 0.6) + cnvc(j,k) = max(cnvc(j,k), 0.0) + end do + end do + + do j=1,lq + zprecc(j)=amax1(0.0,(prsfc(j)+pssfc(j))*ztmst*0.001) + kbot(j) = km-icbot(j)+1 + ktop(j) = km-ictop(j)+1 + if(ktype(j).eq.1 .or. ktype(j).eq.3) then + kcnv(j)=1 + else + kcnv(j)=0 + end if + end do + + if (lmfdudv) then + do k=1,km + k1=km-k+1 + do j=1,lq + pu(j,k)=pu(j,k)+pvom(j,k1)*ztmst + pv(j,k)=pv(j,k)+pvol(j,k1)*ztmst + end do + end do + endif +! + if (ktrac > 0) then + do n=1,ktrac + do k=1,km + k1=km-k+1 + do j=1,lq + clw(j,k,n+2)=pcen(j,k,n)+ptenc(j,k1,n)*ztmst + end do + end do + end do + end if +! + return + end subroutine cu_ntiedtke_run + +!############################################################# +! +! level 2 subroutines +! +!############################################################# +!*********************************************************** +! subroutine cumastrn +!*********************************************************** + subroutine cumastrn & + & (klon, klev, klevp1, klevm1, pten, & + & pqen, puen, pven, pverv, pqsen,& + & pqhfl, ztmst, pap, paph, pgeo, & + & ptte, pqte, pvom, pvol, prsfc,& + & pssfc, ldcum, ktrac, pcen, ptenc,& + & ktype, kcbot, kctop, ptu, pqu,& + & plu, plude, pmfu, pmfd, prain,& + & pcte, phhfl, lndj, zgeoh, pmfude_rate, dx) + implicit none +! +!***cumastrn* master routine for cumulus massflux-scheme +! m.tiedtke e.c.m.w.f. 1986/1987/1989 +! modifications +! y.wang i.p.r.c 2001 +! c.zhang 2012 +!***purpose +! ------- +! this routine computes the physical tendencies of the +! prognostic variables t,q,u and v due to convective processes. +! processes considered are: convective fluxes, formation of +! precipitation, evaporation of falling rain below cloud base, +! saturated cumulus downdrafts. +!***method +! ------ +! parameterization is done using a massflux-scheme. +! (1) define constants and parameters +! (2) specify values (t,q,qs...) at half levels and +! initialize updraft- and downdraft-values in 'cuinin' +! (3) calculate cloud base in 'cutypen', calculate cloud types in cutypen, +! and specify cloud base massflux +! (4) do cloud ascent in 'cuascn' in absence of downdrafts +! (5) do downdraft calculations: +! (a) determine values at lfs in 'cudlfsn' +! (b) determine moist descent in 'cuddrafn' +! (c) recalculate cloud base massflux considering the +! effect of cu-downdrafts +! (6) do final adjusments to convective fluxes in 'cuflxn', +! do evaporation in subcloud layer +! (7) calculate increments of t and q in 'cudtdqn' +! (8) calculate increments of u and v in 'cududvn' +!***externals. +! ---------- +! cuinin: initializes values at vertical grid used in cu-parametr. +! cutypen: cloud bypes, 1: deep cumulus 2: shallow cumulus +! cuascn: cloud ascent for entraining plume +! cudlfsn: determines values at lfs for downdrafts +! cuddrafn:does moist descent for cumulus downdrafts +! cuflxn: final adjustments to convective fluxes (also in pbl) +! cudqdtn: updates tendencies for t and q +! cududvn: updates tendencies for u and v +!***switches. +! -------- +! lmfmid=.t. midlevel convection is switched on +! lmfdd=.t. cumulus downdrafts switched on +! lmfdudv=.t. cumulus friction switched on +!*** +! model parameters (defined in subroutine cuparam) +! ------------------------------------------------ +! entrdd entrainment rate for cumulus downdrafts +! cmfcmax maximum massflux value allowed for +! cmfcmin minimum massflux value (for safety) +! cmfdeps fractional massflux for downdrafts at lfs +! cprcon coefficient for conversion from cloud water to rain +!***reference. +! ---------- +! paper on massflux scheme (tiedtke,1989) +!----------------------------------------------------------------- + integer klev,klon,ktrac,klevp1,klevm1 + real(kind=kind_phys) pten(klon,klev), pqen(klon,klev),& + & puen(klon,klev), pven(klon,klev),& + & ptte(klon,klev), pqte(klon,klev),& + & pvom(klon,klev), pvol(klon,klev),& + & pqsen(klon,klev), pgeo(klon,klev),& + & pap(klon,klev), paph(klon,klevp1),& + & pverv(klon,klev), pqhfl(klon),& + & phhfl(klon) + real(kind=kind_phys) ptu(klon,klev), pqu(klon,klev),& + & plu(klon,klev), plude(klon,klev),& + & pmfu(klon,klev), pmfd(klon,klev),& + & prain(klon),& + & prsfc(klon), pssfc(klon) + real(kind=kind_phys) ztenh(klon,klev), zqenh(klon,klev),& + & zgeoh(klon,klevp1), zqsenh(klon,klev),& + & ztd(klon,klev), zqd(klon,klev),& + & zmfus(klon,klev), zmfds(klon,klev),& + & zmfuq(klon,klev), zmfdq(klon,klev),& + & zdmfup(klon,klev), zdmfdp(klon,klev),& + & zmful(klon,klev), zrfl(klon),& + & zuu(klon,klev), zvu(klon,klev),& + & zud(klon,klev), zvd(klon,klev),& + & zlglac(klon,klev) + real(kind=kind_phys) pmflxr(klon,klevp1), pmflxs(klon,klevp1) + real(kind=kind_phys) zhcbase(klon),& + & zmfub(klon), zmfub1(klon),& + & zdhpbl(klon) + real(kind=kind_phys) zsfl(klon), zdpmel(klon,klev),& + & pcte(klon,klev), zcape(klon),& + & zcape1(klon), zcape2(klon),& + & ztauc(klon), ztaubl(klon),& + & zheat(klon) + real(kind=kind_phys) pcen(klon,klev,ktrac), ptenc(klon,klev,ktrac) + real(kind=kind_phys) wup(klon), zdqcv(klon) + real(kind=kind_phys) wbase(klon), zmfuub(klon) + real(kind=kind_phys) upbl(klon) + real(kind=kind_phys) dx(klon) + real(kind=kind_phys) pmfude_rate(klon,klev), pmfdde_rate(klon,klev) + real(kind=kind_phys) zmfuus(klon,klev), zmfdus(klon,klev) + real(kind=kind_phys) zmfudr(klon,klev), zmfddr(klon,klev) + real(kind=kind_phys) zuv2(klon,klev),ztenu(klon,klev),ztenv(klon,klev) + real(kind=kind_phys) zmfuvb(klon),zsum12(klon),zsum22(klon) + integer ilab(klon,klev), idtop(klon),& + & ictop0(klon), ilwmin(klon) + integer kdpl(klon) + integer kcbot(klon), kctop(klon),& + & ktype(klon), lndj(klon) + logical ldcum(klon), lldcum(klon) + logical loddraf(klon), llddraf3(klon), llo1, llo2(klon) + +! local varaiables + real(kind=kind_phys) zcons,zcons2,zqumqe,zdqmin,zdh,zmfmax + real(kind=kind_phys) zalfaw,zalv,zqalv,zc5ldcp,zc4les,zhsat,zgam,zzz,zhhat + real(kind=kind_phys) zpbmpt,zro,zdz,zdp,zeps,zfac,wspeed + integer jl,jk,ik + integer ikb,ikt,icum,itopm2 + real(kind=kind_phys) ztmst,ztau,zerate,zderate,zmfa + real(kind=kind_phys) zmfs(klon),pmean(klev),zlon + real(kind=kind_phys) zduten,zdvten,ztdis,pgf_u,pgf_v +!------------------------------------------- +! 1. specify constants and parameters +!------------------------------------------- + zcons=1./(g*ztmst) + zcons2=3./(g*ztmst) + + zlon = real(klon) + do jk = klev , 1 , -1 + pmean(jk) = sum(pap(:,jk))/zlon + end do + p650 = klev-2 + do jk = klev , 3 , -1 + if ( pmean(jk)/pmean(klev)*1.013250e5 > 650.e2 ) p650 = jk + end do + +!-------------------------------------------------------------- +!* 2. initialize values at vertical grid points in 'cuini' +!-------------------------------------------------------------- + call cuinin & + & (klon, klev, klevp1, klevm1, pten, & + & pqen, pqsen, puen, pven, pverv,& + & pgeo, paph, zgeoh, ztenh, zqenh,& + & zqsenh, ilwmin, ptu, pqu, ztd, & + & zqd, zuu, zvu, zud, zvd, & + & pmfu, pmfd, zmfus, zmfds, zmfuq,& + & zmfdq, zdmfup, zdmfdp, zdpmel, plu, & + & plude, ilab) + +!---------------------------------- +!* 3.0 cloud base calculations +!---------------------------------- +!* (a) determine cloud base values in 'cutypen', +! and the cumulus type 1 or 2 +! ------------------------------------------- + call cutypen & + & ( klon, klev, klevp1, klevm1, pqen,& + & ztenh, zqenh, zqsenh, zgeoh, paph,& + & phhfl, pqhfl, pgeo, pqsen, pap,& + & pten, lndj, ptu, pqu, ilab,& + & ldcum, kcbot, ictop0, ktype, wbase, plu, kdpl) + +!* (b) assign the first guess mass flux at cloud base +! ------------------------------------------ + do jl=1,klon + zdhpbl(jl)=0.0 + upbl(jl) = 0.0 + idtop(jl)=0 + end do + + do jk=2,klev + do jl=1,klon + if(jk.ge.kcbot(jl) .and. ldcum(jl)) then + zdhpbl(jl)=zdhpbl(jl)+(alv*pqte(jl,jk)+cpd*ptte(jl,jk))& + & *(paph(jl,jk+1)-paph(jl,jk)) + if(lndj(jl) .eq. 0) then + wspeed = sqrt(puen(jl,jk)**2 + pven(jl,jk)**2) + upbl(jl) = upbl(jl) + wspeed*(paph(jl,jk+1)-paph(jl,jk)) + end if + end if + end do + end do + + do jl=1,klon + if(ldcum(jl)) then + ikb=kcbot(jl) + zmfmax = (paph(jl,ikb)-paph(jl,ikb-1))*zcons2 + if(ktype(jl) == 1) then + zmfub(jl)= 0.1*zmfmax + else if ( ktype(jl) == 2 ) then + zqumqe = pqu(jl,ikb) + plu(jl,ikb) - zqenh(jl,ikb) + zdqmin = max(0.01*zqenh(jl,ikb),1.e-10) + zdh = cpd*(ptu(jl,ikb)-ztenh(jl,ikb)) + alv*zqumqe + zdh = g*max(zdh,1.e5*zdqmin) + if ( zdhpbl(jl) > 0. ) then + zmfub(jl) = zdhpbl(jl)/zdh + zmfub(jl) = min(zmfub(jl),zmfmax) + else + zmfub(jl) = 0.1*zmfmax + ldcum(jl) = .false. + end if + end if + else + zmfub(jl) = 0. + end if + end do +!------------------------------------------------------ +!* 4.0 determine cloud ascent for entraining plume +!------------------------------------------------------ +!* (a) do ascent in 'cuasc'in absence of downdrafts +!---------------------------------------------------------- + call cuascn & + & (klon, klev, klevp1, klevm1, ztenh,& + & zqenh, puen, pven, pten, pqen,& + & pqsen, pgeo, zgeoh, pap, paph,& + & pqte, pverv, ilwmin, ldcum, zhcbase,& + & ktype, ilab, ptu, pqu, plu,& + & zuu, zvu, pmfu, zmfub,& + & zmfus, zmfuq, zmful, plude, zdmfup,& + & kcbot, kctop, ictop0, icum, ztmst,& + & zqsenh, zlglac, lndj, wup, wbase, kdpl, pmfude_rate ) + +!* (b) check cloud depth and change entrainment rate accordingly +! calculate precipitation rate (for downdraft calculation) +!------------------------------------------------------------------ + do jl=1,klon + if ( ldcum(jl) ) then + ikb = kcbot(jl) + itopm2 = kctop(jl) + zpbmpt = paph(jl,ikb) - paph(jl,itopm2) + if ( ktype(jl) == 1 .and. zpbmpt < zdnoprc ) ktype(jl) = 2 + if ( ktype(jl) == 2 .and. zpbmpt >= zdnoprc ) ktype(jl) = 1 + ictop0(jl) = kctop(jl) + end if + zrfl(jl)=zdmfup(jl,1) + end do + + do jk=2,klev + do jl=1,klon + zrfl(jl)=zrfl(jl)+zdmfup(jl,jk) + end do + end do + + do jk = 1,klev + do jl = 1,klon + pmfd(jl,jk) = 0. + zmfds(jl,jk) = 0. + zmfdq(jl,jk) = 0. + zdmfdp(jl,jk) = 0. + zdpmel(jl,jk) = 0. + end do + end do + +!----------------------------------------- +!* 6.0 cumulus downdraft calculations +!----------------------------------------- + if(lmfdd) then +!* (a) determine lfs in 'cudlfsn' +!-------------------------------------- + call cudlfsn & + & (klon, klev,& + & kcbot, kctop, lndj, ldcum, & + & ztenh, zqenh, puen, pven, & + & pten, pqsen, pgeo, & + & zgeoh, paph, ptu, pqu, plu, & + & zuu, zvu, zmfub, zrfl, & + & ztd, zqd, zud, zvd, & + & pmfd, zmfds, zmfdq, zdmfdp, & + & idtop, loddraf) +!* (b) determine downdraft t,q and fluxes in 'cuddrafn' +!------------------------------------------------------------ + call cuddrafn & + & ( klon, klev, loddraf, & + & ztenh, zqenh, puen, pven, & + & pgeo, zgeoh, paph, zrfl, & + & ztd, zqd, zud, zvd, pmfu, & + & pmfd, zmfds, zmfdq, zdmfdp, pmfdde_rate ) +!----------------------------------------------------------- + end if +! +!----------------------------------------------------------------------- +!* 6.0 closure and clean work +! ------ +!-- 6.1 recalculate cloud base massflux from a cape closure +! for deep convection (ktype=1) +! + do jl=1,klon + if(ldcum(jl) .and. ktype(jl) .eq. 1) then + ikb = kcbot(jl) + ikt = kctop(jl) + zheat(jl)=0.0 + zcape(jl)=0.0 + zcape1(jl)=0.0 + zcape2(jl)=0.0 + zmfub1(jl)=zmfub(jl) + + ztauc(jl) = (zgeoh(jl,ikt)-zgeoh(jl,ikb)) / & + ((2.+ min(15.0,wup(jl)))*g) + if(lndj(jl) .eq. 0) then + upbl(jl) = 2.+ upbl(jl)/(paph(jl,klev+1)-paph(jl,ikb)) + ztaubl(jl) = (zgeoh(jl,ikb)-zgeoh(jl,klev+1))/(g*upbl(jl)) + ztaubl(jl) = min(300., ztaubl(jl)) + else + ztaubl(jl) = ztauc(jl) + end if + end if + end do +! + do jk = 1 , klev + do jl = 1 , klon + llo1 = ldcum(jl) .and. ktype(jl) .eq. 1 + if ( llo1 .and. jk <= kcbot(jl) .and. jk > kctop(jl) ) then + ikb = kcbot(jl) + zdz = pgeo(jl,jk-1)-pgeo(jl,jk) + zdp = pap(jl,jk)-pap(jl,jk-1) + zheat(jl) = zheat(jl) + ((pten(jl,jk-1)-pten(jl,jk)+zdz*rcpd) / & + ztenh(jl,jk)+vtmpc1*(pqen(jl,jk-1)-pqen(jl,jk))) * & + (g*(pmfu(jl,jk)+pmfd(jl,jk))) + zcape1(jl) = zcape1(jl) + ((ptu(jl,jk)-ztenh(jl,jk))/ztenh(jl,jk) + & + vtmpc1*(pqu(jl,jk)-zqenh(jl,jk))-plu(jl,jk))*zdp + end if + + if ( llo1 .and. jk >= kcbot(jl) ) then + if((paph(jl,klev+1)-paph(jl,kdpl(jl)))<50.e2) then + zdp = paph(jl,jk+1)-paph(jl,jk) + zcape2(jl) = zcape2(jl) + ztaubl(jl)* & + ((1.+vtmpc1*pqen(jl,jk))*ptte(jl,jk)+vtmpc1*pten(jl,jk)*pqte(jl,jk))*zdp + end if + end if + end do + end do + + do jl=1,klon + if(ldcum(jl).and.ktype(jl).eq.1) then + ikb = kcbot(jl) + ikt = kctop(jl) + ztau = ztauc(jl) * (1.+1.33e-5*dx(jl)) + ztau = max(ztmst,ztau) + ztau = max(720.,ztau) + ztau = min(10800.,ztau) + if(isequil) then + zcape2(jl)= max(0.,zcape2(jl)) + zcape(jl) = max(0.,min(zcape1(jl)-zcape2(jl),5000.)) + else + zcape(jl) = max(0.,min(zcape1(jl),5000.)) + end if + zheat(jl) = max(1.e-4,zheat(jl)) + zmfub1(jl) = (zcape(jl)*zmfub(jl))/(zheat(jl)*ztau) + zmfub1(jl) = max(zmfub1(jl),0.001) + zmfmax=(paph(jl,ikb)-paph(jl,ikb-1))*zcons2 + zmfub1(jl)=min(zmfub1(jl),zmfmax) + end if + end do +! +!* 6.2 recalculate convective fluxes due to effect of +! downdrafts on boundary layer moist static energy budget (ktype=2) +!-------------------------------------------------------- + do jl=1,klon + if(ldcum(jl) .and. ktype(jl) .eq. 2) then + ikb=kcbot(jl) + if(pmfd(jl,ikb).lt.0.0 .and. loddraf(jl)) then + zeps=-pmfd(jl,ikb)/max(zmfub(jl),cmfcmin) + else + zeps=0. + endif + zqumqe=pqu(jl,ikb)+plu(jl,ikb)- & + & zeps*zqd(jl,ikb)-(1.-zeps)*zqenh(jl,ikb) + zdqmin=max(0.01*zqenh(jl,ikb),cmfcmin) + zmfmax=(paph(jl,ikb)-paph(jl,ikb-1))*zcons2 +! using moist static engergy closure instead of moisture closure + zdh=cpd*(ptu(jl,ikb)-zeps*ztd(jl,ikb)- & + & (1.-zeps)*ztenh(jl,ikb))+alv*zqumqe + zdh=g*max(zdh,1.e5*zdqmin) + if(zdhpbl(jl).gt.0.)then + zmfub1(jl)=zdhpbl(jl)/zdh + else + zmfub1(jl) = zmfub(jl) + end if + zmfub1(jl) = min(zmfub1(jl),zmfmax) + end if + +!* 6.3 mid-level convection - nothing special +!--------------------------------------------------------- + if(ldcum(jl) .and. ktype(jl) .eq. 3 ) then + zmfub1(jl) = zmfub(jl) + end if + + end do + +!* 6.4 scaling the downdraft mass flux +!--------------------------------------------------------- + do jk=1,klev + do jl=1,klon + if( ldcum(jl) ) then + zfac=zmfub1(jl)/max(zmfub(jl),cmfcmin) + pmfd(jl,jk)=pmfd(jl,jk)*zfac + zmfds(jl,jk)=zmfds(jl,jk)*zfac + zmfdq(jl,jk)=zmfdq(jl,jk)*zfac + zdmfdp(jl,jk)=zdmfdp(jl,jk)*zfac + pmfdde_rate(jl,jk) = pmfdde_rate(jl,jk)*zfac + end if + end do + end do + +!* 6.5 scaling the updraft mass flux +! -------------------------------------------------------- + do jl = 1,klon + if ( ldcum(jl) ) zmfs(jl) = zmfub1(jl)/max(cmfcmin,zmfub(jl)) + end do + do jk = 2 , klev + do jl = 1,klon + if ( ldcum(jl) .and. jk >= kctop(jl)-1 ) then + ikb = kcbot(jl) + if ( jk>ikb ) then + zdz = ((paph(jl,klev+1)-paph(jl,jk))/(paph(jl,klev+1)-paph(jl,ikb))) + pmfu(jl,jk) = pmfu(jl,ikb)*zdz + end if + zmfmax = (paph(jl,jk)-paph(jl,jk-1))*zcons2 + if ( pmfu(jl,jk)*zmfs(jl) > zmfmax ) then + zmfs(jl) = min(zmfs(jl),zmfmax/pmfu(jl,jk)) + end if + end if + end do + end do + do jk = 2 , klev + do jl = 1,klon + if ( ldcum(jl) .and. jk <= kcbot(jl) .and. jk >= kctop(jl)-1 ) then + pmfu(jl,jk) = pmfu(jl,jk)*zmfs(jl) + zmfus(jl,jk) = zmfus(jl,jk)*zmfs(jl) + zmfuq(jl,jk) = zmfuq(jl,jk)*zmfs(jl) + zmful(jl,jk) = zmful(jl,jk)*zmfs(jl) + zdmfup(jl,jk) = zdmfup(jl,jk)*zmfs(jl) + plude(jl,jk) = plude(jl,jk)*zmfs(jl) + pmfude_rate(jl,jk) = pmfude_rate(jl,jk)*zmfs(jl) + end if + end do + end do + +!* 6.6 if ktype = 2, kcbot=kctop is not allowed +! --------------------------------------------------- + do jl = 1,klon + if ( ktype(jl) == 2 .and. & + kcbot(jl) == kctop(jl) .and. kcbot(jl) >= klev-1 ) then + ldcum(jl) = .false. + ktype(jl) = 0 + end if + end do + + if ( .not. lmfscv .or. .not. lmfpen ) then + do jl = 1,klon + llo2(jl) = .false. + if ( (.not. lmfscv .and. ktype(jl) == 2) .or. & + (.not. lmfpen .and. ktype(jl) == 1) ) then + llo2(jl) = .true. + ldcum(jl) = .false. + end if + end do + end if + +!* 6.7 set downdraft mass fluxes to zero above cloud top +!---------------------------------------------------- + do jl = 1,klon + if ( loddraf(jl) .and. idtop(jl) <= kctop(jl) ) then + idtop(jl) = kctop(jl) + 1 + end if + end do + do jk = 2 , klev + do jl = 1,klon + if ( loddraf(jl) ) then + if ( jk < idtop(jl) ) then + pmfd(jl,jk) = 0. + zmfds(jl,jk) = 0. + zmfdq(jl,jk) = 0. + pmfdde_rate(jl,jk) = 0. + zdmfdp(jl,jk) = 0. + else if ( jk == idtop(jl) ) then + pmfdde_rate(jl,jk) = 0. + end if + end if + end do + end do + + itopm2 = 2 +!---------------------------------------------------------- +!* 7.0 determine final convective fluxes in 'cuflx' +!---------------------------------------------------------- + call cuflxn & + & ( klon, klev, ztmst & + & , pten, pqen, pqsen, ztenh, zqenh & + & , paph, pap, zgeoh, lndj, ldcum & + & , kcbot, kctop, idtop, itopm2 & + & , ktype, loddraf & + & , pmfu, pmfd, zmfus, zmfds & + & , zmfuq, zmfdq, zmful, plude & + & , zdmfup, zdmfdp, zdpmel, zlglac & + & , prain, pmfdde_rate, pmflxr, pmflxs ) + +! some adjustments needed + do jl=1,klon + zmfs(jl) = 1. + zmfuub(jl)=0. + end do + do jk = 2 , klev + do jl = 1,klon + if ( loddraf(jl) .and. jk >= idtop(jl)-1 ) then + zmfmax = pmfu(jl,jk)*0.98 + if ( pmfd(jl,jk)+zmfmax+1.e-15 < 0. ) then + zmfs(jl) = min(zmfs(jl),-zmfmax/pmfd(jl,jk)) + end if + end if + end do + end do + + do jk = 2 , klev + do jl = 1 , klon + if ( zmfs(jl) < 1. .and. jk >= idtop(jl)-1 ) then + pmfd(jl,jk) = pmfd(jl,jk)*zmfs(jl) + zmfds(jl,jk) = zmfds(jl,jk)*zmfs(jl) + zmfdq(jl,jk) = zmfdq(jl,jk)*zmfs(jl) + pmfdde_rate(jl,jk) = pmfdde_rate(jl,jk)*zmfs(jl) + zmfuub(jl) = zmfuub(jl) - (1.-zmfs(jl))*zdmfdp(jl,jk) + pmflxr(jl,jk+1) = pmflxr(jl,jk+1) + zmfuub(jl) + zdmfdp(jl,jk) = zdmfdp(jl,jk)*zmfs(jl) + end if + end do + end do + + do jk = 2 , klev - 1 + do jl = 1, klon + if ( loddraf(jl) .and. jk >= idtop(jl)-1 ) then + zerate = -pmfd(jl,jk) + pmfd(jl,jk-1) + pmfdde_rate(jl,jk) + if ( zerate < 0. ) then + pmfdde_rate(jl,jk) = pmfdde_rate(jl,jk) - zerate + end if + end if + if ( ldcum(jl) .and. jk >= kctop(jl)-1 ) then + zerate = pmfu(jl,jk) - pmfu(jl,jk+1) + pmfude_rate(jl,jk) + if ( zerate < 0. ) then + pmfude_rate(jl,jk) = pmfude_rate(jl,jk) - zerate + end if + zdmfup(jl,jk) = pmflxr(jl,jk+1) + pmflxs(jl,jk+1) - & + pmflxr(jl,jk) - pmflxs(jl,jk) + zdmfdp(jl,jk) = 0. + end if + end do + end do + +! avoid negative humidities at ddraught top + do jl = 1,klon + if ( loddraf(jl) ) then + jk = idtop(jl) + ik = min(jk+1,klev) + if ( zmfdq(jl,jk) < 0.3*zmfdq(jl,ik) ) then + zmfdq(jl,jk) = 0.3*zmfdq(jl,ik) + end if + end if + end do + +! avoid negative humidities near cloud top because gradient of precip flux +! and detrainment / liquid water flux are too large + do jk = 2 , klev + do jl = 1, klon + if ( ldcum(jl) .and. jk >= kctop(jl)-1 .and. jk < kcbot(jl) ) then + zdz = ztmst*g/(paph(jl,jk+1)-paph(jl,jk)) + zmfa = zmfuq(jl,jk+1) + zmfdq(jl,jk+1) - & + zmfuq(jl,jk) - zmfdq(jl,jk) + & + zmful(jl,jk+1) - zmful(jl,jk) + zdmfup(jl,jk) + zmfa = (zmfa-plude(jl,jk))*zdz + if ( pqen(jl,jk)+zmfa < 0. ) then + plude(jl,jk) = plude(jl,jk) + 2.*(pqen(jl,jk)+zmfa)/zdz + end if + if ( plude(jl,jk) < 0. ) plude(jl,jk) = 0. + end if + if ( .not. ldcum(jl) ) pmfude_rate(jl,jk) = 0. + if ( abs(pmfd(jl,jk-1)) < 1.0e-20 ) pmfdde_rate(jl,jk) = 0. + end do + end do + + do jl=1,klon + prsfc(jl) = pmflxr(jl,klev+1) + pssfc(jl) = pmflxs(jl,klev+1) + end do + +!---------------------------------------------------------------- +!* 8.0 update tendencies for t and q in subroutine cudtdq +!---------------------------------------------------------------- + call cudtdqn(klon,klev,itopm2,kctop,idtop,ldcum,loddraf, & + ztmst,paph,zgeoh,pgeo,pten,ztenh,pqen,zqenh,pqsen, & + zlglac,plude,pmfu,pmfd,zmfus,zmfds,zmfuq,zmfdq,zmful, & + zdmfup,zdmfdp,zdpmel,ptte,pqte,pcte) +!---------------------------------------------------------------- +!* 9.0 update tendencies for u and u in subroutine cududv +!---------------------------------------------------------------- + if(lmfdudv) then + do jk = klev-1 , 2 , -1 + ik = jk + 1 + do jl = 1,klon + if ( ldcum(jl) ) then + if ( jk == kcbot(jl) .and. ktype(jl) < 3 ) then + ikb = kdpl(jl) + zuu(jl,jk) = puen(jl,ikb-1) + zvu(jl,jk) = pven(jl,ikb-1) + else if ( jk == kcbot(jl) .and. ktype(jl) == 3 ) then + zuu(jl,jk) = puen(jl,jk-1) + zvu(jl,jk) = pven(jl,jk-1) + end if + if ( jk < kcbot(jl) .and. jk >= kctop(jl) ) then + if(momtrans .eq. 1)then + zfac = 0. + if ( ktype(jl) == 1 .or. ktype(jl) == 3 ) zfac = 2. + if ( ktype(jl) == 1 .and. jk <= kctop(jl)+2 ) zfac = 3. + zerate = pmfu(jl,jk) - pmfu(jl,ik) + & + (1.+zfac)*pmfude_rate(jl,jk) + zderate = (1.+zfac)*pmfude_rate(jl,jk) + zmfa = 1./max(cmfcmin,pmfu(jl,jk)) + zuu(jl,jk) = (zuu(jl,ik)*pmfu(jl,ik) + & + zerate*puen(jl,jk)-zderate*zuu(jl,ik))*zmfa + zvu(jl,jk) = (zvu(jl,ik)*pmfu(jl,ik) + & + zerate*pven(jl,jk)-zderate*zvu(jl,ik))*zmfa + else + if(ktype(jl) == 1 .or. ktype(jl) == 3) then + pgf_u = -0.7*0.5*(pmfu(jl,ik)*(puen(jl,ik)-puen(jl,jk))+& + pmfu(jl,jk)*(puen(jl,jk)-puen(jl,jk-1))) + pgf_v = -0.7*0.5*(pmfu(jl,ik)*(pven(jl,ik)-pven(jl,jk))+& + pmfu(jl,jk)*(pven(jl,jk)-pven(jl,jk-1))) + else + pgf_u = 0. + pgf_v = 0. + end if + zerate = pmfu(jl,jk) - pmfu(jl,ik) + pmfude_rate(jl,jk) + zderate = pmfude_rate(jl,jk) + zmfa = 1./max(cmfcmin,pmfu(jl,jk)) + zuu(jl,jk) = (zuu(jl,ik)*pmfu(jl,ik) + & + zerate*puen(jl,jk)-zderate*zuu(jl,ik)+pgf_u)*zmfa + zvu(jl,jk) = (zvu(jl,ik)*pmfu(jl,ik) + & + zerate*pven(jl,jk)-zderate*zvu(jl,ik)+pgf_v)*zmfa + end if + end if + end if + end do + end do + + if(lmfdd) then + do jk = 3 , klev + ik = jk - 1 + do jl = 1,klon + if ( ldcum(jl) ) then + if ( jk == idtop(jl) ) then + zud(jl,jk) = 0.5*(zuu(jl,jk)+puen(jl,ik)) + zvd(jl,jk) = 0.5*(zvu(jl,jk)+pven(jl,ik)) + else if ( jk > idtop(jl) ) then + zerate = -pmfd(jl,jk) + pmfd(jl,ik) + pmfdde_rate(jl,jk) + zmfa = 1./min(-cmfcmin,pmfd(jl,jk)) + zud(jl,jk) = (zud(jl,ik)*pmfd(jl,ik) - & + zerate*puen(jl,ik)+pmfdde_rate(jl,jk)*zud(jl,ik))*zmfa + zvd(jl,jk) = (zvd(jl,ik)*pmfd(jl,ik) - & + zerate*pven(jl,ik)+pmfdde_rate(jl,jk)*zvd(jl,ik))*zmfa + end if + end if + end do + end do + end if +! -------------------------------------------------- +! rescale massfluxes for stability in Momentum +!------------------------------------------------------------------------ + zmfs(:) = 1. + do jk = 2 , klev + do jl = 1, klon + if ( ldcum(jl) .and. jk >= kctop(jl)-1 ) then + zmfmax = (paph(jl,jk)-paph(jl,jk-1))*zcons + if ( pmfu(jl,jk) > zmfmax .and. jk >= kctop(jl) ) then + zmfs(jl) = min(zmfs(jl),zmfmax/pmfu(jl,jk)) + end if + end if + end do + end do + do jk = 1 , klev + do jl = 1, klon + zmfuus(jl,jk) = pmfu(jl,jk) + zmfdus(jl,jk) = pmfd(jl,jk) + if ( ldcum(jl) .and. jk >= kctop(jl)-1 ) then + zmfuus(jl,jk) = pmfu(jl,jk)*zmfs(jl) + zmfdus(jl,jk) = pmfd(jl,jk)*zmfs(jl) + end if + end do + end do +!* 9.1 update u and v in subroutine cududvn +!------------------------------------------------------------------- + do jk = 1 , klev + do jl = 1, klon + ztenu(jl,jk) = pvom(jl,jk) + ztenv(jl,jk) = pvol(jl,jk) + end do + end do + + call cududvn(klon,klev,itopm2,ktype,kcbot,kctop, & + ldcum,ztmst,paph,puen,pven,zmfuus,zmfdus,zuu, & + zud,zvu,zvd,pvom,pvol) + +! calculate KE dissipation + do jl = 1, klon + zsum12(jl) = 0. + zsum22(jl) = 0. + end do + do jk = 1 , klev + do jl = 1, klon + zuv2(jl,jk) = 0. + if ( ldcum(jl) .and. jk >= kctop(jl)-1 ) then + zdz = (paph(jl,jk+1)-paph(jl,jk)) + zduten = pvom(jl,jk) - ztenu(jl,jk) + zdvten = pvol(jl,jk) - ztenv(jl,jk) + zuv2(jl,jk) = sqrt(zduten**2+zdvten**2) + zsum22(jl) = zsum22(jl) + zuv2(jl,jk)*zdz + zsum12(jl) = zsum12(jl) - & + (puen(jl,jk)*zduten+pven(jl,jk)*zdvten)*zdz + end if + end do + end do + do jk = 1 , klev + do jl = 1, klon + if ( ldcum(jl) .and. jk>=kctop(jl)-1 ) then + ztdis = rcpd*zsum12(jl)*zuv2(jl,jk)/max(1.e-15,zsum22(jl)) + ptte(jl,jk) = ptte(jl,jk) + ztdis + end if + end do + end do + + end if + +!---------------------------------------------------------------------- +!* 10. IN CASE THAT EITHER DEEP OR SHALLOW IS SWITCHED OFF +! NEED TO SET SOME VARIABLES A POSTERIORI TO ZERO +! --------------------------------------------------- + if ( .not. lmfscv .or. .not. lmfpen ) then + do jk = 2 , klev + do jl = 1, klon + if ( llo2(jl) .and. jk >= kctop(jl)-1 ) then + ptu(jl,jk) = pten(jl,jk) + pqu(jl,jk) = pqen(jl,jk) + plu(jl,jk) = 0. + pmfude_rate(jl,jk) = 0. + pmfdde_rate(jl,jk) = 0. + end if + end do + end do + do jl = 1, klon + if ( llo2(jl) ) then + kctop(jl) = klev - 1 + kcbot(jl) = klev - 1 + end if + end do + end if + + !---------------------------------------------------------------------- + !* 11.0 CHEMICAL TRACER TRANSPORT + ! ------------------------- + + if ( ktrac > 0 ) then + ! transport switched off for mid-level convection + do jl = 1, klon + if ( ldcum(jl) .and. ktype(jl) /= 3 .and. & + kcbot(jl)-kctop(jl) >= 1 ) then + lldcum(jl) = .true. + llddraf3(jl) = loddraf(jl) + else + lldcum(jl) = .false. + llddraf3(jl) = .false. + end if + end do + ! check and correct mass fluxes for CFL criterium + zmfs(:) = 1. + do jk = 2 , klev + do jl = 1, klon + if ( lldcum(jl) .and. jk >= kctop(jl) ) then + zmfmax = (paph(jl,jk)-paph(jl,jk-1))*0.8*zcons + if ( pmfu(jl,jk) > zmfmax ) then + zmfs(jl) = min(zmfs(jl),zmfmax/pmfu(jl,jk)) + end if + end if + end do + end do + + do jk = 1, klev + do jl = 1, klon + if ( lldcum(jl) .and. jk >= kctop(jl)-1 ) then + zmfuus(jl,jk) = pmfu(jl,jk)*zmfs(jl) + zmfudr(jl,jk) = pmfude_rate(jl,jk)*zmfs(jl) + else + zmfuus(jl,jk) = 0. + zmfudr(jl,jk) = 0. + end if + if ( llddraf3(jl) .and. jk >= idtop(jl)-1 ) then + zmfdus(jl,jk) = pmfd(jl,jk)*zmfs(jl) + zmfddr(jl,jk) = pmfdde_rate(jl,jk)*zmfs(jl) + else + zmfdus(jl,jk) = 0. + zmfddr(jl,jk) = 0. + end if + end do + end do + + call cuctracer(klon,klev,ktrac,kctop,idtop, & + lldcum,llddraf3,ztmst,paph,zmfuus,zmfdus, & + zmfudr,zmfddr,pcen,ptenc) + end if + + return + end subroutine cumastrn + +!********************************************** +! level 3 subroutine cuinin +!********************************************** +! + subroutine cuinin & + & (klon, klev, klevp1, klevm1, pten,& + & pqen, pqsen, puen, pven, pverv,& + & pgeo, paph, pgeoh, ptenh, pqenh,& + & pqsenh, klwmin, ptu, pqu, ptd,& + & pqd, puu, pvu, pud, pvd,& + & pmfu, pmfd, pmfus, pmfds, pmfuq,& + & pmfdq, pdmfup, pdmfdp, pdpmel, plu,& + & plude, klab) + implicit none +! m.tiedtke e.c.m.w.f. 12/89 +!***purpose +! ------- +! this routine interpolates large-scale fields of t,q etc. +! to half levels (i.e. grid for massflux scheme), +! and initializes values for updrafts and downdrafts +!***interface +! --------- +! this routine is called from *cumastr*. +!***method. +! -------- +! for extrapolation to half levels see tiedtke(1989) +!***externals +! --------- +! *cuadjtq* to specify qs at half levels +! ---------------------------------------------------------------- + integer klon,klev,klevp1,klevm1 + real(kind=kind_phys) pten(klon,klev), pqen(klon,klev),& + & puen(klon,klev), pven(klon,klev),& + & pqsen(klon,klev), pverv(klon,klev),& + & pgeo(klon,klev), pgeoh(klon,klevp1),& + & paph(klon,klevp1), ptenh(klon,klev),& + & pqenh(klon,klev), pqsenh(klon,klev) + real(kind=kind_phys) ptu(klon,klev), pqu(klon,klev),& + & ptd(klon,klev), pqd(klon,klev),& + & puu(klon,klev), pud(klon,klev),& + & pvu(klon,klev), pvd(klon,klev),& + & pmfu(klon,klev), pmfd(klon,klev),& + & pmfus(klon,klev), pmfds(klon,klev),& + & pmfuq(klon,klev), pmfdq(klon,klev),& + & pdmfup(klon,klev), pdmfdp(klon,klev),& + & plu(klon,klev), plude(klon,klev) + real(kind=kind_phys) zwmax(klon), zph(klon), & + & pdpmel(klon,klev) + integer klab(klon,klev), klwmin(klon) + logical loflag(klon) +! local variables + integer jl,jk + integer icall,ik + real(kind=kind_phys) zzs +!------------------------------------------------------------ +!* 1. specify large scale parameters at half levels +!* adjust temperature fields if staticly unstable +!* find level of maximum vertical velocity +! ----------------------------------------------------------- + do jk=2,klev + do jl=1,klon + ptenh(jl,jk)=(max(cpd*pten(jl,jk-1)+pgeo(jl,jk-1), & + & cpd*pten(jl,jk)+pgeo(jl,jk))-pgeoh(jl,jk))*rcpd + pqenh(jl,jk) = pqen(jl,jk-1) + pqsenh(jl,jk)= pqsen(jl,jk-1) + zph(jl)=paph(jl,jk) + loflag(jl)=.true. + end do + + if ( jk >= klev-1 .or. jk < 2 ) cycle + ik=jk + icall=0 + call cuadjtqn(klon,klev,ik,zph,ptenh,pqsenh,loflag,icall) + do jl=1,klon + pqenh(jl,jk)=min(pqen(jl,jk-1),pqsen(jl,jk-1)) & + & +(pqsenh(jl,jk)-pqsen(jl,jk-1)) + pqenh(jl,jk)=max(pqenh(jl,jk),0.) + end do + end do + + do jl=1,klon + ptenh(jl,klev)=(cpd*pten(jl,klev)+pgeo(jl,klev)- & + & pgeoh(jl,klev))*rcpd + pqenh(jl,klev)=pqen(jl,klev) + ptenh(jl,1)=pten(jl,1) + pqenh(jl,1)=pqen(jl,1) + klwmin(jl)=klev + zwmax(jl)=0. + end do + + do jk=klevm1,2,-1 + do jl=1,klon + zzs=max(cpd*ptenh(jl,jk)+pgeoh(jl,jk), & + & cpd*ptenh(jl,jk+1)+pgeoh(jl,jk+1)) + ptenh(jl,jk)=(zzs-pgeoh(jl,jk))*rcpd + end do + end do + + do jk=klev,3,-1 + do jl=1,klon + if(pverv(jl,jk).lt.zwmax(jl)) then + zwmax(jl)=pverv(jl,jk) + klwmin(jl)=jk + end if + end do + end do +!----------------------------------------------------------- +!* 2.0 initialize values for updrafts and downdrafts +!----------------------------------------------------------- + do jk=1,klev + ik=jk-1 + if(jk.eq.1) ik=1 + do jl=1,klon + ptu(jl,jk)=ptenh(jl,jk) + ptd(jl,jk)=ptenh(jl,jk) + pqu(jl,jk)=pqenh(jl,jk) + pqd(jl,jk)=pqenh(jl,jk) + plu(jl,jk)=0. + puu(jl,jk)=puen(jl,ik) + pud(jl,jk)=puen(jl,ik) + pvu(jl,jk)=pven(jl,ik) + pvd(jl,jk)=pven(jl,ik) + klab(jl,jk)=0 + end do + end do + return + end subroutine cuinin + +!--------------------------------------------------------- +! level 3 souroutines +!-------------------------------------------------------- + subroutine cutypen & + & ( klon, klev, klevp1, klevm1, pqen,& + & ptenh, pqenh, pqsenh, pgeoh, paph,& + & hfx, qfx, pgeo, pqsen, pap,& + & pten, lndj, cutu, cuqu, culab,& + & ldcum, cubot, cutop, ktype, wbase, culu, kdpl ) +! zhang & wang iprc 2011-2013 +!***purpose. +! -------- +! to produce first guess updraught for cu-parameterizations +! calculates condensation level, and sets updraught base variables and +! first guess cloud type +!***interface +! --------- +! this routine is called from *cumastr*. +! input are environm. values of t,q,p,phi at half levels. +! it returns cloud types as follows; +! ktype=1 for deep cumulus +! ktype=2 for shallow cumulus +!***method. +! -------- +! based on a simplified updraught equation +! partial(hup)/partial(z)=eta(h - hup) +! eta is the entrainment rate for test parcel +! h stands for dry static energy or the total water specific humidity +! references: christian jakob, 2003: a new subcloud model for +! mass-flux convection schemes +! influence on triggering, updraft properties, and model +! climate, mon.wea.rev. +! 131, 2765-2778 +! and +! ifs documentation - cy36r1,cy38r1 +!***input variables: +! ptenh [ztenh] - environment temperature on half levels. (cuini) +! pqenh [zqenh] - env. specific humidity on half levels. (cuini) +! pgeoh [zgeoh] - geopotential on half levels, (mssflx) +! paph - pressure of half levels. (mssflx) +! rho - density of the lowest model level +! qfx - net upward moisture flux at the surface (kg/m^2/s) +! hfx - net upward heat flux at the surface (w/m^2) +!***variables output by cutype: +! ktype - convection type - 1: penetrative (cumastr) +! 2: stratocumulus (cumastr) +! 3: mid-level (cuasc) +! information for updraft parcel (ptu,pqu,plu,kcbot,klab,kdpl...) +! ---------------------------------------------------------------- +!------------------------------------------------------------------- + implicit none +!------------------------------------------------------------------- + integer klon, klev, klevp1, klevm1 + real(kind=kind_phys) ptenh(klon,klev), pqenh(klon,klev),& + & pqsen(klon,klev), pqsenh(klon,klev),& + & pgeoh(klon,klevp1), paph(klon,klevp1),& + & pap(klon,klev), pqen(klon,klev) + real(kind=kind_phys) pten(klon,klev) + real(kind=kind_phys) ptu(klon,klev),pqu(klon,klev),plu(klon,klev) + real(kind=kind_phys) pgeo(klon,klev) + integer klab(klon,klev) + integer kctop(klon),kcbot(klon) + + real(kind=kind_phys) qfx(klon),hfx(klon) + real(kind=kind_phys) zph(klon) + integer lndj(klon) + logical loflag(klon), deepflag(klon), resetflag(klon) + +! output variables + real(kind=kind_phys) cutu(klon,klev), cuqu(klon,klev), culu(klon,klev) + integer culab(klon,klev) + real(kind=kind_phys) wbase(klon) + integer ktype(klon),cubot(klon),cutop(klon),kdpl(klon) + logical ldcum(klon) + +! local variables + real(kind=kind_phys) zqold(klon) + real(kind=kind_phys) rho, part1, part2, root, conw, deltt, deltq + real(kind=kind_phys) eta(klon),dz(klon),coef(klon) + real(kind=kind_phys) dhen(klon,klev), dh(klon,klev) + real(kind=kind_phys) plude(klon,klev) + real(kind=kind_phys) kup(klon,klev) + real(kind=kind_phys) vptu(klon,klev),vten(klon,klev) + real(kind=kind_phys) zbuo(klon,klev),abuoy(klon,klev) + + real(kind=kind_phys) zz,zdken,zdq + real(kind=kind_phys) fscale,crirh1,pp + real(kind=kind_phys) atop1,atop2,abot + real(kind=kind_phys) tmix,zmix,qmix,pmix + real(kind=kind_phys) zlglac,dp + integer nk,is,ikb,ikt + + real(kind=kind_phys) zqsu,zcor,zdp,zesdp,zalfaw,zfacw,zfaci,zfac,zdsdp,zdqsdt,zdtdp + real(kind=kind_phys) zpdifftop, zpdiffbot + integer zcbase(klon), itoppacel(klon) + integer jl,jk,ik,icall,levels + logical needreset, lldcum(klon) +!-------------------------------------------------------------- + do jl=1,klon + kcbot(jl)=klev + kctop(jl)=klev + kdpl(jl) =klev + ktype(jl)=0 + wbase(jl)=0. + ldcum(jl)=.false. + end do + +!----------------------------------------------------------- +! let's do test,and check the shallow convection first +! the first level is klev +! define deltat and deltaq +!----------------------------------------------------------- + do jk=1,klev + do jl=1,klon + plu(jl,jk)=culu(jl,jk) ! parcel liquid water + ptu(jl,jk)=cutu(jl,jk) ! parcel temperature + pqu(jl,jk)=cuqu(jl,jk) ! parcel specific humidity + klab(jl,jk)=culab(jl,jk) + dh(jl,jk)=0.0 ! parcel dry static energy + dhen(jl,jk)=0.0 ! environment dry static energy + kup(jl,jk)=0.0 ! updraught kinetic energy for parcel + vptu(jl,jk)=0.0 ! parcel virtual temperature considering water-loading + vten(jl,jk)=0.0 ! environment virtual temperature + zbuo(jl,jk)=0.0 ! parcel buoyancy + abuoy(jl,jk)=0.0 + end do + end do + + do jl=1,klon + zqold(jl) = 0. + lldcum(jl) = .false. + loflag(jl) = .true. + end do + +! check the levels from lowest level to second top level + do jk=klevm1,2,-1 + +! define the variables at the first level + if(jk .eq. klevm1) then + do jl=1,klon + rho=pap(jl,klev)/ & + & (rd*(pten(jl,klev)*(1.+vtmpc1*pqen(jl,klev)))) + hfx(jl) = hfx(jl)*rho*cpd + qfx(jl) = qfx(jl)*rho + part1 = 1.5*0.4*pgeo(jl,klev)/ & + & (rho*pten(jl,klev)) + part2 = -hfx(jl)*rcpd-vtmpc1*pten(jl,klev)*qfx(jl) + root = 0.001-part1*part2 + if(part2 .lt. 0.) then + conw = 1.2*(root)**t13 + deltt = max(1.5*hfx(jl)/(rho*cpd*conw),0.) + deltq = max(1.5*qfx(jl)/(rho*conw),0.) + kup(jl,klev) = 0.5*(conw**2) + pqu(jl,klev)= pqenh(jl,klev) + deltq + dhen(jl,klev)= pgeoh(jl,klev) + ptenh(jl,klev)*cpd + dh(jl,klev) = dhen(jl,klev) + deltt*cpd + ptu(jl,klev) = (dh(jl,klev)-pgeoh(jl,klev))*rcpd + vptu(jl,klev)=ptu(jl,klev)*(1.+vtmpc1*pqu(jl,klev)) + vten(jl,klev)=ptenh(jl,klev)*(1.+vtmpc1*pqenh(jl,klev)) + zbuo(jl,klev)=(vptu(jl,klev)-vten(jl,klev))/vten(jl,klev) + klab(jl,klev) = 1 + else + loflag(jl) = .false. + end if + end do + end if + + is=0 + do jl=1,klon + if(loflag(jl))then + is=is+1 + endif + enddo + if(is.eq.0) exit + +! the next levels, we use the variables at the first level as initial values + do jl=1,klon + if(loflag(jl)) then + eta(jl) = 0.55/(pgeo(jl,jk)*zrg)+1.e-4 + dz(jl) = (pgeoh(jl,jk)-pgeoh(jl,jk+1))*zrg + coef(jl)= 0.5*eta(jl)*dz(jl) + dhen(jl,jk) = pgeoh(jl,jk) + cpd*ptenh(jl,jk) + dh(jl,jk) = (coef(jl)*(dhen(jl,jk+1)+dhen(jl,jk))& + & +(1.-coef(jl))*dh(jl,jk+1))/(1.+coef(jl)) + pqu(jl,jk) =(coef(jl)*(pqenh(jl,jk+1)+pqenh(jl,jk))& + & +(1.-coef(jl))*pqu(jl,jk+1))/(1.+coef(jl)) + ptu(jl,jk) = (dh(jl,jk)-pgeoh(jl,jk))*rcpd + zqold(jl) = pqu(jl,jk) + zph(jl)=paph(jl,jk) + end if + end do +! check if the parcel is saturated + ik=jk + icall=1 + call cuadjtqn(klon,klev,ik,zph,ptu,pqu,loflag,icall) + do jl=1,klon + if( loflag(jl) ) then + zdq = max((zqold(jl) - pqu(jl,jk)),0.) + plu(jl,jk) = plu(jl,jk+1) + zdq + zlglac=zdq*((1.-foealfa(ptu(jl,jk))) - & + (1.-foealfa(ptu(jl,jk+1)))) + plu(jl,jk) = min(plu(jl,jk),5.e-3) + dh(jl,jk) = pgeoh(jl,jk) + cpd*(ptu(jl,jk)+ralfdcp*zlglac) +! compute the updraft speed + vptu(jl,jk) = ptu(jl,jk)*(1.+vtmpc1*pqu(jl,jk)-plu(jl,jk))+& + ralfdcp*zlglac + vten(jl,jk) = ptenh(jl,jk)*(1.+vtmpc1*pqenh(jl,jk)) + zbuo(jl,jk) = (vptu(jl,jk) - vten(jl,jk))/vten(jl,jk) + abuoy(jl,jk)=(zbuo(jl,jk)+zbuo(jl,jk+1))*0.5*g + atop1 = 1.0 - 2.*coef(jl) + atop2 = 2.0*dz(jl)*abuoy(jl,jk) + abot = 1.0 + 2.*coef(jl) + kup(jl,jk) = (atop1*kup(jl,jk+1) + atop2) / abot + +! let's find the exact cloud base + if ( plu(jl,jk) > 0. .and. klab(jl,jk+1) == 1 ) then + ik = jk + 1 + zqsu = foeewm(ptu(jl,ik))/paph(jl,ik) + zqsu = min(0.5,zqsu) + zcor = 1./(1.-vtmpc1*zqsu) + zqsu = zqsu*zcor + zdq = min(0.,pqu(jl,ik)-zqsu) + zalfaw = foealfa(ptu(jl,ik)) + zfacw = c5les/((ptu(jl,ik)-c4les)**2) + zfaci = c5ies/((ptu(jl,ik)-c4ies)**2) + zfac = zalfaw*zfacw + (1.-zalfaw)*zfaci + zesdp = foeewm(ptu(jl,ik))/paph(jl,ik) + zcor = 1./(1.-vtmpc1*zesdp) + zdqsdt = zfac*zcor*zqsu + zdtdp = rd*ptu(jl,ik)/(cpd*paph(jl,ik)) + zdp = zdq/(zdqsdt*zdtdp) + zcbase(jl) = paph(jl,ik) + zdp +! chose nearest half level as cloud base (jk or jk+1) + zpdifftop = zcbase(jl) - paph(jl,jk) + zpdiffbot = paph(jl,jk+1) - zcbase(jl) + if ( zpdifftop > zpdiffbot .and. kup(jl,jk+1) > 0. ) then + ikb = min(klev-1,jk+1) + klab(jl,ikb) = 2 + klab(jl,jk) = 2 + kcbot(jl) = ikb + plu(jl,jk+1) = 1.0e-8 + else if ( zpdifftop <= zpdiffbot .and.kup(jl,jk) > 0. ) then + klab(jl,jk) = 2 + kcbot(jl) = jk + end if + end if + + if(kup(jl,jk) .lt. 0.)then + loflag(jl) = .false. + if(plu(jl,jk+1) .gt. 0.) then + kctop(jl) = jk + lldcum(jl) = .true. + else + lldcum(jl) = .false. + end if + else + if(plu(jl,jk) .gt. 0.)then + klab(jl,jk)=2 + else + klab(jl,jk)=1 + end if + end if + end if + end do + + end do ! end all the levels + + do jl=1,klon + ikb = kcbot(jl) + ikt = kctop(jl) + if(paph(jl,ikb) - paph(jl,ikt) > zdnoprc) lldcum(jl) = .false. + if(lldcum(jl)) then + ktype(jl) = 2 + ldcum(jl) = .true. + wbase(jl) = sqrt(max(2.*kup(jl,ikb),0.)) + cubot(jl) = ikb + cutop(jl) = ikt + kdpl(jl) = klev + else + cutop(jl) = -1 + cubot(jl) = -1 + kdpl(jl) = klev - 1 + ldcum(jl) = .false. + wbase(jl) = 0. + end if + end do + + do jk=klev,1,-1 + do jl=1,klon + ikt = kctop(jl) + if(jk .ge. ikt)then + culab(jl,jk) = klab(jl,jk) + cutu(jl,jk) = ptu(jl,jk) + cuqu(jl,jk) = pqu(jl,jk) + culu(jl,jk) = plu(jl,jk) + end if + end do + end do + +!----------------------------------------------------------- +! next, let's check the deep convection +! the first level is klevm1-1 +! define deltat and deltaq +!---------------------------------------------------------- +! we check the parcel starting level by level +! assume the mix-layer is 60hPa + deltt = 0.2 + deltq = 1.0e-4 + do jl=1,klon + deepflag(jl) = .false. + end do + + do jk=klev,1,-1 + do jl=1,klon + if((paph(jl,klev+1)-paph(jl,jk)) .lt. 350.e2) itoppacel(jl) = jk + end do + end do + + do levels=klevm1-1,klevm1-20,-1 ! loop starts + do jk=1,klev + do jl=1,klon + plu(jl,jk)=0.0 ! parcel liquid water + ptu(jl,jk)=0.0 ! parcel temperature + pqu(jl,jk)=0.0 ! parcel specific humidity + dh(jl,jk)=0.0 ! parcel dry static energy + dhen(jl,jk)=0.0 ! environment dry static energy + kup(jl,jk)=0.0 ! updraught kinetic energy for parcel + vptu(jl,jk)=0.0 ! parcel virtual temperature consideringwater-loading + vten(jl,jk)=0.0 ! environment virtual temperature + abuoy(jl,jk)=0.0 + zbuo(jl,jk)=0.0 + klab(jl,jk)=0 + end do + end do + + do jl=1,klon + kcbot(jl) = levels + kctop(jl) = levels + zqold(jl) = 0. + lldcum(jl) = .false. + resetflag(jl)= .false. + loflag(jl) = (.not. deepflag(jl)) .and. (levels.ge.itoppacel(jl)) + end do + +! start the inner loop to search the deep convection points + do jk=levels,2,-1 + is=0 + do jl=1,klon + if(loflag(jl))then + is=is+1 + endif + enddo + if(is.eq.0) exit + +! define the variables at the departure level + if(jk .eq. levels) then + do jl=1,klon + if(loflag(jl)) then + if((paph(jl,klev+1)-paph(jl,jk)) < 60.e2) then + tmix=0. + qmix=0. + zmix=0. + pmix=0. + do nk=jk+2,jk,-1 + if(pmix < 50.e2) then + dp = paph(jl,nk) - paph(jl,nk-1) + tmix=tmix+dp*ptenh(jl,nk) + qmix=qmix+dp*pqenh(jl,nk) + zmix=zmix+dp*pgeoh(jl,nk) + pmix=pmix+dp + end if + end do + tmix=tmix/pmix + qmix=qmix/pmix + zmix=zmix/pmix + else + tmix=ptenh(jl,jk+1) + qmix=pqenh(jl,jk+1) + zmix=pgeoh(jl,jk+1) + end if + + pqu(jl,jk+1) = qmix + deltq + dhen(jl,jk+1)= zmix + tmix*cpd + dh(jl,jk+1) = dhen(jl,jk+1) + deltt*cpd + ptu(jl,jk+1) = (dh(jl,jk+1)-pgeoh(jl,jk+1))*rcpd + kup(jl,jk+1) = 0.5 + klab(jl,jk+1)= 1 + vptu(jl,jk+1)=ptu(jl,jk+1)*(1.+vtmpc1*pqu(jl,jk+1)) + vten(jl,jk+1)=ptenh(jl,jk+1)*(1.+vtmpc1*pqenh(jl,jk+1)) + zbuo(jl,jk+1)=(vptu(jl,jk+1)-vten(jl,jk+1))/vten(jl,jk+1) + end if + end do + end if + +! the next levels, we use the variables at the first level as initial values + do jl=1,klon + if(loflag(jl)) then +! define the fscale + fscale = min(1.,(pqsen(jl,jk)/pqsen(jl,levels))**3) + eta(jl) = 1.75e-3*fscale + dz(jl) = (pgeoh(jl,jk)-pgeoh(jl,jk+1))*zrg + coef(jl)= 0.5*eta(jl)*dz(jl) + dhen(jl,jk) = pgeoh(jl,jk) + cpd*ptenh(jl,jk) + dh(jl,jk) = (coef(jl)*(dhen(jl,jk+1)+dhen(jl,jk))& + & +(1.-coef(jl))*dh(jl,jk+1))/(1.+coef(jl)) + pqu(jl,jk) =(coef(jl)*(pqenh(jl,jk+1)+pqenh(jl,jk))& + & +(1.-coef(jl))*pqu(jl,jk+1))/(1.+coef(jl)) + ptu(jl,jk) = (dh(jl,jk)-pgeoh(jl,jk))*rcpd + zqold(jl) = pqu(jl,jk) + zph(jl)=paph(jl,jk) + end if + end do +! check if the parcel is saturated + ik=jk + icall=1 + call cuadjtqn(klon,klev,ik,zph,ptu,pqu,loflag,icall) + + do jl=1,klon + if( loflag(jl) ) then + zdq = max((zqold(jl) - pqu(jl,jk)),0.) + plu(jl,jk) = plu(jl,jk+1) + zdq + zlglac=zdq*((1.-foealfa(ptu(jl,jk))) - & + (1.-foealfa(ptu(jl,jk+1)))) + plu(jl,jk) = 0.5*plu(jl,jk) + dh(jl,jk) = pgeoh(jl,jk) + cpd*(ptu(jl,jk)+ralfdcp*zlglac) +! compute the updraft speed + vptu(jl,jk) = ptu(jl,jk)*(1.+vtmpc1*pqu(jl,jk)-plu(jl,jk))+& + ralfdcp*zlglac + vten(jl,jk) = ptenh(jl,jk)*(1.+vtmpc1*pqenh(jl,jk)) + zbuo(jl,jk) = (vptu(jl,jk) - vten(jl,jk))/vten(jl,jk) + abuoy(jl,jk)=(zbuo(jl,jk)+zbuo(jl,jk+1))*0.5*g + atop1 = 1.0 - 2.*coef(jl) + atop2 = 2.0*dz(jl)*abuoy(jl,jk) + abot = 1.0 + 2.*coef(jl) + kup(jl,jk) = (atop1*kup(jl,jk+1) + atop2) / abot +! let's find the exact cloud base + if ( plu(jl,jk) > 0. .and. klab(jl,jk+1) == 1 ) then + ik = jk + 1 + zqsu = foeewm(ptu(jl,ik))/paph(jl,ik) + zqsu = min(0.5,zqsu) + zcor = 1./(1.-vtmpc1*zqsu) + zqsu = zqsu*zcor + zdq = min(0.,pqu(jl,ik)-zqsu) + zalfaw = foealfa(ptu(jl,ik)) + zfacw = c5les/((ptu(jl,ik)-c4les)**2) + zfaci = c5ies/((ptu(jl,ik)-c4ies)**2) + zfac = zalfaw*zfacw + (1.-zalfaw)*zfaci + zesdp = foeewm(ptu(jl,ik))/paph(jl,ik) + zcor = 1./(1.-vtmpc1*zesdp) + zdqsdt = zfac*zcor*zqsu + zdtdp = rd*ptu(jl,ik)/(cpd*paph(jl,ik)) + zdp = zdq/(zdqsdt*zdtdp) + zcbase(jl) = paph(jl,ik) + zdp +! chose nearest half level as cloud base (jk or jk+1) + zpdifftop = zcbase(jl) - paph(jl,jk) + zpdiffbot = paph(jl,jk+1) - zcbase(jl) + if ( zpdifftop > zpdiffbot .and. kup(jl,jk+1) > 0. ) then + ikb = min(klev-1,jk+1) + klab(jl,ikb) = 2 + klab(jl,jk) = 2 + kcbot(jl) = ikb + plu(jl,jk+1) = 1.0e-8 + else if ( zpdifftop <= zpdiffbot .and.kup(jl,jk) > 0. ) then + klab(jl,jk) = 2 + kcbot(jl) = jk + end if + end if + + if(kup(jl,jk) .lt. 0.)then + loflag(jl) = .false. + if(plu(jl,jk+1) .gt. 0.) then + kctop(jl) = jk + lldcum(jl) = .true. + else + lldcum(jl) = .false. + end if + else + if(plu(jl,jk) .gt. 0.)then + klab(jl,jk)=2 + else + klab(jl,jk)=1 + end if + end if + end if + end do + + end do ! end all the levels + + needreset = .false. + do jl=1,klon + ikb = kcbot(jl) + ikt = kctop(jl) + if(paph(jl,ikb) - paph(jl,ikt) < zdnoprc) lldcum(jl) = .false. + if(lldcum(jl)) then + ktype(jl) = 1 + ldcum(jl) = .true. + deepflag(jl) = .true. + wbase(jl) = sqrt(max(2.*kup(jl,ikb),0.)) + cubot(jl) = ikb + cutop(jl) = ikt + kdpl(jl) = levels+1 + needreset = .true. + resetflag(jl)= .true. + end if + end do + + if(needreset) then + do jk=klev,1,-1 + do jl=1,klon + if(resetflag(jl)) then + ikt = kctop(jl) + ikb = kdpl(jl) + if(jk .le. ikb .and. jk .ge. ikt )then + culab(jl,jk) = klab(jl,jk) + cutu(jl,jk) = ptu(jl,jk) + cuqu(jl,jk) = pqu(jl,jk) + culu(jl,jk) = plu(jl,jk) + else + culab(jl,jk) = 1 + cutu(jl,jk) = ptenh(jl,jk) + cuqu(jl,jk) = pqenh(jl,jk) + culu(jl,jk) = 0. + end if + if ( jk .lt. ikt ) culab(jl,jk) = 0 + end if + end do + end do + end if + + end do ! end all cycles + + return + end subroutine cutypen + +!----------------------------------------------------------------- +! level 3 subroutines 'cuascn' +!----------------------------------------------------------------- + subroutine cuascn & + & (klon, klev, klevp1, klevm1, ptenh,& + & pqenh, puen, pven, pten, pqen,& + & pqsen, pgeo, pgeoh, pap, paph,& + & pqte, pverv, klwmin, ldcum, phcbase,& + & ktype, klab, ptu, pqu, plu,& + & puu, pvu, pmfu, pmfub, & + & pmfus, pmfuq, pmful, plude, pdmfup,& + & kcbot, kctop, kctop0, kcum, ztmst,& + & pqsenh, plglac, lndj, wup, wbase, kdpl, pmfude_rate) + implicit none +! this routine does the calculations for cloud ascents +! for cumulus parameterization +! m.tiedtke e.c.m.w.f. 7/86 modif. 12/89 +! y.wang iprc 11/01 modif. +! c.zhang iprc 05/12 modif. +!***purpose. +! -------- +! to produce cloud ascents for cu-parametrization +! (vertical profiles of t,q,l,u and v and corresponding +! fluxes as well as precipitation rates) +!***interface +! --------- +! this routine is called from *cumastr*. +!***method. +! -------- +! lift surface air dry-adiabatically to cloud base +! and then calculate moist ascent for +! entraining/detraining plume. +! entrainment and detrainment rates differ for +! shallow and deep cumulus convection. +! in case there is no penetrative or shallow convection +! check for possibility of mid level convection +! (cloud base values calculated in *cubasmc*) +!***externals +! --------- +! *cuadjtqn* adjust t and q due to condensation in ascent +! *cuentrn* calculate entrainment/detrainment rates +! *cubasmcn* calculate cloud base values for midlevel convection +!***reference +! --------- +! (tiedtke,1989) +!***input variables: +! ptenh [ztenh] - environ temperature on half levels. (cuini) +! pqenh [zqenh] - env. specific humidity on half levels. (cuini) +! puen - environment wind u-component. (mssflx) +! pven - environment wind v-component. (mssflx) +! pten - environment temperature. (mssflx) +! pqen - environment specific humidity. (mssflx) +! pqsen - environment saturation specific humidity. (mssflx) +! pgeo - geopotential. (mssflx) +! pgeoh [zgeoh] - geopotential on half levels, (mssflx) +! pap - pressure in pa. (mssflx) +! paph - pressure of half levels. (mssflx) +! pqte - moisture convergence (delta q/delta t). (mssflx) +! pverv - large scale vertical velocity (omega). (mssflx) +! klwmin [ilwmin] - level of minimum omega. (cuini) +! klab [ilab] - level label - 1: sub-cloud layer. +! 2: condensation level (cloud base) +! pmfub [zmfub] - updraft mass flux at cloud base. (cumastr) +!***variables modified by cuasc: +! ldcum - logical denoting profiles. (cubase) +! ktype - convection type - 1: penetrative (cumastr) +! 2: stratocumulus (cumastr) +! 3: mid-level (cuasc) +! ptu - cloud temperature. +! pqu - cloud specific humidity. +! plu - cloud liquid water (moisture condensed out) +! puu [zuu] - cloud momentum u-component. +! pvu [zvu] - cloud momentum v-component. +! pmfu - updraft mass flux. +! pmfus [zmfus] - updraft flux of dry static energy. (cubasmc) +! pmfuq [zmfuq] - updraft flux of specific humidity. +! pmful [zmful] - updraft flux of cloud liquid water. +! plude - liquid water returned to environment by detrainment. +! pdmfup [zmfup] - +! kcbot - cloud base level. (cubase) +! kctop - cloud top level +! kctop0 [ictop0] - estimate of cloud top. (cumastr) +! kcum [icum] - flag to control the call + + integer klev,klon,klevp1,klevm1 + real(kind=kind_phys) ptenh(klon,klev), pqenh(klon,klev), & + & puen(klon,klev), pven(klon,klev),& + & pten(klon,klev), pqen(klon,klev),& + & pgeo(klon,klev), pgeoh(klon,klevp1),& + & pap(klon,klev), paph(klon,klevp1),& + & pqsen(klon,klev), pqte(klon,klev),& + & pverv(klon,klev), pqsenh(klon,klev) + real(kind=kind_phys) ptu(klon,klev), pqu(klon,klev),& + & puu(klon,klev), pvu(klon,klev),& + & pmfu(klon,klev), zph(klon),& + & pmfub(klon), & + & pmfus(klon,klev), pmfuq(klon,klev),& + & plu(klon,klev), plude(klon,klev),& + & pmful(klon,klev), pdmfup(klon,klev) + real(kind=kind_phys) zdmfen(klon), zdmfde(klon),& + & zmfuu(klon), zmfuv(klon),& + & zpbase(klon), zqold(klon) + real(kind=kind_phys) phcbase(klon), zluold(klon) + real(kind=kind_phys) zprecip(klon), zlrain(klon,klev) + real(kind=kind_phys) zbuo(klon,klev), kup(klon,klev) + real(kind=kind_phys) wup(klon) + real(kind=kind_phys) wbase(klon), zodetr(klon,klev) + real(kind=kind_phys) plglac(klon,klev) + + real(kind=kind_phys) eta(klon),dz(klon) + + integer klwmin(klon), ktype(klon),& + & klab(klon,klev), kcbot(klon),& + & kctop(klon), kctop0(klon) + integer lndj(klon) + logical ldcum(klon), loflag(klon) + logical llo2,llo3, llo1(klon) + + integer kdpl(klon) + real(kind=kind_phys) zoentr(klon), zdpmean(klon) + real(kind=kind_phys) pdmfen(klon,klev), pmfude_rate(klon,klev) +! local variables + integer jl,jk + integer ikb,icum,itopm2,ik,icall,is,kcum,jlm,jll + integer jlx(klon) + real(kind=kind_phys) ztmst,zcons2,zfacbuo,zprcdgw,z_cwdrag,z_cldmax,z_cwifrac,z_cprc2 + real(kind=kind_phys) zmftest,zmfmax,zqeen,zseen,zscde,zqude + real(kind=kind_phys) zmfusk,zmfuqk,zmfulk + real(kind=kind_phys) zbc,zbe,zkedke,zmfun,zwu,zprcon,zdt,zcbf,zzco + real(kind=kind_phys) zlcrit,zdfi,zc,zd,zint,zlnew,zvw,zvi,zalfaw,zrold + real(kind=kind_phys) zrnew,zz,zdmfeu,zdmfdu,dp + real(kind=kind_phys) zfac,zbuoc,zdkbuo,zdken,zvv,zarg,zchange,zxe,zxs,zdshrd + real(kind=kind_phys) atop1,atop2,abot +!-------------------------------- +!* 1. specify parameters +!-------------------------------- + zcons2=3./(g*ztmst) + zfacbuo = 0.5/(1.+0.5) + zprcdgw = cprcon*zrg + z_cldmax = 5.e-3 + z_cwifrac = 0.5 + z_cprc2 = 0.5 + z_cwdrag = (3.0/8.0)*0.506/0.2 +!--------------------------------- +! 2. set default values +!--------------------------------- + llo3 = .false. + do jl=1,klon + zluold(jl)=0. + wup(jl)=0. + zdpmean(jl)=0. + zoentr(jl)=0. + if(.not.ldcum(jl)) then + ktype(jl)=0 + kcbot(jl) = -1 + pmfub(jl) = 0. + pqu(jl,klev) = 0. + end if + end do + + ! initialize variout quantities + do jk=1,klev + do jl=1,klon + if(jk.ne.kcbot(jl)) plu(jl,jk)=0. + pmfu(jl,jk)=0. + pmfus(jl,jk)=0. + pmfuq(jl,jk)=0. + pmful(jl,jk)=0. + plude(jl,jk)=0. + plglac(jl,jk)=0. + pdmfup(jl,jk)=0. + zlrain(jl,jk)=0. + zbuo(jl,jk)=0. + kup(jl,jk)=0. + pdmfen(jl,jk) = 0. + pmfude_rate(jl,jk) = 0. + if(.not.ldcum(jl).or.ktype(jl).eq.3) klab(jl,jk)=0 + if(.not.ldcum(jl).and.paph(jl,jk).lt.4.e4) kctop0(jl)=jk + end do + end do + + do jl = 1,klon + if ( ktype(jl) == 3 ) ldcum(jl) = .false. + end do +!------------------------------------------------ +! 3.0 initialize values at cloud base level +!------------------------------------------------ + do jl=1,klon + kctop(jl)=kcbot(jl) + if(ldcum(jl)) then + ikb = kcbot(jl) + kup(jl,ikb) = 0.5*wbase(jl)**2 + pmfu(jl,ikb) = pmfub(jl) + pmfus(jl,ikb) = pmfub(jl)*(cpd*ptu(jl,ikb)+pgeoh(jl,ikb)) + pmfuq(jl,ikb) = pmfub(jl)*pqu(jl,ikb) + pmful(jl,ikb) = pmfub(jl)*plu(jl,ikb) + end if + end do +! +!----------------------------------------------------------------- +! 4. do ascent: subcloud layer (klab=1) ,clouds (klab=2) +! by doing first dry-adiabatic ascent and then +! by adjusting t,q and l accordingly in *cuadjtqn*, +! then check for buoyancy and set flags accordingly +!----------------------------------------------------------------- +! + do jk=klevm1,3,-1 +! specify cloud base values for midlevel convection +! in *cubasmc* in case there is not already convection +! --------------------------------------------------------------------- + ik=jk + call cubasmcn& + & (klon, klev, klevm1, ik, pten,& + & pqen, pqsen, puen, pven, pverv,& + & pgeo, pgeoh, ldcum, ktype, klab, zlrain,& + & pmfu, pmfub, kcbot, ptu,& + & pqu, plu, puu, pvu, pmfus,& + & pmfuq, pmful, pdmfup) + is = 0 + jlm = 0 + do jl = 1,klon + loflag(jl) = .false. + zprecip(jl) = 0. + llo1(jl) = .false. + is = is + klab(jl,jk+1) + if ( klab(jl,jk+1) == 0 ) klab(jl,jk) = 0 + if ( (ldcum(jl) .and. klab(jl,jk+1) == 2) .or. & + (ktype(jl) == 3 .and. klab(jl,jk+1) == 1) ) then + loflag(jl) = .true. + jlm = jlm + 1 + jlx(jlm) = jl + end if + zph(jl) = paph(jl,jk) + if ( ktype(jl) == 3 .and. jk == kcbot(jl) ) then + zmfmax = (paph(jl,jk)-paph(jl,jk-1))*zcons2 + if ( pmfub(jl) > zmfmax ) then + zfac = zmfmax/pmfub(jl) + pmfu(jl,jk+1) = pmfu(jl,jk+1)*zfac + pmfus(jl,jk+1) = pmfus(jl,jk+1)*zfac + pmfuq(jl,jk+1) = pmfuq(jl,jk+1)*zfac + pmfub(jl) = zmfmax + end if + pmfub(jl)=min(pmfub(jl),zmfmax) + end if + end do + + if(is.gt.0) llo3 = .true. +! +!* specify entrainment rates in *cuentr* +! ------------------------------------- + ik=jk + call cuentrn(klon,klev,ik,kcbot,ldcum,llo3, & + pgeoh,pmfu,zdmfen,zdmfde) +! +! do adiabatic ascent for entraining/detraining plume + if(llo3) then +! ------------------------------------------------------- +! + do jl = 1,klon + zqold(jl) = 0. + end do + do jll = 1 , jlm + jl = jlx(jll) + zdmfde(jl) = min(zdmfde(jl),0.75*pmfu(jl,jk+1)) + if ( jk == kcbot(jl) ) then + zoentr(jl) = -1.75e-3*(min(1.,pqen(jl,jk)/pqsen(jl,jk)) - & + 1.)*(pgeoh(jl,jk)-pgeoh(jl,jk+1))*zrg + zoentr(jl) = min(0.4,zoentr(jl))*pmfu(jl,jk+1) + end if + if ( jk < kcbot(jl) ) then + zmfmax = (paph(jl,jk)-paph(jl,jk-1))*zcons2 + zxs = max(pmfu(jl,jk+1)-zmfmax,0.) + wup(jl) = wup(jl) + kup(jl,jk+1)*(pap(jl,jk+1)-pap(jl,jk)) + zdpmean(jl) = zdpmean(jl) + pap(jl,jk+1) - pap(jl,jk) + zdmfen(jl) = zoentr(jl) + if ( ktype(jl) >= 2 ) then + zdmfen(jl) = 2.0*zdmfen(jl) + zdmfde(jl) = zdmfen(jl) + end if + zdmfde(jl) = zdmfde(jl) * & + (1.6-min(1.,pqen(jl,jk)/pqsen(jl,jk))) + zmftest = pmfu(jl,jk+1) + zdmfen(jl) - zdmfde(jl) + zchange = max(zmftest-zmfmax,0.) + zxe = max(zchange-zxs,0.) + zdmfen(jl) = zdmfen(jl) - zxe + zchange = zchange - zxe + zdmfde(jl) = zdmfde(jl) + zchange + end if + pdmfen(jl,jk) = zdmfen(jl) - zdmfde(jl) + pmfu(jl,jk) = pmfu(jl,jk+1) + zdmfen(jl) - zdmfde(jl) + zqeen = pqenh(jl,jk+1)*zdmfen(jl) + zseen = (cpd*ptenh(jl,jk+1)+pgeoh(jl,jk+1))*zdmfen(jl) + zscde = (cpd*ptu(jl,jk+1)+pgeoh(jl,jk+1))*zdmfde(jl) + zqude = pqu(jl,jk+1)*zdmfde(jl) + plude(jl,jk) = plu(jl,jk+1)*zdmfde(jl) + zmfusk = pmfus(jl,jk+1) + zseen - zscde + zmfuqk = pmfuq(jl,jk+1) + zqeen - zqude + zmfulk = pmful(jl,jk+1) - plude(jl,jk) + plu(jl,jk) = zmfulk*(1./max(cmfcmin,pmfu(jl,jk))) + pqu(jl,jk) = zmfuqk*(1./max(cmfcmin,pmfu(jl,jk))) + ptu(jl,jk) = (zmfusk * & + (1./max(cmfcmin,pmfu(jl,jk)))-pgeoh(jl,jk))*rcpd + ptu(jl,jk) = max(100.,ptu(jl,jk)) + ptu(jl,jk) = min(400.,ptu(jl,jk)) + zqold(jl) = pqu(jl,jk) + zlrain(jl,jk) = zlrain(jl,jk+1)*(pmfu(jl,jk+1)-zdmfde(jl)) * & + (1./max(cmfcmin,pmfu(jl,jk))) + zluold(jl) = plu(jl,jk) + end do +! reset to environmental values if below departure level + do jl = 1,klon + if ( jk > kdpl(jl) ) then + ptu(jl,jk) = ptenh(jl,jk) + pqu(jl,jk) = pqenh(jl,jk) + plu(jl,jk) = 0. + zluold(jl) = plu(jl,jk) + end if + end do +!* do corrections for moist ascent +!* by adjusting t,q and l in *cuadjtq* +!------------------------------------------------ + ik=jk + icall=1 +! + if ( jlm > 0 ) then + call cuadjtqn(klon,klev,ik,zph,ptu,pqu,loflag,icall) + end if +! compute the upfraft speed in cloud layer + do jll = 1 , jlm + jl = jlx(jll) + if ( pqu(jl,jk) /= zqold(jl) ) then + plglac(jl,jk) = plu(jl,jk) * & + ((1.-foealfa(ptu(jl,jk)))- & + (1.-foealfa(ptu(jl,jk+1)))) + ptu(jl,jk) = ptu(jl,jk) + ralfdcp*plglac(jl,jk) + end if + end do + do jll = 1 , jlm + jl = jlx(jll) + if ( pqu(jl,jk) /= zqold(jl) ) then + klab(jl,jk) = 2 + plu(jl,jk) = plu(jl,jk) + zqold(jl) - pqu(jl,jk) + zbc = ptu(jl,jk)*(1.+vtmpc1*pqu(jl,jk)-plu(jl,jk+1) - & + zlrain(jl,jk+1)) + zbe = ptenh(jl,jk)*(1.+vtmpc1*pqenh(jl,jk)) + zbuo(jl,jk) = zbc - zbe +! set flags for the case of midlevel convection + if ( ktype(jl) == 3 .and. klab(jl,jk+1) == 1 ) then + if ( zbuo(jl,jk) > -0.5 ) then + ldcum(jl) = .true. + kctop(jl) = jk + kup(jl,jk) = 0.5 + else + klab(jl,jk) = 0 + pmfu(jl,jk) = 0. + plude(jl,jk) = 0. + plu(jl,jk) = 0. + end if + end if + if ( klab(jl,jk+1) == 2 ) then + if ( zbuo(jl,jk) < 0. ) then + ptenh(jl,jk) = 0.5*(pten(jl,jk)+pten(jl,jk-1)) + pqenh(jl,jk) = 0.5*(pqen(jl,jk)+pqen(jl,jk-1)) + zbuo(jl,jk) = zbc - ptenh(jl,jk)*(1.+vtmpc1*pqenh(jl,jk)) + end if + zbuoc = (zbuo(jl,jk) / & + (ptenh(jl,jk)*(1.+vtmpc1*pqenh(jl,jk)))+zbuo(jl,jk+1) / & + (ptenh(jl,jk+1)*(1.+vtmpc1*pqenh(jl,jk+1))))*0.5 + zdkbuo = (pgeoh(jl,jk)-pgeoh(jl,jk+1))*zfacbuo*zbuoc +! mixing and "pressure" gradient term in upper troposphere + if ( zdmfen(jl) > 0. ) then + zdken = min(1.,(1.+z_cwdrag)*zdmfen(jl) / & + max(cmfcmin,pmfu(jl,jk+1))) + else + zdken = min(1.,(1.+z_cwdrag)*zdmfde(jl) / & + max(cmfcmin,pmfu(jl,jk+1))) + end if + kup(jl,jk) = (kup(jl,jk+1)*(1.-zdken)+zdkbuo) / & + (1.+zdken) + if ( zbuo(jl,jk) < 0. ) then + zkedke = kup(jl,jk)/max(1.e-10,kup(jl,jk+1)) + zkedke = max(0.,min(1.,zkedke)) + zmfun = sqrt(zkedke)*pmfu(jl,jk+1) !* (1.6-min(1.,pqen(jl,jk) / & + ! pqsen(jl,jk))) + zdmfde(jl) = max(zdmfde(jl),pmfu(jl,jk+1)-zmfun) + plude(jl,jk) = plu(jl,jk+1)*zdmfde(jl) + pmfu(jl,jk) = pmfu(jl,jk+1) + zdmfen(jl) - zdmfde(jl) + end if + if ( zbuo(jl,jk) > -0.2 ) then + ikb = kcbot(jl) + zoentr(jl) = 1.75e-3*(0.3-(min(1.,pqen(jl,jk-1) / & + pqsen(jl,jk-1))-1.))*(pgeoh(jl,jk-1)-pgeoh(jl,jk)) * & + zrg*min(1.,pqsen(jl,jk)/pqsen(jl,ikb))**3 + zoentr(jl) = min(0.4,zoentr(jl))*pmfu(jl,jk) + else + zoentr(jl) = 0. + end if +! erase values if below departure level + if ( jk > kdpl(jl) ) then + pmfu(jl,jk) = pmfu(jl,jk+1) + kup(jl,jk) = 0.5 + end if + if ( kup(jl,jk) > 0. .and. pmfu(jl,jk) > 0. ) then + kctop(jl) = jk + llo1(jl) = .true. + else + klab(jl,jk) = 0 + pmfu(jl,jk) = 0. + kup(jl,jk) = 0. + zdmfde(jl) = pmfu(jl,jk+1) + plude(jl,jk) = plu(jl,jk+1)*zdmfde(jl) + end if +! save detrainment rates for updraught + if ( pmfu(jl,jk+1) > 0. ) pmfude_rate(jl,jk) = zdmfde(jl) + end if + else if ( ktype(jl) == 2 .and. pqu(jl,jk) == zqold(jl) ) then + klab(jl,jk) = 0 + pmfu(jl,jk) = 0. + kup(jl,jk) = 0. + zdmfde(jl) = pmfu(jl,jk+1) + plude(jl,jk) = plu(jl,jk+1)*zdmfde(jl) + pmfude_rate(jl,jk) = zdmfde(jl) + end if + end do + + do jl = 1,klon + if ( llo1(jl) ) then +! conversions only proceeds if plu is greater than a threshold liquid water +! content of 0.3 g/kg over water and 0.5 g/kg over land to prevent precipitation +! generation from small water contents. + if ( lndj(jl).eq.1 ) then + zdshrd = 5.e-4 + else + zdshrd = 3.e-4 + end if + ikb=kcbot(jl) + if ( plu(jl,jk) > zdshrd )then +! if ((paph(jl,ikb)-paph(jl,jk))>zdnoprc) then + zwu = min(15.0,sqrt(2.*max(0.1,kup(jl,jk+1)))) + zprcon = zprcdgw/(0.75*zwu) +! PARAMETERS FOR BERGERON-FINDEISEN PROCESS (T < -5C) + zdt = min(rtber-rtice,max(rtber-ptu(jl,jk),0.)) + zcbf = 1. + z_cprc2*sqrt(zdt) + zzco = zprcon*zcbf + zlcrit = zdshrd/zcbf + zdfi = pgeoh(jl,jk) - pgeoh(jl,jk+1) + zc = (plu(jl,jk)-zluold(jl)) + zarg = (plu(jl,jk)/zlcrit)**2 + if ( zarg < 25.0 ) then + zd = zzco*(1.-exp(-zarg))*zdfi + else + zd = zzco*zdfi + end if + zint = exp(-zd) + zlnew = zluold(jl)*zint + zc/zd*(1.-zint) + zlnew = max(0.,min(plu(jl,jk),zlnew)) + zlnew = min(z_cldmax,zlnew) + zprecip(jl) = max(0.,zluold(jl)+zc-zlnew) + pdmfup(jl,jk) = zprecip(jl)*pmfu(jl,jk) + zlrain(jl,jk) = zlrain(jl,jk) + zprecip(jl) + plu(jl,jk) = zlnew + end if + end if + end do + do jl = 1, klon + if ( llo1(jl) ) then + if ( zlrain(jl,jk) > 0. ) then + zvw = 21.18*zlrain(jl,jk)**0.2 + zvi = z_cwifrac*zvw + zalfaw = foealfa(ptu(jl,jk)) + zvv = zalfaw*zvw + (1.-zalfaw)*zvi + zrold = zlrain(jl,jk) - zprecip(jl) + zc = zprecip(jl) + zwu = min(15.0,sqrt(2.*max(0.1,kup(jl,jk)))) + zd = zvv/zwu + zint = exp(-zd) + zrnew = zrold*zint + zc/zd*(1.-zint) + zrnew = max(0.,min(zlrain(jl,jk),zrnew)) + zlrain(jl,jk) = zrnew + end if + end if + end do + do jll = 1 , jlm + jl = jlx(jll) + pmful(jl,jk) = plu(jl,jk)*pmfu(jl,jk) + pmfus(jl,jk) = (cpd*ptu(jl,jk)+pgeoh(jl,jk))*pmfu(jl,jk) + pmfuq(jl,jk) = pqu(jl,jk)*pmfu(jl,jk) + end do + end if + end do +!---------------------------------------------------------------------- +! 5. final calculations +! ------------------ + do jl = 1,klon + if ( kctop(jl) == -1 ) ldcum(jl) = .false. + kcbot(jl) = max(kcbot(jl),kctop(jl)) + if ( ldcum(jl) ) then + wup(jl) = max(1.e-2,wup(jl)/max(1.,zdpmean(jl))) + wup(jl) = sqrt(2.*wup(jl)) + end if + end do + + return + end subroutine cuascn +!--------------------------------------------------------- +! level 3 souroutines +!-------------------------------------------------------- + subroutine cudlfsn & + & (klon, klev, & + & kcbot, kctop, lndj, ldcum, & + & ptenh, pqenh, puen, pven, & + & pten, pqsen, pgeo, & + & pgeoh, paph, ptu, pqu, plu,& + & puu, pvu, pmfub, prfl, & + & ptd, pqd, pud, pvd, & + & pmfd, pmfds, pmfdq, pdmfdp, & + & kdtop, lddraf) + +! this routine calculates level of free sinking for +! cumulus downdrafts and specifies t,q,u and v values + +! m.tiedtke e.c.m.w.f. 12/86 modif. 12/89 + +! purpose. +! -------- +! to produce lfs-values for cumulus downdrafts +! for massflux cumulus parameterization + +! interface +! --------- +! this routine is called from *cumastr*. +! input are environmental values of t,q,u,v,p,phi +! and updraft values t,q,u and v and also +! cloud base massflux and cu-precipitation rate. +! it returns t,q,u and v values and massflux at lfs. + +! method. + +! check for negative buoyancy of air of equal parts of +! moist environmental air and cloud air. + +! parameter description units +! --------- ----------- ----- +! input parameters (integer): + +! *klon* number of grid points per packet +! *klev* number of levels +! *kcbot* cloud base level +! *kctop* cloud top level + +! input parameters (logical): + +! *lndj* land sea mask (1 for land) +! *ldcum* flag: .true. for convective points + +! input parameters (real(kind=kind_phys)): + +! *ptenh* env. temperature (t+1) on half levels k +! *pqenh* env. spec. humidity (t+1) on half levels kg/kg +! *puen* provisional environment u-velocity (t+1) m/s +! *pven* provisional environment v-velocity (t+1) m/s +! *pten* provisional environment temperature (t+1) k +! *pqsen* environment spec. saturation humidity (t+1) kg/kg +! *pgeo* geopotential m2/s2 +! *pgeoh* geopotential on half levels m2/s2 +! *paph* provisional pressure on half levels pa +! *ptu* temperature in updrafts k +! *pqu* spec. humidity in updrafts kg/kg +! *plu* liquid water content in updrafts kg/kg +! *puu* u-velocity in updrafts m/s +! *pvu* v-velocity in updrafts m/s +! *pmfub* massflux in updrafts at cloud base kg/(m2*s) + +! updated parameters (real(kind=kind_phys)): + +! *prfl* precipitation rate kg/(m2*s) + +! output parameters (real(kind=kind_phys)): + +! *ptd* temperature in downdrafts k +! *pqd* spec. humidity in downdrafts kg/kg +! *pud* u-velocity in downdrafts m/s +! *pvd* v-velocity in downdrafts m/s +! *pmfd* massflux in downdrafts kg/(m2*s) +! *pmfds* flux of dry static energy in downdrafts j/(m2*s) +! *pmfdq* flux of spec. humidity in downdrafts kg/(m2*s) +! *pdmfdp* flux difference of precip. in downdrafts kg/(m2*s) + +! output parameters (integer): + +! *kdtop* top level of downdrafts + +! output parameters (logical): + +! *lddraf* .true. if downdrafts exist + +! externals +! --------- +! *cuadjtq* for calculating wet bulb t and q at lfs +!---------------------------------------------------------------------- + implicit none + + integer klev,klon + real(kind=kind_phys) ptenh(klon,klev), pqenh(klon,klev), & + & puen(klon,klev), pven(klon,klev), & + & pten(klon,klev), pqsen(klon,klev), & + & pgeo(klon,klev), & + & pgeoh(klon,klev+1), paph(klon,klev+1),& + & ptu(klon,klev), pqu(klon,klev), & + & puu(klon,klev), pvu(klon,klev), & + & plu(klon,klev), & + & pmfub(klon), prfl(klon) + + real(kind=kind_phys) ptd(klon,klev), pqd(klon,klev), & + & pud(klon,klev), pvd(klon,klev), & + & pmfd(klon,klev), pmfds(klon,klev), & + & pmfdq(klon,klev), pdmfdp(klon,klev) + integer kcbot(klon), kctop(klon), & + & kdtop(klon), ikhsmin(klon) + logical ldcum(klon), & + & lddraf(klon) + integer lndj(klon) + + real(kind=kind_phys) ztenwb(klon,klev), zqenwb(klon,klev), & + & zcond(klon), zph(klon), & + & zhsmin(klon) + logical llo2(klon) +! local variables + integer jl,jk + integer is,ik,icall,ike + real(kind=kind_phys) zhsk,zttest,zqtest,zbuo,zmftop + +!---------------------------------------------------------------------- + +! 1. set default values for downdrafts +! --------------------------------- + do jl=1,klon + lddraf(jl)=.false. + kdtop(jl)=klev+1 + ikhsmin(jl)=klev+1 + zhsmin(jl)=1.e8 + enddo +!---------------------------------------------------------------------- + +! 2. determine level of free sinking: +! downdrafts shall start at model level of minimum +! of saturation moist static energy or below +! respectively + +! for every point and proceed as follows: + +! (1) determine level of minimum of hs +! (2) determine wet bulb environmental t and q +! (3) do mixing with cumulus cloud air +! (4) check for negative buoyancy +! (5) if buoyancy>0 repeat (2) to (4) for next +! level below + +! the assumption is that air of downdrafts is mixture +! of 50% cloud air + 50% environmental air at wet bulb +! temperature (i.e. which became saturated due to +! evaporation of rain and cloud water) +! ---------------------------------------------------- + do jk=3,klev-2 + do jl=1,klon + zhsk=cpd*pten(jl,jk)+pgeo(jl,jk) + & + & foelhm(pten(jl,jk))*pqsen(jl,jk) + if(zhsk .lt. zhsmin(jl)) then + zhsmin(jl) = zhsk + ikhsmin(jl)= jk + end if + end do + end do + + + ike=klev-3 + do jk=3,ike + +! 2.1 calculate wet-bulb temperature and moisture +! for environmental air in *cuadjtq* +! ------------------------------------------- + is=0 + do jl=1,klon + ztenwb(jl,jk)=ptenh(jl,jk) + zqenwb(jl,jk)=pqenh(jl,jk) + zph(jl)=paph(jl,jk) + llo2(jl)=ldcum(jl).and.prfl(jl).gt.0..and..not.lddraf(jl).and. & + & (jk.lt.kcbot(jl).and.jk.gt.kctop(jl)).and. jk.ge.ikhsmin(jl) + if(llo2(jl))then + is=is+1 + endif + enddo + if(is.eq.0) cycle + + ik=jk + icall=2 + call cuadjtqn & + & ( klon, klev, ik, zph, ztenwb, zqenwb, llo2, icall) + +! 2.2 do mixing of cumulus and environmental air +! and check for negative buoyancy. +! then set values for downdraft at lfs. +! ---------------------------------------- + do jl=1,klon + if(llo2(jl)) then + zttest=0.5*(ptu(jl,jk)+ztenwb(jl,jk)) + zqtest=0.5*(pqu(jl,jk)+zqenwb(jl,jk)) + zbuo=zttest*(1.+vtmpc1 *zqtest)- & + & ptenh(jl,jk)*(1.+vtmpc1 *pqenh(jl,jk)) + zcond(jl)=pqenh(jl,jk)-zqenwb(jl,jk) + zmftop=-cmfdeps*pmfub(jl) + if(zbuo.lt.0..and.prfl(jl).gt.10.*zmftop*zcond(jl)) then + kdtop(jl)=jk + lddraf(jl)=.true. + ptd(jl,jk)=zttest + pqd(jl,jk)=zqtest + pmfd(jl,jk)=zmftop + pmfds(jl,jk)=pmfd(jl,jk)*(cpd*ptd(jl,jk)+pgeoh(jl,jk)) + pmfdq(jl,jk)=pmfd(jl,jk)*pqd(jl,jk) + pdmfdp(jl,jk-1)=-0.5*pmfd(jl,jk)*zcond(jl) + prfl(jl)=prfl(jl)+pdmfdp(jl,jk-1) + endif + endif + enddo + + enddo + + return + end subroutine cudlfsn + +!--------------------------------------------------------- +! level 3 souroutines +!-------------------------------------------------------- +!********************************************** +! subroutine cuddrafn +!********************************************** + subroutine cuddrafn & + & ( klon, klev, lddraf & + & , ptenh, pqenh, puen, pven & + & , pgeo, pgeoh, paph, prfl & + & , ptd, pqd, pud, pvd, pmfu & + & , pmfd, pmfds, pmfdq, pdmfdp, pmfdde_rate ) + +! this routine calculates cumulus downdraft descent + +! m.tiedtke e.c.m.w.f. 12/86 modif. 12/89 + +! purpose. +! -------- +! to produce the vertical profiles for cumulus downdrafts +! (i.e. t,q,u and v and fluxes) + +! interface +! --------- + +! this routine is called from *cumastr*. +! input is t,q,p,phi,u,v at half levels. +! it returns fluxes of s,q and evaporation rate +! and u,v at levels where downdraft occurs + +! method. +! -------- +! calculate moist descent for entraining/detraining plume by +! a) moving air dry-adiabatically to next level below and +! b) correcting for evaporation to obtain saturated state. + +! parameter description units +! --------- ----------- ----- +! input parameters (integer): + +! *klon* number of grid points per packet +! *klev* number of levels + +! input parameters (logical): + +! *lddraf* .true. if downdrafts exist + +! input parameters (real(kind=kind_phys)): + +! *ptenh* env. temperature (t+1) on half levels k +! *pqenh* env. spec. humidity (t+1) on half levels kg/kg +! *puen* provisional environment u-velocity (t+1) m/s +! *pven* provisional environment v-velocity (t+1) m/s +! *pgeo* geopotential m2/s2 +! *pgeoh* geopotential on half levels m2/s2 +! *paph* provisional pressure on half levels pa +! *pmfu* massflux updrafts kg/(m2*s) + +! updated parameters (real(kind=kind_phys)): + +! *prfl* precipitation rate kg/(m2*s) + +! output parameters (real(kind=kind_phys)): + +! *ptd* temperature in downdrafts k +! *pqd* spec. humidity in downdrafts kg/kg +! *pud* u-velocity in downdrafts m/s +! *pvd* v-velocity in downdrafts m/s +! *pmfd* massflux in downdrafts kg/(m2*s) +! *pmfds* flux of dry static energy in downdrafts j/(m2*s) +! *pmfdq* flux of spec. humidity in downdrafts kg/(m2*s) +! *pdmfdp* flux difference of precip. in downdrafts kg/(m2*s) + +! externals +! --------- +! *cuadjtq* for adjusting t and q due to evaporation in +! saturated descent +!---------------------------------------------------------------------- + implicit none + + integer klev,klon + real(kind=kind_phys) ptenh(klon,klev), pqenh(klon,klev), & + & puen(klon,klev), pven(klon,klev), & + & pgeoh(klon,klev+1), paph(klon,klev+1), & + & pgeo(klon,klev), pmfu(klon,klev) + + real(kind=kind_phys) ptd(klon,klev), pqd(klon,klev), & + & pud(klon,klev), pvd(klon,klev), & + & pmfd(klon,klev), pmfds(klon,klev), & + & pmfdq(klon,klev), pdmfdp(klon,klev), & + & prfl(klon) + real(kind=kind_phys) pmfdde_rate(klon,klev) + logical lddraf(klon) + + real(kind=kind_phys) zdmfen(klon), zdmfde(klon), & + & zcond(klon), zoentr(klon), & + & zbuoy(klon) + real(kind=kind_phys) zph(klon) + logical llo2(klon) + logical llo1 +! local variables + integer jl,jk + integer is,ik,icall,ike, itopde(klon) + real(kind=kind_phys) zentr,zdz,zzentr,zseen,zqeen,zsdde,zqdde,zdmfdp + real(kind=kind_phys) zmfdsk,zmfdqk,zbuo,zrain,zbuoyz,zmfduk,zmfdvk + +!---------------------------------------------------------------------- +! 1. calculate moist descent for cumulus downdraft by +! (a) calculating entrainment/detrainment rates, +! including organized entrainment dependent on +! negative buoyancy and assuming +! linear decrease of massflux in pbl +! (b) doing moist descent - evaporative cooling +! and moistening is calculated in *cuadjtq* +! (c) checking for negative buoyancy and +! specifying final t,q,u,v and downward fluxes +! ------------------------------------------------- + do jl=1,klon + zoentr(jl)=0. + zbuoy(jl)=0. + zdmfen(jl)=0. + zdmfde(jl)=0. + enddo + + do jk=klev,1,-1 + do jl=1,klon + pmfdde_rate(jl,jk) = 0. + if((paph(jl,klev+1)-paph(jl,jk)).lt. 60.e2) itopde(jl) = jk + end do + end do + + do jk=3,klev + is=0 + do jl=1,klon + zph(jl)=paph(jl,jk) + llo2(jl)=lddraf(jl).and.pmfd(jl,jk-1).lt.0. + if(llo2(jl)) then + is=is+1 + endif + enddo + if(is.eq.0) cycle + + do jl=1,klon + if(llo2(jl)) then + zentr = entrdd*pmfd(jl,jk-1)*(pgeoh(jl,jk-1)-pgeoh(jl,jk))*zrg + zdmfen(jl)=zentr + zdmfde(jl)=zentr + endif + enddo + + do jl=1,klon + if(llo2(jl)) then + if(jk.gt.itopde(jl)) then + zdmfen(jl)=0. + zdmfde(jl)=pmfd(jl,itopde(jl))* & + & (paph(jl,jk)-paph(jl,jk-1))/ & + & (paph(jl,klev+1)-paph(jl,itopde(jl))) + endif + endif + enddo + + do jl=1,klon + if(llo2(jl)) then + if(jk.le.itopde(jl)) then + zdz=-(pgeoh(jl,jk-1)-pgeoh(jl,jk))*zrg + zzentr=zoentr(jl)*zdz*pmfd(jl,jk-1) + zdmfen(jl)=zdmfen(jl)+zzentr + zdmfen(jl)=max(zdmfen(jl),0.3*pmfd(jl,jk-1)) + zdmfen(jl)=max(zdmfen(jl),-0.75*pmfu(jl,jk)- & + & (pmfd(jl,jk-1)-zdmfde(jl))) + zdmfen(jl)=min(zdmfen(jl),0.) + endif + endif + enddo + + do jl=1,klon + if(llo2(jl)) then + pmfd(jl,jk)=pmfd(jl,jk-1)+zdmfen(jl)-zdmfde(jl) + zseen=(cpd*ptenh(jl,jk-1)+pgeoh(jl,jk-1))*zdmfen(jl) + zqeen=pqenh(jl,jk-1)*zdmfen(jl) + zsdde=(cpd*ptd(jl,jk-1)+pgeoh(jl,jk-1))*zdmfde(jl) + zqdde=pqd(jl,jk-1)*zdmfde(jl) + zmfdsk=pmfds(jl,jk-1)+zseen-zsdde + zmfdqk=pmfdq(jl,jk-1)+zqeen-zqdde + pqd(jl,jk)=zmfdqk*(1./min(-cmfcmin,pmfd(jl,jk))) + ptd(jl,jk)=(zmfdsk*(1./min(-cmfcmin,pmfd(jl,jk)))-& + & pgeoh(jl,jk))*rcpd + ptd(jl,jk)=min(400.,ptd(jl,jk)) + ptd(jl,jk)=max(100.,ptd(jl,jk)) + zcond(jl)=pqd(jl,jk) + endif + enddo + + ik=jk + icall=2 + call cuadjtqn(klon, klev, ik, zph, ptd, pqd, llo2, icall ) + + do jl=1,klon + if(llo2(jl)) then + zcond(jl)=zcond(jl)-pqd(jl,jk) + zbuo=ptd(jl,jk)*(1.+vtmpc1 *pqd(jl,jk))- & + & ptenh(jl,jk)*(1.+vtmpc1 *pqenh(jl,jk)) + if(prfl(jl).gt.0..and.pmfu(jl,jk).gt.0.) then + zrain=prfl(jl)/pmfu(jl,jk) + zbuo=zbuo-ptd(jl,jk)*zrain + endif + if(zbuo.ge.0 .or. prfl(jl).le.(pmfd(jl,jk)*zcond(jl))) then + pmfd(jl,jk)=0. + zbuo=0. + endif + pmfds(jl,jk)=(cpd*ptd(jl,jk)+pgeoh(jl,jk))*pmfd(jl,jk) + pmfdq(jl,jk)=pqd(jl,jk)*pmfd(jl,jk) + zdmfdp=-pmfd(jl,jk)*zcond(jl) + pdmfdp(jl,jk-1)=zdmfdp + prfl(jl)=prfl(jl)+zdmfdp + +! compute organized entrainment for use at next level + zbuoyz=zbuo/ptenh(jl,jk) + zbuoyz=min(zbuoyz,0.0) + zdz=-(pgeo(jl,jk-1)-pgeo(jl,jk)) + zbuoy(jl)=zbuoy(jl)+zbuoyz*zdz + zoentr(jl)=g*zbuoyz*0.5/(1.+zbuoy(jl)) + pmfdde_rate(jl,jk) = -zdmfde(jl) + endif + enddo + + enddo + + return + end subroutine cuddrafn +!--------------------------------------------------------- +! level 3 souroutines +!-------------------------------------------------------- + subroutine cuflxn & + & ( klon, klev, ztmst & + & , pten, pqen, pqsen, ptenh, pqenh & + & , paph, pap, pgeoh, lndj, ldcum & + & , kcbot, kctop, kdtop, ktopm2 & + & , ktype, lddraf & + & , pmfu, pmfd, pmfus, pmfds & + & , pmfuq, pmfdq, pmful, plude & + & , pdmfup, pdmfdp, pdpmel, plglac & + & , prain, pmfdde_rate, pmflxr, pmflxs ) + +! m.tiedtke e.c.m.w.f. 7/86 modif. 12/89 + +! purpose +! ------- + +! this routine does the final calculation of convective +! fluxes in the cloud layer and in the subcloud layer + +! interface +! --------- +! this routine is called from *cumastr*. + + +! parameter description units +! --------- ----------- ----- +! input parameters (integer): + +! *klon* number of grid points per packet +! *klev* number of levels +! *kcbot* cloud base level +! *kctop* cloud top level +! *kdtop* top level of downdrafts + +! input parameters (logical): + +! *lndj* land sea mask (1 for land) +! *ldcum* flag: .true. for convective points + +! input parameters (real(kind=kind_phys)): + +! *ztmst* time step for the physics s +! *pten* provisional environment temperature (t+1) k +! *pqen* provisional environment spec. humidity (t+1) kg/kg +! *pqsen* environment spec. saturation humidity (t+1) kg/kg +! *ptenh* env. temperature (t+1) on half levels k +! *pqenh* env. spec. humidity (t+1) on half levels kg/kg +! *paph* provisional pressure on half levels pa +! *pap* provisional pressure on full levels pa +! *pgeoh* geopotential on half levels m2/s2 + +! updated parameters (integer): + +! *ktype* set to zero if ldcum=.false. + +! updated parameters (logical): + +! *lddraf* set to .false. if ldcum=.false. or kdtop= kdtop(jl) + if ( llddraf .and.jk.ge.kdtop(jl)) then + pmfds(jl,jk) = pmfds(jl,jk)-pmfd(jl,jk) * & + (cpd*ptenh(jl,jk)+pgeoh(jl,jk)) + pmfdq(jl,jk) = pmfdq(jl,jk)-pmfd(jl,jk)*pqenh(jl,jk) + else + pmfd(jl,jk) = 0. + pmfds(jl,jk) = 0. + pmfdq(jl,jk) = 0. + pdmfdp(jl,jk-1) = 0. + end if + if ( llddraf .and. pmfd(jl,jk) < 0. .and. & + abs(pmfd(jl,ikb)) < 1.e-20 ) then + idbas(jl) = jk + end if + else + pmfu(jl,jk)=0. + pmfd(jl,jk)=0. + pmfus(jl,jk)=0. + pmfds(jl,jk)=0. + pmfuq(jl,jk)=0. + pmfdq(jl,jk)=0. + pmful(jl,jk)=0. + plglac(jl,jk)=0. + pdmfup(jl,jk-1)=0. + pdmfdp(jl,jk-1)=0. + plude(jl,jk-1)=0. + endif + enddo + enddo + + do jl=1,klon + pmflxr(jl,klev+1) = 0. + pmflxs(jl,klev+1) = 0. + end do + do jl=1,klon + if(ldcum(jl)) then + ikb=kcbot(jl) + ik=ikb+1 + zzp=((paph(jl,klev+1)-paph(jl,ik))/ & + & (paph(jl,klev+1)-paph(jl,ikb))) + if(ktype(jl).eq.3) then + zzp=zzp**2 + endif + pmfu(jl,ik)=pmfu(jl,ikb)*zzp + pmfus(jl,ik)=(pmfus(jl,ikb)- & + & foelhm(ptenh(jl,ikb))*pmful(jl,ikb))*zzp + pmfuq(jl,ik)=(pmfuq(jl,ikb)+pmful(jl,ikb))*zzp + pmful(jl,ik)=0. + endif + enddo + + do jk=ktopm2,klev + do jl=1,klon + if(ldcum(jl).and.jk.gt.kcbot(jl)+1) then + ikb=kcbot(jl)+1 + zzp=((paph(jl,klev+1)-paph(jl,jk))/ & + & (paph(jl,klev+1)-paph(jl,ikb))) + if(ktype(jl).eq.3) then + zzp=zzp**2 + endif + pmfu(jl,jk)=pmfu(jl,ikb)*zzp + pmfus(jl,jk)=pmfus(jl,ikb)*zzp + pmfuq(jl,jk)=pmfuq(jl,ikb)*zzp + pmful(jl,jk)=0. + endif + ik = idbas(jl) + llddraf = lddraf(jl) .and. jk > ik .and. ik < klev + if ( llddraf .and. ik == kcbot(jl)+1 ) then + zzp = ((paph(jl,klev+1)-paph(jl,jk))/(paph(jl,klev+1)-paph(jl,ik))) + if ( ktype(jl) == 3 ) zzp = zzp*zzp + pmfd(jl,jk) = pmfd(jl,ik)*zzp + pmfds(jl,jk) = pmfds(jl,ik)*zzp + pmfdq(jl,jk) = pmfdq(jl,ik)*zzp + pmfdde_rate(jl,jk) = -(pmfd(jl,jk-1)-pmfd(jl,jk)) + else if ( llddraf .and. ik /= kcbot(jl)+1 .and. jk == ik+1 ) then + pmfdde_rate(jl,jk) = -(pmfd(jl,jk-1)-pmfd(jl,jk)) + end if + enddo + enddo +!* 2. calculate rain/snow fall rates +!* calculate melting of snow +!* calculate evaporation of precip +! ------------------------------- + + do jk=ktopm2,klev + do jl=1,klon + if(ldcum(jl) .and. jk >=kctop(jl)-1 ) then + prain(jl)=prain(jl)+pdmfup(jl,jk) + if(pmflxs(jl,jk).gt.0..and.pten(jl,jk).gt.tmelt) then + zcons1=zcons1a*(1.+0.5*(pten(jl,jk)-tmelt)) + zfac=zcons1*(paph(jl,jk+1)-paph(jl,jk)) + zsnmlt=min(pmflxs(jl,jk),zfac*(pten(jl,jk)-tmelt)) + pdpmel(jl,jk)=zsnmlt + pqsen(jl,jk)=foeewm(pten(jl,jk)-zsnmlt/zfac)/pap(jl,jk) + endif + zalfaw=foealfa(pten(jl,jk)) + ! + ! No liquid precipitation above melting level + ! + if ( pten(jl,jk) < tmelt .and. zalfaw > 0. ) then + plglac(jl,jk) = plglac(jl,jk)+zalfaw*(pdmfup(jl,jk)+pdmfdp(jl,jk)) + zalfaw = 0. + end if + pmflxr(jl,jk+1)=pmflxr(jl,jk)+zalfaw* & + & (pdmfup(jl,jk)+pdmfdp(jl,jk))+pdpmel(jl,jk) + pmflxs(jl,jk+1)=pmflxs(jl,jk)+(1.-zalfaw)* & + & (pdmfup(jl,jk)+pdmfdp(jl,jk))-pdpmel(jl,jk) + if(pmflxr(jl,jk+1)+pmflxs(jl,jk+1).lt.0.0) then + pdmfdp(jl,jk)=-(pmflxr(jl,jk)+pmflxs(jl,jk)+pdmfup(jl,jk)) + pmflxr(jl,jk+1)=0.0 + pmflxs(jl,jk+1)=0.0 + pdpmel(jl,jk) =0.0 + else if ( pmflxr(jl,jk+1) < 0. ) then + pmflxs(jl,jk+1) = pmflxs(jl,jk+1)+pmflxr(jl,jk+1) + pmflxr(jl,jk+1) = 0. + else if ( pmflxs(jl,jk+1) < 0. ) then + pmflxr(jl,jk+1) = pmflxr(jl,jk+1)+pmflxs(jl,jk+1) + pmflxs(jl,jk+1) = 0. + end if + endif + enddo + enddo + do jk=ktopm2,klev + do jl=1,klon + if(ldcum(jl).and.jk.ge.kcbot(jl)) then + zrfl=pmflxr(jl,jk)+pmflxs(jl,jk) + if(zrfl.gt.1.e-20) then + zdrfl1=zcpecons*max(0.,pqsen(jl,jk)-pqen(jl,jk))*zcucov* & + & (sqrt(paph(jl,jk)/paph(jl,klev+1))/5.09e-3* & + & zrfl/zcucov)**0.5777* & + & (paph(jl,jk+1)-paph(jl,jk)) + zrnew=zrfl-zdrfl1 + zrmin=zrfl-zcucov*max(0.,rhevap(jl)*pqsen(jl,jk) & + & -pqen(jl,jk)) *zcons2*(paph(jl,jk+1)-paph(jl,jk)) + zrnew=max(zrnew,zrmin) + zrfln=max(zrnew,0.) + zdrfl=min(0.,zrfln-zrfl) + zdenom=1./max(1.e-20,pmflxr(jl,jk)+pmflxs(jl,jk)) + zalfaw=foealfa(pten(jl,jk)) + if ( pten(jl,jk) < tmelt ) zalfaw = 0. + zpdr=zalfaw*pdmfdp(jl,jk) + zpds=(1.-zalfaw)*pdmfdp(jl,jk) + pmflxr(jl,jk+1)=pmflxr(jl,jk)+zpdr & + & +pdpmel(jl,jk)+zdrfl*pmflxr(jl,jk)*zdenom + pmflxs(jl,jk+1)=pmflxs(jl,jk)+zpds & + & -pdpmel(jl,jk)+zdrfl*pmflxs(jl,jk)*zdenom + pdmfup(jl,jk)=pdmfup(jl,jk)+zdrfl + if ( pmflxr(jl,jk+1)+pmflxs(jl,jk+1) < 0. ) then + pdmfup(jl,jk) = pdmfup(jl,jk)-(pmflxr(jl,jk+1)+pmflxs(jl,jk+1)) + pmflxr(jl,jk+1) = 0. + pmflxs(jl,jk+1) = 0. + pdpmel(jl,jk) = 0. + else if ( pmflxr(jl,jk+1) < 0. ) then + pmflxs(jl,jk+1) = pmflxs(jl,jk+1)+pmflxr(jl,jk+1) + pmflxr(jl,jk+1) = 0. + else if ( pmflxs(jl,jk+1) < 0. ) then + pmflxr(jl,jk+1) = pmflxr(jl,jk+1)+pmflxs(jl,jk+1) + pmflxs(jl,jk+1) = 0. + end if + else + pmflxr(jl,jk+1)=0.0 + pmflxs(jl,jk+1)=0.0 + pdmfdp(jl,jk)=0.0 + pdpmel(jl,jk)=0.0 + endif + endif + enddo + enddo + + return + end subroutine cuflxn +!--------------------------------------------------------- +! level 3 souroutines +!-------------------------------------------------------- + subroutine cudtdqn(klon,klev,ktopm2,kctop,kdtop,ldcum, & + lddraf,ztmst,paph,pgeoh,pgeo,pten,ptenh,pqen, & + pqenh,pqsen,plglac,plude,pmfu,pmfd,pmfus,pmfds, & + pmfuq,pmfdq,pmful,pdmfup,pdmfdp,pdpmel,ptent,ptenq,pcte) + implicit none + integer klon,klev,ktopm2 + integer kctop(klon), kdtop(klon) + logical ldcum(klon), lddraf(klon) + real(kind=kind_phys) ztmst + real(kind=kind_phys) paph(klon,klev+1), pgeoh(klon,klev+1) + real(kind=kind_phys) pgeo(klon,klev), pten(klon,klev), & + pqen(klon,klev), ptenh(klon,klev),& + pqenh(klon,klev), pqsen(klon,klev),& + plglac(klon,klev), plude(klon,klev) + real(kind=kind_phys) pmfu(klon,klev), pmfd(klon,klev),& + pmfus(klon,klev), pmfds(klon,klev),& + pmfuq(klon,klev), pmfdq(klon,klev),& + pmful(klon,klev), pdmfup(klon,klev),& + pdpmel(klon,klev), pdmfdp(klon,klev) + real(kind=kind_phys) ptent(klon,klev), ptenq(klon,klev) + real(kind=kind_phys) pcte(klon,klev) + +! local variables + integer jk , ik , jl + real(kind=kind_phys) zalv , zzp + real(kind=kind_phys) zdtdt(klon,klev) , zdqdt(klon,klev) , zdp(klon,klev) + !* 1.0 SETUP AND INITIALIZATIONS + ! ------------------------- + do jk = 1 , klev + do jl = 1, klon + if ( ldcum(jl) ) then + zdp(jl,jk) = g/(paph(jl,jk+1)-paph(jl,jk)) + end if + end do + end do + + !----------------------------------------------------------------------- + !* 2.0 COMPUTE TENDENCIES + ! ------------------ + do jk = ktopm2 , klev + if ( jk < klev ) then + do jl = 1,klon + if ( ldcum(jl) ) then + zalv = foelhm(pten(jl,jk)) + zdtdt(jl,jk) = zdp(jl,jk)*rcpd * & + (pmfus(jl,jk+1)-pmfus(jl,jk)+pmfds(jl,jk+1) - & + pmfds(jl,jk)+alf*plglac(jl,jk)-alf*pdpmel(jl,jk) - & + zalv*(pmful(jl,jk+1)-pmful(jl,jk)-plude(jl,jk)-pdmfup(jl,jk)-pdmfdp(jl,jk))) + zdqdt(jl,jk) = zdp(jl,jk)*(pmfuq(jl,jk+1) - & + pmfuq(jl,jk)+pmfdq(jl,jk+1)-pmfdq(jl,jk)+pmful(jl,jk+1) - & + pmful(jl,jk)-plude(jl,jk)-pdmfup(jl,jk)-pdmfdp(jl,jk)) + end if + end do + else + do jl = 1,klon + if ( ldcum(jl) ) then + zalv = foelhm(pten(jl,jk)) + zdtdt(jl,jk) = -zdp(jl,jk)*rcpd * & + (pmfus(jl,jk)+pmfds(jl,jk)+alf*pdpmel(jl,jk) - & + zalv*(pmful(jl,jk)+pdmfup(jl,jk)+pdmfdp(jl,jk)+plude(jl,jk))) + zdqdt(jl,jk) = -zdp(jl,jk)*(pmfuq(jl,jk) + plude(jl,jk) + & + pmfdq(jl,jk)+(pmful(jl,jk)+pdmfup(jl,jk)+pdmfdp(jl,jk))) + end if + end do + end if + end do + !--------------------------------------------------------------- + !* 3.0 UPDATE TENDENCIES + ! ----------------- + do jk = ktopm2 , klev + do jl = 1, klon + if ( ldcum(jl) ) then + ptent(jl,jk) = ptent(jl,jk) + zdtdt(jl,jk) + ptenq(jl,jk) = ptenq(jl,jk) + zdqdt(jl,jk) + pcte(jl,jk) = zdp(jl,jk)*plude(jl,jk) + end if + end do + end do + + return + end subroutine cudtdqn +!--------------------------------------------------------- +! level 3 souroutines +!-------------------------------------------------------- + subroutine cududvn(klon,klev,ktopm2,ktype,kcbot,kctop,ldcum, & + ztmst,paph,puen,pven,pmfu,pmfd,puu,pud,pvu,pvd,ptenu, & + ptenv) + implicit none + integer klon,klev,ktopm2 + integer ktype(klon), kcbot(klon), kctop(klon) + logical ldcum(klon) + real(kind=kind_phys) ztmst + real(kind=kind_phys) paph(klon,klev+1) + real(kind=kind_phys) puen(klon,klev), pven(klon,klev),& + pmfu(klon,klev), pmfd(klon,klev),& + puu(klon,klev), pud(klon,klev),& + pvu(klon,klev), pvd(klon,klev) + real(kind=kind_phys) ptenu(klon,klev), ptenv(klon,klev) + +!local variables + real(kind=kind_phys) zuen(klon,klev) , zven(klon,klev) , zmfuu(klon,klev), & + zmfdu(klon,klev), zmfuv(klon,klev), zmfdv(klon,klev) + + integer ik , ikb , jk , jl + real(kind=kind_phys) zzp, zdtdt + + real(kind=kind_phys) zdudt(klon,klev), zdvdt(klon,klev), zdp(klon,klev) +! + do jk = 1 , klev + do jl = 1, klon + if ( ldcum(jl) ) then + zuen(jl,jk) = puen(jl,jk) + zven(jl,jk) = pven(jl,jk) + zdp(jl,jk) = g/(paph(jl,jk+1)-paph(jl,jk)) + end if + end do + end do +!---------------------------------------------------------------------- +!* 1.0 CALCULATE FLUXES AND UPDATE U AND V TENDENCIES +! ---------------------------------------------- + do jk = ktopm2 , klev + ik = jk - 1 + do jl = 1,klon + if ( ldcum(jl) ) then + zmfuu(jl,jk) = pmfu(jl,jk)*(puu(jl,jk)-zuen(jl,ik)) + zmfuv(jl,jk) = pmfu(jl,jk)*(pvu(jl,jk)-zven(jl,ik)) + zmfdu(jl,jk) = pmfd(jl,jk)*(pud(jl,jk)-zuen(jl,ik)) + zmfdv(jl,jk) = pmfd(jl,jk)*(pvd(jl,jk)-zven(jl,ik)) + end if + end do + end do + ! linear fluxes below cloud + do jk = ktopm2 , klev + do jl = 1, klon + if ( ldcum(jl) .and. jk > kcbot(jl) ) then + ikb = kcbot(jl) + zzp = ((paph(jl,klev+1)-paph(jl,jk))/(paph(jl,klev+1)-paph(jl,ikb))) + if ( ktype(jl) == 3 ) zzp = zzp*zzp + zmfuu(jl,jk) = zmfuu(jl,ikb)*zzp + zmfuv(jl,jk) = zmfuv(jl,ikb)*zzp + zmfdu(jl,jk) = zmfdu(jl,ikb)*zzp + zmfdv(jl,jk) = zmfdv(jl,ikb)*zzp + end if + end do + end do +!---------------------------------------------------------------------- +!* 2.0 COMPUTE TENDENCIES +! ------------------ + do jk = ktopm2 , klev + if ( jk < klev ) then + ik = jk + 1 + do jl = 1,klon + if ( ldcum(jl) ) then + zdudt(jl,jk) = zdp(jl,jk) * & + (zmfuu(jl,ik)-zmfuu(jl,jk)+zmfdu(jl,ik)-zmfdu(jl,jk)) + zdvdt(jl,jk) = zdp(jl,jk) * & + (zmfuv(jl,ik)-zmfuv(jl,jk)+zmfdv(jl,ik)-zmfdv(jl,jk)) + end if + end do + else + do jl = 1,klon + if ( ldcum(jl) ) then + zdudt(jl,jk) = -zdp(jl,jk)*(zmfuu(jl,jk)+zmfdu(jl,jk)) + zdvdt(jl,jk) = -zdp(jl,jk)*(zmfuv(jl,jk)+zmfdv(jl,jk)) + end if + end do + end if + end do +!--------------------------------------------------------------------- +!* 3.0 UPDATE TENDENCIES +! ----------------- + do jk = ktopm2 , klev + do jl = 1, klon + if ( ldcum(jl) ) then + ptenu(jl,jk) = ptenu(jl,jk) + zdudt(jl,jk) + ptenv(jl,jk) = ptenv(jl,jk) + zdvdt(jl,jk) + end if + end do + end do +!---------------------------------------------------------------------- + return + end subroutine cududvn + +!--------------------------------------------------------- +! level 3 souroutines +!-------------------------------------------------------- + subroutine cuctracer(klon,klev,ktrac,kctop,kdtop, & + ldcum,lddraf,ztmst,paph,pmfu,pmfd, & + pudrate,pddrate,pcen,ptenc) + implicit none + integer klon,klev,ktrac + integer kctop(klon), kdtop(klon) + logical ldcum(klon), lddraf(klon) + real(kind=kind_phys) ztmst + real(kind=kind_phys) paph(klon,klev+1) + real(kind=kind_phys) pmfu(klon,klev) + real(kind=kind_phys) pmfd(klon,klev) + real(kind=kind_phys) pudrate(klon,klev) + real(kind=kind_phys) pddrate(klon,klev) + real(kind=kind_phys) pcen(klon,klev,ktrac) + real(kind=kind_phys) ptenc(klon,klev,ktrac) + !---------------------------------------------------------------------- + integer ik , jk , jl , jn + real(kind=kind_phys) zzp , zmfa , zerate , zposi + ! ALLOCATABLE ARAYS + real(kind=kind_phys) , dimension(:,:,:) , allocatable :: zcen , zcu , zcd , & + ztenc , zmfc + real(kind=kind_phys) , dimension(:,:) , allocatable :: zdp + logical , dimension(:,:) , allocatable :: llcumask , llcumbas + !---------------------------------------------------------------------- + allocate (zcen(klon,klev,ktrac)) ! Half-level environmental values + allocate (zcu(klon,klev,ktrac)) ! Updraft values + allocate (zcd(klon,klev,ktrac)) ! Downdraft values + allocate (ztenc(klon,klev,ktrac)) ! Tendency + allocate (zmfc(klon,klev,ktrac)) ! Fluxes + allocate (zdp(klon,klev)) ! Pressure difference + allocate (llcumask(klon,klev)) ! Mask for convection + ! Initialize Cumulus mask + some setups + do jk = 2, klev + do jl = 1, klon + llcumask(jl,jk) = .false. + if ( ldcum(jl) ) then + zdp(jl,jk) = g/(paph(jl,jk+1)-paph(jl,jk)) + if ( jk >= kctop(jl)-1 ) llcumask(jl,jk) = .true. + end if + end do + end do + !---------------------------------------------------------------------- + do jn = 1 , ktrac + !* 1.0 DEFINE TRACERS AT HALF LEVELS + ! ----------------------------- + do jk = 2 , klev + ik = jk - 1 + do jl = 1, klon + zcen(jl,jk,jn) = pcen(jl,jk,jn) + zcd(jl,jk,jn) = pcen(jl,ik,jn) + zcu(jl,jk,jn) = pcen(jl,ik,jn) + zmfc(jl,jk,jn) = 0. + ztenc(jl,jk,jn)= 0. + end do + end do + + do jl = 1, klon + zcu(jl,klev,jn) = pcen(jl,klev,jn) + end do + !* 2.0 COMPUTE UPDRAFT VALUES + ! ---------------------- + do jk = klev - 1 , 3 , -1 + ik = jk + 1 + do jl = 1, klon + if ( llcumask(jl,jk) ) then + zerate = pmfu(jl,jk) - pmfu(jl,ik) + pudrate(jl,jk) + zmfa = 1./max(cmfcmin,pmfu(jl,jk)) + if ( jk >= kctop(jl) ) then + zcu(jl,jk,jn) = (pmfu(jl,ik)*zcu(jl,ik,jn) + & + zerate*pcen(jl,jk,jn)-pudrate(jl,jk)*zcu(jl,ik,jn))*zmfa + end if + end if + end do + end do + !* 3.0 COMPUTE DOWNDRAFT VALUES + ! ------------------------ + do jk = 3 , klev + ik = jk - 1 + do jl = 1, klon + if ( lddraf(jl) .and. jk == kdtop(jl) ) then + ! Nota: in order to avoid final negative Tracer values at LFS + ! the allowed value of ZCD depends on the jump in mass flux + ! at the LFS + zcd(jl,jk,jn) = 0.1*zcu(jl,jk,jn) + 0.9*pcen(jl,ik,jn) + else if ( lddraf(jl).and.jk>kdtop(jl) ) then + zerate = -pmfd(jl,jk) + pmfd(jl,ik) + pddrate(jl,jk) + zmfa = 1./min(-cmfcmin,pmfd(jl,jk)) + zcd(jl,jk,jn) = (pmfd(jl,ik)*zcd(jl,ik,jn) - & + zerate*pcen(jl,ik,jn)+pddrate(jl,jk)*zcd(jl,ik,jn))*zmfa + end if + end do + end do + ! In order to avoid negative Tracer at KLEV adjust ZCD + jk = klev + ik = jk - 1 + do jl = 1, klon + if ( lddraf(jl) ) then + zposi = -zdp(jl,jk) *(pmfu(jl,jk)*zcu(jl,jk,jn) + & + pmfd(jl,jk)*zcd(jl,jk,jn)-(pmfu(jl,jk)+pmfd(jl,jk))*pcen(jl,ik,jn)) + if ( pcen(jl,jk,jn)+zposi*ztmst < 0. ) then + zmfa = 1./min(-cmfcmin,pmfd(jl,jk)) + zcd(jl,jk,jn) = ((pmfu(jl,jk)+pmfd(jl,jk))*pcen(jl,ik,jn) - & + pmfu(jl,jk)*zcu(jl,jk,jn)+pcen(jl,jk,jn) / & + (ztmst*zdp(jl,jk)))*zmfa + end if + end if + end do + end do + !---------------------------------------------------------------------- + do jn = 1 , ktrac + !* 4.0 COMPUTE FLUXES + ! -------------- + do jk = 2 , klev + ik = jk - 1 + do jl = 1, klon + if ( llcumask(jl,jk) ) then + zmfa = pmfu(jl,jk) + pmfd(jl,jk) + zmfc(jl,jk,jn) = pmfu(jl,jk)*zcu(jl,jk,jn) + & + pmfd(jl,jk)*zcd(jl,jk,jn) - zmfa*zcen(jl,ik,jn) + end if + end do + end do + !* 5.0 COMPUTE TENDENCIES = RHS + ! ------------------------ + do jk = 2 , klev - 1 + ik = jk + 1 + do jl = 1, klon + if ( llcumask(jl,jk) ) then + ztenc(jl,jk,jn) = zdp(jl,jk)*(zmfc(jl,ik,jn)-zmfc(jl,jk,jn)) + end if + end do + end do + jk = klev + do jl = 1, klon + if ( ldcum(jl) ) ztenc(jl,jk,jn) = -zdp(jl,jk)*zmfc(jl,jk,jn) + end do + end do + !* 6.0 UPDATE TENDENCIES + ! ----------------- + do jn = 1, ktrac + do jk = 2, klev + do jl = 1, klon + if ( llcumask(jl,jk) ) then + ptenc(jl,jk,jn) = ptenc(jl,jk,jn)+ztenc(jl,jk,jn) + end if + end do + end do + end do + !--------------------------------------------------------------------------- + deallocate (llcumask) + deallocate (zdp) + deallocate (zmfc) + deallocate (ztenc) + deallocate (zcd) + deallocate (zcu) + deallocate (zcen) + end subroutine cuctracer + +!--------------------------------------------------------- +! level 4 souroutines +!-------------------------------------------------------- + subroutine cuadjtqn & + & (klon, klev, kk, psp, pt, pq, ldflag, kcall) +! m.tiedtke e.c.m.w.f. 12/89 +! purpose. +! -------- +! to produce t,q and l values for cloud ascent + +! interface +! --------- +! this routine is called from subroutines: +! *cond* (t and q at condensation level) +! *cubase* (t and q at condensation level) +! *cuasc* (t and q at cloud levels) +! *cuini* (environmental t and qs values at half levels) +! input are unadjusted t and q values, +! it returns adjusted values of t and q + +! parameter description units +! --------- ----------- ----- +! input parameters (integer): + +! *klon* number of grid points per packet +! *klev* number of levels +! *kk* level +! *kcall* defines calculation as +! kcall=0 env. t and qs in*cuini* +! kcall=1 condensation in updrafts (e.g. cubase, cuasc) +! kcall=2 evaporation in downdrafts (e.g. cudlfs,cuddraf) +! input parameters (real(kind=kind_phys)): + +! *psp* pressure pa + +! updated parameters (real(kind=kind_phys)): + +! *pt* temperature k +! *pq* specific humidity kg/kg +! externals +! --------- +! for condensation calculations. +! the tables are initialised in *suphec*. + +!---------------------------------------------------------------------- + + implicit none + + integer klev,klon + real(kind=kind_phys) pt(klon,klev), pq(klon,klev), & + & psp(klon) + logical ldflag(klon) +! local variables + integer jl,jk + integer isum,kcall,kk + real(kind=kind_phys) zqmax,zqsat,zcor,zqp,zcond,zcond1,zl,zi,zf +!---------------------------------------------------------------------- +! 1. define constants +! ---------------- + zqmax=0.5 + +! 2. calculate condensation and adjust t and q accordingly +! ----------------------------------------------------- + + if ( kcall == 1 ) then + do jl = 1,klon + if ( ldflag(jl) ) then + zqp = 1./psp(jl) + zl = 1./(pt(jl,kk)-c4les) + zi = 1./(pt(jl,kk)-c4ies) + zqsat = c2es*(foealfa(pt(jl,kk))*exp(c3les*(pt(jl,kk)-tmelt)*zl) + & + (1.-foealfa(pt(jl,kk)))*exp(c3ies*(pt(jl,kk)-tmelt)*zi)) + zqsat = zqsat*zqp + zqsat = min(0.5,zqsat) + zcor = 1. - vtmpc1*zqsat + zf = foealfa(pt(jl,kk))*r5alvcp*zl**2 + & + (1.-foealfa(pt(jl,kk)))*r5alscp*zi**2 + zcond = (pq(jl,kk)*zcor**2-zqsat*zcor)/(zcor**2+zqsat*zf) + if ( zcond > 0. ) then + pt(jl,kk) = pt(jl,kk) + foeldcpm(pt(jl,kk))*zcond + pq(jl,kk) = pq(jl,kk) - zcond + zl = 1./(pt(jl,kk)-c4les) + zi = 1./(pt(jl,kk)-c4ies) + zqsat = c2es*(foealfa(pt(jl,kk)) * & + exp(c3les*(pt(jl,kk)-tmelt)*zl)+(1.-foealfa(pt(jl,kk))) * & + exp(c3ies*(pt(jl,kk)-tmelt)*zi)) + zqsat = zqsat*zqp + zqsat = min(0.5,zqsat) + zcor = 1. - vtmpc1*zqsat + zf = foealfa(pt(jl,kk))*r5alvcp*zl**2 + & + (1.-foealfa(pt(jl,kk)))*r5alscp*zi**2 + zcond1 = (pq(jl,kk)*zcor**2-zqsat*zcor)/(zcor**2+zqsat*zf) + if ( abs(zcond) < 1.e-20 ) zcond1 = 0. + pt(jl,kk) = pt(jl,kk) + foeldcpm(pt(jl,kk))*zcond1 + pq(jl,kk) = pq(jl,kk) - zcond1 + end if + end if + end do + elseif ( kcall == 2 ) then + do jl = 1,klon + if ( ldflag(jl) ) then + zqp = 1./psp(jl) + zqsat = foeewm(pt(jl,kk))*zqp + zqsat = min(0.5,zqsat) + zcor = 1./(1.-vtmpc1*zqsat) + zqsat = zqsat*zcor + zcond = (pq(jl,kk)-zqsat)/(1.+zqsat*zcor*foedem(pt(jl,kk))) + zcond = min(zcond,0.) + pt(jl,kk) = pt(jl,kk) + foeldcpm(pt(jl,kk))*zcond + pq(jl,kk) = pq(jl,kk) - zcond + zqsat = foeewm(pt(jl,kk))*zqp + zqsat = min(0.5,zqsat) + zcor = 1./(1.-vtmpc1*zqsat) + zqsat = zqsat*zcor + zcond1 = (pq(jl,kk)-zqsat)/(1.+zqsat*zcor*foedem(pt(jl,kk))) + if ( abs(zcond) < 1.e-20 ) zcond1 = min(zcond1,0.) + pt(jl,kk) = pt(jl,kk) + foeldcpm(pt(jl,kk))*zcond1 + pq(jl,kk) = pq(jl,kk) - zcond1 + end if + end do + else if ( kcall == 0 ) then + do jl = 1,klon + zqp = 1./psp(jl) + zqsat = foeewm(pt(jl,kk))*zqp + zqsat = min(0.5,zqsat) + zcor = 1./(1.-vtmpc1*zqsat) + zqsat = zqsat*zcor + zcond1 = (pq(jl,kk)-zqsat)/(1.+zqsat*zcor*foedem(pt(jl,kk))) + pt(jl,kk) = pt(jl,kk) + foeldcpm(pt(jl,kk))*zcond1 + pq(jl,kk) = pq(jl,kk) - zcond1 + zqsat = foeewm(pt(jl,kk))*zqp + zqsat = min(0.5,zqsat) + zcor = 1./(1.-vtmpc1*zqsat) + zqsat = zqsat*zcor + zcond1 = (pq(jl,kk)-zqsat)/(1.+zqsat*zcor*foedem(pt(jl,kk))) + pt(jl,kk) = pt(jl,kk) + foeldcpm(pt(jl,kk))*zcond1 + pq(jl,kk) = pq(jl,kk) - zcond1 + end do + end if + + return + end subroutine cuadjtqn +!--------------------------------------------------------- +! level 4 souroutines +!-------------------------------------------------------- + subroutine cubasmcn & + & (klon, klev, klevm1, kk, pten,& + & pqen, pqsen, puen, pven, pverv,& + & pgeo, pgeoh, ldcum, ktype, klab, plrain,& + & pmfu, pmfub, kcbot, ptu,& + & pqu, plu, puu, pvu, pmfus,& + & pmfuq, pmful, pdmfup) + implicit none +! m.tiedtke e.c.m.w.f. 12/89 +! c.zhang iprc 05/2012 +!***purpose. +! -------- +! this routine calculates cloud base values +! for midlevel convection +!***interface +! --------- +! this routine is called from *cuasc*. +! input are environmental values t,q etc +! it returns cloudbase values for midlevel convection +!***method. +! ------- +! s. tiedtke (1989) +!***externals +! --------- +! none +! ---------------------------------------------------------------- + real(kind=kind_phys) pten(klon,klev), pqen(klon,klev),& + & puen(klon,klev), pven(klon,klev),& + & pqsen(klon,klev), pverv(klon,klev),& + & pgeo(klon,klev), pgeoh(klon,klev+1) + real(kind=kind_phys) ptu(klon,klev), pqu(klon,klev),& + & puu(klon,klev), pvu(klon,klev),& + & plu(klon,klev), pmfu(klon,klev),& + & pmfub(klon), & + & pmfus(klon,klev), pmfuq(klon,klev),& + & pmful(klon,klev), pdmfup(klon,klev),& + & plrain(klon,klev) + integer ktype(klon), kcbot(klon),& + & klab(klon,klev) + logical ldcum(klon) +! local variabels + integer jl,kk,klev,klon,klevp1,klevm1 + real(kind=kind_phys) zzzmb +!-------------------------------------------------------- +!* 1. calculate entrainment and detrainment rates +! ------------------------------------------------------- + do jl=1,klon + if(.not.ldcum(jl) .and. klab(jl,kk+1).eq.0) then + if(lmfmid .and. pqen(jl,kk) .gt. 0.80*pqsen(jl,kk).and. & + pgeo(jl,kk)*zrg .gt. 5.0e2 .and. & + & pgeo(jl,kk)*zrg .lt. 1.0e4 ) then + ptu(jl,kk+1)=(cpd*pten(jl,kk)+pgeo(jl,kk)-pgeoh(jl,kk+1))& + & *rcpd + pqu(jl,kk+1)=pqen(jl,kk) + plu(jl,kk+1)=0. + zzzmb=max(cmfcmin,-pverv(jl,kk)*zrg) + zzzmb=min(zzzmb,cmfcmax) + pmfub(jl)=zzzmb + pmfu(jl,kk+1)=pmfub(jl) + pmfus(jl,kk+1)=pmfub(jl)*(cpd*ptu(jl,kk+1)+pgeoh(jl,kk+1)) + pmfuq(jl,kk+1)=pmfub(jl)*pqu(jl,kk+1) + pmful(jl,kk+1)=0. + pdmfup(jl,kk+1)=0. + kcbot(jl)=kk + klab(jl,kk+1)=1 + plrain(jl,kk+1)=0.0 + ktype(jl)=3 + end if + end if + end do + return + end subroutine cubasmcn +! +!--------------------------------------------------------- +! level 4 souroutines +!--------------------------------------------------------- + subroutine cuentrn(klon,klev,kk,kcbot,ldcum,ldwork, & + pgeoh,pmfu,pdmfen,pdmfde) + implicit none + integer klon,klev,kk + integer kcbot(klon) + logical ldcum(klon) + logical ldwork + real(kind=kind_phys) pgeoh(klon,klev+1) + real(kind=kind_phys) pmfu(klon,klev) + real(kind=kind_phys) pdmfen(klon) + real(kind=kind_phys) pdmfde(klon) + logical llo1 + integer jl + real(kind=kind_phys) zdz , zmf + real(kind=kind_phys) zentr(klon) + ! + !* 1. CALCULATE ENTRAINMENT AND DETRAINMENT RATES + ! ------------------------------------------- + if ( ldwork ) then + do jl = 1,klon + pdmfen(jl) = 0. + pdmfde(jl) = 0. + zentr(jl) = 0. + end do + ! + !* 1.1 SPECIFY ENTRAINMENT RATES + ! ------------------------- + do jl = 1, klon + if ( ldcum(jl) ) then + zdz = (pgeoh(jl,kk)-pgeoh(jl,kk+1))*zrg + zmf = pmfu(jl,kk+1)*zdz + llo1 = kk < kcbot(jl) + if ( llo1 ) then + pdmfen(jl) = zentr(jl)*zmf + pdmfde(jl) = 0.75e-4*zmf + end if + end if + end do + end if + end subroutine cuentrn +! +!-------------------------------------------------------- +! external functions +!------------------------------------------------------ + real(kind=kind_phys) function foealfa(tt) +! foealfa is calculated to distinguish the three cases: +! +! foealfa=1 water phase +! foealfa=0 ice phase +! 0 < foealfa < 1 mixed phase +! +! input : tt = temperature +! + implicit none + real(kind=kind_phys) tt + foealfa = min(1.,((max(rtice,min(rtwat,tt))-rtice) & + & /(rtwat-rtice))**2) + + return + end function foealfa + + real(kind=kind_phys) function foelhm(tt) + implicit none + real(kind=kind_phys) tt + foelhm = foealfa(tt)*alv + (1.-foealfa(tt))*als + return + end function foelhm + + real(kind=kind_phys) function foeewm(tt) + implicit none + real(kind=kind_phys) tt + foeewm = c2es * & + & (foealfa(tt)*exp(c3les*(tt-tmelt)/(tt-c4les))+ & + & (1.-foealfa(tt))*exp(c3ies*(tt-tmelt)/(tt-c4ies))) + return + end function foeewm + + real(kind=kind_phys) function foedem(tt) + implicit none + real(kind=kind_phys) tt + foedem = foealfa(tt)*r5alvcp*(1./(tt-c4les)**2)+ & + & (1.-foealfa(tt))*r5alscp*(1./(tt-c4ies)**2) + return + end function foedem + + real(kind=kind_phys) function foeldcpm(tt) + implicit none + real(kind=kind_phys) tt + foeldcpm = foealfa(tt)*ralvdcp+ & + & (1.-foealfa(tt))*ralsdcp + return + end function foeldcpm + + real(kind=kind_phys) function foeldcp(tt) + implicit none + real(kind=kind_phys) tt + foeldcp = foedelta(tt)*ralvdcp + (1.-foedelta(tt))*ralsdcp + end function foeldcp + + real(kind=kind_phys) function foedelta(tt) + implicit none + real(kind=kind_phys) tt + foedelta = max(0.,sign(1.,tt-tmelt)) + end function foedelta + +end module cu_ntiedtke + diff --git a/physics/cu_ntiedtke_post.F90 b/physics/cu_ntiedtke_post.F90 new file mode 100644 index 000000000..fdc0b8b0f --- /dev/null +++ b/physics/cu_ntiedtke_post.F90 @@ -0,0 +1,53 @@ +!> \file cu_ntiedtke_post.F90 +!! Contains code related to New Tiedtke convective scheme + +module cu_ntiedtke_post + + implicit none + + private + + public :: cu_ntiedtke_post_init, cu_ntiedtke_post_run, cu_ntiedtke_post_finalize + + contains + + subroutine cu_ntiedtke_post_init () + end subroutine cu_ntiedtke_post_init + + subroutine cu_ntiedtke_post_finalize() + end subroutine cu_ntiedtke_post_finalize + +!> \section arg_table_cu_ntiedtke_post_run Argument Table +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |----------------|--------------------------------------------------------|--------------------------------------------------|---------|------|-----------|-----------|--------|----------| +!! | t | air_temperature_updated_by_physics | temperature updated by physics | K | 2 | real | kind_phys | in | F | +!! | q | water_vapor_specific_humidity_updated_by_physics | water vapor specific humidity updated by physics | kg kg-1 | 2 | real | kind_phys | in | F | +!! | prevst | temperature_from_previous_timestep | temperature from previous time step | K | 2 | real | kind_phys | out | F | +!! | prevsq | moisture_from_previous_timestep | moisture from previous time step | kg kg-1 | 2 | real | kind_phys | out | F | +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! + subroutine cu_ntiedtke_post_run (t, q, prevst, prevsq, errmsg, errflg) + + use machine, only: kind_phys + + implicit none + + ! Interface variables + real(kind_phys), intent(in) :: t(:,:) + real(kind_phys), intent(in) :: q(:,:) + real(kind_phys), intent(out) :: prevst(:,:) + real(kind_phys), intent(out) :: prevsq(:,:) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + prevst(:,:) = t(:,:) + prevsq(:,:) = q(:,:) + + end subroutine cu_ntiedtke_post_run + +end module cu_ntiedtke_post diff --git a/physics/cu_ntiedtke_pre.F90 b/physics/cu_ntiedtke_pre.F90 new file mode 100644 index 000000000..725b4a351 --- /dev/null +++ b/physics/cu_ntiedtke_pre.F90 @@ -0,0 +1,84 @@ +!> \file cu_ntiedtke_pre.F90 +!! Contains code related to New Tiedtke convective scheme + +module cu_ntiedtke_pre + + implicit none + + private + + public :: cu_ntiedtke_pre_init, cu_ntiedtke_pre_run, cu_ntiedtke_pre_finalize + + contains + + subroutine cu_ntiedtke_pre_init () + end subroutine cu_ntiedtke_pre_init + + subroutine cu_ntiedtke_pre_finalize() + end subroutine cu_ntiedtke_pre_finalize + +!> \section arg_table_cu_ntiedtke_pre_run Argument Table +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |----------------|--------------------------------------------------------|--------------------------------------------------|---------------|------|-----------|-----------|--------|----------| +!! | flag_init | flag_for_first_time_step | flag signaling first time step for time integration loop | flag | 0 | logical | | in | F | +!! | flag_restart | flag_for_restart | flag for restart (warmstart) or coldstart | flag | 0 | logical | | in | F | +!! | kdt | index_of_time_step | current forecast iteration | index | 0 | integer | | in | F | +!! | fhour | forecast_time | curent forecast time | h | 0 | real | kind_phys | in | F | +!! | dtp | time_step_for_physics | physics timestep | s | 0 | real | kind_phys | in | F | +!! | t | air_temperature | model layer mean temperature | K | 2 | real | kind_phys | in | F | +!! | q | water_vapor_specific_humidity | water vapor specific humidity | kg kg-1 | 2 | real | kind_phys | in | F | +!! | prevst | temperature_from_previous_timestep | temperature from previous time step | K | 2 | real | kind_phys | in | F | +!! | prevsq | moisture_from_previous_timestep | moisture from previous time step | kg kg-1 | 2 | real | kind_phys | in | F | +!! | forcet | temperature_tendency_due_to_dynamics | temperature tendency due to dynamics only | K s-1 | 2 | real | kind_phys | out | F | +!! | forceq | moisture_tendency_due_to_dynamics | moisture tendency due to dynamics only | kg kg-1 s-1 | 2 | real | kind_phys | out | F | +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! + subroutine cu_ntiedtke_pre_run (flag_init, flag_restart, kdt, fhour, dtp, t, q, prevst, prevsq, & + forcet, forceq, errmsg, errflg) + + use machine, only: kind_phys + + implicit none + + logical, intent(in) :: flag_init + logical, intent(in) :: flag_restart + integer, intent(in) :: kdt + real(kind_phys), intent(in) :: fhour + real(kind_phys), intent(in) :: dtp + real(kind_phys), intent(in) :: t(:,:) + real(kind_phys), intent(in) :: q(:,:) + real(kind_phys), intent(in) :: prevst(:,:) + real(kind_phys), intent(in) :: prevsq(:,:) + real(kind_phys), intent(out) :: forcet(:,:) + real(kind_phys), intent(out) :: forceq(:,:) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! local variables + real(kind=kind_phys) :: dtdyn + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! For restart runs, can assume that prevst and prevsq + ! are read from the restart files beforehand, same + ! for conv_act. + if(flag_init .and. .not.flag_restart) then + forcet(:,:)=0.0 + forceq(:,:)=0.0 + else + dtdyn=3600.0*(fhour)/kdt + if(dtp > dtdyn) then + forcet(:,:)=(t(:,:) - prevst(:,:))/dtp + forceq(:,:)=(q(:,:) - prevsq(:,:))/dtp + else + forcet(:,:)=(t(:,:) - prevst(:,:))/dtdyn + forceq(:,:)=(q(:,:) - prevsq(:,:))/dtdyn + endif + endif + + end subroutine cu_ntiedtke_pre_run + +end module cu_ntiedtke_pre diff --git a/physics/m_micro_interstitial.F90 b/physics/m_micro_interstitial.F90 index 85b1cbfdc..259c82519 100644 --- a/physics/m_micro_interstitial.F90 +++ b/physics/m_micro_interstitial.F90 @@ -25,8 +25,6 @@ end subroutine m_micro_pre_init !! | do_shoc | flag_for_shoc | flag for SHOC | flag | 0 | logical | | in | F | !! | fprcp | number_of_frozen_precipitation_species | number of frozen precipitation species | count | 0 | integer | | in | F | !! | mg3_as_mg2 | flag_mg3_as_mg2 | flag for controlling prep for Morrison-Gettelman microphysics | flag | 0 | logical | | in | F | -!! | imfdeepcnv | flag_for_mass_flux_deep_convection_scheme | flag for mass-flux deep convection scheme | flag | 0 | integer | | in | F | -!! | imfshalcnv | flag_for_mass_flux_shallow_convection_scheme | flag for mass-flux shallow convection scheme | flag | 0 | integer | | in | F | !! | gq0_ice | ice_water_mixing_ratio_updated_by_physics | moist (dry+vapor, no condensates) mixing ratio of ice water updated by physics | kg kg-1 | 2 | real | kind_phys | in | F | !! | gq0_water | cloud_condensed_water_mixing_ratio_updated_by_physics | moist (dry+vapor, no condensates) mixing ratio of cloud condensed water updated by physics | kg kg-1 | 2 | real | kind_phys | in | F | !! | gq0_rain | rain_water_mixing_ratio_updated_by_physics | moist (dry+vapor, no condensates) mixing ratio of rain water updated by physics | kg kg-1 | 2 | real | kind_phys | in | F | @@ -58,14 +56,14 @@ end subroutine m_micro_pre_init !! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | !! #endif - subroutine m_micro_pre_run (im, levs, do_shoc, fprcp, mg3_as_mg2, imfdeepcnv, imfshalcnv, 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, & + subroutine m_micro_pre_run (im, levs, do_shoc, 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, qlcn, qicn, cf_upi, clw_water, clw_ice, clcn, errmsg, errflg ) use machine, only : kind_phys implicit none - integer, intent(in) :: im, levs, imfdeepcnv, imfshalcnv, fprcp + integer, intent(in) :: im, levs, fprcp logical, intent(in) :: do_shoc, mg3_as_mg2 real(kind=kind_phys), intent(in) :: tcr, tcrf diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index 661bde35e..ff8e6619a 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -35,12 +35,10 @@ ! Added Tripoli and Cotton (1981) correction. ! Added namelist option bl_mynn_cloudmix to test effect of mixing ! cloud species (default = 1: on). -! Added mass-flux option (bl_mynn_edmf, = 1 for StEM, 2 for TEMF). -! This option is off by default (=0). -! Related (hidden) options: +! Added mass-flux option (bl_mynn_edmf, = 1 for DMP mass-flux, 0: off). +! Related options: ! bl_mynn_edmf_mom = 1 : activate momentum transport in MF scheme ! bl_mynn_edmf_tke = 1 : activate TKE transport in MF scheme -! bl_mynn_edmf_part= 1 : activate areal partitioning of ED & MF ! Added mixing length option (bl_mynn_mixlength, see notes below) ! Added more sophisticated saturation checks, following Thompson scheme ! Added new cloud PDF option (bl_mynn_cloudpdf = 2) from Chaboureau @@ -68,12 +66,38 @@ ! New tridiagonal solver, which is supposedly 14% faster and more ! conservative. Impact seems very small. ! Many miscellaneous tweaks to the mixing lengths and stratus -! component of the subgrid clouds. +! component of the subgrid-scale (SGS) clouds. ! v4.1 Big improvements in downward SW radiation due to revision of subgrid clouds -! Improved ensemble spread from changes to SPP in MYNN -! Added many IF checks (within IFDEFS) to protect mixchem code +! - better cloud fraction and subgrid scale mixing ratios. +! - may experience a small cool bias during the daytime now that high +! SW-down bias is greatly reduced... +! Some tweaks to increase the turbulent mixing during the daytime for +! bl_mynn_mixlength option 2 to alleviate cool bias (very small impact). +! Improved ensemble spread from changes to SPP in MYNN +! - now perturbing eddy diffusivity and eddy viscosity directly +! - now perturbing background rh (in SGS cloud calc only) +! - now perturbing entrainment rates in mass-flux scheme +! Added IF checks (within IFDEFS) to protect mixchem code from being used +! when HRRR smoke is used (no impact on regular non-wrf chem use) +! Important bug fix for wrf chem when transporting chemical species in MF scheme +! Removed 2nd mass-flux scheme (no only bl_mynn_edmf = 1, no option 2) +! Removed unused stochastic code for mass-flux scheme +! Changed mass-flux scheme to be integrated on interface levels instead of +! mass levels - impact is small +! Added option to mix 2nd moments in MYNN as opposed to the scalar_pblmix option. +! - activated with bl_mynn_mixscalars = 1; this sets scalar_pblmix = 0 +! - added tridagonal solver used in scalar_pblmix option to duplicate tendencies +! - this alone changes the interface call considerably from v4.0. +! Slight revision to TKE production due to radiation cooling at top of clouds +! Added the non-Guassian buoyancy flux function of Bechtold and Siebesma (1998, JAS). +! - improves TKE in SGS clouds +! Added heating due to dissipation of TKE (small impact, maybe + 0.1 C daytime PBL temp) +! Misc changes made for FV3/MPAS compatibility +! +! Many of these changes are now documented in Olson et al. (2019, +! NOAA Technical Memorandum) ! -! For changes 1, 3, and 6, see "JOE's mods" below: +! For more explanation of some configuration options, see "JOE's mods" below: !------------------------------------------------------------------- MODULE module_bl_mynn @@ -113,7 +137,7 @@ MODULE module_bl_mynn & p_qnc= 0, & & p_qni= 0 -!END FV3 CONSTANTS +!END FV3 CONSTANTS !==================================================================== !WRF CONSTANTS ! USE module_model_constants, only: & @@ -181,7 +205,7 @@ MODULE module_bl_mynn ! Constants for cloud PDF (mym_condensation) REAL, PARAMETER :: rr2=0.7071068, rrp=0.3989423 -! 'parameters' for Poisson distribution (StEM EDMF scheme) +! 'parameters' for Poisson distribution (EDMF scheme) REAL, PARAMETER :: zero = 0.0, half = 0.5, one = 1.0, two = 2.0 !Use Canuto/Kitamura mod (remove Ric and negative TKE) (1:yes, 0:no) @@ -931,10 +955,10 @@ SUBROUTINE mym_length ( & cns = 3.5 alp1 = 0.23 - alp2 = 0.6 !0.3 - alp3 = 4.0 + alp2 = 0.6 !0.3 + alp3 = 2.0 alp4 = 10. - alp5 = 0.6 !0.4 !like alp2, but for free atmosphere + alp5 = 0.6 !0.3 !like alp2, but for free atmosphere alp6 = 10.0 !used for MF mixing length instead of BouLac (x times MF) ! Impose limits on the height integration for elt and the transition layer depth @@ -1763,20 +1787,21 @@ SUBROUTINE mym_turbulence ( & ! ! Add min background stability function (diffusivity) within model levels ! with active plumes and low cloud fractions. - cldavg = 0.5*(cldfra_bl1D(k-1) + cldfra_bl1D(k)) + cldavg = 0.5*(cldfra_bl1D(k-1) + cldfra_bl1D(k)) IF (edmf_a1(k) > 0.001 .OR. cldavg > 0.02) THEN - !cldavg = 0.5*(cldfra_bl1D(k-1) + cldfra_bl1D(k)) - !sm(k) = MAX(sm(k), MAX(1.0 - 2.0*cldavg, 0.0)**0.33 * 0.03 * & + cldavg = 0.5*(cldfra_bl1D(k-1) + cldfra_bl1D(k)) + !sm(k) = MAX(sm(k), MAX(1.0 - 2.0*cldavg, 0.0)**0.33 * 0.03 * & ! & MIN(10.*edmf_a1(k)*edmf_w1(k),1.0) ) - !sh(k) = MAX(sh(k), MAX(1.0 - 2.0*cldavg, 0.0)**0.33 * 0.03 * & + !sh(k) = MAX(sh(k), MAX(1.0 - 2.0*cldavg, 0.0)**0.33 * 0.03 * & ! & MIN(10.*edmf_a1(k)*edmf_w1(k),1.0) ) ! for mass-flux columns sm(k) = MAX(sm(k), 0.03*MIN(10.*edmf_a1(k)*edmf_w1(k),1.0) ) sh(k) = MAX(sh(k), 0.03*MIN(10.*edmf_a1(k)*edmf_w1(k),1.0) ) - ! for clouds + ! for clouds sm(k) = MAX(sm(k), 0.03*MIN(cldavg,1.0) ) sh(k) = MAX(sh(k), 0.03*MIN(cldavg,1.0) ) + ENDIF ! elq = el(k)*qkw(k) @@ -2255,7 +2280,7 @@ SUBROUTINE mym_condensation (kts,kte, & & Sh, el, bl_mynn_cloudpdf,& & qc_bl1D, cldfra_bl1D, & & PBLH1,HFX1, & - & Vt, Vq, th, sgm, & + & Vt, Vq, th, sgm, rmo, & & spp_pbl,rstoch_col ) !------------------------------------------------------------------- @@ -2267,7 +2292,7 @@ SUBROUTINE mym_condensation (kts,kte, & # define kte HARDCODE_VERTICAL #endif - REAL, INTENT(IN) :: dx,PBLH1,HFX1 + REAL, INTENT(IN) :: dx,PBLH1,HFX1,rmo REAL, DIMENSION(kts:kte), INTENT(IN) :: dz REAL, DIMENSION(kts:kte), INTENT(IN) :: p,exner, thl, qw, & &tsq, qsq, cov, th @@ -2285,7 +2310,7 @@ SUBROUTINE mym_condensation (kts,kte, & REAL :: erf !JOE: NEW VARIABLES FOR ALTERNATE SIGMA - REAL::dth,dtl,dqw,dzk + REAL::dth,dtl,dqw,dzk,els REAL, DIMENSION(kts:kte), INTENT(IN) :: Sh,el !JOE: variables for BL clouds @@ -2464,9 +2489,12 @@ SUBROUTINE mym_condensation (kts,kte, & ! in CB02 zagl = zagl + dz(k) + !Use analog to surface layer length scale to make the cloud mixing length scale + !become less than z in stable conditions. + els = zagl/(1.0 + 1.0*MIN( 0.5*dz(1)*MAX(rmo,0.0), 1. )) ls_min = 300. + MIN(3.*MAX(HFX1,0.),300.) - ls_min = MIN(MAX(zagl,25.),ls_min) ! Let this be the minimum possible length scale: + ls_min = MIN(MAX(els,25.),ls_min) ! Let this be the minimum possible length scale: if (zagl > PBLH1+2000.) ls_min = MAX(ls_min + 0.5*(PBLH1+2000.-zagl),300.) ! 25 m < ls_min(=zagl) < 300 m lfac=MIN(4.25+dx/4000.,6.) ! A dx-dependent multiplier for the master length scale: @@ -2620,6 +2648,7 @@ SUBROUTINE mym_condensation (kts,kte, & !ENDIF ! For purposes of the buoyancy flux in stratus, we will use Fng = 1 !Fng = 1. + Q1(k)=MAX(Q1(k),-5.0) IF (Q1(k) .GE. 1.0) THEN Fng = 1.0 ELSEIF (Q1(k) .GE. -1.7 .AND. Q1(k) < 1.0) THEN @@ -2630,7 +2659,7 @@ SUBROUTINE mym_condensation (kts,kte, & Fng = MIN(23.9 + EXP(-1.6*(Q1(k)+2.5)), 60.) ENDIF Fng = MIN(Fng, 20.) - + xl = xl_blend(t) bb = b(k)*t/th(k) ! bb is "b" in BCMT95. Their "b" differs from ! "b" in CB02 (i.e., b(k) above) by a factor @@ -2642,8 +2671,8 @@ SUBROUTINE mym_condensation (kts,kte, & alpha = 0.61*th(k) beta = (th(k)/t)*(xl/cp) - 1.61*th(k) - vt(k) = qww - MIN(cld(k),0.75)*beta*bb*Fng - 1. - vq(k) = alpha + MIN(cld(k),0.75)*beta*a(k)*Fng - tv0 + vt(k) = qww - MIN(cld(k),0.99)*beta*bb*Fng - 1. + vq(k) = alpha + MIN(cld(k),0.99)*beta*a(k)*Fng - tv0 ! vt and vq correspond to beta-theta and beta-q, respectively, ! in NN09, Eq. B8. They also correspond to the bracketed ! expressions in BCMT95, Eq. 15, since (s*ql/sigma^2) = cldfra*Fng @@ -3506,6 +3535,7 @@ SUBROUTINE mynn_mix_chem(kts,kte, & tsq,qsq,cov, & tcd,qcd, & dfm,dfh,dfq, & + s_aw, & s_awchem, & bl_mynn_cloudmix) @@ -3519,6 +3549,7 @@ SUBROUTINE mynn_mix_chem(kts,kte, & REAL, DIMENSION(kts:kte), INTENT(INOUT) :: thl,sqw,sqv,sqc,sqi REAL, INTENT(IN) :: delt,ust,flt,flq,flqv,flqc,wspd,uoce,voce,qcg INTEGER, INTENT(IN ) :: nchem, kdvel, ndvel, num_vert_mix + REAL, DIMENSION( kts:kte+1), INTENT(IN) :: s_aw REAL, DIMENSION( kts:kte, nchem ), INTENT(INOUT) :: chem1 REAL, DIMENSION( kts:kte+1,nchem), INTENT(IN) :: s_awchem REAL, DIMENSION( ndvel ), INTENT(INOUT) :: vd1 @@ -3547,18 +3578,16 @@ SUBROUTINE mynn_mix_chem(kts,kte, & k=kts a(1)=0. - b(1)=1.+dtz(k)*dfh(k+1) - c(1)=-dtz(k)*dfh(k+1) - ! d(1)=sqv(k) + dtz(k)*flqv + qcd(k)*delt - d(1)=chem1(k,ic) + dtz(k) * -vd1(ic)*chem1(1,ic) + b(1)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) + c(1)=-dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) + d(1)=chem1(k,ic) + dtz(k) * -vd1(ic)*chem1(1,ic) - dtz(k)*s_awchem(k+1,ic) DO k=kts+1,kte-1 - kk=k-kts+1 - a(kk)=-dtz(k)*dfh(k) - b(kk)=1.+dtz(k)*(dfh(k)+dfh(k+1)) - c(kk)=-dtz(k)*dfh(k+1) + a(k)=-dtz(k)*dfh(k) + 0.5*dtz(k)*s_aw(k) + b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1)) + c(k)=-dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) ! d(kk)=chem1(k,ic) + qcd(k)*delt - d(kk)=chem1(k,ic) + rhs*delt + dtz(k)*(s_awchem(k,ic)-s_awchem(k+1,ic)) + d(k)=chem1(k,ic) + rhs*delt + dtz(k)*(s_awchem(k,ic)-s_awchem(k+1,ic)) ENDDO ! prescribed value at top @@ -3797,7 +3826,7 @@ SUBROUTINE mynn_bl_driver( & ! = 3; Level 3 ! grav_settling = 1 when gravitational settling accounted for ! grav_settling = 0 when gravitational settling NOT accounted for - + REAL, INTENT(in) :: delt !WRF ! REAL, INTENT(in) :: dx @@ -3955,9 +3984,9 @@ SUBROUTINE mynn_bl_driver( & ENDIF maxKHtopdown(its:ite,jts:jte)=0. - ! DH* CHECK HOW MUCH OF THIS INIT IF-BLOCK IS ACTUALLY NEEDED FOR RESTARTS - IF (initflag > 0) THEN - + ! DH* CHECK HOW MUCH OF THIS INIT IF-BLOCK IS ACTUALLY NEEDED FOR RESTARTS + IF (initflag > 0) THEN + if (.not.restart) THEN Sh3D(its:ite,kts:kte,jts:jte)=0. el_pbl(its:ite,kts:kte,jts:jte)=0. @@ -4342,7 +4371,7 @@ SUBROUTINE mynn_bl_driver( & &Sh,el,bl_mynn_cloudpdf, & &qc_bl1D,cldfra_bl1D, & &PBLH(i,j),HFX(i,j), & - &Vt, Vq, th1, sgm, & + &Vt, Vq, th1, sgm, rmol(i,j), & &spp_pbl, rstoch_col ) !ADD TKE source driven by cloud top cooling @@ -4436,8 +4465,8 @@ SUBROUTINE mynn_bl_driver( & ENDIF !end top-down check IF (bl_mynn_edmf == 1) THEN - !PRINT*,"Calling StEM Mass-Flux: i= ",i," j=",j - CALL StEM_mf( & + !PRINT*,"Calling DMP Mass-Flux: i= ",i," j=",j + CALL DMP_mf( & &kts,kte,delt,zw,dz1,p1, & &bl_mynn_edmf_mom, & &bl_mynn_edmf_tke, & @@ -4447,7 +4476,7 @@ SUBROUTINE mynn_bl_driver( & &qnc1,qni1,qnwfa1,qnifa1, & &ex1,Vt,Vq,sgm, & &ust(i,j),flt,flq,flqv,flqc, & - &PBLH(i,j),KPBL(i,j),DX(I,J), & + &PBLH(i,j),KPBL(i,j),DX(i,j), & &xland(i,j),th_sfc, & ! now outputs - tendencies ! &,dth1mf,dqv1mf,dqc1mf,du1mf,dv1mf & @@ -4473,30 +4502,6 @@ SUBROUTINE mynn_bl_driver( & & spp_pbl,rstoch_col & ) - ELSEIF (bl_mynn_edmf == 2) THEN - CALL temf_mf( & - &kts,kte,delt,zw,p1,ex1, & - &u1,v1,w1,th1,thl,thetav, & - &sqw,sqv,sqc,qke1, & - &ust(i,j),flt,flq,flqv,flqc, & - &hfx(i,j),qfx(i,j),ts(i,j), & - &pblh(i,j),rho1,dfh,dx(i,j),znt(i,j),ep_2, & - ! outputs - updraft properties - & edmf_a1,edmf_w1,edmf_qt1, & - & edmf_thl1,edmf_ent1,edmf_qc1, & - ! for the solver - & s_aw1,s_awthl1,s_awqt1, & - & s_awqv1,s_awqc1, & - & s_awu1,s_awv1,s_awqke1, & -#if (WRF_CHEM == 1) - & nchem,chem1,s_awchem1, & -#endif - & qc_bl1D,cldfra_bl1D & - &,FLAG_QI,FLAG_QC & - &,Psig_shcu(i,j) & - &,spp_pbl,rstoch_col & - &,i,j,ids,ide,jds,jde & - ) ENDIF CALL mym_turbulence ( & @@ -4527,7 +4532,7 @@ SUBROUTINE mynn_bl_driver( & DO k=kts,kte-1 ! Set max dissipative heating rate close to 0.1 K per hour (=0.000027...) - diss_heat(k) = MIN(MAX(0.5*(qke1(k)**1.5)/(b1*MAX(0.5*(el(k)+el(k+1)),1.))/cp, 0.0),0.000025) + diss_heat(k) = MIN(MAX(0.5*(qke1(k)**1.5)/(b1*MAX(0.5*(el(k)+el(k+1)),1.))/cp, 0.0),0.00002) ENDDO diss_heat(kte) = 0. @@ -4579,22 +4584,12 @@ SUBROUTINE mynn_bl_driver( & tcd, qcd, & &dfm, dfh, dfq, & ! mass flux components + & s_aw1, & & s_awchem1, & &bl_mynn_cloudmix) ENDIF #endif -! -! add mass flux tendencies and calculate the new variables. -! Now done implicitly in the mynn_tendencies subroutine -! do k=kts,kte -! du1(k)=du1(k)+du1mf(k) -! dv1(k)=dv1(k)+dv1mf(k) -! dth1(k)=dth1(k)+dth1mf(k) -! dqv1(k)=dqv1(k)+dqv1mf(k) -! that is supposed to be done by bl_fogdes -! dqc1(k)=dqc1(k)+dqc1mf(k) -! enddo CALL retrieve_exchange_coeffs(kts,kte,& &dfm, dfh, dz1, K_m1, K_h1) @@ -4694,7 +4689,7 @@ SUBROUTINE mynn_bl_driver( & IF ( ABS(vq(k)) > 6000.)print*,& "SUSPICIOUS VALUES AT: i,j,k=",i,j,k," vq=",vq(k) IF ( exch_m(i,k,j) < 0. .OR. exch_m(i,k,j)> 2000.)print*,& - "SUSPICIOUS VALUES AT: i,j,k=",i,j,k," exch_m=",exch_m(i,k,j) + "SUSPICIOUS VALUES AT: i,j,k=",i,j,k," exxch_m=",exch_m(i,k,j) IF ( vdfg(i,j) < 0. .OR. vdfg(i,j)>5. )print*,& "SUSPICIOUS VALUES AT: i,j,k=",i,j,k," vdfg=",vdfg(i,j) IF ( ABS(QFX(i,j))>.001)print*,& @@ -4953,6 +4948,8 @@ SUBROUTINE GET_PBLH(KTS,KTE,zi,thetav1D,qke1D,zw1D,dz1D,landsea,kzi) END SUBROUTINE GET_PBLH ! ================================================================== +! Dynamic Multi-Plume (DMP) Mass-Flux Scheme +! ! Much thanks to Kay Suslj of NASA-JPL for contributing the original version ! of this mass-flux scheme. Considerable changes have been made from it's ! original form. Some additions include: @@ -4962,7 +4959,7 @@ END SUBROUTINE GET_PBLH ! 4) some extra limits for numerical stability ! This scheme remains under development, so consider it experimental code. ! - SUBROUTINE StEM_mf( & + SUBROUTINE DMP_mf( & & kts,kte,dt,zw,dz,p, & & momentum_opt, & & tke_opt, & @@ -5046,7 +5043,7 @@ SUBROUTINE StEM_mf( & !------------- local variables ------------------- ! updraft properties defined on interfaces (k=1 is the top of the ! first model layer - REAL,DIMENSION(KTS:KTE+1,1:NUP) :: UPW,UPTHL,UPQT,UPQC,UPQV, & + REAL,DIMENSION(KTS:KTE+1,1:NUP) :: UPW,UPTHL,UPQT,UPQC,UPQV, & UPA,UPU,UPV,UPTHV,UPQKE,UPQNC, & UPQNI,UPQNWFA,UPQNIFA ! entrainment variables @@ -5098,12 +5095,12 @@ SUBROUTINE StEM_mf( & ! VARIABLES FOR CHABOUREAU-BECHTOLD CLOUD FRACTION REAL,DIMENSION(KTS:KTE), INTENT(INOUT) :: vt, vq, sgm - REAL :: sigq,xl,tlk,qsat_tl,rsl,cpm,a,qmq,mf_cf,diffqt,& - Q1,Fng,qww,alpha,beta,bb,f,pt,t,q2p,b9,satvp,rhgrid + REAL :: sigq,xl,tlk,qsat_tl,rsl,cpm,a,qmq,mf_cf,Q1,diffqt,& + Fng,qww,alpha,beta,bb,f,pt,t,q2p,b9,satvp,rhgrid ! Variables for plume interpolation/saturation check REAL,DIMENSION(KTS:KTE) :: exneri,dzi - REAL :: THLp, THp, QTp, QCp, rhplume, esat, qsl + REAL :: THp, QTp, QCp, esat, qsl ! WA TEST 11/9/15 for consistent reduction of updraft params REAL :: csigma,acfac,EntThrottle @@ -5257,15 +5254,16 @@ SUBROUTINE StEM_mf( & !wspd_pbl=SQRT(MAX(u(kpbl)**2 + v(kpbl)**2, 0.01)) maxwidth = 1.1*PBLH !- MIN(15.*MAX(wspd_pbl - 7.5, 0.), 0.3*PBLH) ! Criteria (3) +! maxwidth = MIN(maxwidth,0.5*cloud_base) maxwidth = MIN(maxwidth,0.75*cloud_base) ! Criteria (5) IF((landsea-1.5).LT.0)THEN IF (cloud_base .LT. 2000.) THEN !width_flx = MAX(MIN(1000.*(0.6*tanh((flt - 0.120)/0.03) + .5),1000.), 0.) - width_flx = MAX(MIN(1000.*(0.6*tanh((flt - 0.100)/0.03) + .5),1000.), 0.) + width_flx = MAX(MIN(1000.*(0.6*tanh((flt - 0.090)/0.03) + .5),1000.), 0.) ELSE - !width_flx = MAX(MIN(1000.*(0.6*tanh((flt - 0.050)/0.03) + .5),1000.), 0.) width_flx = MAX(MIN(1000.*(0.6*tanh((flt - 0.040)/0.03) + .5),1000.), 0.) + !width_flx = MAX(MIN(1000.*(0.6*tanh((flt - 0.050)/0.03) + .5),1000.), 0.) ENDIF maxwidth = MIN(maxwidth,width_flx) ENDIF @@ -5302,32 +5300,17 @@ SUBROUTINE StEM_mf( & ! acfac = .5*tanh((fltv - 0.05)/0.2) + .5 ! acfac = .5*tanh((fltv - 0.07)/0.09) + .5 ! acfac = .5*tanh((fltv - 0.03)/0.09) + .5 - acfac = .5*tanh((fltv - 0.015)/0.05) + .5 + acfac = .5*tanh((fltv - 0.02)/0.09) + .5 +! acfac = .5*tanh((fltv - 0.015)/0.05) + .5 UPA(1,I)=UPA(1,I)*acfac An2 = An2 + UPA(1,I) ! total fractional area of all plumes !print*," plume size=",l,"; area=",UPA(1,I),"; total=",An2 end do - ! get entrainment coefficient - ! get dz/L0 - !ENTf(kts:kte,1:Nup)=0.1 - !ENTi(kts:kte,1:Nup)=0.1 - !ENT(kts:kte,1:Nup)=0.001 - !do i=1,Nup2 - ! do k=kts+1,kte - ! ENTf(k,i)=(ZW(k)-ZW(k-1))/L0 ! input into Poisson - ! ENTf(k,i)=MIN(ENTf(k,i),9.9) !JOE: test avoiding FPE - ! ENTf(k,i)=MAX(ENTf(k,i),0.05) !JOE: test avoiding FPE - ! enddo - !enddo - ! get Poisson P(dz/L0) - !call Poisson(1,Nup2,kts+1,kte,ENTf,ENTi) - ! entrainent: Ent=Ent0/dz*P(dz/L0) - ! set initial conditions for updrafts z0=50. pwmin=0.1 ! was 0.5 - pwmax=0.5 ! was 3.0 + pwmax=0.4 ! was 3.0 wstar=max(1.E-2,(g/thv(1)*fltv*pblh)**(1./3.)) qstar=max(flq,1.0E-5)/wstar @@ -5387,14 +5370,6 @@ SUBROUTINE StEM_mf( & ENDIF #endif -! !DEBUG -! IF (UPA(1,I)<0. .OR. UPA(1,I)>0.5 .OR. wstar<0. .OR. wstar>4.0 .OR. & -! ABS(thstar)> 5. .OR. sigmaW>1.5) THEN -! PRINT*,"IN Mass-Flux: UPA(1,i)=",UPA(1,i) -! PRINT*," wstar=",wstar," qstar=",qstar -! PRINT*," thstar=",thstar," sigmaW=",sigmaW -! ENDIF - ENDDO EntThrottle = 0.001 !MAX(0.02/MAX((flt*1.25*1004.)-25.,5.),0.0002) @@ -5461,9 +5436,9 @@ SUBROUTINE StEM_mf( & ! Compute plume properties thvn and qcn call condensation_edmf(QTn,THLn,Pk,ZW(k+1),THVn,QCn) - ! Define THV at the model interface levels + ! Define environment THV at the model interface levels THVk =(THV(k)*DZ(k+1)+THV(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) - THVkm1=(THV(k)*DZ(k-1)+THV(k-1)*DZ(k))/(DZ(k-1)+DZ(k)) + THVkm1=(THV(k-1)*DZ(k)+THV(k)*DZ(k-1))/(DZ(k-1)+DZ(k)) ! B=g*(0.5*(THVn+UPTHV(k-1,I))/THV(k-1) - 1.0) B=g*(THVn/THVk - 1.0) @@ -5491,6 +5466,10 @@ SUBROUTINE StEM_mf( & IF(Wn > UPW(K-1,I) + MIN(1.25*(ZW(k)-ZW(k-1))/200., 2.0) ) THEN Wn = UPW(K-1,I) + MIN(1.25*(ZW(k)-ZW(k-1))/200., 2.0) ENDIF + !Add symmetrical max decrease in w + IF(Wn < UPW(K-1,I) - MIN(1.25*(ZW(k)-ZW(k-1))/200., 2.0) ) THEN + Wn = UPW(K-1,I) - MIN(1.25*(ZW(k)-ZW(k-1))/200., 2.0) + ENDIF Wn = MIN(MAX(Wn,0.0), 3.0) IF (debug_mf == 1) THEN @@ -5509,7 +5488,7 @@ SUBROUTINE StEM_mf( & IF ( THVk-THVkm1 .GT. 0.0 ) THEN bvf = SQRT( gtr*(THVk-THVkm1)/dz(k) ) !vertical Froude number - Frz = UPW(K-1,I)/(bvf*0.5*dz(k)) + Frz = UPW(K-1,I)/(bvf*dz(k)) IF ( Frz >= 0.5 ) Wn = MIN(Frz,1.0)*UPW(K-1,I) ENDIF ELSEIF (fltv > 0.05 .AND. overshoot == 1) THEN @@ -5524,9 +5503,9 @@ SUBROUTINE StEM_mf( & IF(ZW(k+1) >= MIN(pblh+3000.,4500.))Wn=0. !JOE- minimize the plume penetratration in stratocu-topped PBL - !IF (fltv < 0.06) THEN - ! IF(ZW(k+1) >= pblh-200. .AND. qc(k) > 1e-5 .AND. I > 4) Wn=0. - !ENDIF + ! IF (fltv < 0.06) THEN + ! IF(ZW(k+1) >= pblh-200. .AND. qc(k) > 1e-5 .AND. I > 4) Wn=0. + ! ENDIF IF (Wn > 0.) THEN UPW(K,I)=Wn !Wn !sqrt(Wn2) @@ -5632,11 +5611,7 @@ SUBROUTINE StEM_mf( & ! & -dtz(k)*s_awthl(kts+1) + diss_heat(k)*delt*dheat_opt ! So, s_awthl(kts+1) must be less than flt THVk = (THL(kts)*DZ(kts+1)+THL(kts+1)*DZ(kts))/(DZ(kts+1)+DZ(kts)) - if (s_aw(kts+1).ne.0) then flx1 = MAX(s_aw(kts+1)*(s_awthl(kts+1)/s_aw(kts+1) - THVk),0.0) - else - flx1 = 0.0 - end if !flx1 = -dt/dz(kts)*s_awthl(kts+1) !flx1 = (s_awthl(kts+1)-s_awthl(kts))!/(0.5*(dz(k)+dz(k-1))) adjustment=1.0 @@ -5710,8 +5685,8 @@ SUBROUTINE StEM_mf( & ENDDO !First, compute exner, plume theta, and dz centered at interface - !Here, k=1 is the top of the first model layer. These values do not - !need to be defined at k=kte (unused level). + !Here, k=1 is the top of the first model layer. These values do not + !need to be defined at k=kte (unused level). DO K=KTS,KTE-1 exneri(k) = (exner(k)*DZ(k+1)+exner(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) edmf_th(k)= edmf_thl(k) + xlvcp/exneri(k)*edmf_qc(K) @@ -5720,16 +5695,16 @@ SUBROUTINE StEM_mf( & !JOE: ADD CLDFRA_bl1d, qc_bl1d. Note that they have already been defined in ! mym_condensation. Here, a shallow-cu component is added, but no cumulus -! clouds can be added at k=1 (start loop at k=2). +! clouds can be added at k=1 (start loop at k=2). DO K=KTS+1,KTE-2 IF(k > KTOP) exit IF(0.5*(edmf_qc(k)+edmf_qc(k-1))>0.0)THEN + satvp = 3.80*exp(17.27*(th(k)-273.)/ & (th(k)-36.))/(.01*p(k)) rhgrid = max(.01,MIN( 1., qv(k) /satvp)) !then interpolate plume thl, th, and qt to mass levels - THLp= (edmf_thl(k)*dzi(k-1)+edmf_thl(k-1)*dzi(k))/(dzi(k-1)+dzi(k)) THp = (edmf_th(k)*dzi(k-1)+edmf_th(k-1)*dzi(k))/(dzi(k-1)+dzi(k)) QTp = (edmf_qt(k)*dzi(k-1)+edmf_qt(k-1)*dzi(k))/(dzi(k-1)+dzi(k)) !convert TH to T @@ -5738,8 +5713,8 @@ SUBROUTINE StEM_mf( & esat = esat_blend(t) !SATURATED SPECIFIC HUMIDITY qsl=ep_2*esat/max(1.e-4,(p(k)-ep_3*esat)) - rhplume = max(.01,MIN( 1., QTp /qsl)) + !condensed liquid in the plume on mass levels IF (edmf_qc(k)>0.0 .AND. edmf_qc(k-1)>0.0)THEN QCp = 0.5*(edmf_qc(k)+edmf_qc(k-1)) ELSE @@ -5748,27 +5723,27 @@ SUBROUTINE StEM_mf( & !COMPUTE CLDFRA & QC_BL FROM MASS-FLUX SCHEME and recompute vt & vq - xl = xl_blend(t) ! obtain blended heat capacity - tlk = thlp*(p(k)/p1000mb)**rcp ! recover liquid temp (tl) from thl + xl = xl_blend(tk(k)) ! obtain blended heat capacity + tlk = thl(k)*(p(k)/p1000mb)**rcp ! recover liquid temp (tl) from thl qsat_tl = qsat_blend(tlk,p(k)) ! get saturation water vapor mixing ratio ! at tl and p rsl = xl*qsat_tl / (r_v*tlk**2) ! slope of C-C curve at t = tl ! CB02, Eqn. 4 - cpm = cp + qtp*cpv ! CB02, sec. 2, para. 1 + cpm = cp + qt(k)*cpv ! CB02, sec. 2, para. 1 a = 1./(1. + xl*rsl/cpm) ! CB02 variable "a" b9 = a*rsl ! CB02 variable "b" q2p = xlvcp/exner(k) - pt = THp !thlp +q2p*qcp ! potential temp - bb = b9*t/pt ! bb is "b9" in BCMT95. Their "b9" differs from + pt = thl(k) +q2p*QCp*0.5*(edmf_a(k)+edmf_a(k-1)) ! potential temp (env + plume) + bb = b9*tk(k)/pt ! bb is "b9" in BCMT95. Their "b9" differs from ! "b9" in CB02 by a factor ! of T/theta. Strictly, b9 above is formulated in ! terms of sat. mixing ratio, but bb in BCMT95 is ! cast in terms of sat. specific humidity. The ! conversion is neglected here. - qww = 1.+0.61*QTp + qww = 1.+0.61*qt(k) alpha = 0.61*pt - t = THp*exner(k) + t = TH(k)*exner(k) beta = pt*xl/(t*cp) - 1.61*pt !Buoyancy flux terms have been moved to the end of this section... @@ -5778,18 +5753,18 @@ SUBROUTINE StEM_mf( & else f = 1.0 endif - sigq = 6.E-3 * 0.5*(edmf_a(k)+edmf_a(k+1)) * & - & 0.5*(edmf_w(k)+edmf_w(k+1)) * f ! convective component of sigma (CB2005) - !sigq = MAX(sigq, 1.0E-4) + sigq = 9.E-3 * 0.5*(edmf_a(k)+edmf_a(k-1)) * & + & 0.5*(edmf_w(k)+edmf_w(k-1)) * f ! convective component of sigma (CB2005) + !sigq = MAX(sigq, 1.0E-4) sigq = SQRT(sigq**2 + sgm(k)**2) ! combined conv + stratus components - qmq = a * (QTp - qsat_tl) ! saturation deficit/excess; + qmq = a * (qt(k) - qsat_tl) ! saturation deficit/excess; ! the numerator of Q1 mf_cf = min(max(0.5 + 0.36 * atan(1.55*(qmq/sigq)),0.01),0.6) IF ( debug_code ) THEN print*,"In MYNN, StEM edmf" - print*," CB: env qt=",qt(k)," plume qt=",QTp - print*," qsat=",qsat_tl," satdef=",QTp - qsat_tl + print*," CB: env qt=",qt(k)," qsat=",qsat_tl + print*," satdef=",QTp - qsat_tl print*," CB: sigq=",sigq," qmq=",qmq," tlk=",tlk print*," CB: mf_cf=",mf_cf," cldfra_bl=",cldfra_bl1d(k)," edmf_a=",edmf_a(k) ENDIF @@ -5797,17 +5772,13 @@ SUBROUTINE StEM_mf( & IF (cldfra_bl1d(k) < 0.5) THEN IF (mf_cf > 0.5*(edmf_a(k)+edmf_a(k-1))) THEN cldfra_bl1d(k) = mf_cf - !qc_bl1d(k) = edmf_qc(k)*edmf_a(k)/mf_cf - !qc_bl1d(k) = 0.5*(edmf_qc(k)+edmf_qc(k+1))* & - ! & 0.5*(edmf_a(k)+edmf_a(k+1))/mf_cf - qc_bl1d(k) = QCp*0.5*(edmf_a(k)+edmf_a(k-1))/mf_cf + qc_bl1d(k) = QCp*0.5*(edmf_a(k)+edmf_a(k-1))/mf_cf ELSE - !cldfra_bl1d(k)=edmf_a(k) - !qc_bl1d(k) = edmf_qc(k) cldfra_bl1d(k)=0.5*(edmf_a(k)+edmf_a(k-1)) - qc_bl1d(k) = QCp !0.5*(edmf_qc(k)+edmf_qc(k+1)) + qc_bl1d(k) = QCp ENDIF ENDIF + !Now recalculate the terms for the buoyancy flux for mass-flux clouds: !See mym_condensation for details on these formulations. The !cloud-fraction bounding was added to improve cloud retention, @@ -5815,6 +5786,7 @@ SUBROUTINE StEM_mf( & !Fng = 2.05 ! the non-Gaussian transport factor (assumed constant) !Use Bechtold and Siebesma (1998) piecewise estimation of Fng: Q1 = qmq/MAX(sigq,1E-10) + Q1=MAX(Q1,-5.0) IF (Q1 .GE. 1.0) THEN Fng = 1.0 ELSEIF (Q1 .GE. -1.7 .AND. Q1 < 1.0) THEN @@ -5824,8 +5796,9 @@ SUBROUTINE StEM_mf( & ELSE Fng = MIN(23.9 + EXP(-1.6*(Q1+2.5)), 60.) ENDIF - vt(k) = qww - MIN(0.25,cldfra_bl1D(k))*beta*bb*Fng - 1. - vq(k) = alpha + MIN(0.25,cldfra_bl1D(k))*beta*a*Fng - tv0 + + vt(k) = qww - MIN(0.4,cldfra_bl1D(k))*beta*bb*Fng - 1. + vq(k) = alpha + MIN(0.4,cldfra_bl1D(k))*beta*a*Fng - tv0 ENDIF ENDDO @@ -5880,421 +5853,14 @@ SUBROUTINE StEM_mf( & ENDIF !END Debugging -! initialization of deltas -! DO k=kts,kte -! dth(k)=0. -! dqv(k)=0. -! dqc(k)=0. -! du(k)=0. -! dv(k)=0. -! ENDDO #ifdef HARDCODE_VERTICAL # undef kts # undef kte #endif -END SUBROUTINE StEM_MF +END SUBROUTINE DMP_MF !================================================================= -subroutine Poisson(istart,iend,jstart,jend,mu,POI) - - integer, intent(in) :: istart,iend,jstart,jend - real,dimension(istart:iend,jstart:jend),intent(in) :: MU - integer, dimension(istart:iend,jstart:jend), intent(out) :: POI - integer :: i,j - ! - ! do this only once - ! call init_random_seed - - do i=istart,iend - do j=jstart,jend - call random_Poisson(mu(i,j),.true.,POI(i,j)) - enddo - enddo - -end subroutine Poisson -!================================================================= -subroutine init_random_seed() - !JOE: PGI had problem! use iso_fortran_env, only: int64 - !JOE: PGI had problem! use ifport, only: getpid - implicit none - integer, allocatable :: seed(:) - integer :: i, n, un, istat, dt(8), pid - !JOE: PGI had problem! integer(int64) :: t - integer :: t - - call random_seed(size = n) - allocate(seed(n)) - - ! First try if the OS provides a random number generator - !JOE: PGI had problem! open(newunit=un, file="/dev/urandom", access="stream", & - un=191 - open(unit=un, file="/dev/urandom", access="stream", & - form="unformatted", action="read", status="old", iostat=istat) - - if (istat == 0) then - read(un) seed - close(un) - else - ! Fallback to XOR:ing the current time and pid. The PID is - ! useful in case one launches multiple instances of the same - ! program in parallel. - call system_clock(t) - if (t == 0) then - call date_and_time(values=dt) - !t = (dt(1) - 1970) * 365_int64 * 24 * 60 * 60 * 1000 & - ! + dt(2) * 31_int64 * 24 * 60 * 60 * 1000 & - ! + dt(3) * 24_int64 * 60 * 60 * 1000 & - ! + dt(5) * 60 * 60 * 1000 & - ! + dt(6) * 60 * 1000 + dt(7) * 1000 & - ! + dt(8) - t = dt(6) * 60 & ! only return seconds for smaller t - + dt(7) - end if - - !JOE: PGI had problem!pid = getpid() - ! for distributed memory jobs we need to fix this - !pid=1 - pid = 666 + MOD(t,10) !JOE: doesnt work for PG compilers: getpid() - - t = ieor(t, int(pid, kind(t))) - do i = 1, n - seed(i) = lcg(t) - end do - end if - call random_seed(put=seed) - - contains - - ! Pseudo-random number generator (PRNG) - ! This simple PRNG might not be good enough for real work, but is - ! sufficient for seeding a better PRNG. - function lcg(s) - - integer :: lcg - !JOE: PGI had problem! integer(int64) :: s - integer :: s - - if (s == 0) then - !s = 104729 - s = 1047 - else - !s = mod(s, 4294967296_int64) - s = mod(s, 71) - end if - !s = mod(s * 279470273_int64, 4294967291_int64) - s = mod(s * 23, 17) - !lcg = int(mod(s, int(huge(0), int64)), kind(0)) - lcg = int(mod(s, int(s/3.5))) - - end function lcg - - end subroutine init_random_seed - - -subroutine random_Poisson(mu,first,ival) -!********************************************************************** -! Translated to Fortran 90 by Alan Miller from: RANLIB -! -! Library of Fortran Routines for Random Number Generation -! -! Compiled and Written by: -! -! Barry W. Brown -! James Lovato -! -! Department of Biomathematics, Box 237 -! The University of Texas, M.D. Anderson Cancer Center -! 1515 Holcombe Boulevard -! Houston, TX 77030 -! -! Generates a single random deviate from a Poisson distribution with mean mu. -! Scalar Arguments: - REAL, INTENT(IN) :: mu !The mean of the Poisson distribution from which - !a random deviate is to be generated. - LOGICAL, INTENT(IN) :: first - INTEGER :: ival - -! TABLES: COEFFICIENTS A0-A7 FOR STEP F. FACTORIALS FACT -! COEFFICIENTS A(K) - FOR PX = FK*V*V*SUM(A(K)*V**K)-DEL -! SEPARATION OF CASES A AND B -! -! .. Local Scalars .. -!JOE: since many of these scalars conflict with globally declared closure constants (above), -! need to change XX to XX_s -! REAL :: b1, b2, c, c0, c1, c2, c3, del, difmuk, e, fk, fx, fy, g, & -! omega, px, py, t, u, v, x, xx - REAL :: b1_s, b2_s, c, c0, c1_s, c2_s, c3_s, del, difmuk, e, fk, fx, fy, g_s, & - omega, px, py, t, u, v, x, xx - REAL, SAVE :: s, d, p, q, p0 - INTEGER :: j, k, kflag - LOGICAL, SAVE :: full_init - INTEGER, SAVE :: l, m -! .. -! .. Local Arrays .. - REAL, SAVE :: pp(35) -! .. -! .. Data statements .. -!JOE: since many of these scalars conflict with globally declared closure constants (above), -! need to change XX to XX_s -! REAL, PARAMETER :: a0 = -.5, a1 = .3333333, a2 = -.2500068, a3 = .2000118, & - REAL, PARAMETER :: a0 = -.5, a1_s = .3333333, a2_s = -.2500068, a3 = .2000118, & - a4 = -.1661269, a5 = .1421878, a6 = -0.1384794, & - a7 = .1250060 - - REAL, PARAMETER :: fact(10) = (/ 1., 1., 2., 6., 24., 120., 720., 5040., & - 40320., 362880. /) - -!JOE: difmuk,fk,u errors - undefined - difmuk = 0. - fk = 1.0 - u = 0. - -! .. -! .. Executable Statements .. - IF (mu > 10.0) THEN -! C A S E A. (RECALCULATION OF S, D, L IF MU HAS CHANGED) - - IF (first) THEN - s = SQRT(mu) - d = 6.0*mu*mu - -! THE POISSON PROBABILITIES PK EXCEED THE DISCRETE NORMAL -! PROBABILITIES FK WHENEVER K >= M(MU). L=IFIX(MU-1.1484) -! IS AN UPPER BOUND TO M(MU) FOR ALL MU >= 10 . - - l = mu - 1.1484 - full_init = .false. - END IF - -! STEP N. NORMAL SAMPLE - random_normal() FOR STANDARD NORMAL DEVIATE - g_s = mu + s*random_normal() - IF (g_s > 0.0) THEN - ival = g_s - - ! STEP I. IMMEDIATE ACCEPTANCE IF ival IS LARGE ENOUGH - IF (ival>=l) RETURN - - ! STEP S. SQUEEZE ACCEPTANCE - SAMPLE U - fk = ival - difmuk = mu - fk - CALL RANDOM_NUMBER(u) - IF (d*u >= difmuk*difmuk*difmuk) RETURN - END IF - - ! STEP P. PREPARATIONS FOR STEPS Q AND H. - ! (RECALCULATIONS OF PARAMETERS IF NECESSARY) - ! .3989423=(2*PI)**(-.5) .416667E-1=1./24. .1428571=1./7. - ! THE QUANTITIES B1_S, B2_S, C3_S, C2_S, C1_S, C0 ARE FOR THE HERMITE - ! APPROXIMATIONS TO THE DISCRETE NORMAL PROBABILITIES FK. - ! C=.1069/MU GUARANTEES MAJORIZATION BY THE 'HAT'-FUNCTION. - - IF (.NOT. full_init) THEN - omega = .3989423/s - b1_s = .4166667E-1/mu - b2_s = .3*b1_s*b1_s - c3_s = .1428571*b1_s*b2_s - c2_s = b2_s - 15.*c3_s - c1_s = b1_s - 6.*b2_s + 45.*c3_s - c0 = 1. - b1_s + 3.*b2_s - 15.*c3_s - c = .1069/mu - full_init = .true. - END IF - - IF (g_s < 0.0) GO TO 50 - - ! 'SUBROUTINE' F IS CALLED (KFLAG=0 FOR CORRECT RETURN) - - kflag = 0 - GO TO 70 - - ! STEP Q. QUOTIENT ACCEPTANCE (RARE CASE) - - 40 IF (fy-u*fy <= py*EXP(px-fx)) RETURN - - ! STEP E. EXPONENTIAL SAMPLE - random_exponential() FOR STANDARD EXPONENTIAL - ! DEVIATE E AND SAMPLE T FROM THE LAPLACE 'HAT' - ! (IF T <= -.6744 THEN PK < FK FOR ALL MU >= 10.) - - 50 e = random_exponential() - CALL RANDOM_NUMBER(u) - u = u + u - one - t = 1.8 + SIGN(e, u) - IF (t <= (-.6744)) GO TO 50 - ival = mu + s*t - fk = ival - difmuk = mu - fk - - ! 'SUBROUTINE' F IS CALLED (KFLAG=1 FOR CORRECT RETURN) - - kflag = 1 - GO TO 70 - - ! STEP H. HAT ACCEPTANCE (E IS REPEATED ON REJECTION) - - 60 IF (c*ABS(u) > py*EXP(px+e) - fy*EXP(fx+e)) GO TO 50 - RETURN - - ! STEP F. 'SUBROUTINE' F. CALCULATION OF PX, PY, FX, FY. - ! CASE ival < 10 USES FACTORIALS FROM TABLE FACT - - 70 IF (ival>=10) GO TO 80 - px = -mu -!JOE: had error " Subscript #1 of FACT has value -858993459"; shouldn't be < 1. - !py = mu**ival/fact(ival+1) - py = mu**ival/fact(MAX(ival+1,1)) - GO TO 110 - - ! CASE ival >= 10 USES POLYNOMIAL APPROXIMATION - ! A0-A7 FOR ACCURACY WHEN ADVISABLE - ! .8333333E-1=1./12. .3989423=(2*PI)**(-.5) - - 80 del = .8333333E-1/fk - del = del - 4.8*del*del*del - v = difmuk/fk - IF (ABS(v)>0.25) THEN - px = fk*LOG(one + v) - difmuk - del - ELSE - px = fk*v*v* (((((((a7*v+a6)*v+a5)*v+a4)*v+a3)*v+a2_s)*v+a1_s)*v+a0) - del - END IF - py = .3989423/SQRT(fk) - 110 x = (half - difmuk)/s - xx = x*x - fx = -half*xx - fy = omega* (((c3_s*xx + c2_s)*xx + c1_s)*xx + c0) - IF (kflag <= 0) GO TO 40 - GO TO 60 - - !--------------------------------------------------------------------------- - ! C A S E B. mu < 10 - ! START NEW TABLE AND CALCULATE P0 IF NECESSARY - ELSE - - IF (first) THEN - m = MAX(1, INT(mu)) - l = 0 - !print*,"mu=",mu - !print*," mu=",mu," p=",EXP(-mu) - p = EXP(-mu) - q = p - p0 = p - END IF - - ! STEP U. UNIFORM SAMPLE FOR INVERSION METHOD - - DO - CALL RANDOM_NUMBER(u) - ival = 0 - IF (u <= p0) RETURN - - ! STEP T. TABLE COMPARISON UNTIL THE END PP(L) OF THE - ! PP-TABLE OF CUMULATIVE POISSON PROBABILITIES - ! (0.458=PP(9) FOR MU=10) - - IF (l == 0) GO TO 150 - j = 1 - IF (u > 0.458) j = MIN(l, m) - DO k = j, l - IF (u <= pp(k)) GO TO 180 - END DO - IF (l == 35) CYCLE - - ! STEP C. CREATION OF NEW POISSON PROBABILITIES P - ! AND THEIR CUMULATIVES Q=PP(K) - - 150 l = l + 1 - DO k = l, 35 - p = p*mu / k - q = q + p - pp(k) = q - IF (u <= q) GO TO 170 - END DO - l = 35 - END DO - - 170 l = k - 180 ival = k - RETURN - END IF - - RETURN - END subroutine random_Poisson - -!================================================================== - - FUNCTION random_normal() RESULT(fn_val) - - ! Adapted from the following Fortran 77 code - ! ALGORITHM 712, COLLECTED ALGORITHMS FROM ACM. - ! THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE, - ! VOL. 18, NO. 4, DECEMBER, 1992, PP. 434-435. - - ! The function random_normal() returns a normally distributed pseudo-random - ! number with zero mean and unit variance. - - ! The algorithm uses the ratio of uniforms method of A.J. Kinderman - ! and J.F. Monahan augmented with quadratic bounding curves. - - REAL :: fn_val - - ! Local variables - REAL :: s = 0.449871, t = -0.386595, a = 0.19600, b = 0.25472, & - r1 = 0.27597, r2 = 0.27846, u, v, x, y, q - - ! Generate P = (u,v) uniform in rectangle enclosing acceptance region - - DO - CALL RANDOM_NUMBER(u) - CALL RANDOM_NUMBER(v) - v = 1.7156 * (v - half) - - ! Evaluate the quadratic form - x = u - s - y = ABS(v) - t - q = x**2 + y*(a*y - b*x) - - ! Accept P if inside inner ellipse - IF (q < r1) EXIT - ! Reject P if outside outer ellipse - IF (q > r2) CYCLE - ! Reject P if outside acceptance region - IF (v**2 < -4.0*LOG(u)*u**2) EXIT - END DO - - ! Return ratio of P coordinates as the normal deviate - fn_val = v/u - RETURN - - END FUNCTION random_normal - -!=============================================================== - - FUNCTION random_exponential() RESULT(fn_val) - - ! Adapted from Fortran 77 code from the book: - ! Dagpunar, J. 'Principles of random variate generation' - ! Clarendon Press, Oxford, 1988. ISBN 0-19-852202-9 - - ! FUNCTION GENERATES A RANDOM VARIATE IN [0,INFINITY) FROM - ! A NEGATIVE EXPONENTIAL DlSTRIBUTION WlTH DENSITY PROPORTIONAL - ! TO EXP(-random_exponential), USING INVERSION. - - REAL :: fn_val - - ! Local variable - REAL :: r - - DO - CALL RANDOM_NUMBER(r) - IF (r > zero) EXIT - END DO - - fn_val = -LOG(r) - RETURN - - END FUNCTION random_exponential - -!=============================================================== subroutine condensation_edmf(QT,THL,P,zagl,THV,QC) ! @@ -6314,10 +5880,9 @@ subroutine condensation_edmf(QT,THL,P,zagl,THV,QC) ! cp ! rvord .. rv/rd (1.6) - ! number of iterations niter=50 -! minimum difference +! minimum difference (usually converges in < 8 iterations with diff = 2e-5) diff=2.e-5 EXN=(P/p1000mb)**rcp @@ -6339,6 +5904,13 @@ subroutine condensation_edmf(QT,THL,P,zagl,THV,QC) !THV=(THL+xlv/cp*QC).*(1+(1-rvovrd)*(QT-QC)-QC); THV=(THL+xlv/cp*QC)*(1.+QT*(rvovrd-1.)-rvovrd*QC) + +! IF (QC > 0.0) THEN +! PRINT*,"EDMF SAT, p:",p," iterations:",i +! PRINT*," T=",T," THL=",THL," THV=",THV +! PRINT*," QS=",QS," QT=",QT," QC=",QC,"ratio=",qc/qs +! ENDIF + !THIS BASICALLY GIVE THE SAME RESULT AS THE PREVIOUS LINE !TH = THL + xlv/cp/EXN*QC !THV= TH*(1. + 0.608*QT) @@ -6523,828 +6095,6 @@ END FUNCTION xl_blend ! =================================================================== ! =================================================================== -! This is the mass flux part of the TEMF scheme from module_bl_temf.F, -! adapted for the MYNN context by Wayne Angevine June 2015. -! Variable strategy: TEMF external variables that have semantically -! comfortable counterparts in the MYNN-EDMF context have been changed to -! use those names. Otherwise the TEMF variable names have been kept but -! redefined as local variables. Only "moist" vars are used, whether -! updraft condenses or not. Some former local vars are replaced with -! externals. -! -! (Partial) list of conversions: -! wupd_temfx -> moist_w -! thup_temfx -> moist_thl -! qtup_temfx -> moist_qt -! qlup_temfx -> moist_qc -! cf3d_temfx -> cldfra_bl1d -! au -> moist_a - - SUBROUTINE temf_mf( & - & kts,kte,dt,zw,p,pi1d, & - & u,v,w,th,thl,thv,qt,qv,qc,& - & qke,ust,flt,flq,flqv,flqc,& - & hfx,qfx,tsk, & - & pblh,rho,dfh,dx,znt,ep_2, & - ! outputs - updraft properties - & edmf_a,edmf_w,edmf_qt, & - & edmf_thl,edmf_ent,edmf_qc,& - ! outputs - variables needed for solver - & s_aw,s_awthl,s_awqt, & - & s_awqv,s_awqc, & - & s_awu,s_awv,s_awqke, & -#if (WRF_CHEM == 1) - & nchem,chem,s_awchem, & -#endif - ! in/outputs - subgrid scale clouds - & qc_bl1d,cldfra_bl1d, & - ! inputs - flags for moist arrays - &F_QC,F_QI,psig, & - &spp_pbl,rstoch_col, & - &ii,jj,ids,ide,jds,jde) - - - ! inputs: - INTEGER, INTENT(IN) :: kts,kte,ii,jj,ids,ide,jds,jde - REAL,DIMENSION(kts:kte), INTENT(IN) :: u,v,w,th,thl,qt,qv,qc,thv,p,pi1d - REAL,DIMENSION(kts:kte), INTENT(IN) :: qke - REAL,DIMENSION(kts:kte+1), INTENT(IN) :: zw !height at full-sigma - REAL,DIMENSION(kts:kte), INTENT(IN) :: rho !density - REAL,DIMENSION(kts:kte), INTENT(IN) :: dfh !diffusivity for heat - REAL, INTENT(IN) :: dt,ust,flt,flq,flqv,flqc,hfx,qfx,tsk,pblh,dx,znt,ep_2,psig - LOGICAL, OPTIONAL :: f_qc,f_qi - - ! outputs - updraft properties - REAL,DIMENSION(kts:kte), INTENT(OUT) :: & - & edmf_a,edmf_w,edmf_qt, & - & edmf_thl,edmf_ent,edmf_qc - - ! outputs - variables needed for solver - REAL,DIMENSION(kts:kte+1) :: s_aw, & !sum ai*wis_awphi - s_awthl, & !sum ai*wi*phii - s_awqt, & - s_awqv, & - s_awqc, & - s_awu, & - s_awv, & - s_awqke -#if (WRF_CHEM == 1) - INTEGER, INTENT(IN) :: nchem - REAL,DIMENSION(kts:kte+1, nchem) :: chem - REAL,DIMENSION(kts:kte+1, nchem) :: s_awchem - INTEGER :: ic -#endif - - REAL,DIMENSION(kts:kte), INTENT(INOUT) :: qc_bl1d,cldfra_bl1d - -! Local variables -! -! EDMF constants - real, parameter :: CM = 0.03 ! Proportionality constant for subcloud MF - real, parameter :: Cdelt = 0.006 ! Prefactor for detrainment rate - real, parameter :: Cw = 0.5 ! Prefactor for surface wUPD - real, parameter :: Cc = 3.0 ! Prefactor for convective length scale - real, parameter :: lasymp = 200.0 ! Asymptotic length scale WA 11/20/09 - real, parameter :: hmax = 4000.0 ! Max hd,hct WA 11/20/09 - integer, parameter :: Nupd = 8 ! Number of updrafts -! - integer :: i, k, kt, nu ! Loop variable - integer:: h0idx - real:: h0 - real:: wstr, ang, wm - real, dimension( Nupd) :: hd,lcl,hct,ht - real:: convection_TKE_surface_src, sfcFTE - real:: sfcTHVF - real:: z0t - integer, dimension( Nupd) :: hdidx,lclidx,hctidx,htidx - integer:: hmax_idx - integer:: tval - real, dimension( kts:kte) :: zm, zt, dzm, dzt - real, dimension( kts:kte) :: thetal, qtot - real, dimension( kts:kte) :: u_temf, v_temf - real, dimension( kts:kte) :: rv, rl, rt - real, dimension( kts:kte) :: chi_poisson, gam - real, dimension( kts:kte) :: dthdz - real, dimension( kts:kte) :: lepsmin - real, dimension( kts:kte) :: thetav - real, dimension( kts:kte) :: dmoist_qtdz - real, dimension( kts:kte) :: B, Bmoist - real, dimension( kts:kte, Nupd) :: epsmf, deltmf, dMdz - real, dimension( kts:kte, Nupd) :: UUPD, VUPD - real, dimension( kts:kte, Nupd) :: thetavUPD, qlUPD, TEUPD - real, dimension( kts:kte, Nupd) :: thetavUPDmoist, wUPD_dry - real, dimension( kts:kte, Nupd) :: dthUPDdz, dwUPDdz - real, dimension( kts:kte, Nupd) :: dwUPDmoistdz - real, dimension( kts:kte, Nupd) :: dUUPDdz, dVUPDdz, dTEUPDdz - real, dimension( kts:kte, Nupd) :: TUPD, rstUPD, rUPD, rlUPD, qstUPD - real, dimension( kts:kte, Nupd) :: MUPD, wUPD, qtUPD, thlUPD, qcUPD - real, dimension( kts:kte, Nupd) :: aUPD, cldfraUPD, aUPDt - real, dimension( kts:kte) :: N2, S, Ri, beta, ftau, fth, ratio - real, dimension( kts:kte) :: TKE, TE2 - real, dimension( kts:kte) :: ustrtilde, linv, leps - real, dimension( kts:kte) :: km, kh - real, dimension( kts:kte) :: Fz, QFK, uwk, vwk - real, dimension( kts:kte) :: km_conv, kh_conv, lconv - real, dimension( kts:kte) :: alpha2, beta2 ! For thetav flux calculation - real, dimension( kts:kte) :: THVF, buoy_src, srcs - real, dimension( kts:kte) :: beta1 ! For saturation humidity calculations - real, dimension( kts:kte) :: MFCth - real Cepsmf ! Prefactor for entrainment rate - real red_fact ! for reducing MF components - real, dimension( kts:kte) :: edmf_u, edmf_v, edmf_qke ! Same format as registry vars, but not passed out - integer:: bdy_dist,taper_dist - real:: taper - - ! Stochastic - INTEGER, INTENT(IN) :: spp_pbl - REAL, DIMENSION(kts:kte), INTENT(in) :: rstoch_col - -#if (WRF_CHEM == 1) - real,dimension( kts:kte+1, nchem, Nupd) :: chemUPD, dchemUPDdz - real,dimension( kts:kte+1, nchem) :: edmf_chem -#endif - - ! Used to be TEMF external variables, now local - real, dimension( kts:kte, Nupd) :: & - shf_temfx, qf_temfx, uw_temfx, vw_temfx , & - mf_temfx - real, dimension( Nupd) :: hd_temfx, lcl_temfx, hct_temfx, cfm_temfx - logical is_convective - ! Vars for cloud fraction calculation - real, dimension( kts:kte) :: sigq, qst, satdef - real :: sigq2, rst, cldfra_sum, psig_w, maxw - -!---------------------------------------------------------------------- -! Grid staggering: Matlab version has mass and turbulence levels. -! WRF has full levels (with w) and half levels (u,v,theta,q*). Both -! sets of levels use the same indices (kts:kte). See pbl_driver or -! WRF Physics doc for (a few) details. -! So *mass levels correspond to half levels.* -! WRF full levels are ignored, we define our own turbulence levels -! in order to put the first one below the first half level. -! Another difference is that -! the Matlab version (and the Mauritsen et al. paper) consider the -! first mass level to be at z0 (effectively the surface). WRF considers -! the first half level to be above the effective surface. The first half -! level, at k=1, has nonzero values of u,v for example. Here we convert -! all incoming variables to internal ones with the correct indexing -! in order to make the code consistent with the Matlab version. We -! already had to do this for thetal and qt anyway, so the only additional -! overhead is for u and v. -! I use suffixes m for mass and t for turbulence as in Matlab for things -! like indices. -! Note that zsrf is the terrain height ASL, from Registry variable ht. -! Translations (Matlab to WRF): -! dzt -> calculated below -! dzm -> not supplied, calculated below -! k -> karman -! z0 -> znt -! z0t -> not in WRF, calculated below -! zt -> calculated below -! zm -> zw but NOTE zm(1) is now z0 (znt) and zm(2) is zw(1) -! -! Other notes: -! - I have often used 1 instead of kts below, because the scheme demands -! to know where the surface is. It won't work if kts .NE. 1. - - IF ( debug_code ) THEN - print*,' MYNN; in TEMF_MF, beginning' - ENDIF - - !JOE-initialize s_aw* variables - s_aw = 0. - s_awthl= 0. - s_awqt = 0. - s_awqv = 0. - s_awqc = 0. - s_awu = 0. - s_awv = 0. - s_awqke= 0. - edmf_a = 0. - edmf_w = 0. - edmf_qt= 0. !qt - edmf_thl=0. !thl - edmf_ent=0. - edmf_qc= 0. !qc - edmf_u=0. - edmf_v=0. - edmf_qke=0. - - z0t = znt - - do k = kts,kte - rv(k) = qv(k) / (1.-qv(k)) ! Water vapor - rl(k) = qc(k) / (1.-qc(k)) ! Liquid water - rt(k) = qt(k) ! Total water (without ice) - thetal(k) = thl(k) - qtot(k) = qt(k) - thetav(k) = thv(k) - end do - - do k = kts,kte - u_temf(k) = u(k) - v_temf(k) = v(k) - end do - - !taper off MF scheme when significant resolved-scale motions are present - !This function needs to be asymetric... - k = 1 - maxw = 0.0 - DO WHILE (ZW(k) < pblh + 500.) - maxw = MAX(maxw,ABS(W(k))) - k = k+1 - ENDDO - maxw = MAX(0.,maxw - 0.5) ! do nothing for small w, but - Psig_w = MAX(0.0, 1.0 - maxw/0.5) ! linearly taper off for w > 0.5 m/s - Psig_w = MIN(Psig_w, Psig) - !print*," maxw=", maxw," Psig_w=",Psig_w," Psig_shcu=",Psig_shcu - - ! Get delta height at half (mass) levels - zm(1) = znt - dzt(1) = zw(2) - zm(1) - ! Get height and delta at turbulence levels - zt(1) = (zw(2) - znt) / 2. - do kt = kts+1,kte - zm(kt) = zw(kt) ! Convert indexing from WRF to TEMF - zt(kt) = (zm(kt) + zw(kt+1)) / 2. - dzm(kt) = zt(kt) - zt(kt-1) - dzt(kt) = zw(kt+1) - zw(kt) - end do - dzm(1) = dzm(2) - - !print *,"In TEMF_MF zw = ", zw - !print *,"zm = ", zm - !print *,"zt = ", zt - !print *,"dzm = ", dzm - !print *,"dzt = ", dzt - - ! Gradients at first level - dthdz(1) = (thetal(2)-thetal(1)) / (zt(1) * log10(zm(2)/z0t)) - - !print *,"In TEMF_MF dthdz(1),thetal(2,1),tsk,zt(1),zm(2),z0t = ", & - ! dthdz(1),thetal(2),thetal(1),tsk,zt(1),zm(2),z0t - - ! Surface thetaV flux from Stull p.147 - sfcTHVF = hfx/(rho(1)*cp) * (1.+0.608*(qv(1)+qc(1))) + 0.608*thetav(1)*qfx - - ! WA use hd_temf to calculate w* instead of finding h0 here???? - ! Watch initialization! - h0idx = 1 - h0 = zm(1) - - lepsmin(kts) = 0. - - ! WA 2/11/13 find index just above hmax for use below - hmax_idx = kte-1 - - do k = kts+1,kte-1 - lepsmin(k) = 0. - - ! Mean gradients - dthdz(k) = (thetal(k+1) - thetal(k)) / dzt(k) - - ! Find h0 (should eventually be interpolated for smoothness) - if (thetav(k) > thetav(1) .AND. h0idx .EQ. 1) then - ! WA 9/28/11 limit h0 as for hd and hct - if (zm(k) < hmax) then - h0idx = k - h0 = zm(k) - else - h0idx = k - h0 = hmax - end if - end if - ! WA 2/11/13 find index just above hmax for use below - if (zm(k) > hmax) then - hmax_idx = min(hmax_idx,k) - end if - end do - - ! Gradients at top level - - dthdz(kte) = dthdz(kte-1) - - if ( hfx > 0.) then - wstr = (g * h0 / thetav(2) * hfx/(rho(1)*cp) ) ** (1./3.) - bdy_dist = min( min((ii-ids),(ide-ii)) , min((jj-jds),(jde-jj)) ) - taper_dist = 5 - ! JSK - linearly taper w-star near lateral boundaries (within 5 grid columns) - if (bdy_dist .LE. taper_dist) then - taper = max(0., min( 1., real(bdy_dist) / real(taper_dist) ) ) - wstr = wstr * taper - end if - else - wstr = 0. - end if - - !print *,"In TEMF_MF wstr,hfx,dthdz(1:2),h0 = ", wstr,hfx,dthdz(1),dthdz(2),h0 - IF ( debug_code ) THEN - print*,' MYNN; in TEMF_MF: wstr,hfx,dtdz1,dtdz2,h0:', wstr,hfx,dthdz(1),dthdz(2),h0 - ENDIF - - ! Set flag convective or not for use below - is_convective = wstr > 0. .AND. dthdz(1)<0. .AND. dthdz(2)<0. - ! WA 12/16/09 require two levels of negative (unstable) gradient - - !*** Mass flux block starts here *** - ! WA WFIP 11/13/15 allow multiple updrafts, deterministic for now - - if ( is_convective) then - - IF ( debug_code ) THEN - print *,"In TEMF_MF is_convective, wstr = ", wstr - ENDIF - - !Cepsmf = 2. / max(200.,h0) - Cepsmf = 1.0 / max(200.,h0) ! WA TEST reduce entrainment - ! Cepsmf = max(Cepsmf,0.002) - ! Cepsmf = max(Cepsmf,0.0015) ! WA TEST reduce max entrainment - ! Cepsmf = max(Cepsmf,0.0005) ! WA TEST reduce min entrainment - Cepsmf = max(Cepsmf,0.0010) ! WA TEST reduce min entrainment - - do nu = 1,Nupd - do k = kts,kte - ! Calculate lateral entrainment fraction for subcloud layer - ! epsilon and delta are defined on mass grid (half levels) - ! epsmf(k,nu) = Cepsmf * (1+0.2*(floor(nu - Nupd/2.))) ! WA for three updrafts - ! epsmf(k,nu) = Cepsmf * (1+0.05*(floor(nu - Nupd/2.))) ! WA for ten updrafts - ! epsmf(k,nu) = Cepsmf * (1+0.0625*(floor(nu - Nupd/2.))) ! WA for eight updrafts - ! epsmf(k,nu) = Cepsmf * (1+0.03*(floor(nu - Nupd/2.))) ! WA for eight updrafts, less spread - epsmf(k,nu) = Cepsmf * (1+0.25*(nu-1)) ! WA for eight updrafts, much more eps for some plumes, per Neggers 2015 fig. 15 - end do - - !IF ( debug_code ) THEN - print*,' MYNN; in TEMF_MF, Cepsmf, epsmf(1:13,nu)=', Cepsmf - print*," epsmf(1:13,nu)=",epsmf(1:13,nu) - !ENDIF - - ! Initialize updraft - thlUPD(1,nu) = thetal(1) + Cw*wstr - qtUPD(1,nu) = qtot(1) + 0.0*qfx/wstr - rUPD(1,nu) = qtUPD(1,nu) / (1. - qtUPD(1,nu)) - wUPD(1,nu) = Cw * wstr - wUPD_dry(1,nu) = Cw * wstr - UUPD(1,nu) = u_temf(1) - VUPD(1,nu) = v_temf(1) - thetavUPD(1,nu) = thlUPD(1,nu) * (1. + 0.608*qtUPD(1,nu)) ! WA Assumes no liquid - thetavUPDmoist(1,nu) = thetavUPD(1,nu) - TEUPD(1,nu) = qke(1) + g / thetav(1) * sfcTHVF - qlUPD(1,nu) = qc(1) ! WA allow environment liquid - TUPD(1,nu) = thlUPD(1,nu) * pi1d(1) - !rstUPD(1,nu) = rsat_temf(p(1),TUPD(1,nu),ep_2) - rstUPD(1,nu) = qsat_blend(TUPD(1,nu),p(1)) ! get saturation water vapor mixing ratio at tl and p - rlUPD(1,nu) = 0. -#if (WRF_CHEM == 1) - IF (bl_mynn_mixchem == 1) THEN - do ic = 1,nchem - chemUPD(1,ic,nu) = chem(1,ic) - enddo - ENDIF -#endif - - ! Calculate updraft parameters counting up - do k = 2,kte - ! WA 2/11/13 use hmax index to prevent oddness high up - if ( k < hmax_idx) then - dthUPDdz(k-1,nu) = -epsmf(k,nu) * (thlUPD(k-1,nu) - thetal(k-1)) - thlUPD(k,nu) = thlUPD(k-1,nu) + dthUPDdz(k-1,nu) * dzm(k-1) - dmoist_qtdz(k-1) = -epsmf(k,nu) * (qtUPD(k-1,nu) - qtot(k-1)) - qtUPD(k,nu) = qtUPD(k-1,nu) + dmoist_qtdz(k-1) * dzm(k-1) - thetavUPD(k,nu) = thlUPD(k,nu) * (1. + 0.608*qtUPD(k,nu)) ! WA Assumes no liquid - B(k-1) = g * (thetavUPD(k,nu) - thetav(k)) / thetav(k) - if ( wUPD_dry(k-1,nu) < 1e-15 ) then - wUPD_dry(k,nu) = 0. - else - dwUPDdz(k-1,nu) = -2. *epsmf(k,nu)*wUPD_dry(k-1,nu) + 0.33*B(k-1)/wUPD_dry(k-1,nu) - wUPD_dry(k,nu) = wUPD_dry(k-1,nu) + dwUPDdz(k-1,nu) * dzm(k-1) - end if - dUUPDdz(k-1,nu) = -epsmf(k,nu) * (UUPD(k-1,nu) - u_temf(k-1)) - UUPD(k,nu) = UUPD(k-1,nu) + dUUPDdz(k-1,nu) * dzm(k-1) - dVUPDdz(k-1,nu) = -epsmf(k,nu) * (VUPD(k-1,nu) - v_temf(k-1)) - VUPD(k,nu) = VUPD(k-1,nu) + dVUPDdz(k-1,nu) * dzm(k-1) - dTEUPDdz(k-1,nu) = -epsmf(k,nu) * (TEUPD(k-1,nu) - qke(k-1)) - TEUPD(k,nu) = TEUPD(k-1,nu) + dTEUPDdz(k-1,nu) * dzm(k-1) - ! Alternative updraft velocity based on moist thetav - ! Need thetavUPDmoist, qlUPD - rUPD(k,nu) = qtUPD(k,nu) / (1. - qtUPD(k,nu)) - ! WA Updraft temperature assuming no liquid - TUPD(k,nu) = thlUPD(k,nu) * pi1d(k) - ! Updraft saturation mixing ratio - !rstUPD(k,nu) = rsat_temf(p(k-1),TUPD(k,nu),ep_2) - rstUPD(k,nu) = qsat_blend(TUPD(k,nu),p(k-1)) - ! Correct to actual temperature (Sommeria & Deardorff 1977) - beta1(k) = 0.622 * (xlv/(r_d*TUPD(k,nu))) * (xlv/(cp*TUPD(k,nu))) - rstUPD(k,nu) = rstUPD(k,nu) * (1.0+beta1(k)*rUPD(k,nu)) / (1.0+beta1(k)*rstUPD(k,nu)) - qstUPD(k,nu) = rstUPD(k,nu) / (1. + rstUPD(k,nu)) - if (rUPD(k,nu) > rstUPD(k,nu)) then - rlUPD(k,nu) = rUPD(k,nu) - rstUPD(k,nu) - qlUPD(k,nu) = rlUPD(k,nu) / (1. + rlUPD(k,nu)) - thetavUPDmoist(k,nu) = (thlUPD(k,nu) + ((xlv/cp)*qlUPD(k,nu)/pi1d(k))) * & - (1. + 0.608*qstUPD(k,nu) - qlUPD(k,nu)) - else - rlUPD(k,nu) = 0. - qlUPD(k,nu) = qc(k-1) ! WA 4/6/10 allow environment liquid - thetavUPDmoist(k,nu) = thlUPD(k,nu) * (1. + 0.608*qtUPD(k,nu)) - end if - Bmoist(k-1) = g * (thetavUPDmoist(k,nu) - thetav(k)) / thetav(k) - if ( wUPD(k-1,nu) < 1e-15 ) then - wUPD(k,nu) = 0. - else - dwUPDmoistdz(k-1,nu) = -2. *epsmf(k,nu)*wUPD(k-1,nu) + 0.33*Bmoist(k-1)/wUPD(k-1,nu) - wUPD(k,nu) = wUPD(k-1,nu) + dwUPDmoistdz(k-1,nu) * dzm(k-1) - end if -#if (WRF_CHEM == 1) - IF (bl_mynn_mixchem == 1) THEN - do ic = 1,nchem - dchemUPDdz(k-1,ic,nu) = -epsmf(k,nu) * (chemUPD(k-1,ic,nu) - chem(k-1,ic)) - chemUPD(k,ic,nu) = chemUPD(k-1,ic,nu) + dchemUPDdz(k-1,ic,nu) * dzm(k-1) - enddo - ENDIF -#endif - else ! above hmax - thlUPD(k,nu) = thetal(k) - qtUPD(k,nu) = qtot(k) - wUPD_dry(k,nu) = 0. - UUPD(k,nu) = u_temf(k) - VUPD(k,nu) = v_temf(k) - TEUPD(k,nu) = qke(k) - qlUPD(k,nu) = qc(k-1) - wUPD(k,nu) = 0. -#if (WRF_CHEM == 1) - IF (bl_mynn_mixchem == 1) THEN - do ic = 1,nchem - chemUPD(k,ic,nu) = chem(k-1,ic) - enddo - ENDIF -#endif - end if - - IF ( debug_code ) THEN - IF ( ABS(wUPD(k,nu))>10. ) THEN - print*,' MYNN, in TEMF_MF, huge w at (nu,k):', nu,k - print *," thlUPD(1:k,nu) = ", thlUPD(1:k,nu) - print *," wUPD(1:k,nu) = ", wUPD(1:k,nu) - print *," Bmoist(1:k-1) = ", Bmoist(1:k-1) - print *," epsmf(1:k,nu) = ", epsmf(1:k,nu) - ENDIF - ENDIF - - ENDDO !end-k - - ! Find hd based on wUPD - if (wUPD_dry(1,nu) == 0.) then - hdidx(nu) = 1 - else - hdidx(nu) = kte ! In case wUPD <= 0 not found - do k = 2,kte - if (wUPD_dry(k,nu) <= 0. .OR. zm(k) > hmax) then - hdidx(nu) = k - ! goto 100 ! FORTRAN made me do it! - exit - end if - end do - end if - 100 hd(nu) = zm(hdidx(nu)) - - ! Find LCL, hct, and ht - lclidx(nu) = kte ! In case LCL not found - do k = kts,kte - if ( k < hmax_idx .AND. rUPD(k,nu) > rstUPD(k,nu)) then - lclidx(nu) = k - ! goto 200 - exit - end if - end do - 200 lcl(nu) = zm(lclidx(nu)) - - if (hd(nu) > lcl(nu)) then ! Forced cloud (at least) occurs - ! Find hct based on wUPDmoist - if (wUPD(1,nu) == 0.) then - hctidx(nu) = 1 - else - hctidx(nu) = kte ! In case wUPD <= 0 not found - do k = 2,kte - if (wUPD(k,nu) <= 0. .OR. zm(k) > hmax) then - hctidx(nu) = k - ! goto 300 ! FORTRAN made me do it! - exit - end if - end do - end if - 300 hct(nu) = zm(hctidx(nu)) - if (hctidx(nu) <= hdidx(nu)+1) then ! No active cloud - hct(nu) = hd(nu) - hctidx(nu) = hdidx(nu) - else - end if - else ! No cloud - hct(nu) = hd(nu) - hctidx(nu) = hdidx(nu) - end if - ht(nu) = max(hd(nu),hct(nu)) - htidx(nu) = max(hdidx(nu),hctidx(nu)) - - ! Now truncate updraft at ht with taper - do k = 1,kte - if (zm(k) < 0.9*ht(nu)) then ! Below taper region - tval = 1 - else if (zm(k) >= 0.9*ht(nu) .AND. zm(k) <= 1.0*ht(nu)) then - ! Within taper region - tval = 1. - ((zm(k) - 0.9*ht(nu)) / (1.0*ht(nu) - 0.9*ht(nu))) - else ! Above taper region - tval = 0. - end if - thlUPD(k,nu) = tval * thlUPD(k,nu) + (1-tval)*thetal(k) - thetavUPD(k,nu) = tval * thetavUPD(k,nu) + (1-tval)*thetav(k) - qtUPD(k,nu) = tval * qtUPD(k,nu) + (1-tval) * qtot(k) - if (k > 1) then - qlUPD(k,nu) = tval * qlUPD(k,nu) + (1-tval) * qc(k-1) - end if - UUPD(k,nu) = tval * UUPD(k,nu) + (1-tval) * u_temf(k) - VUPD(k,nu) = tval * VUPD(k,nu) + (1-tval) * v_temf(k) - TEUPD(k,nu) = tval * TEUPD(k,nu) + (1-tval) * qke(k) - if (zm(k) > ht(nu)) then ! WA this is just for cleanliness - wUPD(k,nu) = 0. - dwUPDmoistdz(k,nu) = 0. - wUPD_dry(k,nu) = 0. - dwUPDdz(k,nu) = 0. - end if -#if (WRF_CHEM == 1) - IF (bl_mynn_mixchem == 1) THEN - do ic = 1,nchem - chemUPD(k,ic,nu) = tval * chemUPD(k,ic,nu) + (1-tval) * chem(k,ic) - enddo - ENDIF -#endif - end do - - ! Calculate lateral detrainment rate for cloud layer - ! WA 8/5/15 constant detrainment - ! deltmf(1,nu) = Cepsmf - ! do k = 2,kte-1 - ! deltmf(k,nu) = deltmf(k-1,nu) - ! end do - ! deltmf(kte,nu) = Cepsmf - deltmf(:,nu) = epsmf(:,nu) ! WA TEST delt = eps everywhere - - ! Calculate mass flux (defined on turbulence levels) - mf_temfx(1,nu) = CM * wstr / Nupd - ! WA 3/2/16 limit max MF for stability - ! WA reduce the constant for improved numerical stability? - mf_temfx(1,nu) = min(mf_temfx(1,nu),0.2/Nupd) - do kt = 2,kte-1 - dMdz(kt,nu) = (epsmf(kt,nu) - deltmf(kt,nu)) * mf_temfx(kt-1,nu) * dzt(kt) - mf_temfx(kt,nu) = mf_temfx(kt-1,nu) + dMdz(kt,nu) - ! WA TEST 6/14/16 don't allow <0 - mf_temfx(kt,nu) = max(mf_temfx(kt,nu),0.0) - IF ( debug_code ) THEN - IF ( mf_temfx(kt,nu)>=0.2/NUPD ) THEN - print*,' MYNN, in TEMF_MF, huge MF at (nu,k):', nu,kt - print*," mf_temfx(1:kt,nu) = ", mf_temfx(1:kt,nu) - ENDIF - ENDIF - end do - mf_temfx(kte,nu) = 0. - - ! Calculate cloud fraction (on mass levels) - ! WA eventually replace this with the same saturation calculation - ! used in the MYNN code above for consistency. - ! WA TEST 6/14/16 make sure aUPD(1) is reasonable - aUPD(1,nu) = 0.06 / Nupd - do k = 2,kte - ! WA TEST 6/14/16 increase epsilon in test - ! if (wUPD(k-1,nu) >= 1.0e-15 .AND. wUPD(k,nu) >= 1.0e-15) then - if (wUPD(k-1,nu) >= 1.0e-5 .AND. wUPD(k,nu) >= 1.0e-5) then - aUPD(k,nu) = ((mf_temfx(k-1,nu)+mf_temfx(k,nu))/2.0) / & - ((wUPD(k-1,nu)+wUPD(k,nu))/2.0) ! WA average before divide, is that best? - else - aUPD(k,nu) = 0.0 - end if - sigq2 = aUPD(k,nu) * (qtUPD(k,nu)-qtot(k)) - if (sigq2 > 0.0) then - sigq(k) = sqrt(sigq2) - else - sigq(k) = 0.0 - end if - !rst = rsat_temf(p(k-1),th(k-1)*pi1d(k-1),ep_2) - rst = qsat_blend(th(k-1)*pi1d(k-1),p(k-1)) - qst(k) = rst / (1. + rst) - satdef(k) = qtot(k) - qst(k) - if (satdef(k) <= 0.0) then - if (sigq(k) > 1.0e-15) then - cldfraUPD(k,nu) = max(0.5 + 0.36 * atan(1.55*(satdef(k)/sigq(k))),0.0) / Nupd - else - cldfraUPD(k,nu) = 0.0 - end if - else - cldfraUPD(k,nu) = 1.0 / Nupd - end if - if (zm(k) < lcl(nu)) then - cldfraUPD(k,nu) = 0.0 - end if - end do - - end do ! loop over nu updrafts - - ! Add updraft areas into edmf_a, etc. - ! Add cloud fractions into cldfra_bl1d - !cldfra_bl1d(1) = 0.0 - cfm_temfx = 0.0 - do k = 2,kte - !cldfra_bl1d(k) = 0.0 - cldfra_sum = 0.0 - edmf_a(k) = 0.0 - edmf_w(k) = 0.0 - edmf_thl(k) = 0.0 - edmf_qt(k) = 0.0 - edmf_qc(k) = 0.0 - edmf_u(k) = 0.0 - edmf_v(k) = 0.0 - edmf_qke(k) = 0.0 - edmf_ent(k) = 0.0 -#if (WRF_CHEM == 1) - IF (bl_mynn_mixchem == 1) THEN - do ic = 1,nchem - edmf_chem(k,ic) = 0.0 - enddo - ENDIF -#endif - do nu = 1,Nupd - ! WA 7/5/16 put area on turbulence levels for consistency - aUPDt(k,nu) = mf_temfx(k,nu) / wUPD(k,nu) - if (aUPDt(k,nu) >= 1.0e-3 .AND. wUPD(k,nu) >= 1.0e-5) then - edmf_a(k) = edmf_a(k) + aUPDt(k,nu) - edmf_w(k) = edmf_w(k) + aUPDt(k,nu)*wUPD(k,nu) - edmf_thl(k) = edmf_thl(k) + aUPDt(k,nu)*thlUPD(k,nu) - edmf_qt(k) = edmf_qt(k) + aUPDt(k,nu)*qtUPD(k,nu) - edmf_qc(k) = edmf_qc(k) + aUPDt(k,nu)*qlUPD(k,nu) - edmf_u(k) = edmf_u(k) + aUPDt(k,nu)*UUPD(k,nu) - edmf_v(k) = edmf_v(k) + aUPDt(k,nu)*VUPD(k,nu) - edmf_qke(k) = edmf_qke(k) + aUPDt(k,nu)*TEUPD(k,nu) - edmf_ent(k) = edmf_ent(k) + aUPDt(k,nu)*epsmf(k,nu) - cldfra_sum = cldfra_sum + cldfraUPD(k,nu) -#if (WRF_CHEM == 1) - IF (bl_mynn_mixchem == 1) THEN - do ic = 1,nchem - edmf_chem(k,ic) = edmf_chem(k,ic) + aUPDt(k,nu)*chemUPD(k,ic,nu) - enddo - ENDIF -#endif - end if - end do - - IF ( debug_code ) THEN - ! print *,"In TEMF_MF edmf_w = ", edmf_w(1:10) - ! print *,"In TEMF_MF edmf_a = ", edmf_a(1:10) - ! print *,"In TEMF_MF edmf_thl = ", edmf_thl(1:10) - ! print *,"In TEMF_MF aUPD(2,:) = ", aUPD(2,:) - ! print *,"In TEMF_MF wUPD(2,:) = ", wUPD(2,:) - ! print *,"In TEMF_MF thlUPD(2,:) = ", thlUPD(2,:) - ENDIF - - ! WA TEST 6/14/16 don't divide by very small updrafts - !if (edmf_a(k)>0.) then - if (edmf_a(k)>1.e-3) then - edmf_w(k)=edmf_w(k)/edmf_a(k) - edmf_qt(k)=edmf_qt(k)/edmf_a(k) - edmf_thl(k)=edmf_thl(k)/edmf_a(k) - edmf_ent(k)=edmf_ent(k)/edmf_a(k) - edmf_qc(k)=edmf_qc(k)/edmf_a(k) - edmf_u(k)=edmf_u(k)/edmf_a(k) - edmf_v(k)=edmf_v(k)/edmf_a(k) - edmf_qke(k)=edmf_qke(k)/edmf_a(k) -#if (WRF_CHEM == 1) - IF (bl_mynn_mixchem == 1) THEN - do ic = 1,nchem - edmf_chem(k,ic) = edmf_chem(k,ic)/edmf_a(k) - enddo - ENDIF -#endif - - if (edmf_qc(k) > 0.0) then - IF (cldfra_sum > edmf_a(k)) THEN - cldfra_bl1d(k) = cldfra_sum - qc_bl1d(k) = edmf_qc(k)*edmf_a(k)/cldfra_sum - ELSE - cldfra_bl1d(k)=edmf_a(k) - qc_bl1d(k) = edmf_qc(k) - ENDIF - endif - endif - - ! Put max value so far into cfm - if (zt(k) <= hmax) then - cfm_temfx = max(cldfra_bl1d(k),cfm_temfx) - end if - end do - - !cldfra_bl1d(kte) = 0.0 - - ! Computing variables needed for solver - - do k=kts,kte ! do these in loop above - ! WA TEST 6/14/16 don't use very small updrafts to be consistent - ! with block above - if (edmf_a(k)>1.0e-3) then - s_aw(k) = edmf_a(k)*edmf_w(k)*psig_w * (1.0+rstoch_col(k)) - s_awthl(k)= edmf_a(k)*edmf_w(k)*edmf_thl(k)*psig_w * (1.0+rstoch_col(k)) - s_awqt(k) = edmf_a(k)*edmf_w(k)*edmf_qt(k)*psig_w * (1.0+rstoch_col(k)) - s_awqc(k) = edmf_a(k)*edmf_w(k)*edmf_qc(k)*psig_w * (1.0+rstoch_col(k)) - s_awqv(k) = s_awqt(k) - s_awqc(k) - s_awu(k) = edmf_a(k)*edmf_w(k)*edmf_u(k)*psig_w * (1.0+rstoch_col(k)) - s_awv(k) = edmf_a(k)*edmf_w(k)*edmf_v(k)*psig_w * (1.0+rstoch_col(k)) - s_awqke(k) = edmf_a(k)*edmf_w(k)*edmf_qke(k)*psig_w * (1.0+rstoch_col(k)) -#if (WRF_CHEM == 1) - IF (bl_mynn_mixchem == 1) THEN - do ic = 1,nchem - s_awchem(k,ic) = edmf_w(k)*edmf_chem(k,ic)*psig_w * (1.0+rstoch_col(k)) - enddo - ENDIF -#endif - endif - !now reduce diagnostic output array by psig - edmf_a(k)=edmf_a(k)*psig_w - enddo - - ! end if ! is_convective - ! Mass flux block ends here - else - edmf_a = 0. - edmf_w = 0. - edmf_qt = 0. - edmf_thl = 0. - edmf_ent = 0. - edmf_u = 0. - edmf_v = 0. - edmf_qke = 0. - s_aw = 0. - s_awthl= 0. - s_awqt = 0. - s_awqv = 0. - s_awqc = 0. - s_awu = 0. - s_awv = 0. - s_awqke= 0. - edmf_qc(1) = qc(1) - !qc_bl1d(1) = qc(1) - do k = kts+1,kte-1 - edmf_qc(k) = qc(k-1) - !qc_bl1d(k) = qc(k-1) - end do -#if (WRF_CHEM == 1) - IF (bl_mynn_mixchem == 1) THEN - do ic = 1,nchem - s_awchem(:,ic) = 0. - enddo - ENDIF -#endif - end if - !edmf_qc(kte) = qc(kte) - !qc_bl1d(kte) = qc(kte) - - !IF ( debug_code ) THEN - ! print *,"After TEMF_MF, s_aw = ", s_aw(1:5) - ! print *,"After TEMF_MF, s_awthl = ", s_awthl(1:5) - ! print *,"After TEMF_MF, s_awqt = ", s_awqt(1:5) - ! print *,"After TEMF_MF, s_awqc = ", s_awqc(1:5) - ! print *,"After TEMF_MF, s_awqv = ", s_awqv(1:5) - ! print *,"After TEMF_MF, s_awu = ", s_awu(1:5) - ! print *,"After TEMF_MF, s_awv = ", s_awv(1:5) - ! print *,"After TEMF_MF, s_awqke = ", s_awqke(1:5) - !ENDIF - -END SUBROUTINE temf_mf - -!-------------------------------------------------------------------- -! - real function rsat_temf(p,T,ep2) - -! Calculates the saturation mixing ratio with respect to liquid water -! Arguments are pressure (Pa) and absolute temperature (K) -! Uses the formula from the ARM intercomparison setup. -! Converted from Matlab by WA 7/28/08 - -implicit none -real p, T, ep2 -real temp, x -real, parameter :: c0 = 0.6105851e+3 -real, parameter :: c1 = 0.4440316e+2 -real, parameter :: c2 = 0.1430341e+1 -real, parameter :: c3 = 0.2641412e-1 -real, parameter :: c4 = 0.2995057e-3 -real, parameter :: c5 = 0.2031998e-5 -real, parameter :: c6 = 0.6936113e-8 -real, parameter :: c7 = 0.2564861e-11 -real, parameter :: c8 = -0.3704404e-13 - -temp = T - 273.15 - -x =c0+temp*(c1+temp*(c2+temp*(c3+temp*(c4+temp*(c5+temp*(c6+temp*(c7+temp*c8))))))) -rsat_temf = ep2*x/(p-x) - -return -end function rsat_temf - -!================================================================= +! =================================================================== END MODULE module_bl_mynn diff --git a/physics/mp_thompson_hrrr_pre.F90 b/physics/mp_thompson_hrrr_pre.F90 index 0167a952a..737f9c5d9 100644 --- a/physics/mp_thompson_hrrr_pre.F90 +++ b/physics/mp_thompson_hrrr_pre.F90 @@ -28,7 +28,16 @@ end subroutine mp_thompson_hrrr_pre_init !! | kdt | index_of_time_step | current forecast iteration | index | 0 | integer | | in | F | !! | con_g | gravitational_acceleration | gravitational acceleration | m s-2 | 0 | real | kind_phys | in | F | !! | con_rd | gas_constant_dry_air | ideal gas constant for dry air | J kg-1 K-1 | 0 | real | kind_phys | in | F | +!! | spechum | water_vapor_specific_humidity_updated_by_physics | water vapor specific humidity | kg kg-1 | 2 | real | kind_phys | inout | F | +!! | qc | cloud_condensed_water_mixing_ratio_updated_by_physics | cloud water mixing ratio wrt dry+vapor (no condensates) | kg kg-1 | 2 | real | kind_phys | inout | F | +!! | qr | rain_water_mixing_ratio_updated_by_physics | rain water mixing ratio wrt dry+vapor (no condensates) | kg kg-1 | 2 | real | kind_phys | inout | F | +!! | qi | ice_water_mixing_ratio_updated_by_physics | ice water mixing ratio wrt dry+vapor (no condensates) | kg kg-1 | 2 | real | kind_phys | inout | F | +!! | qs | snow_water_mixing_ratio_updated_by_physics | snow water mixing ratio wrt dry+vapor (no condensates) | kg kg-1 | 2 | real | kind_phys | inout | F | +!! | qg | graupel_mixing_ratio_updated_by_physics | graupel mixing ratio wrt dry+vapor (no condensates) | kg kg-1 | 2 | real | kind_phys | inout | F | +!! | ni | ice_number_concentration_updated_by_physics | ice number concentration | kg-1 | 2 | real | kind_phys | inout | F | +!! | nr | rain_number_concentration_updated_by_physics | rain number concentration | kg-1 | 2 | real | kind_phys | inout | F | !! | is_aerosol_aware| flag_for_aerosol_physics | flag for aerosol-aware physics | flag | 0 | logical | | in | F | +!! | nc | cloud_droplet_number_concentration_updated_by_physics | cloud droplet number concentration | kg-1 | 2 | real | kind_phys | inout | T | !! | nwfa | water_friendly_aerosol_number_concentration_updated_by_physics | number concentration of water-friendly aerosols | kg-1 | 2 | real | kind_phys | inout | T | !! | nifa | ice_friendly_aerosol_number_concentration_updated_by_physics | number concentration of ice-friendly aerosols | kg-1 | 2 | real | kind_phys | inout | T | !! | nwfa2d | tendency_of_water_friendly_aerosols_at_surface | instantaneous fake water-friendly surface aerosol source | kg-1 s-1 | 1 | real | kind_phys | inout | T | @@ -47,7 +56,8 @@ end subroutine mp_thompson_hrrr_pre_init !! #endif subroutine mp_thompson_hrrr_pre_run(ncol, nlev, kdt, con_g, con_rd, & - is_aerosol_aware, nwfa, nifa, nwfa2d, & + spechum, qc, qr, qi, qs, qg, ni, nr, & + is_aerosol_aware, nc, nwfa, nifa, nwfa2d, & nifa2d, tgrs, tgrs_save, prsl, phil, area, & mpicomm, mpirank, mpiroot, blkno, & errmsg, errflg) @@ -61,8 +71,18 @@ subroutine mp_thompson_hrrr_pre_run(ncol, nlev, kdt, con_g, con_rd, & integer, intent(in ) :: kdt real(kind_phys), intent(in ) :: con_g real(kind_phys), intent(in ) :: con_rd + ! Hydrometeors + real(kind_phys), intent(inout) :: spechum(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) :: qg(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: ni(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: nr(1:ncol,1:nlev) ! Aerosols logical, intent(in ) :: is_aerosol_aware + real(kind_phys), optional, intent(inout) :: nc(1:ncol,1:nlev) real(kind_phys), optional, intent(inout) :: nwfa(1:ncol,1:nlev) real(kind_phys), optional, intent(inout) :: nifa(1:ncol,1:nlev) real(kind_phys), optional, intent(inout) :: nwfa2d(1:ncol) @@ -97,20 +117,44 @@ subroutine mp_thompson_hrrr_pre_run(ncol, nlev, kdt, con_g, con_rd, & ! Return if not first timestep if (kdt > 1) return + ! Fix initial values of hydrometeors + where(spechum<0) spechum = 0.0 + where(qc<0) qc = 0.0 + where(qr<0) qr = 0.0 + where(qi<0) qi = 0.0 + where(qs<0) qs = 0.0 + where(qg<0) qg = 0.0 + where(ni<0) ni = 0.0 + where(nr<0) nr = 0.0 + ! If qi is in boundary conditions but ni is not, reset qi to zero (and vice versa) + if (maxval(qi)>0.0 .and. maxval(ni)==0.0) qi = 0.0 + if (maxval(ni)>0.0 .and. maxval(qi)==0.0) ni = 0.0 + ! If qr is in boundary conditions but nr is not, reset qr to zero (and vice versa) + if (maxval(qr)>0.0 .and. maxval(nr)==0.0) qr = 0.0 + if (maxval(nr)>0.0 .and. maxval(qr)==0.0) nr = 0.0 + ! Return if aerosol-aware option is not used if (.not. is_aerosol_aware) return - if (.not.present(nwfa2d) .or. & + if (.not.present(nc) .or. & + .not.present(nwfa2d) .or. & .not.present(nifa2d) .or. & .not.present(nwfa) .or. & .not.present(nifa) ) then write(errmsg,fmt='(*(a))') 'Logic error in mp_thompson_hrrr_pre_run:', & ' aerosol-aware microphysics require all of the following', & - ' optional arguments: nifa2d, nwfa2d, nwfa, nifa' + ' optional arguments: nc, nifa2d, nwfa2d, nwfa, nifa' errflg = 1 return end if + ! Fix initial values of aerosols + where(nc<0) nc = 0.0 + where(nwfa<0) nwfa = 0.0 + where(nifa<0) nifa = 0.0 + where(nwfa2d<0) nwfa2d = 0.0 + where(nifa2d<0) nifa2d = 0.0 + #ifdef DEBUG_AEROSOLS if (mpirank==mpiroot) then write(0,'(a,3e16.7)') "AEROSOL DEBUG mp_thompson_hrrr_pre_run before: nwfa2d min/mean/max =", & diff --git a/physics/satmedmfvdif.F b/physics/satmedmfvdif.F index c210d97a2..792895a32 100644 --- a/physics/satmedmfvdif.F +++ b/physics/satmedmfvdif.F @@ -40,7 +40,7 @@ end subroutine satmedmfvdif_finalize !! | km | vertical_dimension | vertical layer dimension | count | 0 | integer | | in | F | !! | ntrac | number_of_vertical_diffusion_tracers | number of tracers to diffuse vertically | count | 0 | integer | | in | F | !! | ntcw | index_for_liquid_cloud_condensate | tracer index for cloud condensate (or liquid water) | index | 0 | integer | | in | F | -!! | ntiw | index_for_ice_cloud_condensate | tracer index for ice water | index | 0 | integer | | in | F | +!! | ntiw | index_for_ice_cloud_condensate_vertical_diffusion_tracer | tracer index for ice water in the vertically diffused tracer array | index | 0 | integer | | in | F | !! | ntke | index_for_turbulent_kinetic_energy_vertical_diffusion_tracer | index for turbulent kinetic energy in the vertically diffused tracer array | index | 0 | integer | | in | F | !! | grav | gravitational_acceleration | gravitational acceleration | m s-2 | 0 | real | kind_phys | in | F | !! | rd | gas_constant_dry_air | ideal gas constant for dry air | J kg-1 K-1 | 0 | real | kind_phys | in | F | @@ -54,11 +54,11 @@ end subroutine satmedmfvdif_finalize !! | dv | tendency_of_y_wind_due_to_model_physics | updated tendency of the y wind | m s-2 | 2 | real | kind_phys | inout | F | !! | du | tendency_of_x_wind_due_to_model_physics | updated tendency of the x wind | m s-2 | 2 | real | kind_phys | inout | F | !! | tdt | tendency_of_air_temperature_due_to_model_physics | updated tendency of the temperature | K s-1 | 2 | real | kind_phys | inout | F | -!! | rtg | tendency_of_tracers_due_to_model_physics | updated tendency of the tracers due to model physics | kg kg-1 s-1 | 3 | real | kind_phys | inout | F | +!! | rtg | tendency_of_vertically_diffused_tracer_concentration | updated tendency of the tracers due to vertical diffusion in PBL scheme | kg kg-1 s-1 | 3 | real | kind_phys | inout | F | !! | u1 | x_wind | x component of layer wind | m s-1 | 2 | real | kind_phys | in | F | !! | v1 | y_wind | y component of layer wind | m s-1 | 2 | real | kind_phys | in | F | !! | t1 | air_temperature | layer mean air temperature | K | 2 | real | kind_phys | in | F | -!! | q1 | tracer_concentration | model layer mean tracer concentration | kg kg-1 | 3 | real | kind_phys | in | F | +!! | q1 | vertically_diffused_tracer_concentration | tracer concentration diffused by PBL scheme | kg kg-1 | 3 | real | kind_phys | in | F | !! | swh | tendency_of_air_temperature_due_to_shortwave_heating_on_radiation_time_step | total sky shortwave heating rate | K s-1 | 2 | real | kind_phys | in | F | !! | hlw | tendency_of_air_temperature_due_to_longwave_heating_on_radiation_time_step | total sky longwave heating rate | K s-1 | 2 | real | kind_phys | in | F | !! | xmu | zenith_angle_temporal_adjustment_factor_for_shortwave_fluxes | zenith angle temporal adjustment factor for shortwave | none | 1 | real | kind_phys | in | F | diff --git a/physics/shinhongvdif.F90 b/physics/shinhongvdif.F90 new file mode 100644 index 000000000..c5011218b --- /dev/null +++ b/physics/shinhongvdif.F90 @@ -0,0 +1,2106 @@ +!> \file shinhongvdif.F90 +!! This file contains the CCPP-compliant Shinhong (saYSU) scheme which computes +!! subgrid vertical turbulence mixing using traditional K-profile method +!! Please refer to (Shin and Hong, 2013,2015). +!! +!! Subroutine 'shinhongvdif_run' computes subgrid vertical turbulence mixing +!! using scale-aware YSU K-profile method +!! +!---------------------------------------------------------------------- + + module shinhongvdif + contains + + subroutine shinhongvdif_init () + end subroutine shinhongvdif_init + + subroutine shinhongvdif_finalize () + end subroutine shinhongvdif_finalize + +!> \defgroup SHINHONG FV3GFS shinhongvdif_run Main +!! \brief This subroutine contains all of the logic for the +!! scale-aware Shinhong scheme. +!! +!> \section arg_table_shinhongvdif_run Argument Table +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |----------------|-----------------------------------------------------------------------------|-------------------------------------------------------|---------------|------|-----------|-----------|--------|----------| +!! | ix | horizontal_dimension | horizontal dimension | count | 0 | integer | | in | F | +!! | im | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | +!! | km | vertical_dimension | vertical layer dimension | count | 0 | integer | | in | F | +!! | ux | x_wind | x component of layer wind | m s-1 | 2 | real | kind_phys | in | F | +!! | vx | y_wind | y component of layer wind | m s-1 | 2 | real | kind_phys | in | F | +!! | tx | air_temperature | layer mean air temperature | K | 2 | real | kind_phys | in | F | +!! | qx | tracer_concentration | model layer mean tracer concentration | kg kg-1 | 3 | real | kind_phys | in | F | +!! | p2d | air_pressure | mean layer pressure | Pa | 2 | real | kind_phys | in | F | +!! | p2di | air_pressure_at_interface | air pressure at model layer interfaces | Pa | 2 | real | kind_phys | in | F | +!! | pi2d | dimensionless_exner_function_at_model_layers | Exner function at layers | none | 2 | real | kind_phys | in | F | +!! | vtnp | tendency_of_y_wind_due_to_model_physics | updated tendency of the y wind | m s-2 | 2 | real | kind_phys | inout | F | +!! | utnp | tendency_of_x_wind_due_to_model_physics | updated tendency of the x wind | m s-2 | 2 | real | kind_phys | inout | F | +!! | ttnp | tendency_of_air_temperature_due_to_model_physics | updated tendency of the temperature | K s-1 | 2 | real | kind_phys | inout | F | +!! | qtnp | tendency_of_tracers_due_to_model_physics | updated tendency of the tracers due to model physics | kg kg-1 s-1 | 3 | real | kind_phys | inout | F | +!! | ntrac | number_of_tracers | number of tracers | count | 0 | integer | | in | F | +!! | ndiff | number_of_vertical_diffusion_tracers | number of tracers to diffuse vertically | count | 0 | integer | | in | F | +!! | ntcw | index_for_liquid_cloud_condensate | tracer index for cloud condensate (or liquid water) | index | 0 | integer | | in | F | +!! | ntiw | index_for_ice_cloud_condensate | tracer index for ice water | index | 0 | integer | | in | F | +!! | phii | geopotential_at_interface | geopotential at model layer interfaces | m2 s-2 | 2 | real | kind_phys | in | F | +!! | phil | geopotential | geopotential at model layer centers | m2 s-2 | 2 | real | kind_phys | in | F | +!! | psfcpa | surface_air_pressure | surface pressure | Pa | 1 | real | kind_phys | in | F | +!! | zorl | surface_roughness_length | surface roughness length in cm | cm | 1 | real | kind_phys | in | F | +!! | stress | surface_wind_stress | surface wind stress | m2 s-2 | 1 | real | kind_phys | in | F | +!! | hpbl | atmosphere_boundary_layer_thickness | PBL thickness | m | 1 | real | kind_phys | out | F | +!! | psim | Monin-Obukhov_similarity_function_for_momentum | Monin-Obukhov similarity function for momentum | none | 1 | real | kind_phys | in | F | +!! | psih | Monin-Obukhov_similarity_function_for_heat | Monin-Obukhov similarity function for heat | none | 1 | real | kind_phys | in | F | +!! | landmask | sea_land_ice_mask | landmask: sea/land/ice=0/1/2 | flag | 1 | integer | | in | F | +!! | heat | kinematic_surface_upward_sensible_heat_flux | kinematic surface upward sensible heat flux | K m s-1 | 1 | real | kind_phys | in | F | +!! | evap | kinematic_surface_upward_latent_heat_flux | kinematic surface upward latent heat flux | kg kg-1 m s-1 | 1 | real | kind_phys | in | F | +!! | wspd | wind_speed_at_lowest_model_layer | wind speed at lowest model level | m s-1 | 1 | real | kind_phys | in | F | +!! | br | bulk_richardson_number_at_lowest_model_level | bulk Richardson number at the surface | none | 1 | real | kind_phys | in | F | +!! | g | gravitational_acceleration | gravitational acceleration | m s-2 | 0 | real | kind_phys | in | F | +!! | rd | gas_constant_dry_air | ideal gas constant for dry air | J kg-1 K-1 | 0 | real | kind_phys | in | F | +!! | cp | specific_heat_of_dry_air_at_constant_pressure | specific heat of dry air at constant pressure | J kg-1 K-1 | 0 | real | kind_phys | in | F | +!! | rv | gas_constant_water_vapor | ideal gas constant for water vapor | J kg-1 K-1 | 0 | real | kind_phys | in | F | +!! | ep1 | ratio_of_vapor_to_dry_air_gas_constants_minus_one | rv/rd - 1 (rv = ideal gas constant for water vapor) | none | 0 | real | kind_phys | in | F | +!! | ep2 | ratio_of_dry_air_to_water_vapor_gas_constants | rd/rv | none | 0 | real | kind_phys | in | F | +!! | xlv | latent_heat_of_vaporization_of_water_at_0C | latent heat of evaporation/sublimation | J kg-1 | 0 | real | kind_phys | in | F | +!! | dusfc | instantaneous_surface_x_momentum_flux | x momentum flux | Pa | 1 | real | kind_phys | out | F | +!! | dvsfc | instantaneous_surface_y_momentum_flux | y momentum flux | Pa | 1 | real | kind_phys | out | F | +!! | dtsfc | instantaneous_surface_upward_sensible_heat_flux | surface upward sensible heat flux | W m-2 | 1 | real | kind_phys | out | F | +!! | dqsfc | instantaneous_surface_upward_latent_heat_flux | surface upward latent heat flux | W m-2 | 1 | real | kind_phys | out | F | +!! | dt | time_step_for_physics | time step for physics | s | 0 | real | kind_phys | in | F | +!! | kpbl1d | vertical_index_at_top_of_atmosphere_boundary_layer | PBL top model level index | index | 1 | integer | | out | F | +!! | u10 | x_wind_at_10m | x component of wind at 10 m | m s-1 | 1 | real | kind_phys | in | F | +!! | v10 | y_wind_at_10m | y component of wind at 10 m | m s-1 | 1 | real | kind_phys | in | F | +!! | dx | cell_size | size of the grid cell | m | 1 | real | kind_phys | in | F | +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! +!------------------------------------------------------------------------------- + subroutine shinhongvdif_run(ix,im,km,ux,vx,tx,qx,p2d,p2di,pi2d, & + utnp,vtnp,ttnp,qtnp,ntrac,ndiff,ntcw,ntiw, & + phii,phil,psfcpa, & + zorl,stress,hpbl,psim,psih, & + landmask,heat,evap,wspd,br, & + g,rd,cp,rv,ep1,ep2,xlv, & + dusfc,dvsfc,dtsfc,dqsfc, & + dt,kpbl1d, & + u10,v10, & + dx,errmsg,errflg ) + + use machine , only : kind_phys +! +!------------------------------------------------------------------------------- + implicit none +!------------------------------------------------------------------------------- +! +! the shinhongpbl (shin and hong 2015) is based on the les study of shin +! and hong (2013). the major ingredients of the shinhongpbl are +! 1) the prescribed nonlocal heat transport profile fit to the les and +! 2) inclusion of explicit scale dependency functions for vertical +! transport in convective pbl. +! so, the shinhongpbl works at the gray zone resolution of convective pbl. +! note that honnert et al. (2011) first suggested explicit scale dependency +! function, and shin and hong (2013) further classified the function by +! stability (u*/w*) in convective pbl and calculated the function for +! nonlocal and local transport separately. +! vertical mixing in the stable boundary layer and free atmosphere follows +! hong (2010) and hong et al. (2006), same as the ysupbl scheme. +! +! shinhongpbl: +! coded and implemented by hyeyum hailey shin (ncar) +! summer 2014 +! +! ysupbl: +! coded by song-you hong (yonsei university) and implemented by +! song-you hong (yonsei university) and jimy dudhia (ncar) +! summer 2002 +! +! references: +! shin and hong (2015) mon. wea. rev. +! shin and hong (2013) j. atmos. sci. +! honnert, masson, and couvreux (2011) j. atmos. sci. +! hong (2010) quart. j. roy. met. soc +! hong, noh, and dudhia (2006), mon. wea. rev. +! +!------------------------------------------------------------------------------- +! + real(kind=kind_phys),parameter :: xkzminm = 0.1,xkzminh = 0.01 + real(kind=kind_phys),parameter :: xkzmax = 1000.,rimin = -100. + real(kind=kind_phys),parameter :: rlam = 30.,prmin = 0.25,prmax = 4. + real(kind=kind_phys),parameter :: brcr_ub = 0.0,brcr_sb = 0.25,cori = 1.e-4 + real(kind=kind_phys),parameter :: afac = 6.8,bfac = 6.8,pfac = 2.0,pfac_q = 2.0 + real(kind=kind_phys),parameter :: phifac = 8.,sfcfrac = 0.1 + real(kind=kind_phys),parameter :: d1 = 0.02, d2 = 0.05, d3 = 0.001 + real(kind=kind_phys),parameter :: h1 = 0.33333335, h2 = 0.6666667 + real(kind=kind_phys),parameter :: ckz = 0.001,zfmin = 1.e-8,aphi5 = 5.,aphi16 = 16. + real(kind=kind_phys),parameter :: tmin=1.e-2 + real(kind=kind_phys),parameter :: gamcrt = 3.,gamcrq = 2.e-3 + real(kind=kind_phys),parameter :: xka = 2.4e-5 + real(kind=kind_phys),parameter :: karman = 0.4 + real(kind=kind_phys),parameter :: corf=0.000073 + real(kind=kind_phys),parameter :: rcl = 1.0 + integer,parameter :: imvdif = 1 + integer,parameter :: shinhong_tke_diag = 0 +! +! tunable parameters for tke +! + real(kind=kind_phys),parameter :: epsq2l = 0.01,c_1 = 1.0,gamcre = 0.224 +! +! tunable parameters for prescribed nonlocal transport profile +! + real(kind=kind_phys),parameter :: mltop = 1.0,sfcfracn1 = 0.075 + real(kind=kind_phys),parameter :: nlfrac = 0.7,enlfrac = -0.4 + real(kind=kind_phys),parameter :: a11 = 1.0,a12 = -1.15 + real(kind=kind_phys),parameter :: ezfac = 1.5 + real(kind=kind_phys),parameter :: cpent = -0.4,rigsmax = 100. + real(kind=kind_phys),parameter :: entfmin = 1.0, entfmax = 5.0 +! 1D in + integer, intent(in ) :: ix,im,km,ntrac,ndiff,ntcw,ntiw + real(kind=kind_phys), intent(in ) :: g,cp,rd,rv,ep1,ep2,xlv,dt +! 3D in + real(kind=kind_phys), dimension(ix, km) , & + intent(in ) :: phil, & + pi2d, & + p2d, & + ux, & + vx, & + tx + real(kind=kind_phys), dimension( ix, km, ntrac ) , & + intent(in ) :: qx + + real(kind=kind_phys), dimension( ix, km+1 ) , & + intent(in ) :: p2di, & + phii +! 3D in&out + real(kind=kind_phys), dimension(im, km) , & + intent(inout) :: utnp, & + vtnp, & + ttnp + real(kind=kind_phys), dimension(im, km, ntrac ) , & + intent(inout) :: qtnp +! 2D in + integer, dimension(im) , & + intent(in ) :: landmask + + real(kind=kind_phys), dimension(im) , & + intent(in ) :: heat, & + evap, & + br, & + psim, & + psih, & + psfcpa, & + stress, & + zorl, & + wspd, & + u10, & + v10, & + dx +! 2D: out + integer, dimension(im) , & + intent(out ) :: kpbl1d + + real(kind=kind_phys), dimension(im) , & + intent(out ) :: hpbl, & + dusfc, & + dvsfc, & + dtsfc, & + dqsfc + +! error messages + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg +! +! local vars +! + integer :: n,i,k,l,ic + integer :: klpbl + integer :: lmh,lmxl,kts,kte,its,ite +! + real(kind=kind_phys) :: dt2,rdt,spdk2,fm,fh,hol1,gamfac,vpert,prnum,prnum0 + real(kind=kind_phys) :: ss,ri,qmean,tmean,alpha,chi,zk,rl2,dk,sri + real(kind=kind_phys) :: brint,dtodsd,dtodsu,rdz,dsdzt,dsdzq,dsdz2,rlamdz + real(kind=kind_phys) :: utend,vtend,ttend,qtend + real(kind=kind_phys) :: dtstep,govrthv + real(kind=kind_phys) :: cont, conq, conw, conwrc + real(kind=kind_phys) :: delxy,pu1,pth1,pq1 + real(kind=kind_phys) :: dex,hgame_c + real(kind=kind_phys) :: zfacdx + real(kind=kind_phys) :: amf1,amf2,bmf2,amf3,bmf3,amf4,bmf4,sflux0,snlflux0 + real(kind=kind_phys) :: mlfrac,ezfrac,sfcfracn + real(kind=kind_phys) :: uwst,uwstx,csfac + real(kind=kind_phys) :: prnumfac,bfx0,hfx0,qfx0,delb,dux,dvx, & + dsdzu,dsdzv,wm3,dthx,dqx,wspd10,ross,tem1,dsig,tvcon,conpr, & + prfac,prfac2,phim8z +! + integer, dimension(im) :: kpbl + real(kind=kind_phys), dimension(im) :: hol + real(kind=kind_phys), dimension(im) :: deltaoh + real(kind=kind_phys), dimension(im) :: rigs, & + enlfrac2, & + cslen + real(kind=kind_phys), dimension(im) :: & + rhox, & + govrth, & + zl1,thermal, & + wscale, & + hgamt,hgamq, & + brdn,brup, & + phim,phih, & + prpbl, & + wspd1, & + ust,hfx,qfx,znt, & + xland + real(kind=kind_phys), dimension(im) :: & + ust3, & + wstar3, & + wstar,delta, & + hgamu,hgamv, & + wm2, we, & + bfxpbl, & + hfxpbl,qfxpbl, & + ufxpbl,vfxpbl, & + dthvx + real(kind=kind_phys), dimension(im) :: & + brcr, & + sflux, & + zol1, & + brcr_sbro + real(kind=kind_phys), dimension(im) :: & + efxpbl, & + hpbl_cbl, & + epshol, & + ct +! + real(kind=kind_phys), dimension(im,km) :: & + xkzm,xkzh, & + f1,f2, & + r1,r2, & + ad,au, & + cu, & + al, & + xkzq, & + zfac + real(kind=kind_phys), dimension(im,km) :: & + thx,thvx, & + del, & + dza, & + dzq, & + xkzom, & + xkzoh, & + za + real(kind=kind_phys), dimension(im,km) :: & + wscalek + real(kind=kind_phys), dimension(im,km) :: & + xkzml,xkzhl, & + zfacent,entfac + real(kind=kind_phys), dimension(im,km) :: & + mf, & + zfacmf, & + entfacmf + real(kind=kind_phys), dimension(im,km) :: & + q2x, & + hgame2d, & + tflux_e, & + qflux_e, & + tvflux_e + real(kind=kind_phys), dimension( im, km+1 ) :: zq + real(kind=kind_phys), dimension( im, km, ndiff ) :: r3,f3 +! + real(kind=kind_phys), dimension( km ) :: & + uxk,vxk, & + txk,thxk,thvxk, & + q2xk, & + hgame + real(kind=kind_phys), dimension( km ) :: & + ps1d,pb1d,eps1d,pt1d, & + xkze1d,eflx_l1d,eflx_nl1d, & + ptke1 + real(kind=kind_phys), dimension( 2:km ) :: & + s2,gh,rig,el, & + akmk,akhk, & + mfk,ufxpblk,vfxpblk,qfxpblk + real(kind=kind_phys), dimension( km+1 ) :: zqk + + real(kind=kind_phys), dimension(im,km) :: dz8w2d +! + logical, dimension(im) :: pblflg, & + sfcflg, & + stable + logical, dimension( ndiff ) :: ifvmix +! +!------------------------------------------------------------------------------- +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + its = 1 + ite = im + kts = 1 + kte = km + + klpbl = kte + lmh = 1 + lmxl = 1 +! + cont=cp/g + conq=xlv/g + conw=1./g + conwrc = conw*sqrt(rcl) + conpr = bfac*karman*sfcfrac +! change xland values + do i=its,ite + if(landmask(i).eq.0) then !ocean + xland(i) = 2 + else + xland(i) = 1 !land + end if + end do +! +! k-start index for cloud and rain +! + ifvmix(:) = .true. +! + do k = kts,kte + do i = its,ite + thx(i,k) = tx(i,k)/pi2d(i,k) + enddo + enddo +! + do k = kts,kte + do i = its,ite + tvcon = (1.+ep1*qx(i,k,1)) + thvx(i,k) = thx(i,k)*tvcon + enddo + enddo +! + do i = its,ite + tvcon = (1.+ep1*qx(i,1,1)) + rhox(i) = psfcpa(i)/(rd*tx(i,1)*tvcon) + govrth(i) = g/thx(i,1) + hfx(i) = heat(i)*rhox(i)*cp ! reset to the variable in WRF + qfx(i) = evap(i)*rhox(i) ! reset to the variable in WRF + ust(i) = sqrt(stress(i)) ! reset to the variable in WRF + znt(i) = 0.01*zorl(i) ! reset to the variable in WRF + enddo +! +!-----compute the height of full- and half-sigma levels above ground +! level, and the layer thicknesses. +! + do i = its,ite + zq(i,1) = 0. + enddo +! + do k = kts,kte + do i = its,ite + zq(i,k+1) = phii(i,k+1)*conw + za(i,k) = phil(i,k)*conw + enddo + enddo +! + do k = kts,kte + do i = its,ite + dzq(i,k) = zq(i,k+1)-zq(i,k) + del(i,k) = p2di(i,k)-p2di(i,k+1) + dz8w2d(i,k)=dzq(i,k) + enddo + enddo +! + do i = its,ite + dza(i,1) = za(i,1) + enddo +! + do k = kts+1,kte + do i = its,ite + dza(i,k) = za(i,k)-za(i,k-1) + enddo + enddo +! + do i = its,ite + wspd1(i) = sqrt(ux(i,1)*ux(i,1)+vx(i,1)*vx(i,1))+1.e-9 + enddo + +! write(0,*)"===CALLING shinhong; input:" +! print*,"t:",tx(1,1),tx(1,2),tx(1,km) +! print*,"u:",ux(1,1),ux(1,2),ux(1,km) +! print*,"v:",vx(1,1),vx(1,2),vx(1,km) +! print*,"q:",qx(1,1,1),qx(1,2,1),qx(1,km,1) +! print*,"exner:",pi2d(1,1),pi2d(1,2),pi2d(1,km) +! print*,"dz8w2d:",dz8w2d(1,1),dz8w2d(1,2),dz8w2d(1,km) +! print *,"del:",del(1,1),del(1,2),del(1,km) +! print*,"phii:",zq(1,1),zq(1,2),zq(1,km+1) +! print*,"phil:",za(1,1),za(1,2),za(1,km) +! print*,"p2d:",p2d(1,1),p2d(1,2),p2d(1,km) +! print*,"p2di:",p2di(1,1),p2di(1,2),p2di(1,km+1) +! print*,"znt,ust,wspd:",znt(1),ust(1),wspd(1) +! print*,"hfx,qfx,xland:",hfx(1),qfx(1),xland(1) +! print*,"rd,rv,g:",rd,rv,g +! print*,"ep1,ep2,xlv:",ep1,ep2,xlv +! print*,"br,psim,psih:",br(1),psim(1),psih(1) +! print*,"dx,u10,v10:",dx(1),u10(1),v10(1) +! print*,"psfcpa,cp:",psfcpa(1),cp +! print*,"ntrac,ndiff,ntcw,ntiw:",ntrac,ndiff,ntcw,ntiw +! +!---- compute vertical diffusion +! +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! compute preliminary variables +! + dtstep = dt + dt2 = 2.*dtstep + rdt = 1./dt2 +! + do i = its,ite + bfxpbl(i) = 0.0 + hfxpbl(i) = 0.0 + qfxpbl(i) = 0.0 + ufxpbl(i) = 0.0 + vfxpbl(i) = 0.0 + hgamu(i) = 0.0 + hgamv(i) = 0.0 + delta(i) = 0.0 + enddo +! + do i = its,ite + efxpbl(i) = 0.0 + hpbl_cbl(i) = 0.0 + epshol(i) = 0.0 + ct(i) = 0.0 + enddo +! + do i = its,ite + deltaoh(i) = 0.0 + rigs(i) = 0.0 + enlfrac2(i) = 0.0 + cslen(i) = 0.0 + enddo +! + do k = kts,klpbl + do i = its,ite + wscalek(i,k) = 0.0 + enddo + enddo +! + do k = kts,klpbl + do i = its,ite + zfac(i,k) = 0.0 + enddo + enddo +! + do k = kts,kte + do i = its,ite + q2x(i,k) = 1.e-4 + enddo + enddo +! + do k = kts,kte + do i = its,ite + hgame2d(i,k) = 0.0 + tflux_e(i,k) = 0.0 + qflux_e(i,k) = 0.0 + tvflux_e(i,k) = 0.0 + enddo + enddo +! + do k = kts,kte + do i = its,ite + mf(i,k) = 0.0 + zfacmf(i,k) = 0.0 + enddo + enddo +! + do k = kts,klpbl-1 + do i = its,ite + xkzom(i,k) = xkzminm + xkzoh(i,k) = xkzminh + enddo + enddo +! + do i = its,ite + dusfc(i) = 0. + dvsfc(i) = 0. + dtsfc(i) = 0. + dqsfc(i) = 0. + enddo +! + do i = its,ite + hgamt(i) = 0. + hgamq(i) = 0. + wscale(i) = 0. + kpbl(i) = 1 + hpbl(i) = zq(i,1) + hpbl_cbl(i) = zq(i,1) + zl1(i) = za(i,1) + thermal(i)= thvx(i,1) + pblflg(i) = .true. + sfcflg(i) = .true. + sflux(i) = hfx(i)/rhox(i)/cp + qfx(i)/rhox(i)*ep1*thx(i,1) + if(br(i).gt.0.0) sfcflg(i) = .false. + enddo +! +! compute the first guess of pbl height +! + do i = its,ite + stable(i) = .false. + brup(i) = br(i) + brcr(i) = brcr_ub + enddo +! + do k = 2,klpbl + do i = its,ite + if(.not.stable(i))then + brdn(i) = brup(i) + spdk2 = max(ux(i,k)**2+vx(i,k)**2,1.) + brup(i) = (thvx(i,k)-thermal(i))*(g*za(i,k)/thvx(i,1))/spdk2 + kpbl(i) = k + stable(i) = brup(i).gt.brcr(i) + endif + enddo + enddo +! + do i = its,ite + k = kpbl(i) + if(brdn(i).ge.brcr(i))then + brint = 0. + elseif(brup(i).le.brcr(i))then + brint = 1. + else + brint = (brcr(i)-brdn(i))/(brup(i)-brdn(i)) + endif + hpbl(i) = za(i,k-1)+brint*(za(i,k)-za(i,k-1)) + if(hpbl(i).lt.zq(i,2)) kpbl(i) = 1 + if(kpbl(i).le.1) pblflg(i) = .false. + enddo +! + do i = its,ite + fm = psim(i) + fh = psih(i) + zol1(i) = max(br(i)*fm*fm/fh,rimin) + if(sfcflg(i))then + zol1(i) = min(zol1(i),-zfmin) + else + zol1(i) = max(zol1(i),zfmin) + endif + hol1 = zol1(i)*hpbl(i)/zl1(i)*sfcfrac + epshol(i) = hol1 + if(sfcflg(i))then + phim(i) = (1.-aphi16*hol1)**(-1./4.) + phih(i) = (1.-aphi16*hol1)**(-1./2.) + bfx0 = max(sflux(i),0.) + hfx0 = max(hfx(i)/rhox(i)/cp,0.) + qfx0 = max(ep1*thx(i,1)*qfx(i)/rhox(i),0.) + wstar3(i) = (govrth(i)*bfx0*hpbl(i)) + wstar(i) = (wstar3(i))**h1 + else + phim(i) = (1.+aphi5*hol1) + phih(i) = phim(i) + wstar(i) = 0. + wstar3(i) = 0. + endif + ust3(i) = ust(i)**3. + wscale(i) = (ust3(i)+phifac*karman*wstar3(i)*0.5)**h1 + wscale(i) = min(wscale(i),ust(i)*aphi16) + wscale(i) = max(wscale(i),ust(i)/aphi5) + enddo +! +! compute the surface variables for pbl height estimation +! under unstable conditions +! + do i = its,ite + if(sfcflg(i).and.sflux(i).gt.0.0)then + gamfac = bfac/rhox(i)/wscale(i) + hgamt(i) = min(gamfac*hfx(i)/cp,gamcrt) + hgamq(i) = min(gamfac*qfx(i),gamcrq) + vpert = (hgamt(i)+ep1*thx(i,1)*hgamq(i))/bfac*afac + thermal(i) = thermal(i)+max(vpert,0.)*min(za(i,1)/(sfcfrac*hpbl(i)),1.0) + hgamt(i) = max(hgamt(i),0.0) + hgamq(i) = max(hgamq(i),0.0) + brint = -15.9*ust(i)*ust(i)/wspd(i)*wstar3(i)/(wscale(i)**4.) + hgamu(i) = brint*ux(i,1) + hgamv(i) = brint*vx(i,1) + else + pblflg(i) = .false. + endif + enddo +! +! enhance the pbl height by considering the thermal +! + do i = its,ite + if(pblflg(i))then + kpbl(i) = 1 + hpbl(i) = zq(i,1) + endif + enddo +! + do i = its,ite + if(pblflg(i))then + stable(i) = .false. + brup(i) = br(i) + brcr(i) = brcr_ub + endif + enddo +! + do k = 2,klpbl + do i = its,ite + if(.not.stable(i).and.pblflg(i))then + brdn(i) = brup(i) + spdk2 = max(ux(i,k)**2+vx(i,k)**2,1.) + brup(i) = (thvx(i,k)-thermal(i))*(g*za(i,k)/thvx(i,1))/spdk2 + kpbl(i) = k + stable(i) = brup(i).gt.brcr(i) + endif + enddo + enddo +! + do i = its,ite + if(pblflg(i)) then + k = kpbl(i) + if(brdn(i).ge.brcr(i))then + brint = 0. + elseif(brup(i).le.brcr(i))then + brint = 1. + else + brint = (brcr(i)-brdn(i))/(brup(i)-brdn(i)) + endif + hpbl(i) = za(i,k-1)+brint*(za(i,k)-za(i,k-1)) + if(hpbl(i).lt.zq(i,2)) kpbl(i) = 1 + if(kpbl(i).le.1) pblflg(i) = .false. + uwst = abs(ust(i)/wstar(i)-0.5) + uwstx = -80.*uwst+14. + csfac = 0.5*(tanh(uwstx)+3.) + cslen(i) = csfac*hpbl(i) + endif + enddo +! +! stable boundary layer +! + do i = its,ite + hpbl_cbl(i) = hpbl(i) + if((.not.sfcflg(i)).and.hpbl(i).lt.zq(i,2)) then + brup(i) = br(i) + stable(i) = .false. + else + stable(i) = .true. + endif + enddo +! + do i = its,ite + if((.not.stable(i)).and.((xland(i)-1.5).ge.0))then + wspd10 = u10(i)*u10(i) + v10(i)*v10(i) + wspd10 = sqrt(wspd10) + ross = wspd10 / (cori*znt(i)) + brcr_sbro(i) = min(0.16*(1.e-7*ross)**(-0.18),.3) + endif + enddo +! + do i = its,ite + if(.not.stable(i))then + if((xland(i)-1.5).ge.0)then + brcr(i) = brcr_sbro(i) + else + brcr(i) = brcr_sb + endif + endif + enddo +! + do k = 2,klpbl + do i = its,ite + if(.not.stable(i))then + brdn(i) = brup(i) + spdk2 = max(ux(i,k)**2+vx(i,k)**2,1.) + brup(i) = (thvx(i,k)-thermal(i))*(g*za(i,k)/thvx(i,1))/spdk2 + kpbl(i) = k + stable(i) = brup(i).gt.brcr(i) + endif + enddo + enddo +! + do i = its,ite + if((.not.sfcflg(i)).and.hpbl(i).lt.zq(i,2)) then + k = kpbl(i) + if(brdn(i).ge.brcr(i))then + brint = 0. + elseif(brup(i).le.brcr(i))then + brint = 1. + else + brint = (brcr(i)-brdn(i))/(brup(i)-brdn(i)) + endif + hpbl(i) = za(i,k-1)+brint*(za(i,k)-za(i,k-1)) + if(hpbl(i).lt.zq(i,2)) kpbl(i) = 1 + if(kpbl(i).le.1) pblflg(i) = .false. + endif + enddo +! +! scale dependency for nonlocal momentum and moisture transport +! + do i = its,ite + pu1=pu(dx(i),cslen(i)) + pq1=pq(dx(i),cslen(i)) + if(pblflg(i)) then + hgamu(i) = hgamu(i)*pu1 + hgamv(i) = hgamv(i)*pu1 + hgamq(i) = hgamq(i)*pq1 + endif + enddo +! +! estimate the entrainment parameters +! + do i = its,ite + if(pblflg(i)) then + k = kpbl(i) - 1 + prpbl(i) = 1.0 + wm3 = wstar3(i) + 5. * ust3(i) + wm2(i) = wm3**h2 + bfxpbl(i) = -0.15*thvx(i,1)/g*wm3/hpbl(i) + dthvx(i) = max(thvx(i,k+1)-thvx(i,k),tmin) + dthx = max(thx(i,k+1)-thx(i,k),tmin) + dqx = min(qx(i,k+1,1)-qx(i,k,1),0.0) + we(i) = max(bfxpbl(i)/dthvx(i),-sqrt(wm2(i))) + hfxpbl(i) = we(i)*dthx + pq1=pq(dx(i),cslen(i)) + qfxpbl(i) = we(i)*dqx*pq1 +! + pu1=pu(dx(i),cslen(i)) + dux = ux(i,k+1)-ux(i,k) + dvx = vx(i,k+1)-vx(i,k) + if(dux.gt.tmin) then + ufxpbl(i) = max(prpbl(i)*we(i)*dux*pu1,-ust(i)*ust(i)) + elseif(dux.lt.-tmin) then + ufxpbl(i) = min(prpbl(i)*we(i)*dux*pu1,ust(i)*ust(i)) + else + ufxpbl(i) = 0.0 + endif + if(dvx.gt.tmin) then + vfxpbl(i) = max(prpbl(i)*we(i)*dvx*pu1,-ust(i)*ust(i)) + elseif(dvx.lt.-tmin) then + vfxpbl(i) = min(prpbl(i)*we(i)*dvx*pu1,ust(i)*ust(i)) + else + vfxpbl(i) = 0.0 + endif + delb = govrth(i)*d3*hpbl(i) + delta(i) = min(d1*hpbl(i) + d2*wm2(i)/delb,100.) + delb = govrth(i)*dthvx(i) + deltaoh(i) = d1*hpbl(i) + d2*wm2(i)/delb + deltaoh(i) = max(ezfac*deltaoh(i),hpbl(i)-za(i,kpbl(i)-1)-1.) + deltaoh(i) = min(deltaoh(i) ,hpbl(i)) + rigs(i) = govrth(i)*dthvx(i)*deltaoh(i)/(dux**2.+dvx**2.) + rigs(i) = max(min(rigs(i), rigsmax),rimin) + enlfrac2(i) = max(min(wm3/wstar3(i)/(1.+cpent/rigs(i)),entfmax), entfmin) + enlfrac2(i) = enlfrac2(i)*enlfrac + endif + enddo +! + do k = kts,klpbl + do i = its,ite + if(pblflg(i))then + entfacmf(i,k) = sqrt(((zq(i,k+1)-hpbl(i))/deltaoh(i))**2.) + endif + if(pblflg(i).and.k.ge.kpbl(i))then + entfac(i,k) = ((zq(i,k+1)-hpbl(i))/deltaoh(i))**2. + else + entfac(i,k) = 1.e30 + endif + enddo + enddo +! +! compute diffusion coefficients below pbl +! + do k = kts,klpbl + do i = its,ite + if(k.lt.kpbl(i)) then + zfac(i,k) = min(max((1.-(zq(i,k+1)-zl1(i))/(hpbl(i)-zl1(i))),zfmin),1.) + zfacent(i,k) = (1.-zfac(i,k))**3. + wscalek(i,k) = (ust3(i)+phifac*karman*wstar3(i)*(1.-zfac(i,k)))**h1 + if(sfcflg(i)) then + prfac = conpr + prfac2 = 15.9*wstar3(i)/ust3(i)/(1.+4.*karman*wstar3(i)/ust3(i)) + prnumfac = -3.*(max(zq(i,k+1)-sfcfrac*hpbl(i),0.))**2./hpbl(i)**2. + else + prfac = 0. + prfac2 = 0. + prnumfac = 0. + phim8z = 1.+aphi5*zol1(i)*zq(i,k+1)/zl1(i) + wscalek(i,k) = ust(i)/phim8z + wscalek(i,k) = max(wscalek(i,k),0.001) + endif + prnum0 = (phih(i)/phim(i)+prfac) + prnum0 = max(min(prnum0,prmax),prmin) + xkzm(i,k) = wscalek(i,k)*karman*zq(i,k+1)*zfac(i,k)**pfac + prnum = 1. + (prnum0-1.)*exp(prnumfac) + xkzq(i,k) = xkzm(i,k)/prnum*zfac(i,k)**(pfac_q-pfac) + prnum0 = prnum0/(1.+prfac2*karman*sfcfrac) + prnum = 1. + (prnum0-1.)*exp(prnumfac) + xkzh(i,k) = xkzm(i,k)/prnum + xkzm(i,k) = xkzm(i,k)+xkzom(i,k) + xkzh(i,k) = xkzh(i,k)+xkzoh(i,k) + xkzq(i,k) = xkzq(i,k)+xkzoh(i,k) + xkzm(i,k) = min(xkzm(i,k),xkzmax) + xkzh(i,k) = min(xkzh(i,k),xkzmax) + xkzq(i,k) = min(xkzq(i,k),xkzmax) + endif + enddo + enddo +! +! compute diffusion coefficients over pbl (free atmosphere) +! + do k = kts,kte-1 + do i = its,ite + if(k.ge.kpbl(i)) then + ss = ((ux(i,k+1)-ux(i,k))*(ux(i,k+1)-ux(i,k)) & + +(vx(i,k+1)-vx(i,k))*(vx(i,k+1)-vx(i,k))) & + /(dza(i,k+1)*dza(i,k+1))+1.e-9 + govrthv = g/(0.5*(thvx(i,k+1)+thvx(i,k))) + ri = govrthv*(thvx(i,k+1)-thvx(i,k))/(ss*dza(i,k+1)) +! in cloud + if(imvdif.eq.1.and.ntcw.ge.2.and.ntiw.ge.2)then + if((qx(i,k,ntcw)+qx(i,k,ntiw)).gt.0.01e-3 & + .and.(qx(i,k+1,ntcw)+qx(i,k+1,ntiw)).gt.0.01e-3) then + qmean = 0.5*(qx(i,k,1)+qx(i,k+1,1)) + tmean = 0.5*(tx(i,k)+tx(i,k+1)) + alpha = xlv*qmean/rd/tmean + chi = xlv*xlv*qmean/cp/rv/tmean/tmean + ri = (1.+alpha)*(ri-g*g/ss/tmean/cp*((chi-alpha)/(1.+chi))) + endif + endif + zk = karman*zq(i,k+1) + rlamdz = min(max(0.1*dza(i,k+1),rlam),300.) + rlamdz = min(dza(i,k+1),rlamdz) + rl2 = (zk*rlamdz/(rlamdz+zk))**2 + dk = rl2*sqrt(ss) + if(ri.lt.0.)then +! unstable regime + ri = max(ri, rimin) + sri = sqrt(-ri) + xkzm(i,k) = dk*(1+8.*(-ri)/(1+1.746*sri)) + xkzh(i,k) = dk*(1+8.*(-ri)/(1+1.286*sri)) + else +! stable regime + xkzh(i,k) = dk/(1+5.*ri)**2 + prnum = 1.0+2.1*ri + prnum = min(prnum,prmax) + xkzm(i,k) = xkzh(i,k)*prnum + endif +! + xkzm(i,k) = xkzm(i,k)+xkzom(i,k) + xkzh(i,k) = xkzh(i,k)+xkzoh(i,k) + xkzm(i,k) = min(xkzm(i,k),xkzmax) + xkzh(i,k) = min(xkzh(i,k),xkzmax) + xkzml(i,k) = xkzm(i,k) + xkzhl(i,k) = xkzh(i,k) + endif + enddo + enddo +! +! prescribe nonlocal heat transport below pbl +! + do i = its,ite + deltaoh(i) = deltaoh(i)/hpbl(i) + enddo +! + do i = its,ite + mlfrac = mltop-deltaoh(i) + ezfrac = mltop+deltaoh(i) + zfacmf(i,1) = min(max((zq(i,2)/hpbl(i)),zfmin),1.) + sfcfracn = max(sfcfracn1,zfacmf(i,1)) +! + sflux0 = (a11+a12*sfcfracn)*sflux(i) + snlflux0 = nlfrac*sflux0 + amf1 = snlflux0/sfcfracn + amf2 = -snlflux0/(mlfrac-sfcfracn) + bmf2 = -mlfrac*amf2 + amf3 = snlflux0*enlfrac2(i)/deltaoh(i) + bmf3 = -amf3*mlfrac + hfxpbl(i) = amf3+bmf3 + pth1=pthnl(dx(i),cslen(i)) + hfxpbl(i) = hfxpbl(i)*pth1 +! + do k = kts,klpbl + zfacmf(i,k) = max((zq(i,k+1)/hpbl(i)),zfmin) + if(pblflg(i).and.k.lt.kpbl(i)) then + if(zfacmf(i,k).le.sfcfracn) then + mf(i,k) = amf1*zfacmf(i,k) + else if (zfacmf(i,k).le.mlfrac) then + mf(i,k) = amf2*zfacmf(i,k)+bmf2 + endif + mf(i,k) = mf(i,k)+hfxpbl(i)*exp(-entfacmf(i,k)) + mf(i,k) = mf(i,k)*pth1 + endif + enddo + enddo +! +! compute tridiagonal matrix elements for heat +! + do k = kts,kte + do i = its,ite + au(i,k) = 0. + al(i,k) = 0. + ad(i,k) = 0. + f1(i,k) = 0. + enddo + enddo +! + do i = its,ite + ad(i,1) = 1. + f1(i,1) = thx(i,1)-300.+hfx(i)/cont/del(i,1)*dt2 + enddo +! + do k = kts,kte-1 + do i = its,ite + dtodsd = dt2/del(i,k) + dtodsu = dt2/del(i,k+1) + dsig = p2d(i,k)-p2d(i,k+1) + rdz = 1./dza(i,k+1) + tem1 = dsig*xkzh(i,k)*rdz + if(pblflg(i).and.k.lt.kpbl(i)) then + dsdzt = tem1*(-mf(i,k)/xkzh(i,k)) + f1(i,k) = f1(i,k)+dtodsd*dsdzt + f1(i,k+1) = thx(i,k+1)-300.-dtodsu*dsdzt + elseif(pblflg(i).and.k.ge.kpbl(i).and.entfac(i,k).lt.4.6) then + xkzh(i,k) = -we(i)*dza(i,kpbl(i))*exp(-entfac(i,k)) + xkzh(i,k) = sqrt(xkzh(i,k)*xkzhl(i,k)) + xkzh(i,k) = max(xkzh(i,k),xkzoh(i,k)) + xkzh(i,k) = min(xkzh(i,k),xkzmax) + f1(i,k+1) = thx(i,k+1)-300. + else + f1(i,k+1) = thx(i,k+1)-300. + endif + tem1 = dsig*xkzh(i,k)*rdz + dsdz2 = tem1*rdz + au(i,k) = -dtodsd*dsdz2 + al(i,k) = -dtodsu*dsdz2 +! +! scale dependency for local heat transport +! + zfacdx=0.2*hpbl(i)/zq(i,k+1) + delxy=dx(i)*max(zfacdx,1.0) + pth1=pthl(delxy,hpbl(i)) + if(pblflg(i).and.k.lt.kpbl(i)) then + au(i,k) = au(i,k)*pth1 + al(i,k) = al(i,k)*pth1 + endif + ad(i,k) = ad(i,k)-au(i,k) + ad(i,k+1) = 1.-al(i,k) + enddo + enddo +! +! copies here to avoid duplicate input args for tridin +! + do k = kts,kte + do i = its,ite + cu(i,k) = au(i,k) + r1(i,k) = f1(i,k) + enddo + enddo +! + call tridin_ysu(al,ad,cu,r1,au,f1,its,ite,kts,kte,1) +! +! recover tendencies of heat +! + do k = kte,kts,-1 + do i = its,ite + ttend = (f1(i,k)-thx(i,k)+300.)*rdt*pi2d(i,k) + ttnp(i,k) = ttnp(i,k)+ttend + dtsfc(i) = dtsfc(i)+ttend*cont*del(i,k) + if(k.eq.kte) then + tflux_e(i,k) = ttend*dz8w2d(i,k) + else + tflux_e(i,k) = tflux_e(i,k+1) + ttend*dz8w2d(i,k) + endif + enddo + enddo +! +! compute tridiagonal matrix elements for moisture, clouds, and gases +! + do k = kts,kte + do i = its,ite + au(i,k) = 0. + al(i,k) = 0. + ad(i,k) = 0. + enddo + enddo +! + do ic = 1,ndiff + do i = its,ite + do k = kts,kte + f3(i,k,ic) = 0. + enddo + enddo + enddo +! + do i = its,ite + ad(i,1) = 1. + f3(i,1,1) = qx(i,1,1)+qfx(i)*g/del(i,1)*dt2 + enddo +! + if(ndiff.ge.2) then + do ic = 2,ndiff + do i = its,ite + f3(i,1,ic) = qx(i,1,ic) + enddo + enddo + endif +! + do k = kts,kte-1 + do i = its,ite + if(k.ge.kpbl(i)) then + xkzq(i,k) = xkzh(i,k) + endif + enddo + enddo +! + do k = kts,kte-1 + do i = its,ite + dtodsd = dt2/del(i,k) + dtodsu = dt2/del(i,k+1) + dsig = p2d(i,k)-p2d(i,k+1) + rdz = 1./dza(i,k+1) + tem1 = dsig*xkzq(i,k)*rdz + if(pblflg(i).and.k.lt.kpbl(i)) then + dsdzq = tem1*(-qfxpbl(i)*zfacent(i,k)/xkzq(i,k)) + f3(i,k,1) = f3(i,k,1)+dtodsd*dsdzq + f3(i,k+1,1) = qx(i,k+1,1)-dtodsu*dsdzq + elseif(pblflg(i).and.k.ge.kpbl(i).and.entfac(i,k).lt.4.6) then + xkzq(i,k) = -we(i)*dza(i,kpbl(i))*exp(-entfac(i,k)) + xkzq(i,k) = sqrt(xkzq(i,k)*xkzhl(i,k)) + xkzq(i,k) = max(xkzq(i,k),xkzoh(i,k)) + xkzq(i,k) = min(xkzq(i,k),xkzmax) + f3(i,k+1,1) = qx(i,k+1,1) + else + f3(i,k+1,1) = qx(i,k+1,1) + endif + tem1 = dsig*xkzq(i,k)*rdz + dsdz2 = tem1*rdz + au(i,k) = -dtodsd*dsdz2 + al(i,k) = -dtodsu*dsdz2 +! +! scale dependency for local moisture transport +! + zfacdx=0.2*hpbl(i)/zq(i,k+1) + delxy=dx(i)*max(zfacdx,1.0) + pq1=pq(delxy,hpbl(i)) + if(pblflg(i).and.k.lt.kpbl(i)) then + au(i,k) = au(i,k)*pq1 + al(i,k) = al(i,k)*pq1 + endif + ad(i,k) = ad(i,k)-au(i,k) + ad(i,k+1) = 1.-al(i,k) + enddo + enddo +! + if(ndiff.ge.2) then + do ic = 2,ndiff + do k = kts,kte-1 + do i = its,ite + f3(i,k+1,ic) = qx(i,k+1,ic) + enddo + enddo + enddo + endif +! +! copies here to avoid duplicate input args for tridin +! + do k = kts,kte + do i = its,ite + cu(i,k) = au(i,k) + enddo + enddo +! + do ic = 1,ndiff + do k = kts,kte + do i = its,ite + r3(i,k,ic) = f3(i,k,ic) + enddo + enddo + enddo +! +! solve tridiagonal problem for moisture, clouds, and gases +! + call tridin_ysu(al,ad,cu,r3,au,f3,its,ite,kts,kte,ndiff) +! +! recover tendencies of heat and moisture +! + do k = kte,kts,-1 + do i = its,ite + qtend = (f3(i,k,1)-qx(i,k,1))*rdt + qtnp(i,k,1) = qtnp(i,k,1)+qtend + dqsfc(i) = dqsfc(i)+qtend*conq*del(i,k) + if(k.eq.kte) then + qflux_e(i,k) = qtend*dz8w2d(i,k) + else + qflux_e(i,k) = qflux_e(i,k+1) + qtend*dz8w2d(i,k) + endif + tvflux_e(i,k) = tflux_e(i,k) + qflux_e(i,k)*ep1*thx(i,k) + enddo + enddo +! print*,"qtnp:",maxval(qtnp(:,:,1)),minval(qtnp(:,:,1)) +! + do k = kts,kte + do i = its,ite + if(pblflg(i).and.k.lt.kpbl(i)) then + hgame_c=c_1*0.2*2.5*(g/thvx(i,k))*wstar(i)/(0.25*(q2x(i,k+1)+q2x(i,k))) + hgame_c=min(hgame_c,gamcre) + if(k.eq.kte)then + hgame2d(i,k)=hgame_c*0.5*tvflux_e(i,k)*hpbl(i) + hgame2d(i,k)=max(hgame2d(i,k),0.0) + else + hgame2d(i,k)=hgame_c*0.5*(tvflux_e(i,k)+tvflux_e(i,k+1))*hpbl(i) + hgame2d(i,k)=max(hgame2d(i,k),0.0) + endif + endif + enddo + enddo +! + if(ndiff.ge.2) then + do ic = 2,ndiff + if(ifvmix(ic)) then + do k = kte,kts,-1 + do i = its,ite + qtend = (f3(i,k,ic)-qx(i,k,ic))*rdt + qtnp(i,k,ic) = qtnp(i,k,ic)+qtend + enddo + enddo + endif + enddo + endif +! +! compute tridiagonal matrix elements for momentum +! + do i = its,ite + do k = kts,kte + au(i,k) = 0. + al(i,k) = 0. + ad(i,k) = 0. + f1(i,k) = 0. + f2(i,k) = 0. + enddo + enddo +! + do i = its,ite + ad(i,1) = 1.+ust(i)**2/wspd1(i)*rhox(i)*g/del(i,1)*dt2 & + *(wspd1(i)/wspd(i))**2 + f1(i,1) = ux(i,1) + f2(i,1) = vx(i,1) + enddo +! + do k = kts,kte-1 + do i = its,ite + dtodsd = dt2/del(i,k) + dtodsu = dt2/del(i,k+1) + dsig = p2d(i,k)-p2d(i,k+1) + rdz = 1./dza(i,k+1) + tem1 = dsig*xkzm(i,k)*rdz + if(pblflg(i).and.k.lt.kpbl(i))then + dsdzu = tem1*(-hgamu(i)/hpbl(i)-ufxpbl(i)*zfacent(i,k)/xkzm(i,k)) + dsdzv = tem1*(-hgamv(i)/hpbl(i)-vfxpbl(i)*zfacent(i,k)/xkzm(i,k)) + f1(i,k) = f1(i,k)+dtodsd*dsdzu + f1(i,k+1) = ux(i,k+1)-dtodsu*dsdzu + f2(i,k) = f2(i,k)+dtodsd*dsdzv + f2(i,k+1) = vx(i,k+1)-dtodsu*dsdzv + elseif(pblflg(i).and.k.ge.kpbl(i).and.entfac(i,k).lt.4.6) then + xkzm(i,k) = prpbl(i)*xkzh(i,k) + xkzm(i,k) = sqrt(xkzm(i,k)*xkzml(i,k)) + xkzm(i,k) = max(xkzm(i,k),xkzom(i,k)) + xkzm(i,k) = min(xkzm(i,k),xkzmax) + f1(i,k+1) = ux(i,k+1) + f2(i,k+1) = vx(i,k+1) + else + f1(i,k+1) = ux(i,k+1) + f2(i,k+1) = vx(i,k+1) + endif + tem1 = dsig*xkzm(i,k)*rdz + dsdz2 = tem1*rdz + au(i,k) = -dtodsd*dsdz2 + al(i,k) = -dtodsu*dsdz2 +! +! scale dependency for local momentum transport +! + zfacdx=0.2*hpbl(i)/zq(i,k+1) + delxy=dx(i)*max(zfacdx,1.0) + pu1=pu(delxy,hpbl(i)) + if(pblflg(i).and.k.lt.kpbl(i)) then + au(i,k) = au(i,k)*pu1 + al(i,k) = al(i,k)*pu1 + endif + ad(i,k) = ad(i,k)-au(i,k) + ad(i,k+1) = 1.-al(i,k) + enddo + enddo +! +! copies here to avoid duplicate input args for tridin +! + do k = kts,kte + do i = its,ite + cu(i,k) = au(i,k) + r1(i,k) = f1(i,k) + r2(i,k) = f2(i,k) + enddo + enddo +! +! solve tridiagonal problem for momentum +! + call tridi1n(al,ad,cu,r1,r2,au,f1,f2,its,ite,kts,kte,1) +! +! recover tendencies of momentum +! + do k = kte,kts,-1 + do i = its,ite + utend = (f1(i,k)-ux(i,k))*rdt + vtend = (f2(i,k)-vx(i,k))*rdt + utnp(i,k) = utnp(i,k)+utend + vtnp(i,k) = vtnp(i,k)+vtend + dusfc(i) = dusfc(i) + utend*conwrc*del(i,k) + dvsfc(i) = dvsfc(i) + vtend*conwrc*del(i,k) + enddo + enddo +! + do i = its,ite + kpbl1d(i) = kpbl(i) + enddo +! +!---- calculate sgs tke which is consistent with shinhongpbl algorithm +! + if (shinhong_tke_diag.eq.1) then +! + tke_calculation: do i = its,ite + do k = kts+1,kte + s2(k) = 0.0 + gh(k) = 0.0 + rig(k) = 0.0 + el(k) = 0.0 + akmk(k) = 0.0 + akhk(k) = 0.0 + mfk(k) = 0.0 + ufxpblk(k) = 0.0 + vfxpblk(k) = 0.0 + qfxpblk(k) = 0.0 + enddo +! + do k = kts,kte + uxk(k) = 0.0 + vxk(k) = 0.0 + txk(k) = 0.0 + thxk(k) = 0.0 + thvxk(k) = 0.0 + q2xk(k) = 0.0 + hgame(k) = 0.0 + ps1d(k) = 0.0 + pb1d(k) = 0.0 + eps1d(k) = 0.0 + pt1d(k) = 0.0 + xkze1d(k) = 0.0 + eflx_l1d(k) = 0.0 + eflx_nl1d(k) = 0.0 + ptke1(k) = 1.0 + enddo +! + do k = kts,kte+1 + zqk(k) = 0.0 + enddo +! + do k = kts,kte + uxk(k) = ux(i,k) + vxk(k) = vx(i,k) + txk(k) = tx(i,k) + thxk(k) = thx(i,k) + thvxk(k) = thvx(i,k) + q2xk(k) = q2x(i,k) + hgame(k) = hgame2d(i,k) + enddo +! + do k = kts,kte-1 + if(pblflg(i).and.k.le.kpbl(i)) then + zfacdx = 0.2*hpbl(i)/za(i,k) + delxy = dx(i)*max(zfacdx,1.0) + ptke1(k+1) = ptke(delxy,hpbl(i)) + endif + enddo +! + do k = kts,kte+1 + zqk(k) = zq(i,k) + enddo +! + do k = kts+1,kte + akmk(k) = xkzm(i,k-1) + akhk(k) = xkzh(i,k-1) + mfk(k) = mf(i,k-1)/xkzh(i,k-1) + ufxpblk(k) = ufxpbl(i)*zfacent(i,k-1)/xkzm(i,k-1) + vfxpblk(k) = vfxpbl(i)*zfacent(i,k-1)/xkzm(i,k-1) + qfxpblk(k) = qfxpbl(i)*zfacent(i,k-1)/xkzq(i,k-1) + enddo +! + if(pblflg(i)) then + k = kpbl(i) - 1 + dex = 0.25*(q2xk(k+2)-q2xk(k)) + efxpbl(i) = we(i)*dex + endif +! +!---- find the mixing length +! + call mixlen(lmh,uxk,vxk,txk,thxk,qx(i,kts,1),qx(i,kts,ntcw) & + ,q2xk,zqk,ust(i),corf,epshol(i) & + ,s2,gh,rig,el & + ,hpbl(i),kpbl(i),lmxl,ct(i) & + ,hgamu(i),hgamv(i),hgamq(i),pblflg(i) & + ,mfk,ufxpblk,vfxpblk,qfxpblk & + ,ep1,karman,cp & + ,kts,kte ) +! +!---- solve for the production/dissipation of the turbulent kinetic energy +! + call prodq2(lmh,dt,ust(i),s2,rig,q2xk,el,zqk,akmk,akhk & + ,uxk,vxk,thxk,thvxk & + ,hgamu(i),hgamv(i),hgamq(i),dx(i) & + ,hpbl(i),pblflg(i),kpbl(i) & + ,mfk,ufxpblk,vfxpblk,qfxpblk & + ,ep1 & + ,kts,kte ) +! +! +!---- carry out the vertical diffusion of turbulent kinetic energy +! + call vdifq(lmh,dt,q2xk,el,zqk & + ,akhk,ptke1 & + ,hgame,hpbl(i),pblflg(i),kpbl(i) & + ,efxpbl(i) & + ,kts,kte ) +! +!---- save the new tke and mixing length. +! + do k = kts,kte + q2x(i,k) = amax1(q2xk(k),epsq2l) + enddo +! + enddo tke_calculation + endif +! +!---- end of tke calculation +! +! +!---- end of vertical diffusion +! + end subroutine shinhongvdif_run +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + subroutine tridi1n(cl,cm,cu,r1,r2,au,f1,f2,its,ite,kts,kte,nt) +!------------------------------------------------------------------------------- + use machine , only : kind_phys + implicit none +!------------------------------------------------------------------------------- +! + integer, intent(in ) :: its,ite, kts,kte, nt +! + real(kind=kind_phys), dimension( its:ite, kts+1:kte+1 ) , & + intent(in ) :: cl +! + real(kind=kind_phys), dimension( its:ite, kts:kte ) , & + intent(in ) :: cm, & + r1 + real(kind=kind_phys), dimension( its:ite, kts:kte,nt ) , & + intent(in ) :: r2 +! + real(kind=kind_phys), dimension( its:ite, kts:kte ) , & + intent(inout) :: au, & + cu, & + f1 + real(kind=kind_phys), dimension( its:ite, kts:kte,nt ) , & + intent(inout) :: f2 +! + real(kind=kind_phys) :: fk + integer :: i,k,l,n,it +! +!------------------------------------------------------------------------------- +! + l = ite + n = kte +! + do i = its,l + fk = 1./cm(i,1) + au(i,1) = fk*cu(i,1) + f1(i,1) = fk*r1(i,1) + enddo +! + do it = 1,nt + do i = its,l + fk = 1./cm(i,1) + f2(i,1,it) = fk*r2(i,1,it) + enddo + enddo +! + do k = kts+1,n-1 + do i = its,l + fk = 1./(cm(i,k)-cl(i,k)*au(i,k-1)) + au(i,k) = fk*cu(i,k) + f1(i,k) = fk*(r1(i,k)-cl(i,k)*f1(i,k-1)) + enddo + enddo +! + do it = 1,nt + do k = kts+1,n-1 + do i = its,l + fk = 1./(cm(i,k)-cl(i,k)*au(i,k-1)) + f2(i,k,it) = fk*(r2(i,k,it)-cl(i,k)*f2(i,k-1,it)) + enddo + enddo + enddo +! + do i = its,l + fk = 1./(cm(i,n)-cl(i,n)*au(i,n-1)) + f1(i,n) = fk*(r1(i,n)-cl(i,n)*f1(i,n-1)) + enddo +! + do it = 1,nt + do i = its,l + fk = 1./(cm(i,n)-cl(i,n)*au(i,n-1)) + f2(i,n,it) = fk*(r2(i,n,it)-cl(i,n)*f2(i,n-1,it)) + enddo + enddo +! + do k = n-1,kts,-1 + do i = its,l + f1(i,k) = f1(i,k)-au(i,k)*f1(i,k+1) + enddo + enddo +! + do it = 1,nt + do k = n-1,kts,-1 + do i = its,l + f2(i,k,it) = f2(i,k,it)-au(i,k)*f2(i,k+1,it) + enddo + enddo + enddo +! + end subroutine tridi1n +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + subroutine tridin_ysu(cl,cm,cu,r2,au,f2,its,ite,kts,kte,nt) +!------------------------------------------------------------------------------- + use machine , only : kind_phys + implicit none +!------------------------------------------------------------------------------- +! + integer, intent(in ) :: its,ite, kts,kte, nt +! + real(kind=kind_phys), dimension( its:ite, kts+1:kte+1 ) , & + intent(in ) :: cl +! + real(kind=kind_phys), dimension( its:ite, kts:kte ) , & + intent(in ) :: cm + real(kind=kind_phys), dimension( its:ite, kts:kte,nt ) , & + intent(in ) :: r2 +! + real(kind=kind_phys), dimension( its:ite, kts:kte ) , & + intent(inout) :: au, & + cu + real(kind=kind_phys), dimension( its:ite, kts:kte,nt ) , & + intent(inout) :: f2 +! + real(kind=kind_phys) :: fk + integer :: i,k,l,n,it +! +!------------------------------------------------------------------------------- +! + l = ite + n = kte +! + do it = 1,nt + do i = its,l + fk = 1./cm(i,1) + au(i,1) = fk*cu(i,1) + f2(i,1,it) = fk*r2(i,1,it) + enddo + enddo +! + do it = 1,nt + do k = kts+1,n-1 + do i = its,l + fk = 1./(cm(i,k)-cl(i,k)*au(i,k-1)) + au(i,k) = fk*cu(i,k) + f2(i,k,it) = fk*(r2(i,k,it)-cl(i,k)*f2(i,k-1,it)) + enddo + enddo + enddo +! + do it = 1,nt + do i = its,l + fk = 1./(cm(i,n)-cl(i,n)*au(i,n-1)) + f2(i,n,it) = fk*(r2(i,n,it)-cl(i,n)*f2(i,n-1,it)) + enddo + enddo +! + do it = 1,nt + do k = n-1,kts,-1 + do i = its,l + f2(i,k,it) = f2(i,k,it)-au(i,k)*f2(i,k+1,it) + enddo + enddo + enddo +! + end subroutine tridin_ysu +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + subroutine mixlen(lmh,u,v,t,the,q,cwm,q2,z,ustar,corf,epshol, & + s2,gh,ri,el,hpbl,lpbl,lmxl,ct, & + hgamu,hgamv,hgamq,pblflg, & + mf,ufxpbl,vfxpbl,qfxpbl, & + p608,vkarman,cp, & + kts,kte) +!------------------------------------------------------------------------------- + use machine , only : kind_phys + implicit none +!------------------------------------------------------------------------------- +! qnse model constants +!------------------------------------------------------------------------------- + real(kind=kind_phys),parameter :: blckdr=0.0063,cn=0.75 + real(kind=kind_phys),parameter :: eps1=1.e-12,epsl=0.32,epsru=1.e-7,epsrs=1.e-7 + real(kind=kind_phys),parameter :: el0max=1000.,el0min=1.,elfc=0.23*0.5 + real(kind=kind_phys),parameter :: alph=0.30,beta=1./273.,g=9.81,btg=beta*g + real(kind=kind_phys),parameter :: a1=0.659888514560862645,a2x=0.6574209922667784586 + real(kind=kind_phys),parameter :: b1=11.87799326209552761,b2=7.226971804046074028 + real(kind=kind_phys),parameter :: c1=0.000830955950095854396 + real(kind=kind_phys),parameter :: adnh= 9.*a1*a2x*a2x*(12.*a1+3.*b2)*btg*btg + real(kind=kind_phys),parameter :: adnm=18.*a1*a1*a2x*(b2-3.*a2x)*btg + real(kind=kind_phys),parameter :: bdnh= 3.*a2x*(7.*a1+b2)*btg,bdnm= 6.*a1*a1 +!------------------------------------------------------------------------------- +! free term in the equilibrium equation for (l/q)**2 +!------------------------------------------------------------------------------- + real(kind=kind_phys),parameter :: aeqh=9.*a1*a2x*a2x*b1*btg*btg & + +9.*a1*a2x*a2x*(12.*a1+3.*b2)*btg*btg + real(kind=kind_phys),parameter :: aeqm=3.*a1*a2x*b1*(3.*a2x+3.*b2*c1+18.*a1*c1-b2) & + *btg+18.*a1*a1*a2x*(b2-3.*a2x)*btg +!------------------------------------------------------------------------------- +! forbidden turbulence area +!------------------------------------------------------------------------------- + real(kind=kind_phys),parameter :: requ=-aeqh/aeqm + real(kind=kind_phys),parameter :: epsgh=1.e-9,epsgm=requ*epsgh +!------------------------------------------------------------------------------- +! near isotropy for shear turbulence, ww/q2 lower limit +!------------------------------------------------------------------------------- + real(kind=kind_phys),parameter :: ubryl=(18.*requ*a1*a1*a2x*b2*c1*btg & + +9.*a1*a2x*a2x*b2*btg*btg) & + /(requ*adnm+adnh) + real(kind=kind_phys),parameter :: ubry=(1.+epsrs)*ubryl,ubry3=3.*ubry + real(kind=kind_phys),parameter :: aubh=27.*a1*a2x*a2x*b2*btg*btg-adnh*ubry3 + real(kind=kind_phys),parameter :: aubm=54.*a1*a1*a2x*b2*c1*btg -adnm*ubry3 + real(kind=kind_phys),parameter :: bubh=(9.*a1*a2x+3.*a2x*b2)*btg-bdnh*ubry3 + real(kind=kind_phys),parameter :: bubm=18.*a1*a1*c1 -bdnm*ubry3 + real(kind=kind_phys),parameter :: cubr=1.-ubry3,rcubr=1./cubr +!------------------------------------------------------------------------------- +! k profile constants +!------------------------------------------------------------------------------- + real(kind=kind_phys),parameter :: elcbl=0.77 +!------------------------------------------------------------------------------- +! + integer, intent(in ) :: kts,kte + integer, intent(in ) :: lmh,lmxl,lpbl +! + real(kind=kind_phys), intent(in ) :: p608,vkarman,cp + real(kind=kind_phys), intent(in ) :: hpbl,corf,ustar,hgamu,hgamv,hgamq + real(kind=kind_phys), intent(inout) :: ct,epshol +! + real(kind=kind_phys), dimension( kts:kte ) , & + intent(in ) :: cwm, & + q, & + q2, & + t, & + the, & + u, & + v +! + real(kind=kind_phys), dimension( kts+1:kte ) , & + intent(in ) :: mf, & + ufxpbl, & + vfxpbl, & + qfxpbl +! + real(kind=kind_phys), dimension( kts:kte+1 ) , & + intent(in ) :: z +! + real(kind=kind_phys), dimension( kts+1:kte ) , & + intent(out ) :: el, & + ri, & + gh, & + s2 +! + logical,intent(in) :: pblflg +! +! local vars +! + integer :: k,lpblm + real(kind=kind_phys) :: suk,svk,elocp + real(kind=kind_phys) :: a,aden,b,bden,aubr,bubr,blmx,el0,eloq2x,ghl,s2l, & + qol2st,qol2un,qdzl,rdz,sq,srel,szq,tem,thm,vkrmz,rlambda, & + rlb,rln,f + real(kind=kind_phys) :: ckp + real(kind=kind_phys), dimension( kts:kte ) :: q1, & + en2 + real(kind=kind_phys), dimension( kts+1:kte ) :: dth, & + elm, & + rel +! +!------------------------------------------------------------------------------- +! + elocp=2.72e6/cp + ct=0. +! + do k = kts,kte + q1(k) = 0. + enddo +! + do k = kts+1,kte + dth(k) = the(k)-the(k-1) + enddo +! + do k = kts+2,kte + if(dth(k)>0..and.dth(k-1)<=0.)then + dth(k)=dth(k)+ct + exit + endif + enddo +! +! compute local gradient richardson number +! + do k = kte,kts+1,-1 + rdz=2./(z(k+1)-z(k-1)) + s2l=((u(k)-u(k-1))**2+(v(k)-v(k-1))**2)*rdz*rdz ! s**2 + if(pblflg.and.k.le.lpbl)then + suk=(u(k)-u(k-1))*rdz + svk=(v(k)-v(k-1))*rdz + s2l=(suk-hgamu/hpbl-ufxpbl(k))*suk+(svk-hgamv/hpbl-vfxpbl(k))*svk + endif + s2l=max(s2l,epsgm) + s2(k)=s2l +! + tem=(t(k)+t(k-1))*0.5 + thm=(the(k)+the(k-1))*0.5 + a=thm*p608 + b=(elocp/tem-1.-p608)*thm + ghl=(dth(k)*((q(k)+q(k-1)+cwm(k)+cwm(k-1))*(0.5*p608)+1.) & + +(q(k)-q(k-1)+cwm(k)-cwm(k-1))*a & + +(cwm(k)-cwm(k-1))*b)*rdz ! dtheta/dz + if(pblflg.and.k.le.lpbl)then + ghl=ghl-mf(k)-(hgamq/hpbl+qfxpbl(k))*a + endif + if(abs(ghl)<=epsgh)ghl=epsgh +! + en2(k)=ghl*g/thm ! n**2 + gh(k)=ghl + ri(k)=en2(k)/s2l + enddo +! +! find maximum mixing lengths and the level of the pbl top +! + do k = kte,kts+1,-1 + s2l=s2(k) + ghl=gh(k) + if(ghl>=epsgh)then + if(s2l/ghl<=requ)then + elm(k)=epsl + else + aubr=(aubm*s2l+aubh*ghl)*ghl + bubr= bubm*s2l+bubh*ghl + qol2st=(-0.5*bubr+sqrt(bubr*bubr*0.25-aubr*cubr))*rcubr + eloq2x=1./qol2st + elm(k)=max(sqrt(eloq2x*q2(k)),epsl) + endif + else + aden=(adnm*s2l+adnh*ghl)*ghl + bden= bdnm*s2l+bdnh*ghl + qol2un=-0.5*bden+sqrt(bden*bden*0.25-aden) + eloq2x=1./(qol2un+epsru) ! repsr1/qol2un + elm(k)=max(sqrt(eloq2x*q2(k)),epsl) + endif + enddo +! + do k = lpbl,lmh,-1 + q1(k)=sqrt(q2(k)) + enddo +! + szq=0. + sq =0. + do k = kte,kts+1,-1 + qdzl=(q1(k)+q1(k-1))*(z(k)-z(k-1)) + szq=(z(k)+z(k-1)-z(lmh)-z(lmh))*qdzl+szq + sq=qdzl+sq + enddo +! +! computation of asymptotic l in blackadar formula +! + el0=min(alph*szq*0.5/sq,el0max) + el0=max(el0 ,el0min) +! +! above the pbl top +! + lpblm=min(lpbl+1,kte) + do k = kte,lpblm,-1 + el(k)=(z(k+1)-z(k-1))*elfc + rel(k)=el(k)/elm(k) + enddo +! +! inside the pbl +! + epshol=min(epshol,0.0) + ckp=elcbl*((1.0-8.0*epshol)**(1./3.)) + if(lpbl>lmh)then + do k = lpbl,lmh+1,-1 + vkrmz=(z(k)-z(lmh))*vkarman + if(pblflg) then + vkrmz=ckp*(z(k)-z(lmh))*vkarman + el(k)=vkrmz/(vkrmz/el0+1.) + else + el(k)=vkrmz/(vkrmz/el0+1.) + endif + rel(k)=el(k)/elm(k) + enddo + endif +! + do k = lpbl-1,lmh+2,-1 + srel=min(((rel(k-1)+rel(k+1))*0.5+rel(k))*0.5,rel(k)) + el(k)=max(srel*elm(k),epsl) + enddo +! +! mixing length for the qnse model in stable case +! + f=max(corf,eps1) + rlambda=f/(blckdr*ustar) + do k = kte,kts+1,-1 + if(en2(k)>=0.0)then ! stable case + vkrmz=(z(k)-z(lmh))*vkarman + rlb=rlambda+1./vkrmz + rln=sqrt(2.*en2(k)/q2(k))/cn + el(k)=1./(rlb+rln) + endif + enddo +! + end subroutine mixlen +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + subroutine prodq2(lmh,dtturbl,ustar,s2,ri,q2,el,z,akm,akh, & + uxk,vxk,thxk,thvxk, & + hgamu,hgamv,hgamq,delxy, & + hpbl,pblflg,kpbl, & + mf,ufxpbl,vfxpbl,qfxpbl, & + p608, & + kts,kte) +!------------------------------------------------------------------------------- + use machine , only : kind_phys + implicit none +!------------------------------------------------------------------------------- +! + real(kind=kind_phys),parameter :: epsq2l = 0.01,c0 = 0.55,ceps = 16.6,g = 9.81 +! + integer, intent(in ) :: kts,kte + integer, intent(in ) :: lmh,kpbl +! + real(kind=kind_phys), intent(in ) :: p608,dtturbl,ustar + real(kind=kind_phys), intent(in ) :: hgamu,hgamv,hgamq,delxy,hpbl +! + logical, intent(in ) :: pblflg +! + real(kind=kind_phys), dimension( kts:kte ) , & + intent(in ) :: uxk, & + vxk, & + thxk, & + thvxk + real(kind=kind_phys), dimension( kts+1:kte ) , & + intent(in ) :: s2, & + ri, & + akm, & + akh, & + el, & + mf, & + ufxpbl, & + vfxpbl, & + qfxpbl +! + real(kind=kind_phys), dimension( kts:kte+1 ) , & + intent(in ) :: z +! + real(kind=kind_phys), dimension( kts:kte ) , & + intent(inout) :: q2 +! +! local vars +! + integer :: k +! + real(kind=kind_phys) :: s2l,q2l,deltaz,akml,akhl,en2,pr,bpr,dis,rc02 + real(kind=kind_phys) :: suk,svk,gthvk,govrthvk,pru,prv + real(kind=kind_phys) :: thm,disel +! +!------------------------------------------------------------------------------- +! + rc02=2.0/(c0*c0) +! +! start of production/dissipation loop +! + main_integration: do k = kts+1,kte + deltaz=0.5*(z(k+1)-z(k-1)) + s2l=s2(k) + q2l=q2(k) + suk=(uxk(k)-uxk(k-1))/deltaz + svk=(vxk(k)-vxk(k-1))/deltaz + gthvk=(thvxk(k)-thvxk(k-1))/deltaz + govrthvk=g/(0.5*(thvxk(k)+thvxk(k-1))) + akml=akm(k) + akhl=akh(k) + en2=ri(k)*s2l !n**2 + thm=(thxk(k)+thxk(k-1))*0.5 +! +! turbulence production term +! + if(pblflg.and.k.le.kpbl)then + pru=(akml*(suk-hgamu/hpbl-ufxpbl(k)))*suk + prv=(akml*(svk-hgamv/hpbl-vfxpbl(k)))*svk + else + pru=akml*suk*suk + prv=akml*svk*svk + endif + pr=pru+prv +! +! buoyancy production +! + if(pblflg.and.k.le.kpbl)then + bpr=(akhl*(gthvk-mf(k)-(hgamq/hpbl+qfxpbl(k))*p608*thm))*govrthvk + else + bpr=akhl*gthvk*govrthvk + endif +! +! dissipation +! + disel=min(delxy,ceps*el(k)) + dis=(q2l)**1.5/disel +! + q2l=q2l+2.0*(pr-bpr-dis)*dtturbl + q2(k)=amax1(q2l,epsq2l) +! +! end of production/dissipation loop +! + enddo main_integration +! +! lower boundary condition for q2 +! + q2(kts)=amax1(rc02*ustar*ustar,epsq2l) +! + end subroutine prodq2 +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + subroutine vdifq(lmh,dtdif,q2,el,z, & + akhk,ptke1, & + hgame,hpbl,pblflg,kpbl, & + efxpbl, & + kts,kte) +!------------------------------------------------------------------------------- + use machine , only : kind_phys + implicit none +!------------------------------------------------------------------------------- +! + real(kind=kind_phys),parameter :: c_k=1.0,esq=5.0 +! + integer, intent(in ) :: kts,kte + integer, intent(in ) :: lmh,kpbl +! + real(kind=kind_phys), intent(in ) :: dtdif,hpbl,efxpbl +! + logical, intent(in ) :: pblflg +! + real(kind=kind_phys), dimension( kts:kte ) , & + intent(in ) :: hgame, & + ptke1 + real(kind=kind_phys), dimension( kts+1:kte ) , & + intent(in ) :: el, & + akhk + real(kind=kind_phys), dimension( kts:kte+1 ) , & + intent(in ) :: z +! + real(kind=kind_phys), dimension( kts:kte ) , & + intent(inout) :: q2 +! +! local vars +! + integer :: k +! + real(kind=kind_phys) :: aden,akqs,bden,besh,besm,cden,cf,dtozs,ell,eloq2,eloq4 + real(kind=kind_phys) :: elqdz,esh,esm,esqhf,ghl,gml,q1l,rden,rdz + real(kind=kind_phys) :: zak +! + real(kind=kind_phys), dimension( kts+1:kte ) :: zfacentk + real(kind=kind_phys), dimension( kts+2:kte ) :: akq, & + cm, & + cr, & + dtoz, & + rsq2 +! +!------------------------------------------------------------------------------- +! +! vertical turbulent diffusion +! + esqhf=0.5*esq + do k = kts+1,kte + zak=0.5*(z(k)+z(k-1)) !zak of vdifq = za(k-1) of shinhong2d + zfacentk(k)=(zak/hpbl)**3.0 + enddo +! + do k = kte,kts+2,-1 + dtoz(k)=(dtdif+dtdif)/(z(k+1)-z(k-1)) + akq(k)=c_k*(akhk(k)/(z(k+1)-z(k-1))+akhk(k-1)/(z(k)-z(k-2))) + akq(k)=akq(k)*ptke1(k) + cr(k)=-dtoz(k)*akq(k) + enddo +! + akqs=c_k*akhk(kts+1)/(z(kts+2)-z(kts)) + akqs=akqs*ptke1(kts+1) + cm(kte)=dtoz(kte)*akq(kte)+1. + rsq2(kte)=q2(kte) +! + do k = kte-1,kts+2,-1 + cf=-dtoz(k)*akq(k+1)/cm(k+1) + cm(k)=-cr(k+1)*cf+(akq(k+1)+akq(k))*dtoz(k)+1. + rsq2(k)=-rsq2(k+1)*cf+q2(k) + if(pblflg.and.k.lt.kpbl) then + rsq2(k)=rsq2(k)-dtoz(k)*(2.0*hgame(k)/hpbl)*akq(k+1)*(z(k+1)-z(k)) & + +dtoz(k)*(2.0*hgame(k-1)/hpbl)*akq(k)*(z(k)-z(k-1)) + rsq2(k)=rsq2(k)-dtoz(k)*2.0*efxpbl*zfacentk(k+1) & + +dtoz(k)*2.0*efxpbl*zfacentk(k) + endif + enddo +! + dtozs=(dtdif+dtdif)/(z(kts+2)-z(kts)) + cf=-dtozs*akq(lmh+2)/cm(lmh+2) +! + if(pblflg.and.((lmh+1).lt.kpbl)) then + q2(lmh+1)=(dtozs*akqs*q2(lmh)-rsq2(lmh+2)*cf+q2(lmh+1) & + -dtozs*(2.0*hgame(lmh+1)/hpbl)*akq(lmh+2)*(z(lmh+2)-z(lmh+1)) & + +dtozs*(2.0*hgame(lmh)/hpbl)*akqs*(z(lmh+1)-z(lmh))) + q2(lmh+1)=q2(lmh+1)-dtozs*2.0*efxpbl*zfacentk(lmh+2) & + +dtozs*2.0*efxpbl*zfacentk(lmh+1) + q2(lmh+1)=q2(lmh+1)/((akq(lmh+2)+akqs)*dtozs-cr(lmh+2)*cf+1.) + else + q2(lmh+1)=(dtozs*akqs*q2(lmh)-rsq2(lmh+2)*cf+q2(lmh+1)) & + /((akq(lmh+2)+akqs)*dtozs-cr(lmh+2)*cf+1.) + endif +! + do k = lmh+2,kte + q2(k)=(-cr(k)*q2(k-1)+rsq2(k))/cm(k) + enddo +! + end subroutine vdifq +!------------------------------------------------------------------------------- + function pu(d,h) +!------------------------------------------------------------------------------- + use machine , only : kind_phys + implicit none +!------------------------------------------------------------------------------- + real(kind=kind_phys) :: pu + real(kind=kind_phys),parameter :: pmin = 0.0,pmax = 1.0 + real(kind=kind_phys),parameter :: a1 = 1.0, a2 = 0.070, a3 = 1.0, a4 = 0.142, a5 = 0.071 + real(kind=kind_phys),parameter :: b1 = 2.0, b2 = 0.6666667 + real(kind=kind_phys) :: d,h,doh,num,den +! + doh=d/h + num=a1*(doh)**b1+a2*(doh)**b2 + den=a3*(doh)**b1+a4*(doh)**b2+a5 + pu=num/den + pu=max(pu,pmin) + pu=min(pu,pmax) +! + return + end function +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + function pq(d,h) +!------------------------------------------------------------------------------- + use machine , only : kind_phys + implicit none +!------------------------------------------------------------------------------- + real(kind=kind_phys) :: pq + real(kind=kind_phys),parameter :: pmin = 0.0,pmax = 1.0 + real(kind=kind_phys),parameter :: a1 = 1.0, a2 = -0.098, a3 = 1.0, a4 = 0.106, a5 = 0.5 + real(kind=kind_phys),parameter :: b1 = 2.0 + real(kind=kind_phys) :: d,h,doh,num,den +! + doh=d/h + num=a1*(doh)**b1+a2 + den=a3*(doh)**b1+a4 + pq=a5*num/den+(1.-a5) + pq=max(pq,pmin) + pq=min(pq,pmax) +! + return + end function +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + function pthnl(d,h) +!------------------------------------------------------------------------------- + use machine , only : kind_phys + implicit none +!------------------------------------------------------------------------------- + real(kind=kind_phys) :: pthnl + real(kind=kind_phys),parameter :: pmin = 0.0,pmax = 1.0 + real(kind=kind_phys),parameter :: a1 = 1.000, a2 = 0.936, a3 = -1.110, & + a4 = 1.000, a5 = 0.312, a6 = 0.329, a7 = 0.243 + real(kind=kind_phys),parameter :: b1 = 2.0, b2 = 0.875 + real(kind=kind_phys) :: d,h,doh,num,den +! + doh=d/h + num=a1*(doh)**b1+a2*(doh)**b2+a3 + den=a4*(doh)**b1+a5*(doh)**b2+a6 + pthnl=a7*num/den+(1.-a7) + pthnl=max(pthnl,pmin) + pthnl=min(pthnl,pmax) +! + return + end function +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + function pthl(d,h) +!------------------------------------------------------------------------------- + use machine , only : kind_phys + implicit none +!------------------------------------------------------------------------------- + real(kind=kind_phys) :: pthl + real(kind=kind_phys),parameter :: pmin = 0.0,pmax = 1.0 + real(kind=kind_phys),parameter :: a1 = 1.000, a2 = 0.870, a3 = -0.913, & + a4 = 1.000, a5 = 0.153, a6 = 0.278, a7 = 0.280 + real(kind=kind_phys),parameter :: b1 = 2.0, b2 = 0.5 + real(kind=kind_phys) :: d,h,doh,num,den +! + doh=d/h + num=a1*(doh)**b1+a2*(doh)**b2+a3 + den=a4*(doh)**b1+a5*(doh)**b2+a6 + pthl=a7*num/den+(1.-a7) + pthl=max(pthl,pmin) + pthl=min(pthl,pmax) +! + return + end function +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + function ptke(d,h) +!------------------------------------------------------------------------------- + use machine , only : kind_phys + implicit none +!------------------------------------------------------------------------------- + real(kind=kind_phys) :: ptke + real(kind=kind_phys),parameter :: pmin = 0.0,pmax = 1.0 + real(kind=kind_phys),parameter :: a1 = 1.000, a2 = 0.070, & + a3 = 1.000, a4 = 0.142, a5 = 0.071 + real(kind=kind_phys),parameter :: b1 = 2.0, b2 = 0.6666667 + real(kind=kind_phys) :: d,h,doh,num,den +! + doh=d/h + num=a1*(doh)**b1+a2*(doh)**b2 + den=a3*(doh)**b1+a4*(doh)**b2+a5 + ptke=num/den + ptke=max(ptke,pmin) + ptke=min(ptke,pmax) +! + return + end function +!------------------------------------------------------------------------------- + end module shinhongvdif diff --git a/physics/ysuvdif.F90 b/physics/ysuvdif.F90 new file mode 100644 index 000000000..e76f2120b --- /dev/null +++ b/physics/ysuvdif.F90 @@ -0,0 +1,1271 @@ +!> \file ysuvdif.F90 +!! This file contains the CCPP-compliant YSU scheme which computes +!! subgrid vertical turbulence mixing using traditional K-profile method +!! Please refer to (Hong, Noh and Dudhia, 2006, MWR). +!! +!! Subroutine 'ysuvdif_run' computes subgrid vertical turbulence mixing +!! using YSU K-profile method +!! +!---------------------------------------------------------------------- + + module ysuvdif + contains + + subroutine ysuvdif_init () + end subroutine ysuvdif_init + + subroutine ysuvdif_finalize () + end subroutine ysuvdif_finalize + +!> \defgroup YSU FV3GFS ysuvdif_run Main +!! \brief This subroutine contains all of the logic for the +!! YSU scheme. +!! +!> \section arg_table_ysuvdif_run Argument Table +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |----------------|-----------------------------------------------------------------------------|-------------------------------------------------------|---------------|------|-----------|-----------|--------|----------| +!! | ix | horizontal_dimension | horizontal dimension | count | 0 | integer | | in | F | +!! | im | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | +!! | km | vertical_dimension | vertical layer dimension | count | 0 | integer | | in | F | +!! | ux | x_wind | x component of layer wind | m s-1 | 2 | real | kind_phys | in | F | +!! | vx | y_wind | y component of layer wind | m s-1 | 2 | real | kind_phys | in | F | +!! | tx | air_temperature | layer mean air temperature | K | 2 | real | kind_phys | in | F | +!! | qx | tracer_concentration | model layer mean tracer concentration | kg kg-1 | 3 | real | kind_phys | in | F | +!! | p2d | air_pressure | mean layer pressure | Pa | 2 | real | kind_phys | in | F | +!! | p2di | air_pressure_at_interface | air pressure at model layer interfaces | Pa | 2 | real | kind_phys | in | F | +!! | pi2d | dimensionless_exner_function_at_model_layers | Exner function at layers | none | 2 | real | kind_phys | in | F | +!! | vtnp | tendency_of_y_wind_due_to_model_physics | updated tendency of the y wind | m s-2 | 2 | real | kind_phys | inout | F | +!! | utnp | tendency_of_x_wind_due_to_model_physics | updated tendency of the x wind | m s-2 | 2 | real | kind_phys | inout | F | +!! | ttnp | tendency_of_air_temperature_due_to_model_physics | updated tendency of the temperature | K s-1 | 2 | real | kind_phys | inout | F | +!! | qtnp | tendency_of_tracers_due_to_model_physics | updated tendency of the tracers due to model physics | kg kg-1 s-1 | 3 | real | kind_phys | inout | F | +!! | swh | tendency_of_air_temperature_due_to_shortwave_heating_on_radiation_time_step | total sky shortwave heating rate | K s-1 | 2 | real | kind_phys | in | F | +!! | hlw | tendency_of_air_temperature_due_to_longwave_heating_on_radiation_time_step | total sky longwave heating rate | K s-1 | 2 | real | kind_phys | in | F | +!! | xmu | zenith_angle_temporal_adjustment_factor_for_shortwave_fluxes | zenith angle temporal adjustment factor for shortwave | none | 1 | real | kind_phys | in | F | +!! | ntrac | number_of_tracers | number of tracers | count | 0 | integer | | in | F | +!! | ndiff | number_of_vertical_diffusion_tracers | number of tracers to diffuse vertically | count | 0 | integer | | in | F | +!! | ntcw | index_for_liquid_cloud_condensate | tracer index for cloud condensate (or liquid water) | index | 0 | integer | | in | F | +!! | ntiw | index_for_ice_cloud_condensate | tracer index for ice water | index | 0 | integer | | in | F | +!! | phii | geopotential_at_interface | geopotential at model layer interfaces | m2 s-2 | 2 | real | kind_phys | in | F | +!! | phil | geopotential | geopotential at model layer centers | m2 s-2 | 2 | real | kind_phys | in | F | +!! | psfcpa | surface_air_pressure | surface pressure | Pa | 1 | real | kind_phys | in | F | +!! | zorl | surface_roughness_length | surface roughness length in cm | cm | 1 | real | kind_phys | in | F | +!! | stress | surface_wind_stress | surface wind stress | m2 s-2 | 1 | real | kind_phys | in | F | +!! | hpbl | atmosphere_boundary_layer_thickness | PBL thickness | m | 1 | real | kind_phys | out | F | +!! | psim | Monin-Obukhov_similarity_function_for_momentum | Monin-Obukhov similarity function for momentum | none | 1 | real | kind_phys | in | F | +!! | psih | Monin-Obukhov_similarity_function_for_heat | Monin-Obukhov similarity function for heat | none | 1 | real | kind_phys | in | F | +!! | landmask | sea_land_ice_mask | landmask: sea/land/ice=0/1/2 | flag | 1 | integer | | in | F | +!! | heat | kinematic_surface_upward_sensible_heat_flux | kinematic surface upward sensible heat flux | K m s-1 | 1 | real | kind_phys | in | F | +!! | evap | kinematic_surface_upward_latent_heat_flux | kinematic surface upward latent heat flux | kg kg-1 m s-1 | 1 | real | kind_phys | in | F | +!! | wspd | wind_speed_at_lowest_model_layer | wind speed at lowest model level | m s-1 | 1 | real | kind_phys | in | F | +!! | br | bulk_richardson_number_at_lowest_model_level | bulk Richardson number at the surface | none | 1 | real | kind_phys | in | F | +!! | g | gravitational_acceleration | gravitational acceleration | m s-2 | 0 | real | kind_phys | in | F | +!! | rd | gas_constant_dry_air | ideal gas constant for dry air | J kg-1 K-1 | 0 | real | kind_phys | in | F | +!! | cp | specific_heat_of_dry_air_at_constant_pressure | specific heat of dry air at constant pressure | J kg-1 K-1 | 0 | real | kind_phys | in | F | +!! | rv | gas_constant_water_vapor | ideal gas constant for water vapor | J kg-1 K-1 | 0 | real | kind_phys | in | F | +!! | ep1 | ratio_of_vapor_to_dry_air_gas_constants_minus_one | rv/rd - 1 (rv = ideal gas constant for water vapor) | none | 0 | real | kind_phys | in | F | +!! | ep2 | ratio_of_dry_air_to_water_vapor_gas_constants | rd/rv | none | 0 | real | kind_phys | in | F | +!! | xlv | latent_heat_of_vaporization_of_water_at_0C | latent heat of evaporation/sublimation | J kg-1 | 0 | real | kind_phys | in | F | +!! | dusfc | instantaneous_surface_x_momentum_flux | x momentum flux | Pa | 1 | real | kind_phys | out | F | +!! | dvsfc | instantaneous_surface_y_momentum_flux | y momentum flux | Pa | 1 | real | kind_phys | out | F | +!! | dtsfc | instantaneous_surface_upward_sensible_heat_flux | surface upward sensible heat flux | W m-2 | 1 | real | kind_phys | out | F | +!! | dqsfc | instantaneous_surface_upward_latent_heat_flux | surface upward latent heat flux | W m-2 | 1 | real | kind_phys | out | F | +!! | dt | time_step_for_physics | time step for physics | s | 0 | real | kind_phys | in | F | +!! | kpbl1d | vertical_index_at_top_of_atmosphere_boundary_layer | PBL top model level index | index | 1 | integer | | out | F | +!! | u10 | x_wind_at_10m | x component of wind at 10 m | m s-1 | 1 | real | kind_phys | in | F | +!! | v10 | y_wind_at_10m | y component of wind at 10 m | m s-1 | 1 | real | kind_phys | in | F | +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! +!------------------------------------------------------------------------------- + subroutine ysuvdif_run(ix,im,km,ux,vx,tx,qx,p2d,p2di,pi2d, & + utnp,vtnp,ttnp,qtnp, & + swh,hlw,xmu,ntrac,ndiff,ntcw,ntiw, & + phii,phil,psfcpa, & + zorl,stress,hpbl,psim,psih, & + landmask,heat,evap,wspd,br, & + g,rd,cp,rv,ep1,ep2,xlv, & + dusfc,dvsfc,dtsfc,dqsfc, & + dt,kpbl1d,u10,v10,errmsg,errflg ) + + use machine , only : kind_phys +! +!------------------------------------------------------------------------------- + implicit none +!------------------------------------------------------------------------------- + real(kind=kind_phys),parameter :: xkzminm = 0.1,xkzminh = 0.01 + real(kind=kind_phys),parameter :: xkzmin = 0.01,xkzmax = 1000.,rimin = -100. + real(kind=kind_phys),parameter :: rlam = 30.,prmin = 0.25,prmax = 4. + real(kind=kind_phys),parameter :: brcr_ub = 0.0,brcr_sb = 0.25,cori = 1.e-4 + real(kind=kind_phys),parameter :: afac = 6.8,bfac = 6.8,pfac = 2.0,pfac_q = 2.0 + real(kind=kind_phys),parameter :: phifac = 8.,sfcfrac = 0.1 + real(kind=kind_phys),parameter :: d1 = 0.02, d2 = 0.05, d3 = 0.001 + real(kind=kind_phys),parameter :: h1 = 0.33333335, h2 = 0.6666667 + real(kind=kind_phys),parameter :: zfmin = 1.e-8,aphi5 = 5.,aphi16 = 16. + real(kind=kind_phys),parameter :: tmin=1.e-2 + real(kind=kind_phys),parameter :: gamcrt = 3.,gamcrq = 2.e-3 + real(kind=kind_phys),parameter :: xka = 2.4e-5 + real(kind=kind_phys),parameter :: rcl = 1.0 + real(kind=kind_phys),parameter :: karman = 0.4 + integer,parameter :: imvdif = 1 + integer,parameter :: ysu_topdown_pblmix = 1 +! +!------------------------------------------------------------------------------------- +! input variables + integer, intent(in ) :: ix,im,km,ntrac,ndiff,ntcw,ntiw + real(kind=kind_phys), intent(in ) :: g,cp,rd,rv,ep1,ep2,xlv,dt + + real(kind=kind_phys), dimension( ix,km ), & + intent(in) :: pi2d,p2d,phil,ux,vx,swh,hlw,tx + + real(kind=kind_phys), dimension( ix,km,ntrac ) , & + intent(in ) :: qx + + real(kind=kind_phys), dimension( ix, km+1 ) , & + intent(in ) :: p2di,phii + + real(kind=kind_phys), dimension( im ) , & + intent(in) :: stress,zorl,heat,evap,wspd,br,psim,psih,psfcpa, & + u10,v10,xmu + integer, dimension(im) ,& + intent(in ) :: landmask +! +!---------------------------------------------------------------------------------- +! input/output variables +! + real(kind=kind_phys), dimension( im,km ) , & + intent(inout) :: utnp,vtnp,ttnp + real(kind=kind_phys), dimension( im,km,ntrac ) , & + intent(inout) :: qtnp +! +!--------------------------------------------------------------------------------- +! output variables + integer, dimension( im ), intent(out ) :: kpbl1d + real(kind=kind_phys), dimension( im ), & + intent(out) :: hpbl + + ! error messages + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg +! +!-------------------------------------------------------------------------------- +! +! local vars +! + real(kind=kind_phys), dimension( im ) :: hol + real(kind=kind_phys), dimension( im, km+1 ) :: zq +! + real(kind=kind_phys), dimension( im, km ) :: & + thx,thvx,thlix, & + del, & + dza, & + dzq, & + xkzom, & + xkzoh, & + za +! + real(kind=kind_phys), dimension( im ) :: & + rhox, & + govrth, & + zl1,thermal, & + wscale, & + hgamt,hgamq, & + brdn,brup, & + phim,phih, & + dusfc,dvsfc, & + dtsfc,dqsfc, & + prpbl, & + wspd1,thermalli +! + real(kind=kind_phys), dimension( im, km ) :: xkzm,xkzh, & + f1,f2, & + r1,r2, & + ad,au, & + cu, & + al, & + xkzq, & + zfac, & + rhox2, & + hgamt2 +! + real(kind=kind_phys), dimension( im ) :: & + brcr, & + sflux, & + zol1, & + brcr_sbro +! + real(kind=kind_phys), dimension( im ) :: xland + real(kind=kind_phys), dimension( im ) :: ust + real(kind=kind_phys), dimension( im ) :: hfx + real(kind=kind_phys), dimension( im ) :: qfx + real(kind=kind_phys), dimension( im ) :: znt + real(kind=kind_phys), dimension( im ) :: uox + real(kind=kind_phys), dimension( im ) :: vox +! + real(kind=kind_phys), dimension( im, km, ndiff) :: r3,f3 + integer, dimension( im ) :: kpbl,kpblold +! + logical, dimension( im ) :: pblflg, & + sfcflg, & + stable, & + cloudflg + + logical :: definebrup +! + integer :: n,i,k,l,ic,is,kk + integer :: klpbl, ktrace1, ktrace2, ktrace3 +! +! + real(kind=kind_phys) :: dt2,rdt,spdk2,fm,fh,hol1,gamfac,vpert,prnum,prnum0 + real(kind=kind_phys) :: ss,ri,qmean,tmean,alph,chi,zk,rl2,dk,sri + real(kind=kind_phys) :: brint,dtodsd,dtodsu,rdz,dsdzt,dsdzq,dsdz2,rlamdz + real(kind=kind_phys) :: utend,vtend,ttend,qtend + real(kind=kind_phys) :: dtstep,govrthv + real(kind=kind_phys) :: cont, conq, conw, conwrc, rovcp +! + + real(kind=kind_phys), dimension( im, km ) :: wscalek,wscalek2 + real(kind=kind_phys), dimension( im ) :: wstar + real(kind=kind_phys), dimension( im ) :: delta + real(kind=kind_phys), dimension( im, km ) :: xkzml,xkzhl, & + zfacent,entfac + real(kind=kind_phys), dimension( im ) :: ust3, & + wstar3, & + wstar3_2, & + hgamu,hgamv, & + wm2, we, & + bfxpbl, & + hfxpbl,qfxpbl, & + ufxpbl,vfxpbl, & + dthvx + real(kind=kind_phys) :: prnumfac,bfx0,hfx0,qfx0,delb,dux,dvx, & + dsdzu,dsdzv,wm3,dthx,dqx,wspd10,ross,tem1,dsig,tvcon,conpr, & + prfac,prfac2,phim8z,radsum,tmp1,templ,rvls,temps,ent_eff, & + rcldb,bruptmp,radflux +! +!------------------------------------------------------------------------------- +! +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + klpbl = km +! + rovcp=rd/cp + cont=cp/g + conq=xlv/g + conw=1./g + conwrc = conw*sqrt(rcl) + conpr = bfac*karman*sfcfrac +! +! change xland values + do i=1,im + if(landmask(i).eq.0) then !ocean + xland(i) = 2 + else + xland(i) = 1 !land + end if + end do +! + do k = 1,km + do i = 1,im + thx(i,k) = tx(i,k)/pi2d(i,k) + thlix(i,k) = (tx(i,k)-xlv*qx(i,k,ntcw)/cp-2.834E6*qx(i,k,ntiw)/cp)/pi2d(i,k) + enddo + enddo +! + do k = 1,km + do i = 1,im + tvcon = (1.+ep1*qx(i,k,1)) + thvx(i,k) = thx(i,k)*tvcon + enddo + enddo +! + do i = 1,im + tvcon = (1.+ep1*qx(i,1,1)) + rhox(i) = psfcpa(i)/(rd*tx(i,1)*tvcon) + govrth(i) = g/thx(i,1) + hfx(i) = heat(i)*rhox(i)*cp ! reset to the variable in WRF + qfx(i) = evap(i)*rhox(i) ! reset to the variable in WRF + ust(i) = sqrt(stress(i)) ! reset to the variable in WRF + znt(i) = 0.01*zorl(i) ! reset to the variable in WRF + uox(i) = 0.0 + vox(i) = 0.0 + enddo +! +!-----compute the height of full- and half-sigma levels above ground +! level, and the layer thicknesses. +! + do i = 1,im + zq(i,1) = 0. + enddo +! + do k = 1,km + do i = 1,im + zq(i,k+1) = phii(i,k+1)*conw + tvcon = (1.+ep1*qx(i,k,1)) + rhox2(i,k) = p2d(i,k)/(rd*tx(i,k)*tvcon) + enddo + enddo +! + do k = 1,km + do i = 1,im + za(i,k) = phil(i,k)*conw + dzq(i,k) = zq(i,k+1)-zq(i,k) + del(i,k) = p2di(i,k)-p2di(i,k+1) + enddo + enddo +! + do i = 1,im + dza(i,1) = za(i,1) + enddo +! + do k = 2,km + do i = 1,im + dza(i,k) = za(i,k)-za(i,k-1) + enddo + enddo + +! write(0,*)"===CALLING ysu; input:" +! print*,"t:",tx(1,1),tx(1,2),tx(1,km) +! print*,"u:",ux(1,1),ux(1,2),ux(1,km) +! print*,"v:",vx(1,1),vx(1,2),vx(1,km) +! print*,"q:",qx(1,1,1),qx(1,2,1),qx(1,km,1) +! print*,"exner:",pi2d(1,1),pi2d(1,2),pi2d(1,km) +! print*,"phii:",zq(1,1),zq(1,2),zq(1,km+1) +! print*,"phil:",za(1,1),za(1,2),za(1,km) +! print*,"p2d:",p2d(1,1),p2d(1,2),p2d(1,km) +! print*,"p2di:",p2di(1,1),p2di(1,2),p2di(1,km+1) +! print *,"del:",del(1,1),del(1,2),del(1,km) +! print*,"znt,ust,wspd:",znt(1),ust(1),wspd(1) +! print*,"hfx,qfx,xland:",hfx(1),qfx(1),xland(1) +! print*,"rd,rv,g:",rd,rv,g +! print*,"ep1,ep2,xlv:",ep1,ep2,xlv +! print*,"br,psim,psih:",br(1),psim(1),psih(1) +! print*,"u10,v10:",u10(1),v10(1) +! print*,"psfcpa,cp:",psfcpa(1),cp +! print*,"ntrac,ndiff,ntcw,ntiw:",ntrac,ndiff,ntcw,ntiw +! +! +!-----initialize vertical tendencies and +! +! utnp(:,:) = 0. +! vtnp(:,:) = 0. +! ttnp(:,:) = 0. +! qtnp(:,:,:) = 0. +! + do i = 1,im + wspd1(i) = sqrt( (ux(i,1)-uox(i))*(ux(i,1)-uox(i)) + (vx(i,1)-vox(i))*(vx(i,1)-vox(i)) )+1.e-9 + enddo +! +!---- compute vertical diffusion +! +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! compute preliminary variables +! + dtstep = dt + dt2 = 2.*dtstep + rdt = 1./dt2 +! + do i = 1,im + bfxpbl(i) = 0.0 + hfxpbl(i) = 0.0 + qfxpbl(i) = 0.0 + ufxpbl(i) = 0.0 + vfxpbl(i) = 0.0 + hgamu(i) = 0.0 + hgamv(i) = 0.0 + delta(i) = 0.0 + wstar3_2(i) = 0.0 + enddo +! + do k = 1,klpbl + do i = 1,im + wscalek(i,k) = 0.0 + wscalek2(i,k) = 0.0 + enddo + enddo +! + do k = 1,klpbl + do i = 1,im + zfac(i,k) = 0.0 + enddo + enddo + do k = 1,klpbl-1 + do i = 1,im + xkzom(i,k) = xkzminm + xkzoh(i,k) = xkzminh + enddo + enddo +! + do i = 1,im + dusfc(i) = 0. + dvsfc(i) = 0. + dtsfc(i) = 0. + dqsfc(i) = 0. + enddo +! + do i = 1,im + hgamt(i) = 0. + hgamq(i) = 0. + wscale(i) = 0. + kpbl(i) = 1 + hpbl(i) = zq(i,1) + zl1(i) = za(i,1) + thermal(i)= thvx(i,1) + thermalli(i) = thlix(i,1) + pblflg(i) = .true. + sfcflg(i) = .true. + sflux(i) = hfx(i)/rhox(i)/cp + qfx(i)/rhox(i)*ep1*thx(i,1) + if(br(i).gt.0.0) sfcflg(i) = .false. + enddo +! +! compute the first guess of pbl height +! + do i = 1,im + stable(i) = .false. + brup(i) = br(i) + brcr(i) = brcr_ub + enddo +! + do k = 2,klpbl + do i = 1,im + if(.not.stable(i))then + brdn(i) = brup(i) + spdk2 = max(ux(i,k)**2+vx(i,k)**2,1.) + brup(i) = (thvx(i,k)-thermal(i))*(g*za(i,k)/thvx(i,1))/spdk2 + kpbl(i) = k + stable(i) = brup(i).gt.brcr(i) + endif + enddo + enddo +! + do i = 1,im + k = kpbl(i) + if(brdn(i).ge.brcr(i))then + brint = 0. + elseif(brup(i).le.brcr(i))then + brint = 1. + else + brint = (brcr(i)-brdn(i))/(brup(i)-brdn(i)) + endif + hpbl(i) = za(i,k-1)+brint*(za(i,k)-za(i,k-1)) + if(hpbl(i).lt.zq(i,2)) kpbl(i) = 1 + if(kpbl(i).le.1) pblflg(i) = .false. + enddo +! + do i = 1,im + fm = psim(i) + fh = psih(i) + zol1(i) = max(br(i)*fm*fm/fh,rimin) + if(sfcflg(i))then + zol1(i) = min(zol1(i),-zfmin) + else + zol1(i) = max(zol1(i),zfmin) + endif + hol1 = zol1(i)*hpbl(i)/zl1(i)*sfcfrac + if(sfcflg(i))then + phim(i) = (1.-aphi16*hol1)**(-1./4.) + phih(i) = (1.-aphi16*hol1)**(-1./2.) + bfx0 = max(sflux(i),0.) + hfx0 = max(hfx(i)/rhox(i)/cp,0.) + qfx0 = max(ep1*thx(i,1)*qfx(i)/rhox(i),0.) + wstar3(i) = (govrth(i)*bfx0*hpbl(i)) + wstar(i) = (wstar3(i))**h1 + else + phim(i) = (1.+aphi5*hol1) + phih(i) = phim(i) + wstar(i) = 0. + wstar3(i) = 0. + endif + ust3(i) = ust(i)**3. + wscale(i) = (ust3(i)+phifac*karman*wstar3(i)*0.5)**h1 + wscale(i) = min(wscale(i),ust(i)*aphi16) + wscale(i) = max(wscale(i),ust(i)/aphi5) + enddo +! +! compute the surface variables for pbl height estimation +! under unstable conditions +! + do i = 1,im + if(sfcflg(i).and.sflux(i).gt.0.0)then + gamfac = bfac/rhox(i)/wscale(i) + hgamt(i) = min(gamfac*hfx(i)/cp,gamcrt) + hgamq(i) = min(gamfac*qfx(i),gamcrq) + vpert = (hgamt(i)+ep1*thx(i,1)*hgamq(i))/bfac*afac + thermal(i) = thermal(i)+max(vpert,0.)*min(za(i,1)/(sfcfrac*hpbl(i)),1.0) + thermalli(i)= thermalli(i)+max(vpert,0.)*min(za(i,1)/(sfcfrac*hpbl(i)),1.0) + hgamt(i) = max(hgamt(i),0.0) + hgamq(i) = max(hgamq(i),0.0) + brint = -15.9*ust(i)*ust(i)/wspd(i)*wstar3(i)/(wscale(i)**4.) + hgamu(i) = brint*ux(i,1) + hgamv(i) = brint*vx(i,1) + else + pblflg(i) = .false. + endif + enddo +! +! enhance the pbl height by considering the thermal +! + do i = 1,im + if(pblflg(i))then + kpbl(i) = 1 + hpbl(i) = zq(i,1) + endif + enddo +! + do i = 1,im + if(pblflg(i))then + stable(i) = .false. + brup(i) = br(i) + brcr(i) = brcr_ub + endif + enddo +! + do k = 2,klpbl + do i = 1,im + if(.not.stable(i).and.pblflg(i))then + brdn(i) = brup(i) + spdk2 = max(ux(i,k)**2+vx(i,k)**2,1.) + brup(i) = (thvx(i,k)-thermal(i))*(g*za(i,k)/thvx(i,1))/spdk2 + kpbl(i) = k + stable(i) = brup(i).gt.brcr(i) + endif + enddo + enddo +! +! enhance pbl by theta-li +! + if (ysu_topdown_pblmix.eq.1)then + do i = 1,im + kpblold(i) = kpbl(i) + definebrup=.false. + do k = kpblold(i), km-1 + spdk2 = max(ux(i,k)**2+vx(i,k)**2,1.) + bruptmp = (thlix(i,k)-thermalli(i))*(g*za(i,k)/thlix(i,1))/spdk2 + stable(i) = bruptmp.ge.brcr(i) + if (definebrup) then + kpbl(i) = k + brup(i) = bruptmp + definebrup=.false. + endif + if (.not.stable(i)) then !overwrite brup brdn values + brdn(i)=bruptmp + definebrup=.true. + pblflg(i)=.true. + endif + enddo + enddo + endif + + do i = 1,im + if(pblflg(i)) then + k = kpbl(i) + if(brdn(i).ge.brcr(i))then + brint = 0. + elseif(brup(i).le.brcr(i))then + brint = 1. + else + brint = (brcr(i)-brdn(i))/(brup(i)-brdn(i)) + endif + hpbl(i) = za(i,k-1)+brint*(za(i,k)-za(i,k-1)) + if(hpbl(i).lt.zq(i,2)) kpbl(i) = 1 + if(kpbl(i).le.1) pblflg(i) = .false. + endif + enddo +! +! stable boundary layer +! + do i = 1,im + if((.not.sfcflg(i)).and.hpbl(i).lt.zq(i,2)) then + brup(i) = br(i) + stable(i) = .false. + else + stable(i) = .true. + endif + enddo +! + do i = 1,im + if((.not.stable(i)).and.((xland(i)-1.5).ge.0))then + wspd10 = u10(i)*u10(i) + v10(i)*v10(i) + wspd10 = sqrt(wspd10) + ross = wspd10 / (cori*znt(i)) + brcr_sbro(i) = min(0.16*(1.e-7*ross)**(-0.18),.3) + endif + enddo +! + do i = 1,im + if(.not.stable(i))then + if((xland(i)-1.5).ge.0)then + brcr(i) = brcr_sbro(i) + else + brcr(i) = brcr_sb + endif + endif + enddo +! + do k = 2,klpbl + do i = 1,im + if(.not.stable(i))then + brdn(i) = brup(i) + spdk2 = max(ux(i,k)**2+vx(i,k)**2,1.) + brup(i) = (thvx(i,k)-thermal(i))*(g*za(i,k)/thvx(i,1))/spdk2 + kpbl(i) = k + stable(i) = brup(i).gt.brcr(i) + endif + enddo + enddo +! + do i = 1,im + if((.not.sfcflg(i)).and.hpbl(i).lt.zq(i,2)) then + k = kpbl(i) + if(brdn(i).ge.brcr(i))then + brint = 0. + elseif(brup(i).le.brcr(i))then + brint = 1. + else + brint = (brcr(i)-brdn(i))/(brup(i)-brdn(i)) + endif + hpbl(i) = za(i,k-1)+brint*(za(i,k)-za(i,k-1)) + if(hpbl(i).lt.zq(i,2)) kpbl(i) = 1 + if(kpbl(i).le.1) pblflg(i) = .false. + endif + enddo +! +! estimate the entrainment parameters +! + do i = 1,im + cloudflg(i)=.false. + if(pblflg(i)) then + k = kpbl(i) - 1 + wm3 = wstar3(i) + 5. * ust3(i) + wm2(i) = wm3**h2 + bfxpbl(i) = -0.15*thvx(i,1)/g*wm3/hpbl(i) + dthvx(i) = max(thvx(i,k+1)-thvx(i,k),tmin) + we(i) = max(bfxpbl(i)/dthvx(i),-sqrt(wm2(i))) + if((qx(i,k,ntcw)+qx(i,k,ntiw)).gt.0.01e-3.and.ysu_topdown_pblmix.eq.1)then + if ( kpbl(i) .ge. 2) then + cloudflg(i)=.true. + templ=thlix(i,k)*(p2di(i,k+1)/100000)**rovcp + !rvls is ws at full level + rvls=100.*6.112*EXP(17.67*(templ-273.16)/(templ-29.65))*(ep2/p2di(i,k+1)) + temps=templ + ((qx(i,k,1)+qx(i,k,ntcw))-rvls)/(cp/xlv + & + ep2*xlv*rvls/(rd*templ**2)) + rvls=100.*6.112*EXP(17.67*(temps-273.15)/(temps-29.65))*(ep2/p2di(i,k+1)) + rcldb=max((qx(i,k,1)+qx(i,k,ntcw))-rvls,0.) + !entrainment efficiency + dthvx(i) = (thlix(i,k+2)+thx(i,k+2)*ep1*(qx(i,k+2,1)+qx(i,k+2,ntcw))) & + - (thlix(i,k) + thx(i,k) *ep1*(qx(i,k,1) +qx(i,k,ntcw))) + dthvx(i) = max(dthvx(i),0.1) + tmp1 = xlv/cp * rcldb/(pi2d(i,k)*dthvx(i)) + ent_eff = 0.2 * 8. * tmp1 +0.2 + + radsum=0. + do kk = 1,kpbl(i)-1 + radflux=swh(i,kk)*xmu(i)+hlw(i,kk) !radiative heating rate temp/s + radflux=radflux*cp/g*(p2di(i,kk)-p2di(i,kk+1)) ! converts temp/s to W/m^2 + if (radflux < 0.0 ) radsum=abs(radflux)+radsum + enddo + radsum=max(radsum,0.0) + + !recompute entrainment from sfc thermals + bfx0 = max(max(sflux(i),0.0)-radsum/rhox2(i,k)/cp,0.) + bfx0 = max(sflux(i),0.0) + wm3 = (govrth(i)*bfx0*hpbl(i))+5. * ust3(i) + wm2(i) = wm3**h2 + bfxpbl(i) = -0.15*thvx(i,1)/g*wm3/hpbl(i) + dthvx(i) = max(thvx(i,k+1)-thvx(i,k),tmin) + we(i) = max(bfxpbl(i)/dthvx(i),-sqrt(wm2(i))) + + !entrainment from PBL top thermals + bfx0 = max(radsum/rhox2(i,k)/cp-max(sflux(i),0.0),0.) + bfx0 = max(radsum/rhox2(i,k)/cp,0.) + wm3 = (g/thvx(i,k)*bfx0*hpbl(i)) ! this is wstar3(i) + wm2(i) = wm2(i)+wm3**h2 + bfxpbl(i) = - ent_eff * bfx0 + dthvx(i) = max(thvx(i,k+1)-thvx(i,k),0.1) + we(i) = we(i) + max(bfxpbl(i)/dthvx(i),-sqrt(wm3**h2)) + + !wstar3_2 + bfx0 = max(radsum/rhox2(i,k)/cp,0.) + wstar3_2(i) = (g/thvx(i,k)*bfx0*hpbl(i)) + !recompute hgamt + wscale(i) = (ust3(i)+phifac*karman*(wstar3(i)+wstar3_2(i))*0.5)**h1 + wscale(i) = min(wscale(i),ust(i)*aphi16) + wscale(i) = max(wscale(i),ust(i)/aphi5) + gamfac = bfac/rhox(i)/wscale(i) + hgamt(i) = min(gamfac*hfx(i)/cp,gamcrt) + hgamq(i) = min(gamfac*qfx(i),gamcrq) + gamfac = bfac/rhox2(i,k)/wscale(i) + hgamt2(i,k) = min(gamfac*radsum/cp,gamcrt) + hgamt(i) = max(hgamt(i),0.0) + max(hgamt2(i,k),0.0) + brint = -15.9*ust(i)*ust(i)/wspd(i)*(wstar3(i)+wstar3_2(i))/(wscale(i)**4.) + hgamu(i) = brint*ux(i,1) + hgamv(i) = brint*vx(i,1) + endif + endif + prpbl(i) = 1.0 + dthx = max(thx(i,k+1)-thx(i,k),tmin) + dqx = min(qx(i,k+1,1)-qx(i,k,1),0.0) + hfxpbl(i) = we(i)*dthx + qfxpbl(i) = we(i)*dqx +! + dux = ux(i,k+1)-ux(i,k) + dvx = vx(i,k+1)-vx(i,k) + if(dux.gt.tmin) then + ufxpbl(i) = max(prpbl(i)*we(i)*dux,-ust(i)*ust(i)) + elseif(dux.lt.-tmin) then + ufxpbl(i) = min(prpbl(i)*we(i)*dux,ust(i)*ust(i)) + else + ufxpbl(i) = 0.0 + endif + if(dvx.gt.tmin) then + vfxpbl(i) = max(prpbl(i)*we(i)*dvx,-ust(i)*ust(i)) + elseif(dvx.lt.-tmin) then + vfxpbl(i) = min(prpbl(i)*we(i)*dvx,ust(i)*ust(i)) + else + vfxpbl(i) = 0.0 + endif + delb = govrth(i)*d3*hpbl(i) + delta(i) = min(d1*hpbl(i) + d2*wm2(i)/delb,100.) + endif + enddo +! + do k = 1,klpbl + do i = 1,im + if(pblflg(i).and.k.ge.kpbl(i))then + entfac(i,k) = ((zq(i,k+1)-hpbl(i))/delta(i))**2. + else + entfac(i,k) = 1.e30 + endif + enddo + enddo +! +! compute diffusion coefficients below pbl +! + do k = 1,klpbl + do i = 1,im + if(k.lt.kpbl(i)) then + zfac(i,k) = min(max((1.-(zq(i,k+1)-zl1(i))/(hpbl(i)-zl1(i))),zfmin),1.) + zfacent(i,k) = (1.-zfac(i,k))**3. + wscalek(i,k) = (ust3(i)+phifac*karman*wstar3(i)*(1.-zfac(i,k)))**h1 + wscalek2(i,k) = (phifac*karman*wstar3_2(i)*(zfac(i,k)))**h1 + if(sfcflg(i)) then + prfac = conpr + prfac2 = 15.9*(wstar3(i)+wstar3_2(i))/ust3(i)/(1.+4.*karman*(wstar3(i)+wstar3_2(i))/ust3(i)) + prnumfac = -3.*(max(zq(i,k+1)-sfcfrac*hpbl(i),0.))**2./hpbl(i)**2. + else + prfac = 0. + prfac2 = 0. + prnumfac = 0. + phim8z = 1.+aphi5*zol1(i)*zq(i,k+1)/zl1(i) + wscalek(i,k) = ust(i)/phim8z + wscalek(i,k) = max(wscalek(i,k),0.001) + endif + prnum0 = (phih(i)/phim(i)+prfac) + prnum0 = max(min(prnum0,prmax),prmin) + xkzm(i,k) = wscalek(i,k) *karman* zq(i,k+1) * zfac(i,k)**pfac+ & + wscalek2(i,k)*karman*(hpbl(i)-zq(i,k+1))*(1-zfac(i,k))**pfac + !Do not include xkzm at kpbl-1 since it changes entrainment + if (k.eq.kpbl(i)-1.and.cloudflg(i).and.we(i).lt.0.0) then + xkzm(i,k) = 0.0 + endif + prnum = 1. + (prnum0-1.)*exp(prnumfac) + xkzq(i,k) = xkzm(i,k)/prnum*zfac(i,k)**(pfac_q-pfac) + prnum0 = prnum0/(1.+prfac2*karman*sfcfrac) + prnum = 1. + (prnum0-1.)*exp(prnumfac) + xkzh(i,k) = xkzm(i,k)/prnum + xkzm(i,k) = xkzm(i,k)+xkzom(i,k) + xkzh(i,k) = xkzh(i,k)+xkzoh(i,k) + xkzq(i,k) = xkzq(i,k)+xkzoh(i,k) + xkzm(i,k) = min(xkzm(i,k),xkzmax) + xkzh(i,k) = min(xkzh(i,k),xkzmax) + xkzq(i,k) = min(xkzq(i,k),xkzmax) + endif + enddo + enddo +! +! compute diffusion coefficients over pbl (free atmosphere) +! + do k = 1,km-1 + do i = 1,im + if(k.ge.kpbl(i)) then + ss = ((ux(i,k+1)-ux(i,k))*(ux(i,k+1)-ux(i,k)) & + +(vx(i,k+1)-vx(i,k))*(vx(i,k+1)-vx(i,k))) & + /(dza(i,k+1)*dza(i,k+1))+1.e-9 + govrthv = g/(0.5*(thvx(i,k+1)+thvx(i,k))) + ri = govrthv*(thvx(i,k+1)-thvx(i,k))/(ss*dza(i,k+1)) + if(imvdif.eq.1.and.ntcw.ge.2.and.ntiw.ge.2)then + if((qx(i,k,ntcw)+qx(i,k,ntiw)).gt.0.01e-3.and.(qx(i & + ,k+1,ntcw)+qx(i,k+1,ntiw)).gt.0.01e-3)then +! in cloud + qmean = 0.5*(qx(i,k,1)+qx(i,k+1,1)) + tmean = 0.5*(tx(i,k)+tx(i,k+1)) + alph = xlv*qmean/rd/tmean + chi = xlv*xlv*qmean/cp/rv/tmean/tmean + ri = (1.+alph)*(ri-g*g/ss/tmean/cp*((chi-alph)/(1.+chi))) + endif + endif + zk = karman*zq(i,k+1) + rlamdz = min(max(0.1*dza(i,k+1),rlam),300.) + rlamdz = min(dza(i,k+1),rlamdz) + rl2 = (zk*rlamdz/(rlamdz+zk))**2 + dk = rl2*sqrt(ss) + if(ri.lt.0.)then +! unstable regime + ri = max(ri, rimin) + sri = sqrt(-ri) + xkzm(i,k) = dk*(1+8.*(-ri)/(1+1.746*sri)) + xkzh(i,k) = dk*(1+8.*(-ri)/(1+1.286*sri)) + else +! stable regime + xkzh(i,k) = dk/(1+5.*ri)**2 + prnum = 1.0+2.1*ri + prnum = min(prnum,prmax) + xkzm(i,k) = xkzh(i,k)*prnum + endif +! + xkzm(i,k) = xkzm(i,k)+xkzom(i,k) + xkzh(i,k) = xkzh(i,k)+xkzoh(i,k) + xkzm(i,k) = min(xkzm(i,k),xkzmax) + xkzh(i,k) = min(xkzh(i,k),xkzmax) + xkzml(i,k) = xkzm(i,k) + xkzhl(i,k) = xkzh(i,k) + endif + enddo + enddo +! +! compute tridiagonal matrix elements for heat +! + do k = 1,km + do i = 1,im + au(i,k) = 0. + al(i,k) = 0. + ad(i,k) = 0. + f1(i,k) = 0. + enddo + enddo +! + do i = 1,im + ad(i,1) = 1. + f1(i,1) = thx(i,1)-300.+hfx(i)/cont/del(i,1)*dt2 + enddo +! + do k = 1,km-1 + do i = 1,im + dtodsd = dt2/del(i,k) + dtodsu = dt2/del(i,k+1) + dsig = p2d(i,k)-p2d(i,k+1) + rdz = 1./dza(i,k+1) + tem1 = dsig*xkzh(i,k)*rdz + if(pblflg(i).and.k.lt.kpbl(i)) then + dsdzt = tem1*(-hgamt(i)/hpbl(i)-hfxpbl(i)*zfacent(i,k)/xkzh(i,k)) + f1(i,k) = f1(i,k)+dtodsd*dsdzt + f1(i,k+1) = thx(i,k+1)-300.-dtodsu*dsdzt + elseif(pblflg(i).and.k.ge.kpbl(i).and.entfac(i,k).lt.4.6) then + xkzh(i,k) = -we(i)*dza(i,kpbl(i))*exp(-entfac(i,k)) + xkzh(i,k) = sqrt(xkzh(i,k)*xkzhl(i,k)) + xkzh(i,k) = max(xkzh(i,k),xkzoh(i,k)) + xkzh(i,k) = min(xkzh(i,k),xkzmax) + f1(i,k+1) = thx(i,k+1)-300. + else + f1(i,k+1) = thx(i,k+1)-300. + endif + tem1 = dsig*xkzh(i,k)*rdz + dsdz2 = tem1*rdz + au(i,k) = -dtodsd*dsdz2 + al(i,k) = -dtodsu*dsdz2 + ad(i,k) = ad(i,k)-au(i,k) + ad(i,k+1) = 1.-al(i,k) + enddo + enddo +! +! copies here to avoid duplicate input args for tridin +! + do k = 1,km + do i = 1,im + cu(i,k) = au(i,k) + r1(i,k) = f1(i,k) + enddo + enddo +! + call tridin_ysu(al,ad,cu,r1,au,f1,im,km,1) +! +! recover tendencies of heat +! + do k = km,1,-1 + do i = 1,im + ttend = (f1(i,k)-thx(i,k)+300.)*rdt*pi2d(i,k) + ttnp(i,k) = ttnp(i,k)+ttend + dtsfc(i) = dtsfc(i)+ttend*cont*del(i,k) + enddo + enddo +! +! compute tridiagonal matrix elements for moisture, clouds, and gases +! + do k = 1,km + do i = 1,im + au(i,k) = 0. + al(i,k) = 0. + ad(i,k) = 0. + enddo + enddo +! + do ic = 1,ndiff + do i = 1,im + do k = 1,km + f3(i,k,ic) = 0. + enddo + enddo + enddo +! + do i = 1,im + ad(i,1) = 1. + f3(i,1,1) = qx(i,1,1)+qfx(i)*g/del(i,1)*dt2 + enddo +! + if(ndiff.ge.2) then + do ic = 2,ndiff + do i = 1,im + f3(i,1,ic) = qx(i,1,ic) + enddo + enddo + endif +! + do k = 1,km-1 + do i = 1,im + if(k.ge.kpbl(i)) then + xkzq(i,k) = xkzh(i,k) + endif + enddo + enddo +! + do k = 1,km-1 + do i = 1,im + dtodsd = dt2/del(i,k) + dtodsu = dt2/del(i,k+1) + dsig = p2d(i,k)-p2d(i,k+1) + rdz = 1./dza(i,k+1) + tem1 = dsig*xkzq(i,k)*rdz + if(pblflg(i).and.k.lt.kpbl(i)) then + dsdzq = tem1*(-qfxpbl(i)*zfacent(i,k)/xkzq(i,k)) + f3(i,k,1) = f3(i,k,1)+dtodsd*dsdzq + f3(i,k+1,1) = qx(i,k+1,1)-dtodsu*dsdzq + elseif(pblflg(i).and.k.ge.kpbl(i).and.entfac(i,k).lt.4.6) then + xkzq(i,k) = -we(i)*dza(i,kpbl(i))*exp(-entfac(i,k)) + xkzq(i,k) = sqrt(xkzq(i,k)*xkzhl(i,k)) + xkzq(i,k) = max(xkzq(i,k),xkzoh(i,k)) + xkzq(i,k) = min(xkzq(i,k),xkzmax) + f3(i,k+1,1) = qx(i,k+1,1) + else + f3(i,k+1,1) = qx(i,k+1,1) + endif + tem1 = dsig*xkzq(i,k)*rdz + dsdz2 = tem1*rdz + au(i,k) = -dtodsd*dsdz2 + al(i,k) = -dtodsu*dsdz2 + ad(i,k) = ad(i,k)-au(i,k) + ad(i,k+1) = 1.-al(i,k) + enddo + enddo +! + if(ndiff.ge.2) then + do ic = 2,ndiff + do k = 1,km-1 + do i = 1,im + f3(i,k+1,ic) = qx(i,k+1,ic) + enddo + enddo + enddo + endif +! +! copies here to avoid duplicate input args for tridin +! + do k = 1,km + do i = 1,im + cu(i,k) = au(i,k) + enddo + enddo +! + do ic = 1,ndiff + do k = 1,km + do i = 1,im + r3(i,k,ic) = f3(i,k,ic) + enddo + enddo + enddo +! +! solve tridiagonal problem for moisture, clouds, and gases +! + call tridin_ysu(al,ad,cu,r3,au,f3,im,km,ndiff) +! +! recover tendencies of heat and moisture +! + do k = km,1,-1 + do i = 1,im + qtend = (f3(i,k,1)-qx(i,k,1))*rdt + qtnp(i,k,1) = qtnp(i,k,1)+qtend + dqsfc(i) = dqsfc(i)+qtend*conq*del(i,k) + enddo + enddo +! + if(ndiff.ge.2) then + do ic = 2,ndiff + do k = km,1,-1 + do i = 1,im + qtend = (f3(i,k,ic)-qx(i,k,ic))*rdt + qtnp(i,k,ic) = qtnp(i,k,ic)+qtend + enddo + enddo + enddo + endif +! +! compute tridiagonal matrix elements for momentum +! + do i = 1,im + do k = 1,km + au(i,k) = 0. + al(i,k) = 0. + ad(i,k) = 0. + f1(i,k) = 0. + f2(i,k) = 0. + enddo + enddo +! + do i = 1,im + ad(i,1) = 1.+ust(i)**2/wspd1(i)*rhox(i)*g/del(i,1)*dt2 & + *(wspd1(i)/wspd(i))**2 + f1(i,1) = ux(i,1)+uox(i)*ust(i)**2*g/del(i,1)*dt2/wspd1(i) + f2(i,1) = vx(i,1)+vox(i)*ust(i)**2*g/del(i,1)*dt2/wspd1(i) + enddo +! + do k = 1,km-1 + do i = 1,im + dtodsd = dt2/del(i,k) + dtodsu = dt2/del(i,k+1) + dsig = p2d(i,k)-p2d(i,k+1) + rdz = 1./dza(i,k+1) + tem1 = dsig*xkzm(i,k)*rdz + if(pblflg(i).and.k.lt.kpbl(i))then + dsdzu = tem1*(-hgamu(i)/hpbl(i)-ufxpbl(i)*zfacent(i,k)/xkzm(i,k)) + dsdzv = tem1*(-hgamv(i)/hpbl(i)-vfxpbl(i)*zfacent(i,k)/xkzm(i,k)) + f1(i,k) = f1(i,k)+dtodsd*dsdzu + f1(i,k+1) = ux(i,k+1)-dtodsu*dsdzu + f2(i,k) = f2(i,k)+dtodsd*dsdzv + f2(i,k+1) = vx(i,k+1)-dtodsu*dsdzv + elseif(pblflg(i).and.k.ge.kpbl(i).and.entfac(i,k).lt.4.6) then + xkzm(i,k) = prpbl(i)*xkzh(i,k) + xkzm(i,k) = sqrt(xkzm(i,k)*xkzml(i,k)) + xkzm(i,k) = max(xkzm(i,k),xkzom(i,k)) + xkzm(i,k) = min(xkzm(i,k),xkzmax) + f1(i,k+1) = ux(i,k+1) + f2(i,k+1) = vx(i,k+1) + else + f1(i,k+1) = ux(i,k+1) + f2(i,k+1) = vx(i,k+1) + endif + tem1 = dsig*xkzm(i,k)*rdz + dsdz2 = tem1*rdz + au(i,k) = -dtodsd*dsdz2 + al(i,k) = -dtodsu*dsdz2 + ad(i,k) = ad(i,k)-au(i,k) + ad(i,k+1) = 1.-al(i,k) + enddo + enddo +! +! copies here to avoid duplicate input args for tridin +! + do k = 1,km + do i = 1,im + cu(i,k) = au(i,k) + r1(i,k) = f1(i,k) + r2(i,k) = f2(i,k) + enddo + enddo +! +! solve tridiagonal problem for momentum +! + call tridi1n(al,ad,cu,r1,r2,au,f1,f2,im,km,1) +! +! recover tendencies of momentum +! + do k = km,1,-1 + do i = 1,im + utend = (f1(i,k)-ux(i,k))*rdt + vtend = (f2(i,k)-vx(i,k))*rdt + utnp(i,k) = utnp(i,k)+utend + vtnp(i,k) = vtnp(i,k)+vtend + dusfc(i) = dusfc(i) + utend*conwrc*del(i,k) + dvsfc(i) = dvsfc(i) + vtend*conwrc*del(i,k) + enddo + enddo +! +!---- end of vertical diffusion +! + do i = 1,im + kpbl1d(i) = kpbl(i) + enddo +! +! + end subroutine ysuvdif_run +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + subroutine tridi1n(cl,cm,cu,r1,r2,au,f1,f2,im,km,nt) + use machine , only : kind_phys +!------------------------------------------------------------------------------- + implicit none +!------------------------------------------------------------------------------- +! + integer, intent(in ) :: im, km, nt +! + real(kind=kind_phys), dimension( im, 2:km+1 ) , & + intent(in ) :: cl +! + real(kind=kind_phys), dimension( im, km ) , & + intent(in ) :: cm, & + r1 + real(kind=kind_phys), dimension( im, km,nt ) , & + intent(in ) :: r2 +! + real(kind=kind_phys), dimension( im, km ) , & + intent(inout) :: au, & + cu, & + f1 + real(kind=kind_phys), dimension( im, km,nt ) , & + intent(inout) :: f2 +! + real(kind=kind_phys) :: fk + integer :: i,k,l,n,it +! +!------------------------------------------------------------------------------- +! + l = im + n = km +! + do i = 1,l + fk = 1./cm(i,1) + au(i,1) = fk*cu(i,1) + f1(i,1) = fk*r1(i,1) + enddo +! + do it = 1,nt + do i = 1,l + fk = 1./cm(i,1) + f2(i,1,it) = fk*r2(i,1,it) + enddo + enddo +! + do k = 2,n-1 + do i = 1,l + fk = 1./(cm(i,k)-cl(i,k)*au(i,k-1)) + au(i,k) = fk*cu(i,k) + f1(i,k) = fk*(r1(i,k)-cl(i,k)*f1(i,k-1)) + enddo + enddo +! + do it = 1,nt + do k = 2,n-1 + do i = 1,l + fk = 1./(cm(i,k)-cl(i,k)*au(i,k-1)) + f2(i,k,it) = fk*(r2(i,k,it)-cl(i,k)*f2(i,k-1,it)) + enddo + enddo + enddo +! + do i = 1,l + fk = 1./(cm(i,n)-cl(i,n)*au(i,n-1)) + f1(i,n) = fk*(r1(i,n)-cl(i,n)*f1(i,n-1)) + enddo +! + do it = 1,nt + do i = 1,l + fk = 1./(cm(i,n)-cl(i,n)*au(i,n-1)) + f2(i,n,it) = fk*(r2(i,n,it)-cl(i,n)*f2(i,n-1,it)) + enddo + enddo +! + do k = n-1,1,-1 + do i = 1,l + f1(i,k) = f1(i,k)-au(i,k)*f1(i,k+1) + enddo + enddo +! + do it = 1,nt + do k = n-1,1,-1 + do i = 1,l + f2(i,k,it) = f2(i,k,it)-au(i,k)*f2(i,k+1,it) + enddo + enddo + enddo +! + end subroutine tridi1n +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + subroutine tridin_ysu(cl,cm,cu,r2,au,f2,im,km,nt) + use machine , only : kind_phys +!------------------------------------------------------------------------------- + implicit none +!------------------------------------------------------------------------------- +! + integer, intent(in ) :: im, km, nt +! + real(kind=kind_phys), dimension( im, 2:km+1 ) , & + intent(in ) :: cl +! + real(kind=kind_phys), dimension( im, km ) , & + intent(in ) :: cm + real(kind=kind_phys), dimension( im, km,nt ) , & + intent(in ) :: r2 +! + real(kind=kind_phys), dimension( im, km ) , & + intent(inout) :: au, & + cu + real(kind=kind_phys), dimension( im, km,nt ) , & + intent(inout) :: f2 +! + real(kind=kind_phys) :: fk + integer :: i,k,l,n,it +! +!------------------------------------------------------------------------------- +! + l = im + n = km +! + do it = 1,nt + do i = 1,l + fk = 1./cm(i,1) + au(i,1) = fk*cu(i,1) + f2(i,1,it) = fk*r2(i,1,it) + enddo + enddo +! + do it = 1,nt + do k = 2,n-1 + do i = 1,l + fk = 1./(cm(i,k)-cl(i,k)*au(i,k-1)) + au(i,k) = fk*cu(i,k) + f2(i,k,it) = fk*(r2(i,k,it)-cl(i,k)*f2(i,k-1,it)) + enddo + enddo + enddo +! + do it = 1,nt + do i = 1,l + fk = 1./(cm(i,n)-cl(i,n)*au(i,n-1)) + f2(i,n,it) = fk*(r2(i,n,it)-cl(i,n)*f2(i,n-1,it)) + enddo + enddo +! + do it = 1,nt + do k = n-1,1,-1 + do i = 1,l + f2(i,k,it) = f2(i,k,it)-au(i,k)*f2(i,k+1,it) + enddo + enddo + enddo +! + end subroutine tridin_ysu +!------------------------------------------------------------------------------- +end module ysuvdif +!-------------------------------------------------------------------------------