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_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 2e590451f..3796d68dc 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -32,7 +32,7 @@ end subroutine GFS_rrtmg_pre_init !! | kt | vertical_index_difference_between_layer_and_upper_bound | vertical index difference between layer and upper bound | index | 0 | integer | | out | F | !! | kb | vertical_index_difference_between_layer_and_lower_bound | vertical index difference between layer and lower bound | index | 0 | integer | | out | F | !! | raddt | time_step_for_radiation | radiation time step | s | 0 | real | kind_phys | out | F | -!! | delp | layer_pressure_thickness_for_radiation | layer pressure thickness on radiation levels | hPa | 2 | real | kind_phys | out | F | +!! | delp | layer_pressure_thickness_for_radiation | layer pressure thickness on radiation levels | hPa | 2 | real | kind_phys | out | F | !! | dz | layer_thickness_for_radiation | layer thickness on radiation levels | km | 2 | real | kind_phys | out | F | !! | plvl | air_pressure_at_interface_for_radiation_in_hPa | air pressure at vertical interface for radiation calculation | hPa | 2 | real | kind_phys | out | F | !! | plyr | air_pressure_at_layer_for_radiation_in_hPa | air pressure at vertical layer for radiation calculation | hPa | 2 | real | kind_phys | out | F | @@ -407,10 +407,10 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input gasvmr_o2 (i,k) = gasvmr(i,k,4) gasvmr_co (i,k) = gasvmr(i,k,5) gasvmr_cfc11 (i,k) = gasvmr(i,k,6) - gasvmr_cfc12 (i,k) = gasvmr(i,k,7) - gasvmr_cfc22 (i,k) = gasvmr(i,k,8) - gasvmr_ccl4 (i,k) = gasvmr(i,k,9) - gasvmr_cfc113 (i,k) = gasvmr(i,k,10) + gasvmr_cfc12 (i,k) = gasvmr(i,k,7) + gasvmr_cfc22 (i,k) = gasvmr(i,k,8) + gasvmr_ccl4 (i,k) = gasvmr(i,k,9) + gasvmr_cfc113 (i,k) = gasvmr(i,k,10) enddo enddo @@ -539,12 +539,12 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input ! CCPP do j = 1,NBDSW do k = 1, LMK - do i = 1, IM + do i = 1, IM ! NF_AESW = 3 faersw1(i,k,j) = faersw(i,k,j,1) faersw2(i,k,j) = faersw(i,k,j,2) faersw3(i,k,j) = faersw(i,k,j,3) - enddo + enddo enddo enddo @@ -571,7 +571,7 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input ! --- ... obtain cloud information for radiation calculations ! if (ntcw > 0) then ! prognostic cloud schemes - + ccnd = 0.0_kind_phys if (Model%ncnd == 1) then ! Zhao_Carr_Sundqvist do k=1,LMK do i=1,IM @@ -615,13 +615,13 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input if (.not. Model%lgfdlmprad) then -! rsun the summation methods and order make the difference in calculation +! rsun the summation methods and order make the difference in calculation -! clw(:,:) = clw(:,:) + tracer1(:,1:LMK,Model%ntcw) & -! + tracer1(:,1:LMK,Model%ntiw) & -! + tracer1(:,1:LMK,Model%ntrw) & -! + tracer1(:,1:LMK,Model%ntsw) & -! + tracer1(:,1:LMK,Model%ntgl) +! clw(:,:) = clw(:,:) + tracer1(:,1:LMK,Model%ntcw) & +! + tracer1(:,1:LMK,Model%ntiw) & +! + tracer1(:,1:LMK,Model%ntrw) & +! + tracer1(:,1:LMK,Model%ntsw) & +! + tracer1(:,1:LMK,Model%ntgl) ccnd(:,:,1) = tracer1(:,1:LMK,ntcw) ccnd(:,:,1) = ccnd(:,:,1) + tracer1(:,1:LMK,ntrw) ccnd(:,:,1) = ccnd(:,:,1) + tracer1(:,1:LMK,ntiw) @@ -632,7 +632,7 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input ! do j=1,Model%ncld ! ccnd(:,:,1) = ccnd(:,:,1) + tracer1(:,1:LMK,ntcw+j-1) ! cloud condensate amount ! enddo - endif + endif do k=1,LMK do i=1,IM if (ccnd(i,k,1) < EPSQ ) ccnd(i,k,1) = 0.0 @@ -769,13 +769,13 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input ! call progcld4o (plyr, plvl, tlyr, tvly, qlyr, qstl, rhly, & ! --- inputs ! tracer1, Grid%xlat, Grid%xlon, Sfcprop%slmsk, & ! dz, delp, & -! ntrac-1, Model%ntcw-1,Model%ntiw-1,Model%ntrw-1,& +! ntrac-1, Model%ntcw-1,Model%ntiw-1,Model%ntrw-1,& ! Model%ntsw-1,Model%ntgl-1,Model%ntclamt-1, & ! im, lmk, lmp, & ! clouds, cldsa, mtopa, mbota, de_lgth) ! --- outputs - endif + endif - elseif(Model%imp_physics == 8 .or. Model%imp_physics == 6) then ! Thompson / WSM6 cloud micrphysics scheme + elseif(Model%imp_physics == 8 .or. Model%imp_physics == 6) then ! Thompson / WSM6 cloud micrphysics scheme if (Model%kdt == 1) then Tbd%phy_f3d(:,:,1) = 10. @@ -783,16 +783,16 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input Tbd%phy_f3d(:,:,3) = 250. endif - call progcld5 (plyr,plvl,tlyr,qlyr,qstl,rhly,tracer1, & ! --- inputs + call progcld5 (plyr,plvl,tlyr,qlyr,qstl,rhly,tracer1, & ! --- inputs Grid%xlat,Grid%xlon,Sfcprop%slmsk,dz,delp, & - ntrac-1, ntcw-1,ntiw-1,ntrw-1, & + ntrac-1, ntcw-1,ntiw-1,ntrw-1, & ntsw-1,ntgl-1, & im, lmk, lmp, Model%uni_cld, & Model%lmfshal,Model%lmfdeep2, & cldcov(:,1:LMK),Tbd%phy_f3d(:,:,1), & Tbd%phy_f3d(:,:,2), Tbd%phy_f3d(:,:,3), & - clouds,cldsa,mtopa,mbota, de_lgth) ! --- outputs - + clouds,cldsa,mtopa,mbota, de_lgth) ! --- outputs + endif ! end if_imp_physics ! endif ! end_if_ntcw @@ -827,7 +827,7 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input ! mg, sfc-perts end subroutine GFS_rrtmg_pre_run - + !> \section arg_table_GFS_rrtmg_pre_finalize Argument Table !! subroutine GFS_rrtmg_pre_finalize () @@ -835,5 +835,3 @@ end subroutine GFS_rrtmg_pre_finalize !! @} end module GFS_rrtmg_pre - - 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/aer_cloud.F b/physics/aer_cloud.F index 680ce8438..ed7d38ab4 100644 --- a/physics/aer_cloud.F +++ b/physics/aer_cloud.F @@ -172,7 +172,7 @@ end subroutine aer_cloud_init subroutine aerosol_activate(tparc_in, pparc_in, sigwparc_in, - & wparc_ls, Aer_Props, npre_in, dpre_in, ccn_diagr8, Ndropr8, + & wparc_ls, Aer_Props, npre_in, dpre_in, ccn_diagr8, Ndropr8, & cdncr8, smaxliqr8, incr8, smaxicer8, nheticer8, INimmr8, & dINimmr8, Ncdepr8, Ncdhfr8, sc_icer8, fdust_immr8, fdust_depr8, & fdust_dhfr8, nlimr8, use_average_v, CCN_param, IN_param, fd_dust, @@ -224,9 +224,9 @@ subroutine aerosol_activate(tparc_in, pparc_in, sigwparc_in, ! & ddust_ice real*8 :: temp_par, pres_par real*8 :: akoh_par, alfa_par, bet2_par - real*8 aka_par, dv_par, psat_par, dair_par,surt_par,ddry_ice, + real*8 aka_par, dv_par, psat_par, dair_par,surt_par,ddry_ice, & np_ice,nin_ice,alfa_ice,beta_ice,shom_ice, koft_ice, dliq_ice, - & g1_ice, g2_ice,gdoin_ice, z_ice, norg_ice, sigorg_ice, + & g1_ice, g2_ice,gdoin_ice, z_ice, norg_ice, sigorg_ice, & dorg_ice, dbc_ice,sigbc_ice,lambda_ice, & kdust_ice, kbc_ice, shdust_ice, shbc_ice, & effdust_ice, effbc_ice, del1dust_ice, si0dust_ice, del1bc_ice, @@ -433,7 +433,7 @@ subroutine aerosol_activate(tparc_in, pparc_in, sigwparc_in, shdust_ice = 0. shbc_ice = 0. effdust_ice = 0. - effbc_ice = 0. + effbc_ice = 0. del1dust_ice = 0. si0dust_ice = 0. del1bc_ice = 0. @@ -460,7 +460,9 @@ subroutine aerosol_activate(tparc_in, pparc_in, sigwparc_in, ! allocate(sigdust_ice(nbindust_ice)) ! allocate(ddust_ice(nbindust_ice)) - + ddust_ice = zero_par + ndust_ice = zero_par + sigdust_ice = zero_par do n=1,nbindust_ice ddust_ice(n) = DBLE(Aeraux%dpg(n)) ndust_ice(n) = DBLE(Aeraux%num(n))*air_den @@ -1294,7 +1296,7 @@ subroutine ccn_at_super (super,ccn_at_s,nmodes, do j=1, nmodes dlgsg = sig_par(j) - + if (sg_par(j) .gt. 0.0) then if (super .gt. 0.0) then dlgsp = dlog(sg_par(j)/super) @@ -2634,7 +2636,7 @@ real*8 function FINDSMAX(SX,DSH, tao=NHET_*SIZECORR*SX*sqrt(DSTAR)/(SX+1d0)/NSTAR - + else DSH=SX-sh_ice @@ -3076,7 +3078,8 @@ subroutine INSPEC_ice(six, N, Dsh,np_ice,norg_ice, sigorg_ice, & dNglassy, SIW, D_grid_bio, n_grid_bio,vpresw_ice,vpresi_ice real*8, dimension(3) :: sig_array, the_array, frac_array - real*8, dimension(:) :: ndust_ice, sigdust_ice,ddust_ice + real*8, dimension(1:nbindust_ice) :: ndust_ice, sigdust_ice, + & ddust_ice real :: n_iw, DSh_s , nbc_s, dbc_s, Asolo real, dimension (nbindust_ice) :: ndust_s, ddust_s @@ -4012,9 +4015,3 @@ real function H_1_smooth(X, X_1, X_2, Hlo, Hhi,dH1smooth) END MODULE aer_cloud - - - - - - 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_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/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 +!-------------------------------------------------------------------------------