diff --git a/.gitmodules b/.gitmodules index 5d206bcbf5..41f7345dd5 100644 --- a/.gitmodules +++ b/.gitmodules @@ -4,3 +4,6 @@ [submodule ".ci/hpc-workflows"] path = .ci/hpc-workflows url = https://github.com/islas/hpc-workflows +[submodule "phys/MYNN-EDMF"] + path = phys/MYNN-EDMF + url = https://github.com/NCAR/MYNN-EDMF diff --git a/CMakeLists.txt b/CMakeLists.txt index 3cd0264b72..0c365d018b 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -1,11 +1,11 @@ cmake_minimum_required( VERSION 3.20 ) -cmake_policy( SET CMP0118 NEW ) + +project( WRF ) enable_language( C ) enable_language( CXX ) enable_language( Fortran ) -project( WRF ) set( EXPORT_NAME ${PROJECT_NAME} ) if ( DEFINED CMAKE_TOOLCHAIN_FILE ) @@ -14,6 +14,11 @@ if ( DEFINED CMAKE_TOOLCHAIN_FILE ) # include( ${WRF_CONFIG} ) endif() +# Import default flags now, get rid of any imported release flag +# we will handle that ourselves with WRF_FCOPTIM/WRF_FCNOOPT +set( CMAKE_Fortran_FLAGS_RELEASE "" CACHE STRING "" FORCE ) +set( CMAKE_C_FLAGS_RELEASE "" CACHE STRING "" FORCE ) + # list( APPEND CMAKE_MODULE_PATH ) list( APPEND CMAKE_MODULE_PATH ${PROJECT_SOURCE_DIR}/cmake/ ${PROJECT_SOURCE_DIR}/cmake/modules ) @@ -213,6 +218,13 @@ set( DWORDSIZE 8 ) set( LWORDSIZE 4 ) +# To limit the KPP generation to not consume copious amounts of RAM +if ( NOT DEFINED MAX_KPP_GEN_THREADS ) + # 1 thread takes about 4.75 GB + set( MAX_KPP_GEN_THREADS 2 ) +endif() + + ######################## ################################################################################ @@ -254,6 +266,7 @@ endif() if ( ${ENABLE_KPP} AND NOT ${ENABLE_CHEM} ) message( WARNING "ENABLE_KPP requires ENABLE_CHEM but is not set, ignoring" ) + set( ENABLE_KPP OFF CACHE BOOL "Force ignore by configuration" FORCE ) endif() @@ -315,6 +328,29 @@ if ( ${USE_IPO} ) endif() + +################################################################################ +## +## Checkout external repositories using manage_externals +## +################################################################################ +message( STATUS "Checking out external repos via manage_externals" ) +set( LOG_FILE ${CMAKE_CURRENT_BINARY_DIR}/checkout_externals.log ) +execute_process( + COMMAND + ${PROJECT_SOURCE_DIR}/tools/manage_externals/checkout_externals --externals ${PROJECT_SOURCE_DIR}/arch/Externals.cfg + WORKING_DIRECTORY ${PROJECT_SOURCE_DIR} + RESULT_VARIABLE MANAGE_EXTERNALS_STATUS + OUTPUT_FILE ${LOG_FILE} + ERROR_FILE ${LOG_FILE} + ) +if ( ${MANAGE_EXTERNALS_STATUS} AND NOT ${MANAGE_EXTERNALS_STATUS} EQUAL 0 ) + message( FATAL_ERROR "Failed to checkout external repos via manage_externals" ) +else() + message( STATUS "Finished checking out external repos via manage_externals" ) +endif() + + ################################################################################ ## ## Create our flags / defines properties and variables to carry our information @@ -377,23 +413,20 @@ if ( ${USE_MPI} ) # Which may or may not get polluted by the environment # It still technically finds MPI but the output is nonintuitive # saying things like hdf5 or pthread - find_package( MPI REQUIRED COMPONENTS Fortran C ) - list( APPEND PROJECT_COMPILE_DEFINITIONS_OPTIONS - USE_MPI=1 - DM_PARALLEL - ) + # Supply any language-specific flags for interrogation if ( DEFINED WRF_MPI_Fortran_FLAGS AND NOT "${WRF_MPI_Fortran_FLAGS}" STREQUAL "" ) - list( APPEND PROJECT_COMPILE_OPTIONS_OPTIONS - $<$:${WRF_MPI_Fortran_FLAGS}> - ) + set( MPI_Fortran_COMPILER_FLAGS ${WRF_MPI_Fortran_FLAGS} ) endif() if ( DEFINED WRF_MPI_C_FLAGS AND NOT "${WRF_MPI_C_FLAGS}" STREQUAL "" ) - list( APPEND PROJECT_COMPILE_OPTIONS_OPTIONS - $<$:${WRF_MPI_C_FLAGS}> - ) + set( MPI_C_COMPILER_FLAGS ${WRF_MPI_C_FLAGS} ) endif() + find_package( MPI REQUIRED COMPONENTS Fortran C ) + list( APPEND PROJECT_COMPILE_DEFINITIONS_OPTIONS + USE_MPI=1 + DM_PARALLEL + ) # Check if MPI in all its glory has forced IPO down our throats due to hard-coding the wrapper flags # https://www.open-mpi.org/faq/?category=mpi-apps#why-no-rpath LOL! @@ -472,6 +505,19 @@ if ( ${ENABLE_CTSM} ) # find_package( CTSM REQUIRED ) endif() +if ( ${ENABLE_KPP} ) + find_package( BISON REQUIRED ) + find_package( FLEX REQUIRED ) + if ( ${FLEX_FOUND} AND "${FLEX_LIBRARIES}" STREQUAL "FL_LIBRARY-NOTFOUND" ) + message( FATAL_ERROR + "Flex executable found, but libraries were not. Please provide a searchable path for both " + "\n" + "Refer to https://cmake.org/cmake/help/latest/command/find_package.html for more info " + "on providing a suitable path" + ) + endif() +endif() + # Will need our own finder # find_package( GPFS REQUIRED ) @@ -678,10 +724,13 @@ list( APPEND PROJECT_COMPILE_DEFINITIONS_OPTIONS # Only define if set, this is to use #ifdef/#ifndef preprocessors # in code since cmake cannot handle basically any others :( # https://gitlab.kitware.com/cmake/cmake/-/issues/17398 +if ( ${USE_DOUBLE} ) + list( APPEND PROJECT_COMPILE_DEFINITIONS_OPTIONS DOUBLE_PRECISION ) +endif() if ( ${ENABLE_CHEM} ) - list( APPEND PROJECT_COMPILE_DEFINITIONS_OPTIONS WRF_CHEM=1 ) + list( APPEND PROJECT_COMPILE_DEFINITIONS_OPTIONS WRF_CHEM ) if ( ${ENABLE_KPP} ) - list( APPEND PROJECT_COMPILE_DEFINITIONS_OPTIONS WRF_KPP=1 ) + list( APPEND PROJECT_COMPILE_DEFINITIONS_OPTIONS WRF_KPP ) endif() endif() if ( ${ENABLE_CHEM} ) @@ -914,7 +963,7 @@ add_subdirectory( share ) add_subdirectory( frame ) add_subdirectory( inc ) -if ( ${WRF_CHEM} ) +if ( ${ENABLE_CHEM} ) add_subdirectory( chem ) endif() @@ -922,6 +971,10 @@ if ( ${ENABLE_HYDRO} ) add_subdirectory( hydro ) endif() +if ( ${WRF_CORE} STREQUAL "PLUS" ) + add_subdirectory( wrftladj ) +endif() + add_subdirectory( dyn_em ) diff --git a/Makefile b/Makefile index 2bdff94d81..022538c088 100644 --- a/Makefile +++ b/Makefile @@ -124,6 +124,20 @@ wrf : framework_only echo "NoahMP submodule files populating WRF directories" ; \ echo "------------------------------------------------------------------------------" ; \ fi + @if [ \( ! -f phys/module_bl_mynnedmf.F \) -o \ + \( ! -f phys/module_bl_mynnedmf_common.F \) -o \ + \( ! -f phys/module_bl_mynnedmf_common.F \) ] ; then \ + echo " " ; \ + echo "------------------------------------------------------------------------------" ; \ + echo "Error Error Error MYNN-EDMF submodule files not populating WRF directories" ; \ + echo "------------------------------------------------------------------------------" ; \ + echo " " ; \ + exit 31 ; \ + else \ + echo "------------------------------------------------------------------------------" ; \ + echo "MYNN-EDMF submodule files populating WRF directories" ; \ + echo "------------------------------------------------------------------------------" ; \ + fi if [ $(WRF_CHEM) -eq 1 ] ; then $(MAKE) MODULE_DIRS="$(ALL_MODULES)" chemics ; fi if [ $(WRF_EM_CORE) -eq 1 ] ; then $(MAKE) MODULE_DIRS="$(ALL_MODULES)" em_core ; fi if [ $(WRF_HYDRO) -eq 1 ] ; then $(MAKE) MODULE_DIRS="$(ALL_MODULES)" wrf_hydro ; fi @@ -595,7 +609,7 @@ em_real : wrf ln -sf ../../run/ishmael-qi-qr.bin . ; \ ln -sf ../../run/BROADBAND_CLOUD_GODDARD.bin . ; \ ln -sf ../../run/STOCHPERT.TBL . ; \ - if [ $(RWORDSIZE) -eq 8 ] ; then \ + if [ -n "$(DOUBLE_PRECISION)" ] ; then \ ln -sf ../../run/ETAMPNEW_DATA_DBL ETAMPNEW_DATA ; \ ln -sf ../../run/ETAMPNEW_DATA.expanded_rain_DBL ETAMPNEW_DATA.expanded_rain ; \ ln -sf ../../run/RRTM_DATA_DBL RRTM_DATA ; \ @@ -677,7 +691,7 @@ em_real : wrf ln -sf ../../run/ishmael-qi-qr.bin . ; \ ln -sf ../../run/BROADBAND_CLOUD_GODDARD.bin . ; \ ln -sf ../../run/STOCHPERT.TBL . ; \ - if [ $(RWORDSIZE) -eq 8 ] ; then \ + if [ -n "$(DOUBLE_PRECISION)" ] ; then \ ln -sf ../../run/ETAMPNEW_DATA_DBL ETAMPNEW_DATA ; \ ln -sf ../../run/ETAMPNEW_DATA.expanded_rain_DBL ETAMPNEW_DATA.expanded_rain ; \ ln -sf ../../run/RRTM_DATA_DBL RRTM_DATA ; \ diff --git a/README b/README index 64ceeda6b4..5dd83164c2 100644 --- a/README +++ b/README @@ -1,4 +1,4 @@ -WRF Model Version 4.6.1 +WRF Model Version 4.7.0 https://www2.mmm.ucar.edu/wrf/users/ diff --git a/Registry/Registry.EM_COMMON b/Registry/Registry.EM_COMMON index 76f485293d..4d133c9bfa 100644 --- a/Registry/Registry.EM_COMMON +++ b/Registry/Registry.EM_COMMON @@ -1142,7 +1142,6 @@ state real sub_thl3D ikj misc 1 - h "s state real sub_sqv3D ikj misc 1 - h "sub_sqv3D" "qv subsidence tendency from EDMF" "kg kg-1 s-1" state real det_thl3D ikj misc 1 - h "det_thl3D" "thetaL detrainment tendency from EDMF" "K s-1" state real det_sqv3D ikj misc 1 - h "det_sqv3D" "qv detrainment tendency from EDMF" "kg kg-1 s-1" -state integer ktop_plume ij misc 1 - h "ktop_plume" "k-level of highest pentrating plume" "" state real maxMF ij misc 1 - h "maxMF" "Maximum mass-flux (neg: all dry, pos: moist)" "m/s * area" state real maxwidth ij misc 1 - h "maxwidth" "Maximum plume width" "m" state real ztop_plume ij misc 1 - h "ztop_plume" "Height of tallest plume" "m" @@ -1613,6 +1612,9 @@ state real itype ikj misc 1 - hdu "i state real itype_2 ikj misc 1 - hdu "ice_type2" "Diagnostic ice type cat 2 ISHMAEL microphysics" "" state real itype_3 ikj misc 1 - hdu "ice_type3" "Diagnostic ice type cat 3 ISHMAEL microphysics" "" +state real ssat ikj dyn_em 1 - hdu "ssat" "Supersaturation wrt liquid" "%" +state real ssati ikj dyn_em 1 - hdu "ssati" "Supersaturation wrt ice" "%" + # LIGHTNING NUDGING #state real ltg_dat ij misc 1 - r "ltg_dat" "gridded lightning data" "Flash per xkm x xkm per LAD_INT sec" # END LIGHTNING NUDGING @@ -2417,12 +2419,13 @@ rconfig real nssl_rho_qhl namelist,physics 1 900 rconfig real nssl_rho_qs namelist,physics 1 100. rh "Snow particle density" "" "" rconfig integer nssl_icdx namelist,physics 1 6 rh "NSSL Graupel fall speed option" "" "" rconfig integer nssl_icdxhl namelist,physics 1 6 rh "NSSL Hail fall speed option" "" "" -rconfig integer nssl_hail_on namelist,physics max_domains -1 rh "NSSL Hail flag" "" "" +rconfig integer nssl_hail_on namelist,physics 1 -1 rh "NSSL Hail flag" "" "" rconfig integer nssl_ccn_on namelist,physics 1 -1 rh "NSSL CCN flag" "" "" rconfig integer nssl_ccn_is_ccna namelist,physics 1 0 rh "NSSL flag that CCN is CCNA" "" "" rconfig integer nssl_2moment_on namelist,physics 1 -1 rh "NSSL 2-moment flag" "" "" rconfig integer nssl_3moment namelist,physics 1 0 rh "NSSL 3-moment flag" "" "" rconfig integer nssl_density_on namelist,physics 1 -1 rh "NSSL graupel/hail density flag" "" "" +rconfig integer nssl_ssat_output namelist,physics 1 0 rh "NSSL ssat output flag" "" "" @@ -2476,7 +2479,7 @@ rconfig integer bl_mynn_mixlength namelist,physics 1 1 rconfig integer bl_mynn_edmf namelist,physics max_domains 1 irh "bl_mynn_edmf" "0:off,1:activate mass-flux in mynn" "" rconfig integer bl_mynn_edmf_mom namelist,physics max_domains 1 irh "bl_mynn_edmf_mom" "0:off,1:activate mass-flux transport of momentum" "" rconfig integer bl_mynn_edmf_tke namelist,physics max_domains 0 irh "bl_mynn_edmf_tke" "0:off,1:activate mass-flux transport of tke" "" -rconfig integer bl_mynn_mixscalars namelist,physics max_domains 0 irh "bl_mynn_mixscalars" "0:off,1:activate mixing of scalars (qnx, qnxfa) in MYNN" "" +rconfig integer bl_mynn_mixscalars namelist,physics max_domains 1 irh "bl_mynn_mixscalars" "0:off,1:activate mixing of scalars (qnx, qnxfa) in MYNN" "" rconfig integer bl_mynn_output namelist,physics max_domains 0 irh "bl_mynn_output" "0:off,1:Allocate and output extra 3D arrays" "" rconfig integer bl_mynn_cloudmix namelist,physics max_domains 1 irh "bl_mynn_cloudmix" "0:off,1:activate mixing of all cloud species" "" rconfig integer bl_mynn_mixqt namelist,physics max_domains 0 irh "bl_mynn_mixqt" "0:mix moisture species separate,1: mix total water" "" @@ -2502,6 +2505,7 @@ rconfig integer ideal_xland namelist,physics 1 1 rconfig real swrad_scat namelist,physics 1 1 irh "SWRAD_SCAT" "SCATTERING FACTOR IN SWRAD" "" rconfig integer surface_input_source namelist,physics 1 3 irh "surface_input_source" "1=static (fractional), 2=time dependent (dominant), 3=dominant cateogry from metgrid" "" rconfig integer num_soil_layers namelist,physics 1 5 irh "num_soil_layers" "" "" +rconfig integer default_soiltype namelist,physics 1 8 rh "default_soiltype" "Soil category used to correct missing values (default 8 : silty clay loam)" "" rconfig integer num_pft_clm namelist,physics 1 17 - "num_pft_clm" "" "" rconfig logical input_pft namelist,physics 1 .false. h "input_pft_flag" "use input pft instead of USGS" "" rconfig integer maxpatch namelist,physics 1 10 irh "maxpatch" "" "" @@ -3033,6 +3037,7 @@ package wdm6scheme mp_physics==16 - moist:qv,qc package nssl_2mom mp_physics==18 - moist:qv,qc,qr,qi,qs,qg package wsm7scheme mp_physics==24 - moist:qv,qc,qr,qi,qs,qg,qh;state:re_cloud,re_ice,re_snow package wdm7scheme mp_physics==26 - moist:qv,qc,qr,qi,qs,qg,qh;scalar:qnn,qnc,qnr;state:re_cloud,re_ice,re_snow +package udmscheme mp_physics==27 - moist:qv,qc,qr,qi,qs,qg,qh;scalar:qnn,qnc,qnr;state:re_cloud,re_ice,re_snow package thompsonaero mp_physics==28 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qnr,qnc,qnwfa,qnifa,qnbca;state:re_cloud,re_ice,re_snow,qnwfa2d,qnifa2d,taod5503d,taod5502d package thompsongh mp_physics==38 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qnr,qnc,qng,qvolg,qnwfa,qnifa,qnbca;state:re_cloud,re_ice,re_snow,qnwfa2d,qnifa2d,taod5503d,taod5502d package p3_1category mp_physics==50 - moist:qv,qc,qr,qi;scalar:qni,qnr,qir,qib;state:re_cloud,re_ice,vmi3d,rhopo3d,di3d,refl_10cm,th_old,qv_old @@ -3045,7 +3050,8 @@ package ntu mp_physics==56 - moist:qv,qc package etampnew mp_physics==95 - moist:qv,qc,qr,qs;scalar:qt;state:f_ice_phy,f_rain_phy,f_rimef_phy package gsfcgcescheme mp_physics==97 - moist:qv,qc,qr,qi,qs,qg package madwrf_mp mp_physics==96 - moist:qv,qc,qi,qs - +package rcon_mp_scheme mp_physics==29 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qnr,qnc,qnwfa,qnifa,qnbca;state:re_cloud,re_ice,re_snow,qnwfa2d,qnifa2d,taod5503d,taod5502d,cloudnc + package nssl2mconc nssl_2moment_on==1 - scalar:qndrop,qnr,qni,qns,qng;state:re_cloud,re_ice,re_snow package nssl3mg nssl_3moment==1 - scalar:qzr,qzg package nssl3m nssl_3moment==2 - scalar:qzr,qzg,qzh @@ -3054,6 +3060,8 @@ package nssl_hail1m nssl_hail_on==2 - moist:qh; package nssl_ccn_opt nssl_ccn_on==1 - scalar:qnn package nssl_graupelvol nssl_density_on==1 - scalar:qvolg package nssl_hailvol nssl_density_on==2 - scalar:qvolg,qvolh +package nssl_ssat_out nssl_ssat_output==1 - state:ssat +package nssl_ssati_out nssl_ssat_output==2 - state:ssat,ssati package radar_refl compute_radar_ref==1 - state:refl_10cm,refd_max @@ -3087,6 +3095,7 @@ package nssl_2mom_dfi mp_physics_dfi==18 - dfi_moist:dfi #package nssl_2momg_dfi mp_physics_dfi==22 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qndrop,dfi_qnr,dfi_qni,dfi_qns,dfi_qng,dfi_qvolg;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow package wsm7scheme_dfi mp_physics_dfi==24 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow package wdm7scheme_dfi mp_physics_dfi==26 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qnn,dfi_qnc,dfi_qnr;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow +package udmscheme_dfi mp_physics_dfi==27 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qnn,dfi_qnc,dfi_qnr;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow package thompsonaero_dfi mp_physics_dfi==28 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qnr,dfi_qnc,dfi_qnwfa,dfi_qnifa,dfi_qnbca;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow package thompsongh_dfi mp_physics_dfi==38 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qnr,dfi_qng,dfi_qvolg,dfi_qnc,dfi_qnwfa,dfi_qnifa,dfi_qnbca;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow package p3_1category_dfi mp_physics_dfi==50 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi;dfi_scalar:dfi_qni,dfi_qnr,dfi_qir,dfi_qib;state:dfi_re_cloud,dfi_re_ice @@ -3097,6 +3106,7 @@ package jensen_ishmael_dfi mp_physics_dfi==55 - dfi_moist:dfi package ntu_dfi mp_physics_dfi==56 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qnc,dfi_qnr,dfi_qni,dfi_qns,dfi_qng,dfi_qnh,dfi_qdcn,dfi_qtcn,dfi_qccn,dfi_qrcn,dfi_qnin,dfi_fi,dfi_fs,dfi_vi,dfi_vs,dfi_vg,dfi_ai,dfi_as,dfi_ag,dfi_ah,dfi_i3m package etampnew_dfi mp_physics_dfi==95 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qs;dfi_scalar:dfi_qt package gsfcgcescheme_dfi mp_physics_dfi==97 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg +package rcon_dfi mp_physics_dfi==29 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qnr,dfi_qnc,dfi_qnwfa,dfi_qnifa,dfi_qnbca;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow package noprogn progn==0 - - package progndrop progn==1 - scalar:qndrop;dfi_scalar:dfi_qndrop;state:qndropsource @@ -3177,7 +3187,7 @@ package kepsscheme bl_pbl_physics==17 - scalar:tke_ad package mrfscheme bl_pbl_physics==99 - - package tkebudget tke_budget==1 - state:qSHEAR,qBUOY,qDISS,qWT,dqke -package mynn_dmp_edmf bl_mynn_edmf==1 - state:ktop_plume,ztop_plume,maxmf,maxwidth +package mynn_dmp_edmf bl_mynn_edmf==1 - state:ztop_plume,maxmf,maxwidth package mynn_3Doutput bl_mynn_output==1 - state:edmf_a,edmf_w,edmf_thl,edmf_qt,edmf_ent,edmf_qc,sub_thl3D,sub_sqv3D,det_thl3D,det_sqv3D package pbl_cloud icloud_bl==1 - state:cldfra_bl,qc_bl,qi_bl @@ -3654,3 +3664,8 @@ rconfig integer windfarm_wake_model namelist,physics max_domai # wake overlap method, M1, M2, M3, M4 [1, 2, 3, 4] rconfig integer windfarm_overlap_method namelist,physics max_domains 4 rh "windfarm_overlap_method" "" "" rconfig real windfarm_deg namelist,physics max_domains 0 - "windfarm_deg" "for windfarm ideal case" "degree" + + +# outputs for RCON model. +state real CLOUDNC ij misc 1 - rh "CLOUDNC" "ACCUMULATED TOTAL GRID SCALE CLOUD PRECIPITATION" "mm" + diff --git a/Registry/Registry.EM_COMMON.var b/Registry/Registry.EM_COMMON.var index 6281c0f8e0..5df5eedcc0 100644 --- a/Registry/Registry.EM_COMMON.var +++ b/Registry/Registry.EM_COMMON.var @@ -347,6 +347,20 @@ state real QFX ij misc 1 - irh "Q state real REGIME ij misc 1 - irh "REGIME" "FLAGS: 1=Night/Stable, 2=Mechanical Turbulent, 3=Forced Conv, 4=Free Conv" "" state integer KPBL ij misc 1 - irh "KPBL" "LEVEL OF PBL TOP" "" +# Increment Output +state real u_iau ijk dyn_em 1 X ih5 "U_IAU" "x-wind component inc" "m s-1" +state real v_iau ijk dyn_em 1 Y ih5 "V_IAU" "y-wind component inc" "m s-1" +state real t_iau ijk dyn_em 1 - ih5 "T_IAU" "potential temp inc" "K" +state real w_iau ijk dyn_em 1 - ih5 "W_IAU" "z-wind component inc" "m s-1" +state real qv_iau ijk dyn_em 1 - ih5 "QV_IAU" "water water mixing ratio inc" "kg kg-1" +state real qc_iau ijk dyn_em 1 - ih5 "QC_IAU" "cloud water mixing ratio inc" "kg kg-1" +state real qr_iau ijk dyn_em 1 - ih5 "QR_IAU" "rain water mixing ratio inc" "kg kg-1" +state real qi_iau ijk dyn_em 1 - ih5 "QI_IAU" "ice water mixing ratio inc" "kg kg-1" +state real qs_iau ijk dyn_em 1 - ih5 "QS_IAU" "snow water mixing ratio inc" "kg kg-1" +state real qg_iau ijk dyn_em 1 - ih5 "QG_IAU" "graupel mixing ratio inc" "kg kg-1" +state real ph_iau ijk dyn_em 1 - ih5 "PH_IAU" "perturbation geopotential inc" "m2 s-2" +state real mu_iau ij dyn_em 1 - ih5 "MU_IAU" "dry air mass inc" "pa" + # #--------------------------------------------------------------------------------------------------------------------------------------- # diff --git a/Registry/Registry.wrfvar b/Registry/Registry.wrfvar index aa3c5bba64..85d694cdef 100644 --- a/Registry/Registry.wrfvar +++ b/Registry/Registry.wrfvar @@ -10,7 +10,7 @@ state real - ijkft g_scalar 1 - - - state real landmask ij misc 1 - i012rhd=(interp_fcnm)u=(copy_fcnm) "LANDMASK" "LAND MASK (1 FOR LAND, 0 FOR WATER)" "" -state real SST ij misc 1 - i01245rh05d=(interp_mask_water_field:lu_index,iswater) "SST" "SEA SURFACE TEMPERATURE" "K" +state real SST ij misc 1 - i01245rd=(interp_mask_water_field:lu_index,iswater) "SST" "SEA SURFACE TEMPERATURE" "K" # Registry entries that are exclusive to Registry.EM diff --git a/Registry/registry.em_shared_collection b/Registry/registry.em_shared_collection index 484514c482..28a75f175d 100644 --- a/Registry/registry.em_shared_collection +++ b/Registry/registry.em_shared_collection @@ -28,4 +28,5 @@ include registry.new3d_wif include registry.trad_fields include registry.solar_fields include registry.diags +include registry.iau include registry.CMAQ diff --git a/Registry/registry.iau b/Registry/registry.iau new file mode 100644 index 0000000000..882dfba9ce --- /dev/null +++ b/Registry/registry.iau @@ -0,0 +1,38 @@ +# IAU variables + +state character iau_time - - - - i{15}r "TIME_IAU" " " " " +state real mu_iau ij misc 1 - i{15}r "MU_IAU" "mu analysis increments array" " " +state real u_iau ikj misc 1 - i{15}r "U_IAU" "u analysis increments array" " " +state real v_iau ikj misc 1 - i{15}r "V_IAU" "v analysis increments array" " " +state real w_iau ikj misc 1 - i{15}r "W_IAU" "w analysis increments array" " " +state real p_iau ikj misc 1 - i{15}r "P_IAU" "p analysis increments array" " " +state real t_iau ikj misc 1 - i{15}r "T_IAU" "t analysis increments array" " " +state real ph_iau ikj misc 1 - i{15}r "PH_IAU" "ph analysis increments array" " " +state real qv_iau ikj misc 1 - i{15}r "QV_IAU" "qv analysis increments array" " " +state real qr_iau ikj misc 1 - i{15}r "QR_IAU" "qr analysis increments array" " " +state real qc_iau ikj misc 1 - i{15}r "QC_IAU" "qc analysis increments array" " " +state real qs_iau ikj misc 1 - i{15}r "QS_IAU" "qs analysis increments array" " " +state real qi_iau ikj misc 1 - i{15}r "QI_IAU" "qice analysis increments array" " " +state real qg_iau ikj misc 1 - i{15}r "QG_IAU" "qgraupel analysis increments array" " " + +state real RUIAUTEN ikj misc 1 X r "RUIAUTEN" "X WIND TENDENCY DUE TO IAU" "m s-2" +state real RVIAUTEN ikj misc 1 Y r "RVIAUTEN" "Y WIND TENDENCY DUE TO IAU" "m s-2" +state real RTHIAUTEN ikj misc 1 - r "RTHIAUTEN" "THETA TENDENCY DUE TO IAU" "K s-1" +state real RPHIAUTEN ikj misc 1 - r "RPHIAUTEN" "GEOPOTENTIAL TENDENCY DUE TO IAU" "m2 s-3" +state real RQVIAUTEN ikj misc 1 - r "RQVIAUTEN" "Q_V TENDENCY DUE TO IAU" "kg kg-1 s-1" +state real RQCIAUTEN ikj misc 1 - r "RQCIAUTEN" "Q_C TENDENCY DUE TO IAU" "kg kg-1 s-1" +state real RQRIAUTEN ikj misc 1 - r "RQRIAUTEN" "Q_R TENDENCY DUE TO IAU" "kg kg-1 s-1" +state real RQIIAUTEN ikj misc 1 - r "RQIIAUTEN" "Q_I TENDENCY DUE TO IAU" "kg kg-1 s-1" +state real RQSIAUTEN ikj misc 1 - r "RQSIAUTEN" "Q_S TENDENCY DUE TO IAU" "kg kg-1 s-1" +state real RQGIAUTEN ikj misc 1 - r "RQGIAUTEN" "Q_G TENDENCY DUE TO IAU" "kg kg-1 s-1" +state real RMUIAUTEN ij misc 1 - r "RMUIAUTEN" "MU TENDENCY DUE TO IAU" "Pa s-1" + +# IAU namelist options + +rconfig integer iau namelist,time_control max_domains 0 irh "analysis increments read" "0/1 ACTIVATE FOR ANALYSIS INCREMENTS UPDATES" "" +rconfig real iau_time_window_sec namelist,time_control max_domains 3600. irh "iau_time_window_sec" "TIME WINDOW OF INCREMENTS ANALYSIS UPDATES" "SECONDS" + +# IAU packages + +package noiau iau==0 - - +package iau iau==1 - state:u_iau,v_iau,w_iau,p_iau,t_iau,ph_iau,qqv_iau,qqr_iau,qqc_iau,qqs_iau,qqi_iau,qqg_iau,ruiauten,rviauten,rthiauten,rqviauten,rqciauten,rqriauten,rqiiauten,rqsiauten,rqgiauten diff --git a/Registry/registry.var b/Registry/registry.var index 32cc1471db..930d5a59d1 100644 --- a/Registry/registry.var +++ b/Registry/registry.var @@ -596,6 +596,7 @@ package wdm6scheme mp_physics==16 - moist:qv,qc # Note: Options 17, 19, 21, 22 are deprecated but still reserved for compatibility -- for now package nssl_2mom mp_physics==18 - moist:qv,qc,qr,qi,qs,qg package thompsonaero mp_physics==28 - moist:qv,qc,qr,qi,qs,qg +package rcon_mp_scheme mp_physics==29 - moist:qv,qc,qr,qi,qs,qg package p3_1category mp_physics==50 - moist:qv,qc,qr,qi package p3_1category_nc mp_physics==51 - moist:qv,qc,qr,qi package p3_2category mp_physics==52 - moist:qv,qc,qr,qi,qi2 @@ -627,6 +628,7 @@ package wdm6_4dvar mp_physics_4dvar==16 - g_moist:g_q # Note: Options 17, 19, 21, 22 are deprecated but still reserved for compatibility -- for now package nssl_2mom_4dvar mp_physics_4dvar==18 - g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg,g_qh;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg,a_qh package thompsonaero_4dvar mp_physics_4dvar==28 - g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg +package rcon_mp_scheme_4dvar mp_physics_4dvar==29 - g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg package p3_1category_4dvar mp_physics_4dvar==50 - g_moist:g_qv,g_qc,g_qr,g_qi;a_moist:a_qv,a_qc,a_qr,a_qi package p3_1category_nc_4dvar mp_physics_4dvar==51 - g_moist:g_qv,g_qc,g_qr,g_qi;a_moist:a_qv,a_qc,a_qr,a_qi package p3_2category_4dvar mp_physics_4dvar==52 - g_moist:g_qv,g_qc,g_qr,g_qi,g_qi2;a_moist:a_qv,a_qc,a_qr,a_qi,a_qi2 diff --git a/arch/Config.pl b/arch/Config.pl index 761c540abe..0c36ddcf12 100644 --- a/arch/Config.pl +++ b/arch/Config.pl @@ -25,6 +25,7 @@ $sw_compileflags=""; $sw_opt_level=""; $sw_rwordsize="\$\(NATIVE_RWORDSIZE\)"; +$sw_promotion=""; $sw_rttov_flag = "" ; $sw_rttov_inc = "" ; $sw_rttov_path = "" ; @@ -228,6 +229,10 @@ { $sw_config_line=substr( $ARGV[0], 13 ) ; } + if ( substr( $ARGV[0], 1, 6 ) eq "rword=" ) + { + $sw_rwordsize=substr( $ARGV[0], 7 ) ; + } shift @ARGV ; } @@ -316,6 +321,10 @@ } $sw_rwordsize = "8" if ( $sw_wrfplus_core eq "-DWRFPLUS=1" ); + if ( $sw_rwordsize eq "8" ) + { + $sw_promotion = "-DDOUBLE_PRECISION" ; + } # A separately-installed ESMF library is required to build the ESMF # implementation of WRF IOAPI in external/io_esmf. This is needed @@ -634,6 +643,7 @@ $_ =~ s/CONFIGURE_LDFLAGS/$sw_ldflags/g ; $_ =~ s/CONFIGURE_COMPILEFLAGS/$sw_compileflags/g ; $_ =~ s/CONFIGURE_RWORDSIZE/$sw_rwordsize/g ; + $_ =~ s/CONFIGURE_PROMOTION/$sw_promotion/g ; $_ =~ s/CONFIGURE_FC/$sw_time $sw_fc/g ; $_ =~ s/CONFIGURE_CC/$sw_cc/g ; $_ =~ s/CONFIGURE_COMMS_LIB/$sw_comms_lib/g ; diff --git a/arch/Externals.cfg b/arch/Externals.cfg new file mode 100644 index 0000000000..48cd9b11e0 --- /dev/null +++ b/arch/Externals.cfg @@ -0,0 +1,10 @@ +[MMM-physics] +local_path = ./phys/physics_mmm +protocol = git +repo_url = https://github.com/NCAR/MMM-physics.git +tag = 20240626-MPASv8.2 + +required = True + +[externals_description] +schema_version = 1.0.0 diff --git a/arch/configure.defaults b/arch/configure.defaults index 8874630057..b0dc9ad502 100644 --- a/arch/configure.defaults +++ b/arch/configure.defaults @@ -42,7 +42,7 @@ RANLIB = ls RLFLAGS = #ranlib CC_TOOLS = cc -NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD + ########################################################### #ARCH Linux i486 i586 i686 armv7l aarch64, gfortran compiler with gcc #serial smpar dmpar dm+sm @@ -87,7 +87,7 @@ M4 = m4 -B 14000 RANLIB = ranlib RLFLAGS = CC_TOOLS = $(SCC) -NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD + ########################################################### #ARCH Linux i486 i586 i686, g95 compiler with gcc #serial dmpar @@ -131,7 +131,7 @@ M4 = m4 -B 14000 RANLIB = ranlib RLFLAGS = CC_TOOLS = $(SCC) -NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD + ########################################################### #ARCH Linux x86_64 ppc64le i486 i586 i686, PGI compiler with gcc # serial smpar dmpar dm+sm @@ -175,7 +175,7 @@ M4 = m4 -B 14000 RANLIB = ranlib RLFLAGS = CC_TOOLS = $(SCC) -NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD + ########################################################### #ARCH Linux x86_64 ppc64le, PGI compiler with pgcc, SGI MPT # serial smpar dmpar dm+sm @@ -219,7 +219,7 @@ M4 = m4 -B 14000 RANLIB = ranlib RLFLAGS = CC_TOOLS = $(SCC) -NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD + ########################################################### #ARCH Linux x86_64 ppc64le, PGI accelerator compiler with gcc # serial smpar dmpar dm+sm @@ -262,7 +262,7 @@ M4 = m4 -B 14000 RANLIB = ranlib RLFLAGS = CC_TOOLS = $(SCC) -NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD + ########################################################### #ARCH Linux x86_64 ppc64le i486 i586 i686, ifort compiler with icc #serial smpar dmpar dm+sm @@ -340,7 +340,7 @@ M4 = m4 RANLIB = ranlib RLFLAGS = CC_TOOLS = $(SCC) -NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD + ########################################################### #ARCH Linux x86_64 ppc64le i486 i586 i686, Xeon Phi (MIC architecture) ifort compiler with icc # dm+sm @@ -388,7 +388,7 @@ M4 = m4 RANLIB = ranlib RLFLAGS = CC_TOOLS = gcc -NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD + ########################################################### #ARCH Linux x86_64 ppc64le i486 i586 i686, Xeon (SNB with AVX mods) ifort compiler with icc # serial smpar dmpar dm+sm @@ -436,7 +436,7 @@ M4 = m4 RANLIB = ranlib RLFLAGS = CC_TOOLS = gcc -NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD + ########################################################### #ARCH Linux x86_64 ppc64le i486 i586 i686, ifort compiler with icc, SGI MPT #serial smpar dmpar dm+sm @@ -508,7 +508,7 @@ M4 = m4 RANLIB = ranlib RLFLAGS = CC_TOOLS = $(SCC) -NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD + ########################################################### #ARCH Linux x86_64 ppc64le i486 i586 i686, ifort compiler with icc, IBM POE #serial smpar dmpar dm+sm @@ -558,7 +558,7 @@ M4 = m4 RANLIB = ranlib RLFLAGS = CC_TOOLS = $(SCC) -NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD + ########################################################### #ARCH ia64 Linux ifort compiler with icc 9.x,10.x #serial smpar dmpar dm+sm @@ -640,7 +640,7 @@ M4 = m4 RANLIB = ranlib RLFLAGS = CC_TOOLS = $(SCC) -NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD + ########################################################### #ARCH Linux SGI Altix, ifort compiler with icc 9.x,10.x #serial smpar dmpar dm+sm @@ -724,7 +724,7 @@ M4 = m4 RANLIB = ranlib RLFLAGS = CC_TOOLS = $(SCC) -NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD + ########################################################### #ARCH Linux i486 i586 i686 x86_64 ppc64le, PathScale compiler with pathcc #serial dmpar @@ -768,7 +768,7 @@ M4 = m4 -B 14000 RANLIB = ranlib RLFLAGS = CC_TOOLS = $(SCC) -NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD + ########################################################### #ARCH Linux x86_64 ppc64le, gfortran compiler with gcc #serial smpar dmpar dm+sm @@ -815,7 +815,7 @@ M4 = m4 -G RANLIB = ranlib RLFLAGS = CC_TOOLS = $(SCC) -NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD + ########################################################### #ARCH Darwin x86_64 arm64, (MACOS) PGI compiler with pgcc #serial smpar dmpar dm+sm @@ -859,7 +859,7 @@ M4 = m4 -B 14000 RANLIB = ranlib RLFLAGS = -c CC_TOOLS = cc -NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD + ########################################################### #ARCH Darwin x86_64 arm64, (MACOS) intel compiler with icc #serial smpar dmpar dm+sm @@ -906,7 +906,7 @@ M4 = m4 -B 14000 RANLIB = ranlib RLFLAGS = -c CC_TOOLS = cc -NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD + ########################################################### #ARCH Darwin x86_64 arm64, (MACOS) intel compiler with clang EDIT FOR OPENMPI #serial smpar dmpar dm+sm @@ -952,7 +952,7 @@ M4 = m4 -B 14000 RANLIB = ranlib RLFLAGS = -c CC_TOOLS = cc -NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD + ########################################################### #ARCH Darwin x86_64 arm64, (MACOS) g95 with gcc #serial dmpar @@ -997,7 +997,7 @@ M4 = m4 -B 14000 RANLIB = ranlib -c RLFLAGS = -c CC_TOOLS = $(SCC) -NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD + ########################################################### #ARCH Darwin x86_64 arm64, (MACOS) gfortran with gcc #serial smpar dmpar dm+sm @@ -1042,7 +1042,7 @@ M4 = m4 -B 14000 RANLIB = ranlib RLFLAGS = -c CC_TOOLS = $(SCC) -NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD + ########################################################### #ARCH Darwin x86_64 arm64, (MACOS) gfortran with clang #serial smpar dmpar dm+sm @@ -1087,7 +1087,7 @@ M4 = m4 -B 14000 RANLIB = ranlib RLFLAGS = -c CC_TOOLS = clang -NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD + ########################################################### #ARCH Darwin x86_64 arm64, (MACOS) xlf #serial dmpar @@ -1133,7 +1133,7 @@ M4 = m4 -B 14000 RANLIB = ranlib RLFLAGS = -c CC_TOOLS = $(SCC) -NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD + ########################################################### #ARCH AIX xlf compiler with xlc #serial smpar dmpar dm+sm @@ -1182,7 +1182,7 @@ M4 = m4 -B 20000 RANLIB = ranlib RLFLAGS = CC_TOOLS = cc -NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD + ########################################################### #ARCH Linux x86_64 ppc64le i486 i586 i686, xlf compiler with xlc # serial smpar dmpar dm+sm @@ -1234,7 +1234,7 @@ M4 = m4 -B 14000 RANLIB = ranlib RLFLAGS = CC_TOOLS = cc -NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD + ########################################################### #ARCH Cray XC CLE/Linux x86_64, PGI compiler with gcc # serial dmpar smpar dm+sm @@ -1297,7 +1297,7 @@ M4 = m4 -B 14000 RANLIB = ranlib RLFLAGS = CC_TOOLS = $(SCC) -NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD + ########################################################### #ARCH Cray XE and XC CLE/Linux x86_64, Cray CCE compiler # serial dmpar smpar dm+sm @@ -1348,7 +1348,7 @@ M4 = m4 RANLIB = ranlib RLFLAGS = CC_TOOLS = gcc -NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD + ########################################################### #ARCH Cray XC CLE/Linux x86_64, Xeon ifort compiler # serial dmpar smpar dm+sm @@ -1398,7 +1398,7 @@ M4 = m4 RANLIB = ranlib RLFLAGS = CC_TOOLS = gcc -NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD + ########################################################### @@ -1451,7 +1451,7 @@ M4 = m4 -B 14000 RANLIB = ranlib RLFLAGS = CC_TOOLS = cc -NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD + ########################################################### #ARCH Linux ppc64 BG /P xlf compiler with xlc # smpar dmpar dm+sm @@ -1500,7 +1500,7 @@ M4 = m4 -B 14000 RANLIB = ranlib RLFLAGS = CC_TOOLS = cc -NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD + ########################################################### #ARCH Linux ppc64 IBM Blade Server xlf compiler with xlc # dmpar @@ -1546,7 +1546,7 @@ M4 = m4 -B 14000 RANLIB = ranlib RLFLAGS = CC_TOOLS = xlc -q64 -NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD + ########################################################### #ARCH Linux x86_64 ppc64le i486 i586 i686, PGI compiler with pgcc # serial smpar dmpar dm+sm @@ -1590,7 +1590,7 @@ M4 = m4 -B 14000 RANLIB = ranlib RLFLAGS = CC_TOOLS = $(SCC) -NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD + ########################################################### #ARCH CYGWIN_NT i686, PGI compiler on Windows # serial smpar dmpar dm+sm @@ -1634,7 +1634,7 @@ M4 = NA RANLIB = ranlib RLFLAGS = CC_TOOLS = $(SCC) -NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD + LIB_EXTERNAL = \ ../external/io_netcdf/libwrfio_nf.a CONFIGURE_NETCDF_PATH/lib/libnetcdf.lib \ @@ -1692,7 +1692,7 @@ M4 = m4 -B 14000 RANLIB = ranlib RLFLAGS = CC_TOOLS = $(SCC) -NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD + ########################################################### #ARCH Darwin x86_64 arm64, (MACOS) PGI compiler with pgcc -f90= #serial smpar dmpar dm+sm @@ -1736,7 +1736,7 @@ M4 = m4 -B 14000 RANLIB = ranlib RLFLAGS = -c CC_TOOLS = cc -NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD + ########################################################### #ARCH Darwin x86_64 arm64, (MACOS) intel compiler with icc #serial smpar dmpar dm+sm @@ -1783,7 +1783,7 @@ M4 = m4 -B 14000 RANLIB = ranlib RLFLAGS = -c CC_TOOLS = cc -NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD + ########################################################### #ARCH Darwin x86_64 arm64, (MACOS) gfortran with gcc openmpi #serial smpar dmpar dm+sm @@ -1828,7 +1828,7 @@ M4 = m4 -B 14000 RANLIB = ranlib RLFLAGS = -c CC_TOOLS = $(SCC) -NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD + ########################################################### #ARCH Linux x86_64 ppc64le i486 i586 i686, PGI compiler with pgcc -f90= # serial smpar dmpar dm+sm @@ -1872,7 +1872,7 @@ M4 = m4 -B 14000 RANLIB = ranlib RLFLAGS = CC_TOOLS = $(SCC) -NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD + ########################################################### #ARCH Linux HSW/BDW x86_64 ppc64le i486 i586 i686, ifort compiler with icc #serial smpar dmpar dm+sm @@ -1917,7 +1917,7 @@ M4 = m4 RANLIB = ranlib RLFLAGS = CC_TOOLS = $(SCC) -NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD + ########################################################### #ARCH Linux KNL x86_64 ppc64le i486 i586 i686, ifort compiler with icc #serial smpar dmpar dm+sm @@ -1962,7 +1962,7 @@ M4 = m4 RANLIB = ranlib RLFLAGS = CC_TOOLS = $(SCC) -NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD + ########################################################### #ARCH CYGWIN_NT i686 x86_64 Cygwin, gfortran compiler with gcc #serial smpar dmpar dm+sm @@ -2007,7 +2007,7 @@ M4 = m4 -G RANLIB = ranlib RLFLAGS = CC_TOOLS = $(SCC) -NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD + LIB_EXTERNAL = \ $(WRF_SRC_ROOT_DIR)/external/io_netcdf/libwrfio_nf.a CONFIGURE_NETCDF_PATH/lib/libnetcdf.dll.a \ @@ -2067,7 +2067,7 @@ M4 = m4 -G RANLIB = ranlib RLFLAGS = CC_TOOLS = $(SCC) -NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD + ########################################################### #ARCH AMD Linux x86_64, AOCC flang compiler with AOCC clang #serial smpar dmpar dm+sm @@ -2120,7 +2120,7 @@ M4 = m4 RANLIB = llvm-ranlib RLFLAGS = CC_TOOLS = $(SCC) -NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD + #insert new stanza here @@ -2168,13 +2168,13 @@ M4 = m4 RANLIB = ranlib RLFLAGS = CC_TOOLS = $(SCC) -NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD + ########################################################### #ARCH Linux aarch64, armclang compiler OpenMPI # serial smpar dmpar dm+sm # DESCRIPTION = armclang ($SFC/$SCC): Aarch64 -DMPARALLEL = +DMPARALLEL = # 1 OMPCPP = -fopenmp OMP = -fopenmp OMPCC = -fopenmp @@ -2214,7 +2214,7 @@ CC_TOOLS = $(SCC) -Wno-implicit-function-declaration -Wno-int-conver #ARCH Linux aarch64, GCC compiler OpenMPI # serial smpar dmpar dm+sm # DESCRIPTION = GCC ($SFC/$SCC): Aarch64 -DMPARALLEL = +DMPARALLEL = # 1 OMPCPP = -fopenmp OMP = -fopenmp OMPCC = -fopenmp @@ -2337,7 +2337,7 @@ M4 = m4 RANLIB = ranlib RLFLAGS = CC_TOOLS = /usr/bin/gcc -Wall -NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD + #insert new stanza before the Fujitsu block, keep Fujitsu at the end of the list ########################################################### diff --git a/arch/configure_reader.py b/arch/configure_reader.py index c52d776af7..0da6e52efa 100755 --- a/arch/configure_reader.py +++ b/arch/configure_reader.py @@ -19,6 +19,7 @@ referenceVar = re.compile( r"[$]([(])?(\w+)(?(1)[)])", re.I ) compileObject = re.compile( r"(\W|^)-c(\W|$)" ) configureRepl = re.compile( r"(\W|^)CONFIGURE_\w+(\W|$)" ) +defineRepl = re.compile( r"-D([^ ]+)" ) class Stanza(): @@ -140,7 +141,7 @@ def splitIntoFieldAndFlags( self, field ) : fieldValue = self.kvPairs_[ field ] self.kvPairs_[field] = fieldValue.partition(" ")[0] - self.kvPairs_[field + "_FLAGS"] = fieldValue.partition(" ")[1] + self.kvPairs_[field + "_FLAGS"] = fieldValue.partition(" ")[2] ###################################################################################################################### ## @@ -164,6 +165,7 @@ def sanitize( self ) : for keyToSan in self.kvPairs_.keys() : self.kvPairs_[ keyToSan ] = configureRepl.sub( r"\1\2", self.kvPairs_[ keyToSan ] ).strip() self.kvPairs_[ keyToSan ] = compileObject.sub( r"\1\2", self.kvPairs_[ keyToSan ] ).strip() + self.kvPairs_[ keyToSan ] = defineRepl.sub( r"\1", self.kvPairs_[ keyToSan ] ).strip() # Now fix certain ones that are mixing programs with flags all mashed into one option @@ -180,6 +182,26 @@ def sanitize( self ) : # And for final measure strip self.kvPairs_[ key ] = self.kvPairs_[ key ].strip() + # Finally, further sanitize MPI compilers, we don't need to specify underlying + # compiler since CMake already does that + filters = [ + self.kvPairs_[ "SFC" ], + self.kvPairs_[ "SCC" ], + "-compiler" + ] + keysToSanitize = [ "DM_FC_FLAGS", "DM_CC_FLAGS" ] + + for keyToSan in keysToSanitize : + if self.kvPairs_[ keyToSan ] : + allFlags = self.kvPairs_[ keyToSan ].split( " " ) + newFlags = [] + for flag in allFlags : + if not any( [ f in flag for f in filters ] ) : + newFlags.append( flag ) + + # We always need this field updated + self.kvPairs_[ keyToSan ] = " ".join( newFlags ) + def serialCompilersAvailable( self ) : return which( self.kvPairs_["SFC"] ) is not None and which( self.kvPairs_["SCC"] ) is not None diff --git a/arch/md_calls.inc b/arch/md_calls.inc index 88e0722fbb..11b6e3be24 100644 --- a/arch/md_calls.inc +++ b/arch/md_calls.inc @@ -258,7 +258,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef NETCDF CASE ( IO_NETCDF ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_ncd_get_dom_ti_double ( Hndl, Element, Data, & locCount, Outcount, Status ) # else @@ -280,7 +280,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef NETCDFPAR CASE ( IO_NETCDFPAR ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_ncdpar_get_dom_ti_double ( Hndl, Element, Data, & locCount, Outcount, Status ) # else @@ -291,7 +291,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef PNETCDF CASE ( IO_PNETCDF ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_pnc_get_dom_ti_double ( Hndl, Element, Data, & locCount, Outcount, Status ) # else @@ -301,7 +301,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef PHDF5 CASE ( IO_PHDF5 ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_phdf5_get_dom_ti_double ( Hndl, Element, Data, & locCount, Outcount, Status ) # else @@ -311,7 +311,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef ESMFIO CASE ( IO_ESMF ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_esmf_get_dom_ti_double ( Hndl, Element, Data, & locCount, Outcount, Status ) # else @@ -321,7 +321,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef XXX CASE ( IO_XXX ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_xxx_get_dom_ti_double ( Hndl, Element, Data, & locCount, Outcount, Status ) # else @@ -331,7 +331,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef YYY CASE ( IO_YYY ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_yyy_get_dom_ti_double ( Hndl, Element, Data, & locCount, Outcount, Status ) # else @@ -342,7 +342,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef GRIB1 CASE ( IO_GRIB1 ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_gr1_get_dom_ti_double ( Hndl, Element, Data, & locCount, Outcount, Status ) # else @@ -365,7 +365,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef GRIB2 CASE ( IO_GRIB2 ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_gr2_get_dom_ti_double ( Hndl, Element, Data, & locCount, Outcount, Status ) # else @@ -388,7 +388,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef INTIO CASE ( IO_INTIO ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_int_get_dom_ti_double ( Hndl, Element, Data, & locCount, Outcount, Status ) # else @@ -472,7 +472,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef NETCDF CASE ( IO_NETCDF ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_ncd_get_dom_ti_double ( Hndl, Element, Data, & locCount, Outcount, Status ) # else @@ -494,7 +494,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef NETCDFPAR CASE ( IO_NETCDFPAR ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_ncdpar_get_dom_ti_double ( Hndl, Element, Data, & locCount, Outcount, Status ) # else @@ -505,7 +505,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef PNETCDF CASE ( IO_PNETCDF ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_pnc_get_dom_ti_double ( Hndl, Element, Data, & locCount, Outcount, Status ) # else @@ -515,7 +515,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef PHDF5 CASE ( IO_PHDF5 ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_phdf5_get_dom_ti_double ( Hndl, Element, Data, & locCount, Outcount, Status ) # else @@ -525,7 +525,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef ESMFIO CASE ( IO_ESMF ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_esmf_get_dom_ti_double ( Hndl, Element, Data, & locCount, Outcount, Status ) # else @@ -535,7 +535,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef XXX CASE ( IO_XXX ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_xxx_get_dom_ti_double ( Hndl, Element, Data, & locCount, Outcount, Status ) # else @@ -545,7 +545,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef YYY CASE ( IO_YYY ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_yyy_get_dom_ti_double ( Hndl, Element, Data, & locCount, Outcount, Status ) # else @@ -556,7 +556,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef GRIB1 CASE ( IO_GRIB1 ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_gr1_get_dom_ti_double ( Hndl, Element, Data, & locCount, Outcount, Status ) # else @@ -579,7 +579,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef GRIB2 CASE ( IO_GRIB2 ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_gr2_get_dom_ti_double ( Hndl, Element, Data, & locCount, Outcount, Status ) # else @@ -602,7 +602,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef INTIO CASE ( IO_INTIO ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_int_get_dom_ti_double ( Hndl, Element, Data, & locCount, Outcount, Status ) # else @@ -688,7 +688,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef NETCDF CASE ( IO_NETCDF ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_ncd_put_dom_ti_double ( Hndl, Element, Data, & locCount, Status ) # else @@ -710,7 +710,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef NETCDFPAR CASE ( IO_NETCDFPAR ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_ncdpar_put_dom_ti_double ( Hndl, Element, Data, & locCount, Status ) # else @@ -721,7 +721,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef PNETCDF CASE ( IO_PNETCDF ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_pnc_put_dom_ti_double ( Hndl, Element, Data, & locCount, Status ) # else @@ -731,7 +731,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef PHDF5 CASE ( IO_PHDF5 ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_phdf5_put_dom_ti_double ( Hndl, Element, Data, & locCount, Status ) # else @@ -741,7 +741,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef ESMFIO CASE ( IO_ESMF ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_esmf_put_dom_ti_double ( Hndl, Element, Data, & locCount, Status ) # else @@ -751,7 +751,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef XXX CASE ( IO_XXX ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_xxx_put_dom_ti_double ( Hndl, Element, Data, & locCount, Status ) # else @@ -761,7 +761,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef YYY CASE ( IO_YYY ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_yyy_put_dom_ti_double ( Hndl, Element, Data, & locCount, Status ) # else @@ -772,7 +772,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef GRIB1 CASE ( IO_GRIB1 ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_gr1_put_dom_ti_double ( Hndl, Element, Data, & locCount, Status ) # else @@ -795,7 +795,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef GRIB2 CASE ( IO_GRIB2 ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_gr2_put_dom_ti_double ( Hndl, Element, Data, & locCount, Status ) # else @@ -818,7 +818,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef INTIO CASE ( IO_INTIO ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_int_put_dom_ti_double ( Hndl, Element, Data, & locCount, Status ) # else @@ -902,7 +902,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef NETCDF CASE ( IO_NETCDF ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_ncd_put_dom_ti_double ( Hndl, Element, Data, & locCount, Status ) # else @@ -924,7 +924,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef NETCDFPAR CASE ( IO_NETCDFPAR ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_ncdpar_put_dom_ti_double ( Hndl, Element, Data, & locCount, Status ) # else @@ -935,7 +935,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef PNETCDF CASE ( IO_PNETCDF ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_pnc_put_dom_ti_double ( Hndl, Element, Data, & locCount, Status ) # else @@ -945,7 +945,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef PHDF5 CASE ( IO_PHDF5 ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_phdf5_put_dom_ti_double ( Hndl, Element, Data, & locCount, Status ) # else @@ -955,7 +955,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef ESMFIO CASE ( IO_ESMF ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_esmf_put_dom_ti_double ( Hndl, Element, Data, & locCount, Status ) # else @@ -965,7 +965,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef XXX CASE ( IO_XXX ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_xxx_put_dom_ti_double ( Hndl, Element, Data, & locCount, Status ) # else @@ -975,7 +975,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef YYY CASE ( IO_YYY ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_yyy_put_dom_ti_double ( Hndl, Element, Data, & locCount, Status ) # else @@ -986,7 +986,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef GRIB1 CASE ( IO_GRIB1 ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_gr1_put_dom_ti_double ( Hndl, Element, Data, & locCount, Status ) # else @@ -1009,7 +1009,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef GRIB2 CASE ( IO_GRIB2 ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_gr2_put_dom_ti_double ( Hndl, Element, Data, & locCount, Status ) # else @@ -1032,7 +1032,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef INTIO CASE ( IO_INTIO ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_int_put_dom_ti_double ( Hndl, Element, Data, & locCount, Status ) # else @@ -3431,7 +3431,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef NETCDF CASE ( IO_NETCDF ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_ncd_get_dom_td_double ( Hndl, Element, DateStr, Data, & locCount, Outcount, Status ) # else @@ -3453,7 +3453,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef NETCDFPAR CASE ( IO_NETCDFPAR ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_ncdpar_get_dom_td_double ( Hndl, Element, DateStr, Data, & locCount, Outcount, Status ) # else @@ -3464,7 +3464,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef PNETCDF CASE ( IO_PNETCDF ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_pnc_get_dom_td_double ( Hndl, Element, DateStr, Data, & locCount, Outcount, Status ) # else @@ -3474,7 +3474,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef PHDF5 CASE ( IO_PHDF5 ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_phdf5_get_dom_td_double ( Hndl, Element, DateStr, Data, & locCount, Outcount, Status ) # else @@ -3484,7 +3484,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef ESMFIO CASE ( IO_ESMF ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_esmf_get_dom_td_double ( Hndl, Element, DateStr, Data, & locCount, Outcount, Status ) # else @@ -3494,7 +3494,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef XXX CASE ( IO_XXX ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_xxx_get_dom_td_double ( Hndl, Element, DateStr, Data, & locCount, Outcount, Status ) # else @@ -3504,7 +3504,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef YYY CASE ( IO_YYY ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_yyy_get_dom_td_double ( Hndl, Element, DateStr, Data, & locCount, Outcount, Status ) # else @@ -3515,7 +3515,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef GRIB1 CASE ( IO_GRIB1 ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_gr1_get_dom_td_double ( Hndl, Element, DateStr, Data, & locCount, Outcount, Status ) # else @@ -3538,7 +3538,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef GRIB2 CASE ( IO_GRIB2 ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_gr2_get_dom_td_double ( Hndl, Element, DateStr, Data, & locCount, Outcount, Status ) # else @@ -3561,7 +3561,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef INTIO CASE ( IO_INTIO ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_int_get_dom_td_double ( Hndl, Element, DateStr, Data, & locCount, Outcount, Status ) # else @@ -3645,7 +3645,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef NETCDF CASE ( IO_NETCDF ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_ncd_get_dom_td_double ( Hndl, Element, DateStr, Data, & locCount, Outcount, Status ) # else @@ -3667,7 +3667,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef NETCDFPAR CASE ( IO_NETCDFPAR ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_ncdpar_get_dom_td_double ( Hndl, Element, DateStr, Data, & locCount, Outcount, Status ) # else @@ -3678,7 +3678,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef PNETCDF CASE ( IO_PNETCDF ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_pnc_get_dom_td_double ( Hndl, Element, DateStr, Data, & locCount, Outcount, Status ) # else @@ -3688,7 +3688,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef PHDF5 CASE ( IO_PHDF5 ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_phdf5_get_dom_td_double ( Hndl, Element, DateStr, Data, & locCount, Outcount, Status ) # else @@ -3698,7 +3698,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef ESMFIO CASE ( IO_ESMF ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_esmf_get_dom_td_double ( Hndl, Element, DateStr, Data, & locCount, Outcount, Status ) # else @@ -3708,7 +3708,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef XXX CASE ( IO_XXX ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_xxx_get_dom_td_double ( Hndl, Element, DateStr, Data, & locCount, Outcount, Status ) # else @@ -3718,7 +3718,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef YYY CASE ( IO_YYY ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_yyy_get_dom_td_double ( Hndl, Element, DateStr, Data, & locCount, Outcount, Status ) # else @@ -3729,7 +3729,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef GRIB1 CASE ( IO_GRIB1 ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_gr1_get_dom_td_double ( Hndl, Element, DateStr, Data, & locCount, Outcount, Status ) # else @@ -3752,7 +3752,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef GRIB2 CASE ( IO_GRIB2 ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_gr2_get_dom_td_double ( Hndl, Element, DateStr, Data, & locCount, Outcount, Status ) # else @@ -3775,7 +3775,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef INTIO CASE ( IO_INTIO ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_int_get_dom_td_double ( Hndl, Element, DateStr, Data, & locCount, Outcount, Status ) # else @@ -3861,7 +3861,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef NETCDF CASE ( IO_NETCDF ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_ncd_put_dom_td_double ( Hndl, Element, DateStr, Data, & locCount, Status ) # else @@ -3883,7 +3883,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef NETCDFPAR CASE ( IO_NETCDFPAR ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_ncdpar_put_dom_td_double ( Hndl, Element, DateStr, Data, & locCount, Status ) # else @@ -3894,7 +3894,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef PNETCDF CASE ( IO_PNETCDF ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_pnc_put_dom_td_double ( Hndl, Element, DateStr, Data, & locCount, Status ) # else @@ -3904,7 +3904,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef PHDF5 CASE ( IO_PHDF5 ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_phdf5_put_dom_td_double ( Hndl, Element, DateStr, Data, & locCount, Status ) # else @@ -3914,7 +3914,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef ESMFIO CASE ( IO_ESMF ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_esmf_put_dom_td_double ( Hndl, Element, DateStr, Data, & locCount, Status ) # else @@ -3924,7 +3924,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef XXX CASE ( IO_XXX ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_xxx_put_dom_td_double ( Hndl, Element, DateStr, Data, & locCount, Status ) # else @@ -3934,7 +3934,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef YYY CASE ( IO_YYY ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_yyy_put_dom_td_double ( Hndl, Element, DateStr, Data, & locCount, Status ) # else @@ -3945,7 +3945,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef GRIB1 CASE ( IO_GRIB1 ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_gr1_put_dom_td_double ( Hndl, Element, DateStr, Data, & locCount, Status ) # else @@ -3968,7 +3968,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef GRIB2 CASE ( IO_GRIB2 ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_gr2_put_dom_td_double ( Hndl, Element, DateStr, Data, & locCount, Status ) # else @@ -3991,7 +3991,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef INTIO CASE ( IO_INTIO ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_int_put_dom_td_double ( Hndl, Element, DateStr, Data, & locCount, Status ) # else @@ -4075,7 +4075,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef NETCDF CASE ( IO_NETCDF ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_ncd_put_dom_td_double ( Hndl, Element, DateStr, Data, & locCount, Status ) # else @@ -4097,7 +4097,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef NETCDFPAR CASE ( IO_NETCDFPAR ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_ncdpar_put_dom_td_double ( Hndl, Element, DateStr, Data, & locCount, Status ) # else @@ -4108,7 +4108,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef PNETCDF CASE ( IO_PNETCDF ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_pnc_put_dom_td_double ( Hndl, Element, DateStr, Data, & locCount, Status ) # else @@ -4118,7 +4118,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef PHDF5 CASE ( IO_PHDF5 ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_phdf5_put_dom_td_double ( Hndl, Element, DateStr, Data, & locCount, Status ) # else @@ -4128,7 +4128,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef ESMFIO CASE ( IO_ESMF ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_esmf_put_dom_td_double ( Hndl, Element, DateStr, Data, & locCount, Status ) # else @@ -4138,7 +4138,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef XXX CASE ( IO_XXX ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_xxx_put_dom_td_double ( Hndl, Element, DateStr, Data, & locCount, Status ) # else @@ -4148,7 +4148,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef YYY CASE ( IO_YYY ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_yyy_put_dom_td_double ( Hndl, Element, DateStr, Data, & locCount, Status ) # else @@ -4159,7 +4159,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef GRIB1 CASE ( IO_GRIB1 ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_gr1_put_dom_td_double ( Hndl, Element, DateStr, Data, & locCount, Status ) # else @@ -4182,7 +4182,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef GRIB2 CASE ( IO_GRIB2 ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_gr2_put_dom_td_double ( Hndl, Element, DateStr, Data, & locCount, Status ) # else @@ -4205,7 +4205,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef INTIO CASE ( IO_INTIO ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_int_put_dom_td_double ( Hndl, Element, DateStr, Data, & locCount, Status ) # else @@ -6604,7 +6604,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef NETCDF CASE ( IO_NETCDF ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_ncd_get_var_ti_double ( Hndl, Element, Varname, Data, & locCount, Outcount, Status ) # else @@ -6626,7 +6626,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef NETCDFPAR CASE ( IO_NETCDFPAR ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_ncdpar_get_var_ti_double ( Hndl, Element, Varname, Data, & locCount, Outcount, Status ) # else @@ -6637,7 +6637,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef PNETCDF CASE ( IO_PNETCDF ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_pnc_get_var_ti_double ( Hndl, Element, Varname, Data, & locCount, Outcount, Status ) # else @@ -6647,7 +6647,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef PHDF5 CASE ( IO_PHDF5 ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_phdf5_get_var_ti_double ( Hndl, Element, Varname, Data, & locCount, Outcount, Status ) # else @@ -6657,7 +6657,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef ESMFIO CASE ( IO_ESMF ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_esmf_get_var_ti_double ( Hndl, Element, Varname, Data, & locCount, Outcount, Status ) # else @@ -6667,7 +6667,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef XXX CASE ( IO_XXX ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_xxx_get_var_ti_double ( Hndl, Element, Varname, Data, & locCount, Outcount, Status ) # else @@ -6677,7 +6677,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef YYY CASE ( IO_YYY ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_yyy_get_var_ti_double ( Hndl, Element, Varname, Data, & locCount, Outcount, Status ) # else @@ -6688,7 +6688,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef GRIB1 CASE ( IO_GRIB1 ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_gr1_get_var_ti_double ( Hndl, Element, Varname, Data, & locCount, Outcount, Status ) # else @@ -6711,7 +6711,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef GRIB2 CASE ( IO_GRIB2 ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_gr2_get_var_ti_double ( Hndl, Element, Varname, Data, & locCount, Outcount, Status ) # else @@ -6734,7 +6734,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef INTIO CASE ( IO_INTIO ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_int_get_var_ti_double ( Hndl, Element, Varname, Data, & locCount, Outcount, Status ) # else @@ -6818,7 +6818,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef NETCDF CASE ( IO_NETCDF ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_ncd_get_var_ti_double ( Hndl, Element, Varname, Data, & locCount, Outcount, Status ) # else @@ -6840,7 +6840,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef NETCDFPAR CASE ( IO_NETCDFPAR ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_ncdpar_get_var_ti_double ( Hndl, Element, Varname, Data, & locCount, Outcount, Status ) # else @@ -6851,7 +6851,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef PNETCDF CASE ( IO_PNETCDF ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_pnc_get_var_ti_double ( Hndl, Element, Varname, Data, & locCount, Outcount, Status ) # else @@ -6861,7 +6861,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef PIO CASE ( IO_PIO ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_pnc_get_var_ti_double ( Hndl, Element, Varname, Data, & locCount, Outcount, Status ) # else @@ -6871,7 +6871,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef PHDF5 CASE ( IO_PHDF5 ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_phdf5_get_var_ti_double ( Hndl, Element, Varname, Data, & locCount, Outcount, Status ) # else @@ -6881,7 +6881,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef ESMFIO CASE ( IO_ESMF ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_esmf_get_var_ti_double ( Hndl, Element, Varname, Data, & locCount, Outcount, Status ) # else @@ -6891,7 +6891,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef XXX CASE ( IO_XXX ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_xxx_get_var_ti_double ( Hndl, Element, Varname, Data, & locCount, Outcount, Status ) # else @@ -6901,7 +6901,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef YYY CASE ( IO_YYY ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_yyy_get_var_ti_double ( Hndl, Element, Varname, Data, & locCount, Outcount, Status ) # else @@ -6912,7 +6912,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef GRIB1 CASE ( IO_GRIB1 ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_gr1_get_var_ti_double ( Hndl, Element, Varname, Data, & locCount, Outcount, Status ) # else @@ -6935,7 +6935,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef GRIB2 CASE ( IO_GRIB2 ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_gr2_get_var_ti_double ( Hndl, Element, Varname, Data, & locCount, Outcount, Status ) # else @@ -6958,7 +6958,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef INTIO CASE ( IO_INTIO ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_int_get_var_ti_double ( Hndl, Element, Varname, Data, & locCount, Outcount, Status ) # else @@ -7044,7 +7044,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef NETCDF CASE ( IO_NETCDF ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_ncd_put_var_ti_double ( Hndl, Element, Varname, Data, & locCount, Status ) # else @@ -7066,7 +7066,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef NETCDFPAR CASE ( IO_NETCDFPAR ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_ncdpar_put_var_ti_double ( Hndl, Element, Varname, Data, & locCount, Status ) # else @@ -7077,7 +7077,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef PNETCDF CASE ( IO_PNETCDF ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_pnc_put_var_ti_double ( Hndl, Element, Varname, Data, & locCount, Status ) # else @@ -7087,7 +7087,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef PHDF5 CASE ( IO_PHDF5 ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_phdf5_put_var_ti_double ( Hndl, Element, Varname, Data, & locCount, Status ) # else @@ -7097,7 +7097,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef ESMFIO CASE ( IO_ESMF ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_esmf_put_var_ti_double ( Hndl, Element, Varname, Data, & locCount, Status ) # else @@ -7107,7 +7107,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef XXX CASE ( IO_XXX ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_xxx_put_var_ti_double ( Hndl, Element, Varname, Data, & locCount, Status ) # else @@ -7117,7 +7117,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef YYY CASE ( IO_YYY ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_yyy_put_var_ti_double ( Hndl, Element, Varname, Data, & locCount, Status ) # else @@ -7128,7 +7128,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef GRIB1 CASE ( IO_GRIB1 ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_gr1_put_var_ti_double ( Hndl, Element, Varname, Data, & locCount, Status ) # else @@ -7151,7 +7151,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef GRIB2 CASE ( IO_GRIB2 ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_gr2_put_var_ti_double ( Hndl, Element, Varname, Data, & locCount, Status ) # else @@ -7174,7 +7174,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef INTIO CASE ( IO_INTIO ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_int_put_var_ti_double ( Hndl, Element, Varname, Data, & locCount, Status ) # else @@ -7258,7 +7258,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef NETCDF CASE ( IO_NETCDF ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_ncd_put_var_ti_double ( Hndl, Element, Varname, Data, & locCount, Status ) # else @@ -7280,7 +7280,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef NETCDFPAR CASE ( IO_NETCDFPAR ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_ncdpar_put_var_ti_double ( Hndl, Element, Varname, Data, & locCount, Status ) # else @@ -7291,7 +7291,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef PNETCDF CASE ( IO_PNETCDF ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_pnc_put_var_ti_double ( Hndl, Element, Varname, Data, & locCount, Status ) # else @@ -7301,7 +7301,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef PHDF5 CASE ( IO_PHDF5 ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_phdf5_put_var_ti_double ( Hndl, Element, Varname, Data, & locCount, Status ) # else @@ -7311,7 +7311,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef ESMFIO CASE ( IO_ESMF ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_esmf_put_var_ti_double ( Hndl, Element, Varname, Data, & locCount, Status ) # else @@ -7321,7 +7321,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef XXX CASE ( IO_XXX ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_xxx_put_var_ti_double ( Hndl, Element, Varname, Data, & locCount, Status ) # else @@ -7331,7 +7331,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef YYY CASE ( IO_YYY ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_yyy_put_var_ti_double ( Hndl, Element, Varname, Data, & locCount, Status ) # else @@ -7342,7 +7342,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef GRIB1 CASE ( IO_GRIB1 ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_gr1_put_var_ti_double ( Hndl, Element, Varname, Data, & locCount, Status ) # else @@ -7365,7 +7365,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef GRIB2 CASE ( IO_GRIB2 ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_gr2_put_var_ti_double ( Hndl, Element, Varname, Data, & locCount, Status ) # else @@ -7388,7 +7388,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef INTIO CASE ( IO_INTIO ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_int_put_var_ti_double ( Hndl, Element, Varname, Data, & locCount, Status ) # else @@ -9787,7 +9787,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef NETCDF CASE ( IO_NETCDF ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_ncd_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, & locCount, Outcount, Status ) # else @@ -9809,7 +9809,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef NETCDFPAR CASE ( IO_NETCDFPAR ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_ncdpar_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, & locCount, Outcount, Status ) # else @@ -9820,7 +9820,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef PNETCDF CASE ( IO_PNETCDF ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_pnc_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, & locCount, Outcount, Status ) # else @@ -9830,7 +9830,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef PHDF5 CASE ( IO_PHDF5 ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_phdf5_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, & locCount, Outcount, Status ) # else @@ -9840,7 +9840,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef ESMFIO CASE ( IO_ESMF ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_esmf_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, & locCount, Outcount, Status ) # else @@ -9850,7 +9850,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef XXX CASE ( IO_XXX ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_xxx_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, & locCount, Outcount, Status ) # else @@ -9860,7 +9860,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef YYY CASE ( IO_YYY ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_yyy_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, & locCount, Outcount, Status ) # else @@ -9871,7 +9871,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef GRIB1 CASE ( IO_GRIB1 ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_gr1_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, & locCount, Outcount, Status ) # else @@ -9894,7 +9894,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef GRIB2 CASE ( IO_GRIB2 ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_gr2_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, & locCount, Outcount, Status ) # else @@ -9917,7 +9917,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef INTIO CASE ( IO_INTIO ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_int_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, & locCount, Outcount, Status ) # else @@ -10001,7 +10001,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef NETCDF CASE ( IO_NETCDF ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_ncd_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, & locCount, Outcount, Status ) # else @@ -10023,7 +10023,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef NETCDFPAR CASE ( IO_NETCDFPAR ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_ncdpar_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, & locCount, Outcount, Status ) # else @@ -10034,7 +10034,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef PNETCDF CASE ( IO_PNETCDF ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_pnc_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, & locCount, Outcount, Status ) # else @@ -10044,7 +10044,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef PHDF5 CASE ( IO_PHDF5 ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_phdf5_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, & locCount, Outcount, Status ) # else @@ -10054,7 +10054,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef ESMFIO CASE ( IO_ESMF ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_esmf_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, & locCount, Outcount, Status ) # else @@ -10064,7 +10064,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef XXX CASE ( IO_XXX ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_xxx_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, & locCount, Outcount, Status ) # else @@ -10074,7 +10074,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef YYY CASE ( IO_YYY ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_yyy_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, & locCount, Outcount, Status ) # else @@ -10085,7 +10085,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef GRIB1 CASE ( IO_GRIB1 ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_gr1_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, & locCount, Outcount, Status ) # else @@ -10108,7 +10108,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef GRIB2 CASE ( IO_GRIB2 ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_gr2_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, & locCount, Outcount, Status ) # else @@ -10131,7 +10131,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef INTIO CASE ( IO_INTIO ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_int_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, & locCount, Outcount, Status ) # else @@ -10217,7 +10217,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef NETCDF CASE ( IO_NETCDF ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_ncd_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, & locCount, Status ) # else @@ -10239,7 +10239,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef NETCDFPAR CASE ( IO_NETCDFPAR ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_ncdpar_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, & locCount, Status ) # else @@ -10250,7 +10250,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef PNETCDF CASE ( IO_PNETCDF ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_pnc_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, & locCount, Status ) # else @@ -10260,7 +10260,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef PHDF5 CASE ( IO_PHDF5 ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_phdf5_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, & locCount, Status ) # else @@ -10270,7 +10270,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef ESMFIO CASE ( IO_ESMF ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_esmf_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, & locCount, Status ) # else @@ -10280,7 +10280,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef XXX CASE ( IO_XXX ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_xxx_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, & locCount, Status ) # else @@ -10290,7 +10290,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef YYY CASE ( IO_YYY ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_yyy_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, & locCount, Status ) # else @@ -10301,7 +10301,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef GRIB1 CASE ( IO_GRIB1 ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_gr1_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, & locCount, Status ) # else @@ -10324,7 +10324,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef GRIB2 CASE ( IO_GRIB2 ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_gr2_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, & locCount, Status ) # else @@ -10347,7 +10347,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef INTIO CASE ( IO_INTIO ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_int_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, & locCount, Status ) # else @@ -10431,7 +10431,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef NETCDF CASE ( IO_NETCDF ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_ncd_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, & locCount, Status ) # else @@ -10453,7 +10453,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef NETCDFPAR CASE ( IO_NETCDFPAR ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_ncdpar_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, & locCount, Status ) # else @@ -10464,7 +10464,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef PNETCDF CASE ( IO_PNETCDF ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_pnc_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, & locCount, Status ) # else @@ -10474,7 +10474,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef PHDF5 CASE ( IO_PHDF5 ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_phdf5_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, & locCount, Status ) # else @@ -10484,7 +10484,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef ESMFIO CASE ( IO_ESMF ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_esmf_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, & locCount, Status ) # else @@ -10494,7 +10494,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef XXX CASE ( IO_XXX ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_xxx_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, & locCount, Status ) # else @@ -10504,7 +10504,7 @@ IF ( Hndl .GT. -1 ) THEN #endif #ifdef YYY CASE ( IO_YYY ) -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_yyy_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, & locCount, Status ) # else @@ -10515,7 +10515,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef GRIB1 CASE ( IO_GRIB1 ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_gr1_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, & locCount, Status ) # else @@ -10538,7 +10538,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef GRIB2 CASE ( IO_GRIB2 ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_gr2_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, & locCount, Status ) # else @@ -10561,7 +10561,7 @@ IF ( Hndl .GT. -1 ) THEN #ifdef INTIO CASE ( IO_INTIO ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION CALL ext_int_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, & locCount, Status ) # else diff --git a/arch/postamble b/arch/postamble index b5e585d29e..44a5bdf8de 100644 --- a/arch/postamble +++ b/arch/postamble @@ -2,8 +2,10 @@ # POSTAMBLE FGREP = fgrep -iq +### Used throughout the build system to inform promotion to double precision +DOUBLE_PRECISION = CONFIGURE_PROMOTION -ARCHFLAGS = $(COREDEFS) -DIWORDSIZE=$(IWORDSIZE) -DDWORDSIZE=$(DWORDSIZE) -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=$(LWORDSIZE) \ +ARCHFLAGS = $(COREDEFS) -DIWORDSIZE=$(IWORDSIZE) -DDWORDSIZE=$(DWORDSIZE) -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=$(LWORDSIZE) CONFIGURE_PROMOTION \ $(ARCH_LOCAL) \ $(DA_ARCHFLAGS) \ CONFIGURE_DMPARALLEL \ @@ -69,6 +71,8 @@ WRFPLUSPATH = CONFIGURE_WRFPLUS_PATH RTTOVPATH = CONFIGURE_RTTOV_PATH PNETCDFPATH = CONFIGURE_PNETCDF_PATH ADIOS2PATH = CONFIGURE_ADIOS2_PATH +NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD + bundled: io_only CONFIGURE_ATMOCN external: io_only CONFIGURE_COMMS_EXTERNAL $(ESMF_TARGET) diff --git a/chem/CMakeLists.txt b/chem/CMakeLists.txt index 544b253256..8c329a1397 100644 --- a/chem/CMakeLists.txt +++ b/chem/CMakeLists.txt @@ -4,6 +4,11 @@ target_include_directories( PRIVATE ${CMAKE_CURRENT_SOURCE_DIR} ) +if ( ${ENABLE_KPP} ) + add_compile_options ( "${PROJECT_COMPILE_OPTIONS}" ) + add_compile_definitions( "${PROJECT_COMPILE_DEFINITIONS}" ) + add_subdirectory( KPP ) +endif() ######################################################################################################################## # @@ -209,31 +214,47 @@ target_sources( aerosol_driver.F ) -######################################################################################################################## -# -# convert_emiss executable -# -######################################################################################################################## -add_executable( - convert_emiss - convert_emiss.F - ) - -target_link_libraries( - convert_emiss - PRIVATE - ${PROJECT_NAME}_Core - ) +#!TODO: I'm not entirely sure when this exec is supposed to be generated or if it +# is exclusive to the real test case +# ######################################################################################################################## +# # +# # convert_emiss executable +# # +# ######################################################################################################################## +# set( CONVERT_EMISS_TARGET convert_emiss ) +# add_executable( +# ${CONVERT_EMISS_TARGET} +# convert_emiss.F +# ) -target_compile_options( - convert_emiss - PRIVATE - ${PROJECT_COMPILE_OPTIONS} - ) +# target_link_libraries( +# ${CONVERT_EMISS_TARGET} +# PRIVATE +# ${PROJECT_NAME}_Core +# ) +# set_target_properties( +# ${CONVERT_EMISS_TARGET} +# PROPERTIES +# # Just dump everything in here +# Fortran_MODULE_DIRECTORY ${CMAKE_INSTALL_PREFIX}/modules/${CONVERT_EMISS_TARGET}/ +# Fortran_FORMAT FREE +# ) +# target_compile_options( +# convert_emiss +# PRIVATE +# ${PROJECT_COMPILE_OPTIONS} +# ) -target_compile_definitions( - convert_emiss - PRIVATE - ${PROJECT_COMPILE_DEFINITIONS} - ) +# target_compile_definitions( +# convert_emiss +# PRIVATE +# ${PROJECT_COMPILE_DEFINITIONS} +# ) +# install( +# TARGETS ${CONVERT_EMISS_TARGET} +# EXPORT ${EXPORT_NAME}Targets +# RUNTIME DESTINATION bin/ +# ARCHIVE DESTINATION lib/ +# LIBRARY DESTINATION lib/ +# ) diff --git a/chem/KPP/CMakeLists.txt b/chem/KPP/CMakeLists.txt new file mode 100644 index 0000000000..91e65723f7 --- /dev/null +++ b/chem/KPP/CMakeLists.txt @@ -0,0 +1,302 @@ + +message( STATUS "[KPP] Starting preprocessing preparation..." ) +list(APPEND CMAKE_MESSAGE_INDENT " ") + +# These names will also be used by the registry_kpp +set( + MECHANISMS + cb05_sorg_aq + cb05_sorg_vbs_aq + cbm4 + cbmz_bb + cbmz_mosaic + crimech + cri_mosaic_4bin_aq + cri_mosaic_8bin_aq + gocartracm + mozart + mozart_mosaic_4bin + mozart_mosaic_4bin_aq + mozcart + nmhc9 + racm + racm_esrlsorg + racm_esrlsorg_aqchem + racm_mim + racmpm + racm_soa_vbs + racm_soa_vbs_aqchem + racm_soa_vbs_het + racmsorg + racmsorg_aqchem + radm2 + radm2sorg + saprc99 + saprc99_mosaic_4bin_vbs2 + saprc99_mosaic_8bin_vbs2_aq + t1_mozcart + ) + +add_subdirectory( kpp/kpp-2.1 ) +add_subdirectory( util/wkc ) +add_subdirectory( util/write_decomp ) + + +target_sources( + ${PROJECT_NAME}_Core + PRIVATE + module_wkppc_constants.F + ) + +target_include_directories( + ${PROJECT_NAME}_Core + PRIVATE + ${CMAKE_CURRENT_SOURCE_DIR}/inc + ) + +set( GEN_MECHD_INC u l b a ibu ib ia e ) +set( + GEN_RCONST_INC + extra_args_to_update_rconst + extra_args_update_rconst + extra_decls_update_rconst + ) + +message( STATUS "[KPP] Adding generation for mechanisms" ) + +# Some helper vars for grouping the kpp gen and tuv inc +set( KPP_GEN_GROUPS ) +set( KPP_CURRENT_GEN_GROUP 0 ) + +set( TUV_PHOTOLYSIS_GEN FALSE ) +set( TUV_PHOTOLYSIS_CMD ) +set( TUV_PHOTOLYSIS_OUT ) + +foreach ( MECH ${MECHANISMS} ) + + ###################################################################################################################### + ## + ## Generate any "missing" includes that are just empty + ## + if ( EXISTS ${CMAKE_CURRENT_SOURCE_DIR}/inc/${MECH} ) + file( COPY ${CMAKE_CURRENT_SOURCE_DIR}/inc/${MECH}/ DESTINATION ${CMAKE_BINARY_DIR}/inc ) + endif() + + foreach ( MECHD_INAME ${GEN_MECHD_INC} ) + set( GEN_MECHD_INC_FILENAME kpp_mechd_${MECHD_INAME}_${MECH}.inc ) + if ( NOT EXISTS ${CMAKE_BINARY_DIR}/inc/${GEN_MECHD_INC_FILENAME} ) + message( STATUS "[KPP] Touching empty include ${GEN_MECHD_INC_FILENAME}" ) + file( TOUCH ${CMAKE_BINARY_DIR}/inc/${GEN_MECHD_INC_FILENAME} ) + endif() + endforeach() + + foreach ( RCONST_INAME ${GEN_RCONST_INC} ) + set( GEN_RCONST_INC_FILENAME ${RCONST_INAME}_${MECH}.inc ) + if ( NOT EXISTS ${CMAKE_BINARY_DIR}/inc/${GEN_RCONST_INC_FILENAME} ) + message( STATUS "[KPP] Touching empty include ${GEN_RCONST_INC_FILENAME}" ) + file( TOUCH ${CMAKE_BINARY_DIR}/inc/${GEN_RCONST_INC_FILENAME} ) + endif() + endforeach() + ## + ## + ## + ###################################################################################################################### + + ###################################################################################################################### + ## + ## run kpp model, generates .F files + ## + # KPP_HOME must be set by this point + # often set to chem/KPP/kpp/kpp-2.1 in case you didn't know it was KPP + set( KPP_HOME ${CMAKE_CURRENT_SOURCE_DIR}/kpp/kpp-2.1 ) + + # I'm using the configure-time dir creation to simplify custom target/command usage + set( KPP_WORKING_DIR ${CMAKE_CURRENT_BINARY_DIR}/mechanisms/${MECH} ) + file( COPY ${CMAKE_CURRENT_SOURCE_DIR}/mechanisms/${MECH}/ DESTINATION ${KPP_WORKING_DIR} ) + set( + ${MECH}_KPP_SOURCES + ${KPP_WORKING_DIR}/${MECH}_Parameters.f90 + ${KPP_WORKING_DIR}/${MECH}_Precision.f90 + ${KPP_WORKING_DIR}/${MECH}_JacobianSP.f90 + ${KPP_WORKING_DIR}/${MECH}_Jacobian.f90 + ${KPP_WORKING_DIR}/${MECH}_Update_Rconst.f90 + ) + set( + ${MECH}_KPP_SOURCES_INTEGRATOR + ${KPP_WORKING_DIR}/${MECH}_Integrator.f90 + ) + + add_custom_command( + OUTPUT + ${${MECH}_KPP_SOURCES} + ${${MECH}_KPP_SOURCES_INTEGRATOR} + COMMAND ${CMAKE_COMMAND} -E env KPP_HOME=${KPP_HOME} $ ${MECH}.kpp > ${CMAKE_BINARY_DIR}/kpp_${MECH}.log 2>&1 + COMMAND ${CMAKE_COMMAND} -E compare_files ${KPP_WORKING_DIR}/${MECH}_Integrator.f90 ${KPP_WORKING_DIR}/${MECH}_Integrator.f90 + COMMAND ${CMAKE_COMMAND} -E compare_files ${KPP_WORKING_DIR}/${MECH}_Parameters.f90 ${KPP_WORKING_DIR}/${MECH}_Parameters.f90 + COMMAND ${CMAKE_COMMAND} -E compare_files ${KPP_WORKING_DIR}/${MECH}_Precision.f90 ${KPP_WORKING_DIR}/${MECH}_Precision.f90 + COMMAND ${CMAKE_COMMAND} -E compare_files ${KPP_WORKING_DIR}/${MECH}_JacobianSP.f90 ${KPP_WORKING_DIR}/${MECH}_JacobianSP.f90 + COMMAND ${CMAKE_COMMAND} -E compare_files ${KPP_WORKING_DIR}/${MECH}_Jacobian.f90 ${KPP_WORKING_DIR}/${MECH}_Jacobian.f90 + COMMAND ${CMAKE_COMMAND} -E compare_files ${KPP_WORKING_DIR}/${MECH}_Update_Rconst.f90 ${KPP_WORKING_DIR}/${MECH}_Update_Rconst.f90 + WORKING_DIRECTORY ${KPP_WORKING_DIR} + DEPENDS kpp + ) + add_custom_target( + ${MECH}_kpp + COMMENT "[KPP] Generating kpp files for ${MECH}" + DEPENDS + ${${MECH}_KPP_SOURCES} + ${${MECH}_KPP_SOURCES_INTEGRATOR} + ) + + add_dependencies( ${PROJECT_NAME}_Core ${MECH}_kpp ) + target_sources( ${PROJECT_NAME}_Core PRIVATE ${${MECH}_KPP_SOURCES} ) + ## + ## + ## + ###################################################################################################################### + + ###################################################################################################################### + ## + ## Special KPP generation logic to streamline parallel building without crashing + ## + # Assign target to a group to serialize based on maximum threads allowed as + # this consumes a ton of RAM + list( LENGTH KPP_GEN_GROUPS KPP_GEN_GROUPS_LEN ) + if ( ${KPP_GEN_GROUPS_LEN} GREATER ${KPP_CURRENT_GEN_GROUP} ) + list( GET KPP_GEN_GROUPS ${KPP_CURRENT_GEN_GROUP} KPP_PREVIOUS_GROUP_TARGET ) + endif() + + # This is the start point, add it into the list + list( INSERT KPP_GEN_GROUPS ${KPP_CURRENT_GEN_GROUP} ${MECH}_kpp ) + MATH( EXPR KPP_NEXT_IDX "${KPP_CURRENT_GEN_GROUP} + 1" ) + + if ( DEFINED KPP_PREVIOUS_GROUP_TARGET ) + # Add as a dependency + add_dependencies( ${KPP_PREVIOUS_GROUP_TARGET} ${MECH}_kpp ) + # Replace current listing - currently next index is actually pointing to old + list( REMOVE_AT KPP_GEN_GROUPS ${KPP_NEXT_IDX} ) + endif() + + # Now we have min( MAX_KPP_GEN_THREADS, KPP_CURRENT_GEN_GROUP ) in list, loop modulus to go back to zero + MATH( EXPR KPP_CURRENT_GEN_GROUP "${KPP_NEXT_IDX} % ${MAX_KPP_GEN_THREADS}" ) + ## + ## end grouping logic + ## + ###################################################################################################################### + + + # generate tuv photolysis inc file + if ( EXISTS ${CMAKE_CURRENT_SOURCE_DIR}/mechanisms/${MECH}/${MECH}.tuv.jmap ) + if ( NOT ${TUV_PHOTOLYSIS_GEN} ) + set( TUV_PHOTOLYSIS_GEN TRUE ) + endif() + + list( + APPEND TUV_PHOTOLYSIS_CMD + COMMAND ${CMAKE_COMMAND} -E chdir ${KPP_WORKING_DIR} $ ${MECH} ${CMAKE_BINARY_DIR}/inc/ >> ${CMAKE_BINARY_DIR}/tuv_photolysis_inc.log 2>&1 + COMMAND ${CMAKE_COMMAND} -E touch tuv_photolysis_${MECH} + ) + list( + APPEND TUV_PHOTOLYSIS_OUT + tuv_photolysis_${MECH} + ) + endif() + + ###################################################################################################################### + ## + ## Integrator decomp rewrite + ## + # Do decomp for all - easier to manually specify rather than greps + file( + WRITE ${KPP_WORKING_DIR}/decomp_uses.inc + "USE ${MECH}_Parameters\nUSE ${MECH}_JacobianSP\n" + ) + file( + WRITE ${KPP_WORKING_DIR}/mech.tmp + "${MECH}\n" + ) + + add_executable( + write_decomp_${MECH} + util/write_decomp/write_decomp.F + ${KPP_WORKING_DIR}/${MECH}_Parameters.f90 + ${KPP_WORKING_DIR}/${MECH}_Precision.f90 + ${KPP_WORKING_DIR}/${MECH}_JacobianSP.f90 + ) + target_include_directories( write_decomp_${MECH} PRIVATE ${KPP_WORKING_DIR} ) + set_target_properties( + write_decomp_${MECH} + PROPERTIES + Fortran_MODULE_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}/decomp/${MECH}/ + Fortran_FORMAT FREE + ) + add_dependencies( write_decomp_${MECH} ${MECH}_kpp ) + + + # Now that write_decomp is generated for this kpp mechanism, process it + add_custom_command( + OUTPUT + ${KPP_WORKING_DIR}/${MECH}_Integrator_decomp.f90 + ${KPP_WORKING_DIR}/decomp_${MECH}.inc + # ${CMAKE_COMMAND} -E chdir ${KPP_WORKING_DIR} + COMMAND $ > ${CMAKE_BINARY_DIR}/kpp_write_decomp_${MECH}.log 2>&1 + COMMAND ${CMAKE_COMMAND} -E compare_files ${KPP_WORKING_DIR}/decomp_${MECH}.inc ${KPP_WORKING_DIR}/decomp_${MECH}.inc + + COMMAND $ + ${MECH} ${MECH}_Integrator.f90 + decomp_${MECH}.inc + ${MECH}_Integrator_decomp.f90 > ${CMAKE_BINARY_DIR}/kpp_integrator_edit_${MECH}.log 2>&1 + COMMAND ${CMAKE_COMMAND} -E compare_files ${KPP_WORKING_DIR}/${MECH}_Integrator_decomp.f90 ${KPP_WORKING_DIR}/${MECH}_Integrator_decomp.f90 + + WORKING_DIRECTORY ${KPP_WORKING_DIR} + DEPENDS kpp + ) + add_custom_target( + ${MECH}_integrator_decomp + COMMENT "[KPP] Post-processing integrator decomposition for ${MECH}_Integrator.f90" + DEPENDS + ${KPP_WORKING_DIR}/${MECH}_Integrator_decomp.f90 + ${KPP_WORKING_DIR}/decomp_${MECH}.inc + ) + + add_dependencies( ${PROJECT_NAME}_Core ${MECH}_integrator_decomp ) + target_sources( ${PROJECT_NAME}_Core PRIVATE ${KPP_WORKING_DIR}/${MECH}_Integrator_decomp.f90 ) + ## + ## + ## + ###################################################################################################################### + +endforeach() + +# Group our aggregated tuv commands if it was specified +if ( ${TUV_PHOTOLYSIS_GEN} ) + add_custom_command( + OUTPUT + # Note: I am not setting output as + # inc/tuv2wrf_jvals.inc + # inc/tuvdef_jvals.inc + # Because I want each step to succeed and not just the start or stop + tuv_photolysis_start + ${TUV_PHOTOLYSIS_OUT} + tuv_photolysis_stop + COMMAND ${CMAKE_COMMAND} -E make_directory ${CMAKE_BINARY_DIR}/inc/ + COMMAND $ FIRST ${CMAKE_BINARY_DIR}/inc/ > ${CMAKE_BINARY_DIR}/tuv_photolysis_inc.log 2>&1 + COMMAND ${CMAKE_COMMAND} -E touch tuv_photolysis_start + ${TUV_PHOTOLYSIS_CMD} + COMMAND $ LAST ${CMAKE_BINARY_DIR}/inc/ >> ${CMAKE_BINARY_DIR}/tuv_photolysis_inc.log 2>&1 + COMMAND ${CMAKE_COMMAND} -E touch tuv_photolysis_stop + WORKING_DIRECTORY ${CMAKE_BINARY_DIR} + DEPENDS tuv_kpp + ) + add_custom_target( + tuv_photolysis_inc # Naming this something different just to identify this is a target + COMMENT "[KPP] Generating tuv_photolysis include file" + DEPENDS + tuv_photolysis_start + ${TUV_PHOTOLYSIS_OUT} + tuv_photolysis_stop + ) + add_dependencies( ${PROJECT_NAME}_Core tuv_photolysis_inc ) +endif() + +list(POP_BACK CMAKE_MESSAGE_INDENT) diff --git a/chem/KPP/compile_wkc b/chem/KPP/compile_wkc index 1d0cdc190c..0695e772d3 100755 --- a/chem/KPP/compile_wkc +++ b/chem/KPP/compile_wkc @@ -118,10 +118,10 @@ echo $kdir # generate tuv photolysis inc files if( -e $model.tuv.jmap ) then if( $found == 0 ) then - $WKC_HOME/util/wkc/tuv_kpp FIRST + $WKC_HOME/util/wkc/tuv_kpp FIRST ../../inc/ set found = 1 endif - $WKC_HOME/util/wkc/tuv_kpp $model + $WKC_HOME/util/wkc/tuv_kpp $model ../../../../inc/ endif if ( `echo $WRFC_ROOT | awk '{print ( length ( $1 ) > 40 ) }' `) then @@ -139,7 +139,7 @@ end # finish tuv photolysis inc files if( $found == 1 ) then - $WKC_HOME/util/wkc/tuv_kpp LAST + $WKC_HOME/util/wkc/tuv_kpp LAST ../../inc/ endif echo "=========================================================" diff --git a/chem/KPP/kpp/kpp-2.1/CMakeLists.txt b/chem/KPP/kpp/kpp-2.1/CMakeLists.txt new file mode 100644 index 0000000000..47f85af88f --- /dev/null +++ b/chem/KPP/kpp/kpp-2.1/CMakeLists.txt @@ -0,0 +1,50 @@ +# Port of cflags.guess logic +# If the compiler starts with "cc" +if ( ${CMAKE_C_COMPILER} MATCHES "(/|\\\\)cc[A-Za-z0-9_]*$" ) + if ( ${CMAKE_SYSTEM_NAME} STREQUAL "SunOS" ) + message( FATAL_ERROR "KPP must be compiled with gcc on SunOS machines" ) + endif() + + set( + KPP_CC_FLAGS + "$<$,$>:-Aa;-D_HPUX_SOURCE>" #@ Hewlett Packard Unix + "$<$,$>:-Aa>" #@ IBM Unix operating system + ) +endif() + + +FLEX_TARGET( + kpp_lex + src/scan.l + ${CMAKE_CURRENT_BINARY_DIR}/lex.yy.c + ) + +BISON_TARGET( + kpp_tab + src/scan.y + ${CMAKE_CURRENT_BINARY_DIR}/y.tab.c + ) + +add_executable( + kpp + ${FLEX_kpp_lex_OUTPUTS} + ${BISON_kpp_tab_OUTPUTS} + src/scanner.c + src/scanutil.c + src/kpp.c + src/gen.c + src/code.c + src/code_c.c + src/code_f77.c + src/code_f90.c + src/code_matlab.c + src/debug.c + ) + +target_include_directories( + kpp + PRIVATE + ${CMAKE_CURRENT_SOURCE_DIR}/src + ${CMAKE_CURRENT_BINARY_DIR} + ) +target_link_libraries( kpp PRIVATE ${FLEX_LIBRARIES} ) diff --git a/chem/KPP/util/wkc/CMakeLists.txt b/chem/KPP/util/wkc/CMakeLists.txt new file mode 100644 index 0000000000..949c07c1f8 --- /dev/null +++ b/chem/KPP/util/wkc/CMakeLists.txt @@ -0,0 +1,139 @@ + + +set( FOLDER_COMPILE_TARGET registry_kpp ) + +add_executable( + ${FOLDER_COMPILE_TARGET} + ) + +set( GEN_COMMS ${PROJECT_SOURCE_DIR}/tools/gen_comms.stub ) +# if ( ${USE_RSL_LITE} ) +# message( STATUS "Setting gen_comms to RSL_LITE" ) +# set( GEN_COMMS ${PROJECT_SOURCE_DIR}/external/RSL_LITE/gen_comms.c ) +# else() +# # Account for the weird makefile nonsense of copying things around +# Apparently chem-kpp does not use the rsl_lite comms, but I'm leaving the logic +# here just in case it needs to change +set_source_files_properties( + ${GEN_COMMS} + TARGET_DIRECTORY ${FOLDER_COMPILE_TARGET} + PROPERTIES + LANGUAGE C + ) +# endif() + +target_sources( + ${FOLDER_COMPILE_TARGET} + PRIVATE + registry_kpp.c + ${PROJECT_SOURCE_DIR}/tools/my_strtok.c + ${PROJECT_SOURCE_DIR}/tools/reg_parse.c + ${PROJECT_SOURCE_DIR}/tools/data.c + ${PROJECT_SOURCE_DIR}/tools/type.c + ${PROJECT_SOURCE_DIR}/tools/misc.c + ${PROJECT_SOURCE_DIR}/tools/sym.c + ${PROJECT_SOURCE_DIR}/tools/symtab_gen.c + + gen_kpp.c + get_wrf_chem_specs.c + gen_kpp_mech_dr.c + gen_kpp_interface.c + get_kpp_chem_specs.c + compare_kpp_to_species.c + get_wrf_radicals.c + get_wrf_jvals.c + gen_kpp_utils.c + gen_kpp_interf_utils.c + gen_kpp_args_to_Update_Rconst.c + kpp_data.c + + ${GEN_COMMS} + ) + + +target_include_directories( ${FOLDER_COMPILE_TARGET} + PRIVATE + ${CMAKE_CURRENT_SOURCE_DIR} + ${PROJECT_SOURCE_DIR}/tools + ) + +# Make sure we don't do any weird in-place modification of files +target_compile_definitions( ${FOLDER_COMPILE_TARGET} PRIVATE NO_MODIFY_MAKEFILE ) + +# Should this be installed? Consider also removing regular registry from install... +# install( +# TARGETS ${FOLDER_COMPILE_TARGET} +# RUNTIME DESTINATION bin/ +# ARCHIVE DESTINATION lib/ +# LIBRARY DESTINATION lib/ +# ) + + +# Quickly add tuv_kpp exec as well +add_executable( tuv_kpp tuv_kpp.c ) + + +# Do registry_kpp generation of sources and include files +set( KPP_INTERFACE_SOURCES ) +set( KPP_INTERFACE_SOURCES_CMD_CHECK ) +foreach( MECH ${MECHANISMS} ) + set( KPP_INTERFACE_SOURCE ${CMAKE_BINARY_DIR}/chem/module_kpp_${MECH}_interface.F ) + list( APPEND KPP_INTERFACE_SOURCES ${KPP_INTERFACE_SOURCE} ) + list( + APPEND KPP_INTERFACE_SOURCES_CMD_CHECK + COMMAND ${CMAKE_COMMAND} -E compare_files ${KPP_INTERFACE_SOURCE} ${KPP_INTERFACE_SOURCE} + ) + +endforeach() + + +get_directory_property( DIR_DEFS DIRECTORY ${CMAKE_SOURCE_DIR} COMPILE_DEFINITIONS ) +wrf_expand_definitions( + RESULT_VAR REGISTRY_DEFS + DEFINITIONS ${DIR_DEFS} + ) + +add_custom_command( + OUTPUT + gen_${FOLDER_COMPILE_TARGET} + ${CMAKE_BINARY_DIR}/chem/kpp_mechanism_driver.F + ${KPP_INTERFACE_SOURCES} + WORKING_DIRECTORY + ${CMAKE_BINARY_DIR} + # Replicate what exists in project directory for registry + COMMAND + ${CMAKE_COMMAND} -E make_directory ${CMAKE_BINARY_DIR}/Registry + COMMAND + ${CMAKE_COMMAND} -E make_directory ${CMAKE_BINARY_DIR}/inc + COMMAND + ${CMAKE_COMMAND} -E make_directory ${CMAKE_BINARY_DIR}/frame + COMMAND + $ ${REGISTRY_DEFS} ${REGISTRY_FILE} > ${CMAKE_BINARY_DIR}/${FOLDER_COMPILE_TARGET}.log 2>&1 + ${KPP_INTERFACE_SOURCES_CMD_CHECK} + COMMAND + ${CMAKE_COMMAND} -E compare_files ${CMAKE_BINARY_DIR}/chem/kpp_mechanism_driver.F ${CMAKE_BINARY_DIR}/chem/kpp_mechanism_driver.F + COMMAND + ${CMAKE_COMMAND} -E touch gen_${FOLDER_COMPILE_TARGET} + DEPENDS + ${FOLDER_COMPILE_TARGET} + ) + + + +add_custom_target( + registry_kpp_code + DEPENDS + ${KPP_INTERFACE_SOURCES} + ${CMAKE_BINARY_DIR}/chem/kpp_mechanism_driver.F + gen_${FOLDER_COMPILE_TARGET} + ) + + +add_dependencies( ${PROJECT_NAME}_Core registry_kpp_code ) +target_sources( + ${PROJECT_NAME}_Core + PRIVATE + ${KPP_INTERFACE_SOURCES} + ${CMAKE_BINARY_DIR}/chem/kpp_mechanism_driver.F + ) + diff --git a/chem/KPP/util/wkc/gen_kpp.c b/chem/KPP/util/wkc/gen_kpp.c index 63dcd2f853..ef1df7f110 100644 --- a/chem/KPP/util/wkc/gen_kpp.c +++ b/chem/KPP/util/wkc/gen_kpp.c @@ -225,12 +225,11 @@ gen_kpp ( char * inc_dirname, char * kpp_dirname ) check_all ( kpp_dirname ); - +#ifndef NO_MODIFY_MAKEFILE /* add the kpp generated modules to the Makefile in the chem directory */ if ( DEBUGR == 1 ) printf("next: change_chem_Makefile \n"); change_chem_Makefile ( ); - - +#endif /* write the mechanism driver */ diff --git a/chem/KPP/util/wkc/protos_kpp.h b/chem/KPP/util/wkc/protos_kpp.h index e1f6c41b65..8254a017d9 100644 --- a/chem/KPP/util/wkc/protos_kpp.h +++ b/chem/KPP/util/wkc/protos_kpp.h @@ -18,8 +18,9 @@ int compare_kpp_to_species ( char * kpp_dirname) ; int run_kpp( char * dirname , char * kpp_version ); +#ifndef NO_MODIFY_MAKEFILE void change_chem_Makefile( ); - +#endif void gen_kpp_mechanism_driver ( ); void gen_kpp_call_to_mech_dr ( ); diff --git a/chem/KPP/util/wkc/tuv_kpp.c b/chem/KPP/util/wkc/tuv_kpp.c index cd878c5df3..32b5de6ddc 100644 --- a/chem/KPP/util/wkc/tuv_kpp.c +++ b/chem/KPP/util/wkc/tuv_kpp.c @@ -31,6 +31,7 @@ int main( int argc, char *argv[], char *env[] ) { char squezzed[NAMELEN]; char *wrf_jname, *cwrk, *tuv_jspec, *token; char *tuv_jname; + char openMode[1] = "a"; FILE * fp_in, *fp_set, *fp_def; wrf_node *Wrf_node; wrf_node *Wrf_HEAD; @@ -46,22 +47,27 @@ int main( int argc, char *argv[], char *env[] ) { argv++; strcpy( mech,*argv ); + argv++; + strcpy( dir,*argv ); + fprintf(stderr,"tuv_kpp: Argument = %s\n",mech); // open and write inc files + strcpy( fname_inc, dir ); + strcat( fname_inc, "tuv2wrf_jvals.inc" ); - if( !strcmp(mech,"LAST") ) - strcpy(fname_inc,"../../inc/tuv2wrf_jvals.inc"); - else - strcpy(fname_inc,"../../../../inc/tuv2wrf_jvals.inc"); - if( (fp_set = fopen( fname_inc,"a" )) == NULL ) { + if( !strcmp(mech,"FIRST") ) { + strcpy( openMode, "w" ); + } + + if( (fp_set = fopen( fname_inc, openMode )) == NULL ) { fprintf(stderr,"Can not open %s\n",fname_inc ); return(-1); } - if( !strcmp(mech,"LAST") ) - strcpy(fname_inc,"../../inc/tuvdef_jvals.inc"); - else - strcpy(fname_inc,"../../../../inc/tuvdef_jvals.inc"); - if( (fp_def = fopen( fname_inc,"a" )) == NULL ) { + + strcpy( fname_inc, dir ); + strcat( fname_inc, "tuvdef_jvals.inc" ); + + if( (fp_def = fopen( fname_inc, openMode )) == NULL ) { fprintf(stderr,"Can not open %s\n",fname_inc ); return(-1); } diff --git a/chem/KPP/util/write_decomp/CMakeLists.txt b/chem/KPP/util/write_decomp/CMakeLists.txt new file mode 100644 index 0000000000..f80de45d35 --- /dev/null +++ b/chem/KPP/util/write_decomp/CMakeLists.txt @@ -0,0 +1,3 @@ +# Compile once and only ONCE +add_executable( integration_edit integr_edit.c ) +target_compile_definitions( integration_edit PRIVATE -DNO_COPY ) diff --git a/chem/KPP/util/write_decomp/Makefile b/chem/KPP/util/write_decomp/Makefile index 7be276bf72..f8f1ebbe6d 100644 --- a/chem/KPP/util/write_decomp/Makefile +++ b/chem/KPP/util/write_decomp/Makefile @@ -28,7 +28,7 @@ all: $(MAKE) comp ./write_decomp.exe $(MAKE) integr_edit - ./integr_edit.exe $(MECH) + ./integr_edit.exe $(MECH) module_kpp_$(MECH)_Integr.F decomp_$(MODEL).inc $(MODEL)_new $(MAKE) clean diff --git a/chem/KPP/util/write_decomp/integr_edit.c b/chem/KPP/util/write_decomp/integr_edit.c index 82faae53c4..dee009dce4 100644 --- a/chem/KPP/util/write_decomp/integr_edit.c +++ b/chem/KPP/util/write_decomp/integr_edit.c @@ -25,99 +25,84 @@ main( int argc, char *argv[] ) FILE * ofile; - argv++ ; + + if ( argc != 5 ) + { + printf("ERROR: USAGE: integr_edit mech_name integrator_file decomp_inc_file output_file\n"); + exit(11); + } - if ( *argv ) - { + argv++ ; strcpy( mechname, *argv ); - } - else - { - printf("ERROR: USAGE: integr_edit mech_name\n"); - exit(11); - } - - sprintf ( intfname, "module_kpp_%s_Integr.F", mechname); - sprintf ( incfname, "decomp_%s.inc", mechname); - sprintf ( tfname, "%s_new", intfname ); - + argv++; + strcpy( intfname, *argv ); + argv++; + strcpy( incfname, *argv ); + argv++; + strcpy( tfname, *argv ); - sprintf( cp_command,"cp %s %s",tfname, intfname); + sprintf( cp_command,"cp %s %s",tfname, intfname ); - intf = fopen( intfname , "r" ); - incf = fopen( incfname , "r" ); - ofile = fopen( tfname , "w" ); + intf = fopen( intfname, "r" ); + incf = fopen( incfname, "r" ); + ofile = fopen( tfname, "w" ); - sprintf ( callln , " CALL %s_KppDecomp\0", mechname ); - sprintf ( endln , "END MODULE"); - - /* loop over lines in Integr file */ - while ( fgets ( inln , 4096 , intf ) != NULL ){ - - copyit=1; - - - /* replace call to decomp routine */ - - if ( !strncmp (inln, callln, strlen(callln)-1) ) { - - printf(" integr_edit: replacing %s \n", inln); - - fprintf(ofile, "!!! use direct adressing in decomp \n"); - fprintf(ofile, "!!! %s", inln); - fprintf(ofile, "CALL decomp_%s ( A, ising )\n", mechname ); + sprintf( callln, " CALL %s_KppDecomp\0", mechname ); + sprintf( endln, "END MODULE" ); + /* loop over lines in Integr file */ + while ( fgets( inln , 4096 , intf ) != NULL ) { - add_sub=1; - copyit=0; - } + copyit = 1; - /* add decomp routine w. direct referncing */ + /* replace call to decomp routine */ + if ( !strncmp( inln, callln, strlen( callln ) - 1 ) ) { - if ( !strncmp (inln, endln, strlen(endln)-1) ) { + printf(" integr_edit: replacing %s \n", inln); + fprintf(ofile, "!!! use direct adressing in decomp \n"); + fprintf(ofile, "!!! %s", inln); + fprintf(ofile, "CALL decomp_%s ( A, ising )\n", mechname ); - if ( add_sub ){ - printf(" %s ", inln ); - while ( fgets ( incln , 4096 , incf ) != NULL ){ - - fprintf(ofile, "%s", incln); - - } - - fprintf(ofile, " \n\n\n"); - } - } - - - - - /* copy line from original file */ - if ( copyit ) { - - fprintf(ofile, "%s", inln); + add_sub = 1; + copyit = 0; + } - } + /* add decomp routine w. direct referncing */ + if ( !strncmp (inln, endln, strlen(endln)-1) ) { - } + if ( add_sub ) { + printf(" %s ", inln ); + while ( fgets ( incln , 4096 , incf ) != NULL ) { + fprintf( ofile, "%s", incln ); + } + fprintf(ofile, " \n\n\n"); + } + } - if ( ! add_sub ) { - printf(" integr_edit: Kept previous version. \n "); - } + /* copy line from original file */ + if ( copyit ) { + fprintf( ofile, "%s", inln ); + } + } + if ( ! add_sub ) { + printf( " integr_edit: Kept previous version. \n " ); + } fclose( intf ); fclose( incf ); fclose( ofile ); - - system(cp_command); +#ifndef NO_COPY + system(cp_command); +#endif exit (0); } diff --git a/chem/chem_driver.F b/chem/chem_driver.F index 8650b9444a..485574ffe6 100755 --- a/chem/chem_driver.F +++ b/chem/chem_driver.F @@ -43,11 +43,12 @@ subroutine chem_driver ( grid , config_flags & USE module_wetdep_ls, only:wetdep_ls USE module_uoc_dustwd ! Claudia, 3 April 2014 [mklose 03082015] USE module_input_chem_data, only: last_chem_time, & + mozcart_lbc_set, & + bdy_chem_value_top_pv, & + PVS #if (defined(CHEM_DBG_I) && defined(CHEM_DBG_J) && defined(CHEM_DBG_K)) - chem_dbg, & + USE module_input_chem_data, only: chem_dbg #endif - mozcart_lbc_set, & - bdy_chem_value_top_pv,PVS USE module_chem_share, only: get_last_gas USE module_upper_bc_driver, only: upper_bc_driver USE module_tropopause, only: tropopause_driver diff --git a/chem/module_ftuv_driver.F b/chem/module_ftuv_driver.F index 0a3c1f6982..69fa086584 100644 --- a/chem/module_ftuv_driver.F +++ b/chem/module_ftuv_driver.F @@ -1308,10 +1308,11 @@ subroutine ftuv_timestep_init( id, julday ) !----------------------------------------------------------------------------- ! set solar distance factor !----------------------------------------------------------------------------- - if( curjulday /= julday ) then - curjulday = julday - call sundis( curjulday, esfact ) - endif + ! osipov fix the bug. Always calc the distance. Testing for 0 results in True on 1 Jan, keeps the sfact=0 and shutsdown the photolysis for entire day + !if( curjulday /= julday ) then + curjulday = julday + call sundis( curjulday, esfact ) + !endif end subroutine ftuv_timestep_init diff --git a/chem/module_optical_averaging.F b/chem/module_optical_averaging.F index 5b7403b77f..278f1a65f5 100644 --- a/chem/module_optical_averaging.F +++ b/chem/module_optical_averaging.F @@ -3534,7 +3534,10 @@ end subroutine optical_prep_mam ! MOZAIC grids. ! 10/24/18 - A. Ukhov, bug fix: mass redistribution between GOCART dust/sea salt and ! MOZAIC bins should be computed using interpolation over the logarithmic axis. - +! 09/17/24 - A. Ukhov, bug fix: mass redistribution between GOCART dust/sea salt and +! MOZAIC bins now accounts for 5th dust and 4th sea salt bins. Number of MOZAIC bins was +! changed from 8 to 9 and MOZAIC max size range was increased from 10 to 20 um. +! ! This subroutine computes volume-averaged refractive index and wet radius needed ! by the mie calculations. Aerosol number is also passed into the mie calculations ! in terms of other units. @@ -3642,9 +3645,9 @@ subroutine optical_prep_gocart(nbin_o, chem, alt,relhum, & ! 7/21/09 SAM variables needed to convert GOCART sectional dust and seasalt to MOZAIC sections real dgnum, dhi, dlo, xlo, xhi, dxbin, relh_frc real dlo_sectm(nbin_o), dhi_sectm(nbin_o) - integer, parameter :: nbin_omoz=8 - real, save :: seasfrc_goc8bin(4,nbin_omoz) ! GOCART seasalt size distibution - mass fracs in MOSAIC 8-bins - real, save :: dustfrc_goc8bin(ndust,nbin_omoz) ! GOCART dust size distibution - mass fracs in MOSAIC 8-bins + integer, parameter :: nbin_omoz=9 ! A. Ukhov 09/17/24 + real, save :: seasfrc_goc9bin(4,nbin_omoz) ! GOCART seasalt size distibution - mass fracs in MOSAIC 9-bins + real, save :: dustfrc_goc9bin(ndust,nbin_omoz) ! GOCART dust size distibution - mass fracs in MOSAIC 9-bins real mass_bc1 , mass_bc2 , vol_bc2 , mass_bc1j , mass_bc2j, & mass_bc1i , mass_bc2i , vol_soil real*8 dlogoc, dhigoc @@ -3671,7 +3674,7 @@ subroutine optical_prep_gocart(nbin_o, chem, alt,relhum, & ! sixpi=6.0/3.14159265359 dlo_um=0.0390625 - dhi_um=10.0 + dhi_um=20.0 !A. Ukhov 09/17/24 drydens=1.8 iflag=2 duma=1.0 @@ -3692,18 +3695,8 @@ subroutine optical_prep_gocart(nbin_o, chem, alt,relhum, & dlo_sectm(n) = exp( xlo + dxbin*(n-1) ) dhi_sectm(n) = exp( xlo + dxbin*n ) end do -! real, save :: seasfrc_goc8bin(4,nbin_o) ! GOCART seasalt size distibution - mass fracs in MOSAIC 8-bins -! real, save :: dustfrc_goc8bin(ndust,nbin_o) ! GOCART dust size distibution - mass fracs in MOSAIC 8-bins -! USE module_data_gocart_seas -! real*8, DIMENSION (4), PARAMETER :: ra(4)=(/1.d-1,5.d-1,1.5d0,5.0d0/) -! real*8, DIMENSION (4), PARAMETER :: rb(4)=(/5.d-1,1.5d0,5.d0,1.d1/) -! real*8, DIMENSION (4), PARAMETER :: den_seas(4)=(/2.2d3,2.2d3,2.2d3,2.2d3/) -! real*8, DIMENSION (4), PARAMETER :: reff_seas(4)=(/0.30D-6,1.00D-6,3.25D-6,7.50D-6/) -! USE module_data_gocart_dust, only: ndust, reff_dust, den_dust -! real*8, DIMENSION (5), PARAMETER :: den_dust(5)=(/2500.,2650.,2650.,2650.,2650./) -! real*8, DIMENSION (5), PARAMETER :: reff_dust(5)=(/0.73D-6,1.4D-6,2.4D-6,4.5D-6,8.0D-6/) ! Seasalt bin mass fractions - seasfrc_goc8bin=0. + seasfrc_goc9bin=0. ! WRITE(*,*)'Seasalt mass fractions' ! WRITE(*,*)' ',' ',(dlo_sectm(n),n=1,nbin_o) ! WRITE(*,*)' ',' ',(dhi_sectm(n),n=1,nbin_o) @@ -3711,28 +3704,42 @@ subroutine optical_prep_gocart(nbin_o, chem, alt,relhum, & dlogoc = ra(m)*2.E-6 ! low diameter limit (m) dhigoc = rb(m)*2.E-6 ! hi diameter limit (m) do n = 1, nbin_o - seasfrc_goc8bin(m,n)=max(DBLE(0.),min(DBLE(log(dhi_sectm(n))),log(dhigoc))- & + seasfrc_goc9bin(m,n)=max(DBLE(0.),min(DBLE(log(dhi_sectm(n))),log(dhigoc))- & max(log(dlogoc),DBLE(log(dlo_sectm(n)))) )/(log(dhigoc)-log(dlogoc)) end do -! WRITE(*,*)m,dlogoc,dhigoc,(seasfrc_goc8bin(m,n),n=1,nbin_o) +! WRITE(*,*)m,dlogoc,dhigoc,(seasfrc_goc9bin(m,n),n=1,nbin_o) end do ! Dust bin mass fractions ! WRITE(*,*)'Dust mass fractions' ! WRITE(*,*)' ',' ',(dlo_sectm(n),n=1,nbin_o) ! WRITE(*,*)' ',' ',(dhi_sectm(n),n=1,nbin_o) - dustfrc_goc8bin=0. + dustfrc_goc9bin=0. do m =1, ndust ! loop over dust size bins dlogoc = ra_dust(m)*2.E-6 ! low diameter limit (m) dhigoc = rb_dust(m)*2.E-6 ! hi diameter limit (m) do n = 1, nbin_o - dustfrc_goc8bin(m,n)=max(DBLE(0.),min(DBLE(log(dhi_sectm(n))),log(dhigoc))- & + dustfrc_goc9bin(m,n)=max(DBLE(0.),min(DBLE(log(dhi_sectm(n))),log(dhigoc))- & max(log(dlogoc),DBLE(log(dlo_sectm(n)))) )/(log(dhigoc)-log(dlogoc)) end do -! WRITE(*,*)m,dlogoc,dhigoc,(dustfrc_goc8bin(m,n),n=1,nbin_o) +! WRITE(*,*)m,dlogoc,dhigoc,(dustfrc_goc9bin(m,n),n=1,nbin_o) end do kcall=kcall+1 + + !Diagnostic. A. Ukhov 09/17/24 + !----- + ! WRITE(*,*)nbin_o + ! WRITE(*,*)'Dust redistribution:' + ! do m =1, ndust + ! WRITE(*,*)m,dustfrc_goc9bin(m,:) + ! end do + + ! WRITE(*,*)'Sea salt redistribution:' + ! do m =1, 4 + ! WRITE(*,*)m,seasfrc_goc9bin(m,:) + ! end do + !----- ! ISTOP=1 ! IF(ISTOP.EQ.1)THEN ! STOP @@ -3991,15 +3998,15 @@ subroutine optical_prep_gocart(nbin_o, chem, alt,relhum, & ! Add in seasalt and dust from GOCART sectional distributions n = 0 mass_seas = 0.0 - do m =p_seas_1, p_seas_3 ! loop over seasalt size bins less than 10 um diam + do m =p_seas_1, p_seas_4 ! loop over seasalt size bins less than 20 um. A. Ukhov 09/17/24 n = n+1 - mass_seas=mass_seas+seasfrc_goc8bin(n,isize)*chem(i,k,j,m) + mass_seas=mass_seas+seasfrc_goc9bin(n,isize)*chem(i,k,j,m) end do n = 0 mass_soil = 0.0 - do m =p_dust_1, p_dust_1+ndust-2 ! loop over dust size bins less than 10 um diam + do m =p_dust_1, p_dust_5 ! loop over dust size bins less than 20 um. A. Ukhov 09/17/24 n = n+1 - mass_soil=mass_soil+dustfrc_goc8bin(n,isize)*chem(i,k,j,m) + mass_soil=mass_soil+dustfrc_goc9bin(n,isize)*chem(i,k,j,m) end do mass_cl=mass_seas*conv1a*35.4530/58.4428 mass_na=mass_seas*conv1a*22.9898/58.4428 diff --git a/chem/module_phot_tuv.F b/chem/module_phot_tuv.F index f37d167a67..68eadbe7f3 100644 --- a/chem/module_phot_tuv.F +++ b/chem/module_phot_tuv.F @@ -341,10 +341,11 @@ subroutine tuv_driver( & !----------------------------------------------------------------------------- ! set solar distance factor !----------------------------------------------------------------------------- - if( curjulday /= julday ) then - curjulday = julday - esfact = sundis( julday ) - endif + ! osipov fix the bug. Always calc the distance. Testing for 0 results in True on 1 Jan, keeps the sfact=0 and shutsdown the photolysis for entire day + !if( curjulday /= julday ) then + curjulday = julday + esfact = sundis( julday ) + !endif if( .not. config_flags%scale_o3_to_grnd_exo_coldens ) then if( config_flags%scale_o3_to_du_at_grnd ) then dobsi = max( 0.,config_flags%du_at_grnd ) @@ -1457,11 +1458,10 @@ subroutine get_xsqy_tab CALL wrf_dm_bcast_bytes( temp_data, n_temp_data*RWORDSIZE ) CALL wrf_dm_bcast_bytes( o3_data, n_o3_data*RWORDSIZE ) CALL wrf_dm_bcast_bytes( air_dens_data, n_air_dens_data*RWORDSIZE ) -#if RWORDSIZE == 4 +#ifndef DOUBLE_PRECISION CALL wrf_dm_bcast_bytes( chebev_ac, nchebev_term*nchebev_wave*2*RWORDSIZE ) CALL wrf_dm_bcast_bytes( chebev_bc, nchebev_term*nchebev_wave*2*RWORDSIZE ) -#endif -#if RWORDSIZE == 8 +#else CALL wrf_dm_bcast_bytes( chebev_ac, nchebev_term*nchebev_wave*RWORDSIZE ) CALL wrf_dm_bcast_bytes( chebev_bc, nchebev_term*nchebev_wave*RWORDSIZE ) #endif diff --git a/chem/optical_driver.F b/chem/optical_driver.F index 81af457c75..fff5ad8644 100755 --- a/chem/optical_driver.F +++ b/chem/optical_driver.F @@ -143,13 +143,19 @@ SUBROUTINE optical_driver(id,curr_secs,dtstep,config_flags,haveaer,& ! select case (config_flags%chem_opt) case ( RADM2SORG, RACM_ESRLSORG_KPP, RADM2SORG_KPP, RADM2SORG_AQ, RADM2SORG_AQCHEM, & - GOCARTRACM_KPP, GOCARTRADM2, & - GOCART_SIMPLE, RACMSORG_KPP, RACMSORG_AQ, RACMSORG_AQCHEM_KPP, & + ! A. Ukhov 09/17/24 + !GOCARTRACM_KPP, GOCARTRADM2, GOCART_SIMPLE, MOZCART_KPP, & + RACMSORG_KPP, RACMSORG_AQ, RACMSORG_AQCHEM_KPP, & RACM_ESRLSORG_AQCHEM_KPP, RACM_SOA_VBS_KPP, RACM_SOA_VBS_AQCHEM_KPP, & - RACM_SOA_VBS_HET_KPP, CBMZSORG, CBMZSORG_AQ, MOZCART_KPP, T1_MOZCART_KPP, & + RACM_SOA_VBS_HET_KPP, CBMZSORG, CBMZSORG_AQ, & !T1_MOZCART_KPP, & CBMZ_CAM_MAM3_NOAQ, CBMZ_CAM_MAM7_NOAQ, CBMZ_CAM_MAM3_AQ, CBMZ_CAM_MAM7_AQ, & CB05_SORG_AQ_KPP, CB05_SORG_VBS_AQ_KPP ) nbin_o = 8 + + ! A. Ukhov 09/17/24 + case (GOCARTRACM_KPP,GOCARTRADM2,GOCART_SIMPLE,MOZCART_KPP,T1_MOZCART_KPP) + nbin_o = 9 + case (CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_8BIN, CBMZ_MOSAIC_KPP, & CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ, & CBMZ_MOSAIC_DMS_4BIN, CBMZ_MOSAIC_DMS_8BIN, & diff --git a/clean b/clean index a4af6a3a21..bf063ba4d1 100755 --- a/clean +++ b/clean @@ -83,6 +83,8 @@ if ( "$arg" == '-a' || "$arg" == '-aa' ) then /bin/rm -f phys/module_sf_noahmpdrv.F phys/module_sf_noahmp_glacier.F \ phys/module_sf_noahmp_groundwater.F phys/module_sf_noahmplsm.F \ run/MPTABLE.TBL + /bin/rm -f phys/module_bl_mynnedmf.F phys/module_bl_mynnedmf_common.F \ + phys/module_bl_mynnedmf_driver.F endif endif diff --git a/cmake/c_preproc.cmake b/cmake/c_preproc.cmake index 0d0dd751ef..40af0a8ee2 100644 --- a/cmake/c_preproc.cmake +++ b/cmake/c_preproc.cmake @@ -60,19 +60,13 @@ macro( wrf_c_preproc_fortran ) # # It keeps getting better lol # # https://gitlab.kitware.com/cmake/cmake/-/issues/18399 # # We could use cmake 3.20+ and CMP0118, but this allows usage from 3.18.6+ - # TL;DR - This doesn't work despite all documentation stating otherwise, need to use CMP0118 - # set_source_files_properties( - # ${WRF_PP_F_OUTPUT_FILE} - # ${WRF_PP_F_TARGET_DIRECTORY} - # PROPERTIES - # GENERATED TRUE - # ) set_source_files_properties( ${WRF_PP_F_OUTPUT_FILE} DIRECTORY ${PROJECT_SOURCE_DIR} ${CMAKE_CURRENT_SOURCE_DIR} ${WRF_PP_F_TARGET_DIRECTORY} PROPERTIES Fortran_PREPROCESS OFF + GENERATED TRUE ) # message( STATUS "File ${WRF_PP_F_SOURCE_FILE} will be preprocessed into ${WRF_PP_F_OUTPUT_FILE}" ) diff --git a/cmake/confcheck.cmake b/cmake/confcheck.cmake index 5db8469519..4c4970bda8 100644 --- a/cmake/confcheck.cmake +++ b/cmake/confcheck.cmake @@ -1,18 +1,18 @@ # WRF Macro for adding configuration checks from source file, default is fortran # https://cmake.org/cmake/help/latest/module/CheckFortranSourceCompiles.html # https://github.com/ufs-community/ufs-weather-model/issues/132 -include( CheckFortranSourceRuns ) -include( CheckFortranSourceCompiles ) -include( CheckCSourceRuns ) -include( CheckCSourceCompiles ) -include( CheckCXXSourceRuns ) -include( CheckCXXSourceCompiles ) +# include( CheckFortranSourceRuns ) +# include( CheckFortranSourceCompiles ) +# include( CheckCSourceRuns ) +# include( CheckCSourceCompiles ) +# include( CheckCXXSourceRuns ) +# include( CheckCXXSourceCompiles ) -macro( wrf_conf_check ) +function( wrf_conf_check ) set( options QUIET RUN REQUIRED ) - set( oneValueArgs RESULT_VAR EXTENSION FAIL_REGEX SOURCE MESSAGE SOURCE_TYPE ) - set( multiValueArgs ADDITIONAL_FLAGS ADDITIONAL_DEFINITIONS ADDITIONAL_INCLUDES ADDITIONAL_LINK_OPTIONS ADDITIONAL_LIBRARIES ) + set( oneValueArgs RESULT_VAR MESSAGE ) + set( multiValueArgs SOURCES OPTIONS ) cmake_parse_arguments( WRF_CFG @@ -20,102 +20,41 @@ macro( wrf_conf_check ) ${ARGN} ) - get_filename_component( WRF_CFG_SOURCE_FILE ${WRF_CFG_SOURCE} REALPATH ) - file( READ ${WRF_CFG_SOURCE_FILE} WRF_CFG_CODE ) - - # Santize for newlines - string( REPLACE "\\n" "\\\\n" WRF_CFG_CODE "${WRF_CFG_CODE}" ) - - if ( NOT DEFINED WRF_CFG_SOURCE_TYPE ) - set( WRF_CFG_SOURCE_TYPE fortran ) - endif() - - if ( DEFINED WRF_CFG_FAIL_REGEX ) - if ( DEFINED WRF_CFG_RUN ) - message( WARNING "wrf_conf_check: FAIL_REGEX ignored when running check" ) - else() - set( WRF_CFG_FAIL_REGEX FAIL_REGEX ${WRF_CFG_FAIL_REGEX} ) - endif() + if ( NOT DEFINED WRF_CFG_BINDIR ) + set( WRF_CFG_BINDIR ${CMAKE_CURRENT_BINARY_DIR}/confcheck/${WRF_CFG_RESULT_VAR}/ ) endif() - if ( DEFINED WRF_CFG_EXTENSION ) - set( WRF_CFG_EXTENSION SRC_EXT ${WRF_CFG_EXTENSION} ) - endif() - - # Additional options - if ( DEFINED WRF_CFG_QUIET AND ${WRF_CFG_QUIET} ) - set( CMAKE_REQUIRED_QUIET ${WRF_CFG_QUIET} ) - endif() + message( STATUS "Performing Check ${WRF_CFG_RESULT_VAR}" ) - if ( DEFINED WRF_CFG_ADDITIONAL_FLAGS ) - set( CMAKE_REQUIRED_FLAGS ${WRF_CFG_ADDITIONAL_FLAGS} ) - endif() - - if ( DEFINED WRF_CFG_ADDITIONAL_DEFINITIONS ) - set( CMAKE_REQUIRED_DEFINITIONS ${WRF_CFG_ADDITIONAL_DEFINITIONS} ) - endif() - - if ( DEFINED WRF_CFG_ADDITIONAL_INCLUDES ) - set( CMAKE_REQUIRED_INCLUDES ${WRF_CFG_ADDITIONAL_INCLUDES} ) - endif() - - if ( DEFINED WRF_CFG_ADDITIONAL_LINK_OPTIONS ) - set( CMAKE_REQUIRED_LINK_OPTIONS ${WRF_CFG_ADDITIONAL_LINK_OPTIONS} ) - endif() - - if ( DEFINED WRF_CFG_ADDITIONAL_LIBRARIES ) - set( CMAKE_REQUIRED_LIBRARIES ${WRF_CFG_ADDITIONAL_LIBRARIES} ) - endif() - - string( TOLOWER "${WRF_CFG_SOURCE_TYPE}" WRF_CFG_SOURCE_TYPE ) if ( DEFINED WRF_CFG_RUN ) - if ( ${WRF_CFG_SOURCE_TYPE} STREQUAL "fortran" ) - check_fortran_source_runs( - "${WRF_CFG_CODE}" - ${WRF_CFG_RESULT_VAR} - ${WRF_CFG_FAIL_REGEX} - ${WRF_CFG_EXTENSION} - ) - elseif ( ${WRF_CFG_SOURCE_TYPE} STREQUAL "c" ) - check_c_source_runs( - "${WRF_CFG_CODE}" - ${WRF_CFG_RESULT_VAR} - ${WRF_CFG_FAIL_REGEX} - ${WRF_CFG_EXTENSION} - ) - elseif ( ${WRF_CFG_SOURCE_TYPE} STREQUAL "cpp" ) - check_cpp_source_runs( - "${WRF_CFG_CODE}" - ${WRF_CFG_RESULT_VAR} - ${WRF_CFG_FAIL_REGEX} - ${WRF_CFG_EXTENSION} - ) + try_run( + ${WRF_CFG_RESULT_VAR} + WRF_CFG_COMPILE_RESULT_VAR + ${WRF_CFG_BINDIR} + ${WRF_CFG_SOURCES} + ${WRF_CFG_OPTIONS} + ) + if ( ${WRF_CFG_COMPILE_RESULT_VAR} ) + # Did it run successfully + if ( ${${WRF_CFG_RESULT_VAR}} EQUAL 0 ) + set( ${WRF_CFG_RESULT_VAR} TRUE ) + endif() + else() + set( ${WRF_CFG_RESULT_VAR} FALSE ) endif() else() - if ( ${WRF_CFG_SOURCE_TYPE} STREQUAL "fortran" ) - check_fortran_source_compiles( - "${WRF_CFG_CODE}" - ${WRF_CFG_RESULT_VAR} - ${WRF_CFG_EXTENSION} - ) - elseif ( ${WRF_CFG_SOURCE_TYPE} STREQUAL "c" ) - check_c_source_compiles( - "${WRF_CFG_CODE}" - ${WRF_CFG_RESULT_VAR} - ${WRF_CFG_EXTENSION} - ) - elseif ( ${WRF_CFG_SOURCE_TYPE} STREQUAL "cpp" ) - check_cpp_source_compiles( - "${WRF_CFG_CODE}" - ${WRF_CFG_RESULT_VAR} - ${WRF_CFG_EXTENSION} - ) - endif() + try_compile( + ${WRF_CFG_RESULT_VAR} + ${WRF_CFG_BINDIR} + SOURCES ${WRF_CFG_SOURCES} + ${WRF_CFG_OPTIONS} + ) endif() # If it failed - note that since this is a run/compile test we expect pass/true # to just proceed as normal, but if failure we should do something about it if ( NOT ( DEFINED ${WRF_CFG_RESULT_VAR} AND "${${WRF_CFG_RESULT_VAR}}" ) ) + message( STATUS "Performing Check ${WRF_CFG_RESULT_VAR} - Failure" ) set( WRF_CFG_MSG_TYPE STATUS ) if ( DEFINED WRF_CFG_REQUIRED AND ${WRF_CFG_REQUIRED} ) set( WRF_CFG_MSG_TYPE FATAL_ERROR ) @@ -126,8 +65,12 @@ macro( wrf_conf_check ) else() message( ${WRF_CFG_MSG_TYPE} "${WRF_CFG_RESULT_VAR} marked as required, check failed" ) endif() + else() + message( STATUS "Performing Check ${WRF_CFG_RESULT_VAR} - Success" ) endif() -endmacro() + set( ${WRF_CFG_RESULT_VAR} ${${WRF_CFG_RESULT_VAR}} PARENT_SCOPE ) + +endfunction() diff --git a/cmake/m4_preproc.cmake b/cmake/m4_preproc.cmake index 4158795578..f4deefd365 100644 --- a/cmake/m4_preproc.cmake +++ b/cmake/m4_preproc.cmake @@ -54,19 +54,13 @@ macro( wrf_m4_preproc_fortran ) # # It keeps getting better lol # # https://gitlab.kitware.com/cmake/cmake/-/issues/18399 # # We could use cmake 3.20+ and CMP0118, but this allows usage from 3.18.6+ - # TL;DR - This doesn't work despite all documentation stating otherwise, need to use CMP0118 - # set_source_files_properties( - # ${WRF_PP_M4_OUTPUT_FILE} - # ${WRF_PP_M4_TARGET_DIRECTORY} - # PROPERTIES - # GENERATED TRUE - # ) set_source_files_properties( ${WRF_PP_M4_OUTPUT_FILE} DIRECTORY ${PROJECT_SOURCE_DIR} ${CMAKE_CURRENT_SOURCE_DIR} ${WRF_PP_M4_TARGET_DIRECTORY} PROPERTIES Fortran_PREPROCESS OFF + GENERATED TRUE ) # message( STATUS "File ${WRF_PP_M4_SOURCE_FILE} will be preprocessed into ${WRF_PP_M4_OUTPUT_FILE}" ) diff --git a/cmake/modules/FindnetCDF.cmake b/cmake/modules/FindnetCDF.cmake index 896acaba00..29f137e6ea 100644 --- a/cmake/modules/FindnetCDF.cmake +++ b/cmake/modules/FindnetCDF.cmake @@ -66,9 +66,9 @@ else() foreach( NC_QUERY ${netCDF_QUERY_YES_OPTIONS} ) execute_process( COMMAND ${NETCDF_PROGRAM} --has-${NC_QUERY} OUTPUT_STRIP_TRAILING_WHITESPACE OUTPUT_VARIABLE netCDF_${NC_QUERY}_LOWERCASE ) - if ( NOT "${netCDF-Fortran_${NF_QUERY}_LOWERCASE}" ) + if ( NOT "${netCDF_${NC_QUERY}_LOWERCASE}" ) # might be empty - set( netCDF-Fortran_${NF_QUERY}_LOWERCASE no ) + set( netCDF_${NC_QUERY}_LOWERCASE no ) endif() string( TOUPPER ${NC_QUERY} NC_QUERY_UPPERCASE ) string( TOUPPER ${netCDF_${NC_QUERY}_LOWERCASE} NC_ANSWER_UPPERCASE ) diff --git a/cmake/target_source_properties.cmake b/cmake/target_source_properties.cmake index 64bd47379b..42f0c02a2d 100644 --- a/cmake/target_source_properties.cmake +++ b/cmake/target_source_properties.cmake @@ -42,12 +42,16 @@ function( define_target_source_properties ) SOURCE PROPERTY ${PROPERTY} # INHERITED # they will be "inherited" via target to source + BRIEF_DOCS "Transitive property from target to file" + FULL_DOCS "This property can override an existing property derived from a target" ) define_property( TARGET PROPERTY ${PROPERTY} # INHERITED # they will be "inherited" via target to source + BRIEF_DOCS "Transitive property from target to file" + FULL_DOCS "This property can be overridden on a per file basis" ) endforeach() endfunction() diff --git a/cmake/template/arch_config.cmake b/cmake/template/arch_config.cmake index 0a655a4e32..7780034c30 100644 --- a/cmake/template/arch_config.cmake +++ b/cmake/template/arch_config.cmake @@ -15,10 +15,10 @@ set( CMAKE_Fortran_FLAGS_INIT "{SFC_FLAGS} {FCBASEOPTS} {BYTESWAPIO}" ) set( CMAKE_C_FLAGS_INIT "{SCC_FLAGS} {CFLAGS_LOCAL}" ) # https://cmake.org/cmake/help/latest/variable/CMAKE_LANG_FLAGS_CONFIG_INIT.html -set( CMAKE_Fortran_FLAGS_Debug_INIT "{FCDEBUG}" ) -set( CMAKE_Fortran_FLAGS_Release_INIT "" ) -set( CMAKE_C_FLAGS_Debug_INIT "" ) -set( CMAKE_C_FLAGS_Release_INIT "" ) +set( CMAKE_Fortran_FLAGS_DEBUG_INIT "{FCDEBUG}" ) +set( CMAKE_Fortran_FLAGS_RELEASE_INIT "" ) +set( CMAKE_C_FLAGS_DEBUG_INIT "" ) +set( CMAKE_C_FLAGS_RELEASE_INIT "" ) # Project specifics now set( WRF_MPI_Fortran_FLAGS "{DM_FC_FLAGS}" ) diff --git a/cmake/wrf_case_setup.cmake b/cmake/wrf_case_setup.cmake index 4e65dc0a72..c92b1b6a30 100644 --- a/cmake/wrf_case_setup.cmake +++ b/cmake/wrf_case_setup.cmake @@ -47,6 +47,51 @@ macro( wrf_setup_targets ) endmacro() +# WRF Macro for adding target symlinks/copies to be run after internal install() code +# this allows for alternate naming +macro( wrf_setup_target_new_name ) + + set( options USE_SYMLINKS ) + set( oneValueArgs TARGET DEST_PATH NEW_NAME ) + set( multiValueArgs ) + + cmake_parse_arguments( + WRF_SETUP + "${options}" "${oneValueArgs}" "${multiValueArgs}" + ${ARGN} + ) + set( WRF_SETUP_CMD copy_if_different ) + if ( ${WRF_SETUP_USE_SYMLINKS} ) + set( WRF_SETUP_CMD create_symlink ) + endif() + + # Generate install code for each target + # https://stackoverflow.com/a/56528615 + #!TODO Do we *need* the rm for symlinks beforehand? + # get_filename_component( WRF_SETUP_FILE_ONLY $ NAME + + # If we ever wanted to link or copy things other than binaries we could change this + set( WRF_SETUP_INSTALL_LOCATION ${CMAKE_INSTALL_PREFIX}/bin ) + + install( + CODE " + message( STATUS \"Setting up $ via ${WRF_SETUP_CMD} as ${WRF_SETUP_NEW_NAME}\" ) + execute_process( COMMAND ${CMAKE_COMMAND} -E ${WRF_SETUP_CMD} ${WRF_SETUP_INSTALL_LOCATION}/$ ${WRF_SETUP_DEST_PATH}/${WRF_SETUP_NEW_NAME} ) + " + COMPONENT setup + ) + + # Add .exe link as well + install( + CODE " + message( STATUS \"Creating symlink for ${WRF_SETUP_NEW_NAME}.exe\" ) + execute_process( COMMAND ${CMAKE_COMMAND} -E create_symlink ${WRF_SETUP_DEST_PATH}/${WRF_SETUP_NEW_NAME} ${WRF_SETUP_DEST_PATH}/${WRF_SETUP_NEW_NAME}.exe ) + " + COMPONENT setup + ) + +endmacro() + # WRF Macro for adding file symlinks/copies to be run after internal install() code macro( wrf_setup_files ) diff --git a/confcheck/CMakeLists.txt b/confcheck/CMakeLists.txt index aab2e3bc69..8f798e7416 100644 --- a/confcheck/CMakeLists.txt +++ b/confcheck/CMakeLists.txt @@ -2,24 +2,21 @@ wrf_conf_check( RUN RESULT_VAR Fortran_2003_IEEE - SOURCE ${PROJECT_SOURCE_DIR}/tools/fortran_2003_ieee_test.F - EXTENSION .F + SOURCES ${PROJECT_SOURCE_DIR}/tools/fortran_2003_ieee_test.F MESSAGE "Some IEEE Fortran 2003 features missing, removing usage of these features" ) wrf_conf_check( RUN RESULT_VAR Fortran_2003_ISO_C - SOURCE ${PROJECT_SOURCE_DIR}/tools/fortran_2003_iso_c_test.F - EXTENSION .F + SOURCES ${PROJECT_SOURCE_DIR}/tools/fortran_2003_iso_c_test.F MESSAGE "Some ISO_C Fortran 2003 features missing, removing usage ISO_C and stubbing code dependent on it" ) wrf_conf_check( RUN RESULT_VAR Fortran_2003_FLUSH - SOURCE ${PROJECT_SOURCE_DIR}/tools/fortran_2003_flush_test.F - EXTENSION .F + SOURCES ${PROJECT_SOURCE_DIR}/tools/fortran_2003_flush_test.F MESSAGE "Standard FLUSH routine Fortran 2003 features missing, checking for alternate Fortran_2003_FFLUSH" ) @@ -27,8 +24,7 @@ if ( NOT ${Fortran_2003_FLUSH} ) wrf_conf_check( RUN RESULT_VAR Fortran_2003_FFLUSH - SOURCE ${PROJECT_SOURCE_DIR}/tools/fortran_2003_fflush_test.F - EXTENSION .F + SOURCES ${PROJECT_SOURCE_DIR}/tools/fortran_2003_fflush_test.F MESSAGE "Standard FFLUSH routine Fortran 2003 features missing, no alternate to FLUSH found, feature stubbed out" ) endif() @@ -36,8 +32,7 @@ endif() wrf_conf_check( RUN RESULT_VAR Fortran_2003_GAMMA - SOURCE ${PROJECT_SOURCE_DIR}/tools/fortran_2008_gamma_test.F - EXTENSION .F + SOURCES ${PROJECT_SOURCE_DIR}/tools/fortran_2008_gamma_test.F MESSAGE "Some Fortran 2003 features missing, removing usage gamma function intrinsic and stubbing code dependent on it" ) @@ -45,22 +40,20 @@ wrf_conf_check( wrf_conf_check( RUN - SOURCE_TYPE C RESULT_VAR FSEEKO64 - SOURCE ${PROJECT_SOURCE_DIR}/tools/fseek_test.c - EXTENSION .c - ADDITIONAL_DEFINITIONS -DTEST_FSEEKO64 -D_FILE_OFFSET_BITS=64 -D_LARGEFILE_SOURCE=1 -DFILE_TO_TEST="${PROJECT_SOURCE_DIR}/CMakeLists.txt" + SOURCES ${PROJECT_SOURCE_DIR}/tools/fseek_test.c + OPTIONS + COMPILE_DEFINITIONS -DTEST_FSEEKO64 -D_FILE_OFFSET_BITS=64 -D_LARGEFILE_SOURCE=1 -DFILE_TO_TEST="${PROJECT_SOURCE_DIR}/CMakeLists.txt" MESSAGE "fseeko64 not supported, checking alternate fseeko" ) if ( NOT "${FSEEKO64}" ) wrf_conf_check( RUN - SOURCE_TYPE C RESULT_VAR FSEEKO - SOURCE ${PROJECT_SOURCE_DIR}/tools/fseek_test.c - EXTENSION .c - ADDITIONAL_DEFINITIONS -DTEST_FSEEKO -D_FILE_OFFSET_BITS=64 -D_LARGEFILE_SOURCE=1 -DFILE_TO_TEST="${PROJECT_SOURCE_DIR}/CMakeLists.txt" + SOURCES ${PROJECT_SOURCE_DIR}/tools/fseek_test.c + OPTIONS + COMPILE_DEFINITIONS -DTEST_FSEEKO -D_FILE_OFFSET_BITS=64 -D_LARGEFILE_SOURCE=1 -DFILE_TO_TEST="${PROJECT_SOURCE_DIR}/CMakeLists.txt" MESSAGE "fseeko not supported, compiling with fseek (caution with large files)" ) endif() diff --git a/configure b/configure index 5e2bedb10f..dd1bbac8b7 100755 --- a/configure +++ b/configure @@ -6,7 +6,7 @@ thiscmd=$0 FORTRAN_COMPILER_TIMER="" opt_level="-f" -rword="-r4" +rword=4 print_usage="" chemistry="" wrf_core="" @@ -22,7 +22,7 @@ while [ $# -ge 1 ]; do -help) print_usage="yes" ;; -os) shift ; WRF_OS=$1 ;; -mach) shift ; WRF_MACH=$1 ;; - -r8) rword="-r8" ;; + -r8) rword=8 ;; -time) shift ; FORTRAN_COMPILER_TIMER=$1 ;; chem) WRF_CHEM=1 ;; cmaq) WRF_CMAQ=1 ;; @@ -529,7 +529,7 @@ if test -n "$wrf_core" ; then if [ "$wrf_core" = "DA_CORE" -o \ "$wrf_core" = "4D_DA_CORE" -o \ "$wrf_core" = "WRF_PLUS_CORE" ] ; then - rword="-r8" + rword=8 fi fi @@ -541,7 +541,7 @@ if test -n "$PERL" ; then -netcdf=$NETCDF -pnetcdf=$PNETCDF -netcdfpar=$NETCDFPAR -adios2=$ADIOS2 -hdf5=$HDF5 -phdf5=$PHDF5 -os=$os -mach=$mach -ldflags=$ldflags \ -compileflags=$compileflags -opt_level=$opt_level -USENETCDFF=$USENETCDFF -USENETCDF=$USENETCDF \ -time=$FORTRAN_COMPILER_TIMER -tfl="$TFL" -cfl="$CFL" -config_line="$config_line" \ - -wrf_core=$wrf_core -gpfs=$GPFS_PATH -curl=$CURL_PATH -netcdf4_dep_lib="$NETCDF4_DEP_LIB" + -wrf_core=$wrf_core -gpfs=$GPFS_PATH -curl=$CURL_PATH -netcdf4_dep_lib="$NETCDF4_DEP_LIB" -rword="$rword" if test ! -f configure.wrf ; then echo "configure.wrf not created! Exiting configure script..." exit 1 @@ -556,13 +556,10 @@ if test -n "$PERL" ; then fi # GNU has a funny way of doing promotion to real*8 - if [ "$rword" = "-r8" ] ; then + if [ $rword -eq 8 ] ; then srch=`grep -i "^SFC" configure.wrf | grep -i "gfortran"` if [ -n "$srch" ] ; then - sed -e '/^PROMOTION/s/#//' \ - -e '/^RWORDSIZE/s/$(NATIVE_RWORDSIZE)/8/' configure.wrf > configure.wrf.edit - else - sed -e '/^RWORDSIZE/s/$(NATIVE_RWORDSIZE)/8/' configure.wrf > configure.wrf.edit + sed -e '/^PROMOTION/s/#//' configure.wrf > configure.wrf.edit fi /bin/mv configure.wrf.edit configure.wrf sed -e 's/-DBUILD_SBM_FAST=1/-DBUILD_SBM_FAST=0/' configure.wrf > configure.wrf.edit diff --git a/doc/README.NSSLmp b/doc/README.NSSLmp index e9b673653e..915b63cea8 100644 --- a/doc/README.NSSLmp +++ b/doc/README.NSSLmp @@ -22,16 +22,16 @@ Basic options in physics namelist: CCN concentration + options The legacy options (17,19,21,22) still behave as before (for now), but going - forward one should use mp_physics=18 with modifier flags: + forward one should use mp_physics=18 with modifier flags. 2025 Update, however, sets nssl_ccn_on=1 by default (keeps supersaturation much more reasonable; except for single moment). mp_physics = 22 ! NSSL scheme (2-moment) without hail - Equivalent: mp=18, nssl_hail_on=0, nssl_ccn_on=0 - = 17 ! NSSL scheme (2-moment) with hail with constant background CCN - concentration - Equivalent: mp=18, nssl_ccn_on=0 + Equivalent: mp=18, nssl_hail_on=0, nssl_ccn_on=1 + = 17 ! NSSL scheme (2-moment) with hail is now the same as mp=18 + Equivalent: mp=18, nssl_ccn_on=1 <- must explicitly set nssl_ccn_on=0 to + get old behavior = 19, NSSL 1-moment (7 class: qv,qc,qr,qi,qs,qg,qh; predicts graupel density) - Equivalent: mp=18, nssl_2moment_on=0, nssl_ccn_on=0 (do no set nssl_hail_on) + Equivalent: mp=18, nssl_2moment_on=0, nssl_ccn_on=1 (do no set nssl_hail_on) = 21, NSSL 1-moment, (6-class), very similar to Gilmore et al. 2004 Equivalent: mp=18, nssl_2moment_on=0, nssl_hail_on=0, nssl_ccn_on=0, nssl_density_on=0 @@ -98,14 +98,23 @@ Cloud concentration nuclei (CCN) concentration is predicted as in Mansell et al. Droplet activation option method is controlled by the 'irenuc' option (internal to NSSL module). The default option (2) depletes CCN from the unactivated CCN field. A new option (7) instead counts the number of activated CCN (nucleated droplets) with the assumption of an initial constant CCN number mixing ratio. Option 7 better handles supersaturation at low CCN (e.g., maritime) concentrations by allowing extra droplet activation at high SS. irenuc : (nssl_mp_params namelist) - 2 = ccn field is UNactivated aerosol (default; old droplet activation) + 2 = ccn field is UNactivated aerosol (old default; old droplet activation) Can switch to counting activated CCN with nssl_ccn_is_ccna=1 + 5 = ccn field must be ACTVIATED aerosol (new default as of Feb. 2025) + Must have nssl_ccn_on=1 for irenuc=5 + Allows activation beyond limit of nssl_cccn at higher supersaturation + as an approximation of nucleation mode aerosol being activated. (Mainly + an issue for low CCN concentration with deep updrafts.) + If more strict limitation of activation is desired, use option 7. 7 = ccn field must be ACTVIATED aerosol (new droplet activation) Must have nssl_ccn_on=1 for irenuc=7 Excessive size sorting (common in 2-moment schemes) is effectively controlled by an adaptive breakup method that prevents reflectivity growth by sedimentation (Mansell 2010). For 2-moment, infall=4 (default; nssl_mp_params namelist) is recommended. For 3-moment, infall only really applies to droplets, cloud ice, and snow. +3-moment active rain breakup (WRF 4.7.x, 2025): The 3-moment rain without explicit breakup can result in cold pools that are too warm and rain median diameters that are too large in rain cores. A bin-model-based breakup parameterization for rain was implemented to address these issues. Very low rain rates (sparse drops) are largely unaffected (e.g., maintains Zdr arc feature). The breakup coefficient (rainbreakfac) has a default value of 1.0e6 and can reasonably be increased up to around 2.5e6 if desired (nssl_mp_params). Active breakup is automatically turned on for 3-moment (irainbreak=2) but not for 2-moment. Option irainbreak=2 is not recommended for 2-moment, but a user may experiment with irainbreak=11, which breaks up large drops in the tail of the spectrum starting at D=draintail (default 10.e-3 m). + Graupel -> hail conversion: The parameter ihlcnh selects the method of converting graupel (hail embryos) to the hail category. The default value is -1 for automatic setting. The original option (ihlcnh=1) is replaced by a new option (ihlcnh=3) as of May 2023. ihlcnh=3 converts from the graupel spectrum itself based on the wet growth diameter, which generally results in fewer initiated hailstones with larger diameters (and larger mean diameter at the ground). If hail size seems excessive, try setting ihlcnh=1, which tends to generate higher hail number concentrations and thus smaller diameters. +UPDATE (4.7.x/2025): The conversion has been updated to conserve reflectivity of the new hailstones compared to the graupel. This results in new hail that is smaller than previously but prevents spurious increases in reflectivity. (Active for both 2- and 3-moment) The June 2023 (WRF 4.6) update introduces changes in the default options for graupel/hail fall speeds and collection efficiencies. The original fall speed options (icdx=3; icdxhl=3) from Mansell et al. (2010) are switched to the Milbrandt and Morrison (2013) fall speed curves (icdx=6; icdxhl=6). Because the fall speeds are generally a bit lower, a partially compensating increase in maximum collection efficiency is set by default: ehw0/ehlw0 increased to 0.9. One effect is somewhat reduced total precipitation and cold pool intensity for supercell storms. @@ -138,6 +147,15 @@ Snow self-collection (aggregation) has been curbed in the 4.6 version by reducin Snow reflectivity formerly had a default setting that turned on a crude bright band enhancement (iusewetsnow=1). This is now turned off by default (iusewetsnow=0) These snow parameters can be accessed through the nssl_mp_params namelist. +Saturation mixing ratio (WRF 4.7.x, 2025): New formulation (iqvsopt=1) is more consistent with other microphysics schemes. Previously (iqvsopt=0), the quantity e/(p-e) was approximated as e/p, but the new default restores the full equation and uses slightly more accurate (Bolton) coefficients for the saturation (wrt liquid) tables. + +New options (Feb. 2025) (not enabled by default): + - Option (nsplinter=1001) for ice crystal production by drop freezing/shattering (Sullivan et al. 2018) + - Option (incwet = 1) to treat wet growth only for D > Dwet rather than all or nothing; results in greater hail production due to maintaining dry growth at D < Dwet + +New diagnostic output option: + nssl_ssat_output : (default 0); 1 = Supersaturation wrt liquid; 2 = also supersat. wrt ice + References: Mansell, E. R., C. L. Ziegler, and E. C. Bruning, 2010: Simulated electrification diff --git a/doc/README.cmake_build b/doc/README.cmake_build index d11c248cf6..6ce2ec57c8 100644 --- a/doc/README.cmake_build +++ b/doc/README.cmake_build @@ -24,7 +24,7 @@ How to compile and run? be selectable via the interactive dialogs. Compared to previous version of `configure` this will look much more sparse - and the numbering will be changed to reflect what is availble. For this + and the numbering will be changed to reflect what is available. For this reason it will be best to talk about configuration with their description or some other unique identifier from now on with this build methodology. @@ -48,10 +48,10 @@ How to compile and run? place a configuration) -- If sucessful, this will create either `real` or `ideal` and `wrf` executables +- If successful, this will create either `real` or `ideal` and `wrf` executables in the install location's bin/ directory (for default location this will be install/bin/) and the appropriate executables will be also copied into - the respective test directoires under the same install directory as + the respective test directories under the same install directory as /test/. Likewise, for specific test cases that have additional or modified inputs, those input files are copied from the respective source location test/ @@ -67,7 +67,7 @@ How to compile and run? ./ideal - to produce wrfinput_d01 file for wrf model. Then type + to produce wrfinput_d01 file for WRF. Then type ./wrf @@ -113,7 +113,7 @@ Advanced Configuration The '-x' option allows the interactive dialogs to be suppressed, and configuration will immediately proceed with whatever options have been set or - passed in. This is meant to be used with the '--' delimeter option + passed in. This is meant to be used with the '--' delimiter option The '-d' option allows us to specify an alternative build/configuration directory. As CMake best operates with out-of-source builds, our configuration @@ -135,7 +135,7 @@ Advanced Configuration configuration is no longer desired. This also allows multiple installs of different compilations to coexist from within the same source repo - The '--' option is meant to be a delimeter marking all subsequent input to be + The '--' option is meant to be a delimiter marking all subsequent input to be fed directly to the CMake command execution. In other words, after this marker anything that you place afterwards is as if you are directly passing in command line options to `cmake`. This allows you to more effectively use the @@ -152,6 +152,37 @@ Advanced Configuration WRF_CASE option. Note that the value used is the actual name of the value, not the numeric shorthand used during interactive dialog. + Note: When using the cmake `*_ROOT` package variables to control where certain + depenendencies are found, please refer to the top-level CMakeLists.txt + (i.e. /CMakeLists.txt) for all instances of `find_package()` + for the latest accurate list of all possible values. The construction of the + respective `*_ROOT` variable for a package uses the name in the call to + `find_package( )` verbatim and *is case sensitive* resulting + in `_ROOT`. + + The current list of possible `*_ROOT` is as follows : + Dependecies always used : + * netCDF_ROOT + * netCDF-Fortran_ROOT + * ZLIB_ROOT + + Conditional depenendencies based on configuration: + * MPI_ROOT + * OpenMP_ROOT + * HDF5_ROOT + * Jasper_ROOT + * RPC_ROOT + * BISON_ROOT + * FLEX_ROOT + + One can make use of passing in `CMAKE_PREFIX_PATH` to provide a lower priority + general search location if multiple depenendencies reside in the same directory. + Please refer to https://cmake.org/cmake/help/v3.20/command/find_package.html + for further documentation on using `*_ROOT` variables or other control methods + of resolving depenendency locations. Note that the minimum required CMake version + for WRF is specified as v3.20, and so the package finding logic for WRF will + follow as closely as possible the behavior of find_package() in version v3.20, + even if a newer version of CMake is being used to build WRF. - The 'compile_new' has a complimentary feature to pair with 'configure_new'. This feature is specifying an alternate build directory to use as a compile @@ -217,7 +248,7 @@ Advanced Configuration ./cleanCMake.sh -b -d _buildCustomDirectory One might think we would use the install directory when specifying the '-b' - option, but recall that the install location is embeded into the build + option, but recall that the install location is embedded into the build configuration and thus removing the installs that cmake did without entirely removing the install directory requires going to the build directory. This can be extremely versatile when installing into common locations where other diff --git a/dyn_em/module_big_step_utilities_em.F b/dyn_em/module_big_step_utilities_em.F index 1d24d3cf00..5076959843 100644 --- a/dyn_em/module_big_step_utilities_em.F +++ b/dyn_em/module_big_step_utilities_em.F @@ -2,7 +2,7 @@ !wrf:MODEL_LAYER:DYNAMICS ! -#if (RWORDSIZE == 4) +#ifndef DOUBLE_PRECISION # define VPOWX vspowx # define VPOW vspow #else diff --git a/dyn_em/module_em.F b/dyn_em/module_em.F index 56df890f90..62abb8b7c3 100644 --- a/dyn_em/module_em.F +++ b/dyn_em/module_em.F @@ -2089,6 +2089,14 @@ SUBROUTINE calculate_phy_tend (config_flags,c1,c2, & RQISHTEN,RQSSHTEN,RQGSHTEN, & RUNDGDTEN,RVNDGDTEN,RTHNDGDTEN,RQVNDGDTEN, & RMUNDGDTEN, & + ruiauten,rviauten,rthiauten, & + rqviauten,rqciauten,rqriauten, & + rqiiauten,rqsiauten,rqgiauten, & + rmuiauten,rphiauten, & + u_iau,v_iau,t_iau,ph_iau, & + mu_iau,qv_iau,qc_iau,qr_iau, & + qi_iau,qs_iau,qg_iau, & + itimestep, & scalar, scalar_tend, num_scalar, & tracer, tracer_tend, num_tracer, & ids,ide, jds,jde, kds,kde, & @@ -2163,6 +2171,38 @@ SUBROUTINE calculate_phy_tend (config_flags,c1,c2, & REAL, DIMENSION( ims:ime, jms:jme ) , & INTENT(INOUT) :: RMUNDGDTEN +! iau + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & + INTENT(INOUT) :: RUIAUTEN, & + RVIAUTEN, & + RTHIAUTEN, & + RPHIAUTEN, & + RQVIAUTEN, & + RQCIAUTEN, & + RQRIAUTEN, & + RQIIAUTEN, & + RQSIAUTEN, & + RQGIAUTEN + + REAL, DIMENSION( ims:ime, jms:jme ), & + INTENT(INOUT) :: RMUIAUTEN + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & + INTENT(IN ) :: & + u_iau, & + v_iau, & + t_iau, & + ph_iau, & + qv_iau, & + qc_iau, & + qr_iau, & + qs_iau, & + qi_iau, & + qg_iau + + REAL, DIMENSION( ims:ime, jms:jme ), & + INTENT(IN ) :: mu_iau + ! 4d arrays REAL ,DIMENSION(ims:ime,kms:kme,jms:jme,num_tracer),INTENT(INOUT) :: tracer @@ -2170,9 +2210,13 @@ SUBROUTINE calculate_phy_tend (config_flags,c1,c2, & REAL ,DIMENSION(ims:ime,kms:kme,jms:jme,num_scalar),INTENT(INOUT) :: scalar REAL ,DIMENSION(ims:ime,kms:kme,jms:jme,num_scalar),INTENT(INOUT) :: scalar_tend + INTEGER :: itimestep INTEGER :: i,k,j, im INTEGER :: itf,ktf,jtf,itsu,jtsv +! local + real :: wgt_iau + !----------------------------------------------------------------------- ! @@ -2448,6 +2492,88 @@ SUBROUTINE calculate_phy_tend (config_flags,c1,c2, & ENDDO ENDDO +! IAU (Incremental Analysis Updates) + + IF (config_flags%iau .gt. 0) THEN + + wgt_iau = iau_coef(config_flags%iau_time_window_sec,config_flags%dt,itimestep) + + DO J=jts,jtf + DO K=kts,ktf + DO I=its,itf + RUIAUTEN(I,K,J) =(c1(k)*mut(I,J)+c2(k))*U_IAU(I,K,J)*WGT_IAU + RVIAUTEN(I,K,J) =(c1(k)*mut(I,J)+c2(k))*V_IAU(I,K,J)*WGT_IAU + RTHIAUTEN(I,K,J)=(c1(k)*mut(I,J)+c2(k))*T_IAU(I,K,J)*WGT_IAU + RQVIAUTEN(I,K,J)=(c1(k)*mut(I,J)+c2(k))*QV_IAU(I,K,J)*WGT_IAU + ENDDO + ENDDO + ENDDO + + DO J=jts,jtf + DO K=kts,ktf+1 + DO I=its,itf + RPHIAUTEN(I,K,J)=PH_IAU(I,K,J)*WGT_IAU + ENDDO + ENDDO + ENDDO + + DO J=jts,jtf + DO I=its,itf + RMUIAUTEN(I,J) =MU_IAU(I,J)*WGT_IAU + ENDDO + ENDDO + + IF (P_QC .ge. PARAM_FIRST_SCALAR)THEN + DO J=jts,jtf + DO K=kts,ktf + DO I=its,itf + RQCIAUTEN(I,K,J)=(c1(k)*mut(I,J)+c2(k))*QC_IAU(I,K,J)*WGT_IAU + ENDDO + ENDDO + ENDDO + ENDIF + + IF (P_QR .ge. PARAM_FIRST_SCALAR)THEN + DO J=jts,jtf + DO K=kts,ktf + DO I=its,itf + RQRIAUTEN(I,K,J)=(c1(k)*mut(I,J)+c2(k))*QR_IAU(I,K,J)*WGT_IAU + ENDDO + ENDDO + ENDDO + ENDIF + + IF (P_QI .ge. PARAM_FIRST_SCALAR)THEN + DO J=jts,jtf + DO K=kts,ktf + DO I=its,itf + RQIIAUTEN(I,K,J)=(c1(k)*mut(I,J)+c2(k))*QI_IAU(I,K,J)*WGT_IAU + ENDDO + ENDDO + ENDDO + ENDIF + + IF(P_QS .ge. PARAM_FIRST_SCALAR)THEN + DO J=jts,jtf + DO K=kts,ktf + DO I=its,itf + RQSIAUTEN(I,K,J)=(c1(k)*mut(I,J)+c2(k))*QS_IAU(I,K,J)*WGT_IAU + ENDDO + ENDDO + ENDDO + ENDIF + + IF(P_QG .ge. PARAM_FIRST_SCALAR)THEN + DO J=jts,jtf + DO K=kts,ktf + DO I=its,itf + RQGIAUTEN(I,K,J)=(c1(k)*mut(I,J)+c2(k))*QG_IAU(I,K,J)*WGT_IAU + ENDDO + ENDDO + ENDDO + ENDIF + + ENDIF END SUBROUTINE calculate_phy_tend @@ -3018,4 +3144,22 @@ subroutine trajmapproj (grid,config_flags,ts_proj) end subroutine trajmapproj +FUNCTION iau_coef (iau_time_window_sec, dt, itimestep) result(wgt_iau) + + implicit none + +! This function returns the coeficient for IAU + + INTEGER :: itimestep + INTEGER :: nsteps_iau + REAL :: wgt_iau, iau_time_window_sec, dt + + wgt_iau = 0. + nsteps_iau = nint(iau_time_window_sec / dt) + if (itimestep <= nsteps_iau) then + wgt_iau = 1.0/iau_time_window_sec + endif + +END FUNCTION iau_coef + END MODULE module_em diff --git a/dyn_em/module_first_rk_step_part1.F b/dyn_em/module_first_rk_step_part1.F index 6623cab7bd..9a56bb2414 100644 --- a/dyn_em/module_first_rk_step_part1.F +++ b/dyn_em/module_first_rk_step_part1.F @@ -19,6 +19,7 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & , ph_tendf, mu_tendf & , tke_tend & , adapt_step_flag , curr_secs & + , curr_mins2 & , psim , psih , gz1oz0 , chklowq & , cu_act_flag , hol , th_phy & , pi_phy , p_phy , t_phy & @@ -77,7 +78,7 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & LOGICAL ,INTENT(IN) :: adapt_step_flag - REAL, INTENT(IN) :: curr_secs + REAL, INTENT(IN) :: curr_secs, curr_mins2 REAL ,DIMENSION(ims:ime,kms:kme,jms:jme,num_moist),INTENT(INOUT) :: moist REAL ,DIMENSION(ims:ime,kms:kme,jms:jme,num_moist),INTENT(INOUT) :: moist_tend @@ -1232,7 +1233,7 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,qcg=grid%qcg, grav_settling=config_flags%grav_settling & ! & ,K_m=grid%K_m, K_h=grid%K_h, K_q=grid%K_q & & ,vdfg=grid%vdfg,maxwidth=grid%maxwidth,maxMF=grid%maxmf & - & ,ztop_plume=grid%ztop_plume,ktop_plume=grid%ktop_plume & + & ,ztop_plume=grid%ztop_plume & & ,spp_pbl=config_flags%spp_pbl & & ,pattern_spp_pbl=grid%pattern_spp_pbl & & ,restart=config_flags%restart,cycling=config_flags%cycling & @@ -1770,7 +1771,7 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & BENCH_START(fdda_driver_tim) CALL fddagd_driver(itimestep=grid%itimestep,dt=grid%dt,xtime=grid%XTIME, & - id=grid%id, & + curr_mins2=curr_mins2, id=grid%id, & RUNDGDTEN=grid%rundgdten,RVNDGDTEN=grid%rvndgdten, & RTHNDGDTEN=grid%rthndgdten,RPHNDGDTEN=grid%rphndgdten, & RQVNDGDTEN=grid%rqvndgdten,RMUNDGDTEN=grid%rmundgdten, & diff --git a/dyn_em/module_first_rk_step_part2.F b/dyn_em/module_first_rk_step_part2.F index 8f092ce794..656f063f7c 100644 --- a/dyn_em/module_first_rk_step_part2.F +++ b/dyn_em/module_first_rk_step_part2.F @@ -402,6 +402,14 @@ SUBROUTINE first_rk_step_part2 ( grid , config_flags & grid%rqishten,grid%rqsshten,grid%rqgshten, & grid%RUNDGDTEN,grid%RVNDGDTEN,grid%RTHNDGDTEN,grid%RQVNDGDTEN, & grid%RMUNDGDTEN, & + grid%ruiauten,grid%rviauten,grid%rthiauten, & + grid%rqviauten,grid%rqciauten,grid%rqriauten, & + grid%rqiiauten,grid%rqsiauten,grid%rqgiauten, & + grid%rmuiauten,grid%rphiauten, & + grid%u_iau,grid%v_iau,grid%t_iau,grid%ph_iau, & + grid%mu_iau,grid%qv_iau,grid%qc_iau,grid%qr_iau, & + grid%qs_iau,grid%qi_iau,grid%qg_iau, & + grid%itimestep, & scalar, scalar_tend, num_scalar, & tracer, tracer_tend, num_tracer, & ids,ide, jds,jde, kds,kde, & @@ -807,6 +815,10 @@ SUBROUTINE first_rk_step_part2 ( grid , config_flags & grid%RVNDGDTEN,grid%RTHNDGDTEN,grid%RPHNDGDTEN, & grid%RQVNDGDTEN,grid%RMUNDGDTEN, & grid%rthfrten,grid%rqvfrten, & ! fire + grid%ruiauten,grid%rviauten,grid%rthiauten, & + grid%rqviauten,grid%rqciauten,grid%rqriauten, & + grid%rqiiauten,grid%rqsiauten,grid%rqgiauten, & + grid%rphiauten,grid%rmuiauten, & num_moist,num_scalar,config_flags,rk_step, & grid%adv_moist_cond, & ids, ide, jds, jde, kds, kde, & diff --git a/dyn_em/module_initialize_real.F b/dyn_em/module_initialize_real.F index d8663ca6f1..30a6d34a2a 100644 --- a/dyn_em/module_initialize_real.F +++ b/dyn_em/module_initialize_real.F @@ -237,21 +237,27 @@ SUBROUTINE init_domain_rk ( grid & geogrid_flag_error = geogrid_flag_error + 1 END IF - IF ( ( config_flags%mp_physics .EQ. thompsonaero ) .AND. & + IF ( ( (config_flags%mp_physics .EQ. thompsonaero .OR. & + config_flags%mp_physics .EQ. rcon_mp_scheme & + ) ) .AND. & ( config_flags%dust_emis .EQ. 1 ) .AND. ( flag_erod .EQ. 0 ) ) THEN - CALL wrf_message ( '----- ERROR: mp=28 AND dust_emis= 1 AND flag_erod = 0 ' ) + CALL wrf_message ( '----- ERROR: mp=28 or mp=29 AND dust_emis= 1 AND flag_erod = 0 ' ) geogrid_flag_error = geogrid_flag_error + 1 END IF - IF ( ( config_flags%mp_physics .EQ. thompsonaero ) .AND. & + IF ( ( (config_flags%mp_physics .EQ. thompsonaero .OR. & + config_flags%mp_physics .EQ. rcon_mp_scheme & + ) ) .AND. & ( config_flags%dust_emis .EQ. 1 ) .AND. ( flag_clayfrac .EQ. 0 ) ) THEN - CALL wrf_message ( '----- ERROR: mp=28 AND dust_emis= 1 AND flag_clayfrac = 0 ' ) + CALL wrf_message ( '----- ERROR: mp=28 or mp=29 AND dust_emis= 1 AND flag_clayfrac = 0 ' ) geogrid_flag_error = geogrid_flag_error + 1 END IF - IF ( ( config_flags%mp_physics .EQ. thompsonaero ) .AND. & - ( config_flags%dust_emis .EQ. 1 ) .AND. ( flag_sandfrac .EQ. 0 ) ) THEN - CALL wrf_message ( '----- ERROR: mp=28 AND dust_emis= 1 AND flag_sandfrac = 0 ' ) + IF ( ( (config_flags%mp_physics .EQ. thompsonaero .OR. & + config_flags%mp_physics .EQ. rcon_mp_scheme & + ) ) .AND. & + ( config_flags%dust_emis .EQ. 1 ) .AND. ( flag_sandfrac .EQ. 0 ) ) THEN + CALL wrf_message ( '----- ERROR: mp=28 or mp=29 AND dust_emis= 1 AND flag_sandfrac = 0 ' ) geogrid_flag_error = geogrid_flag_error + 1 END IF @@ -2321,10 +2327,12 @@ SUBROUTINE init_domain_rk ( grid & ! QNWFA - Number concentration water-friendly aerosols ! QNIFA - Number concentration ice-friendly aerosols ! QNBCA - Number concentration black carbon aerosols + ! Also used in RCON Microphysics, mp=29 aer_init_opt = config_flags%aer_init_opt - if_thompsonaero_3d: IF (config_flags%mp_physics .EQ. THOMPSONAERO .AND. & + if_thompsonaero_3d: IF ((config_flags%mp_physics .EQ. THOMPSONAERO & + .OR. config_flags%mp_physics .EQ. RCON_MP_SCHEME) .AND. & config_flags%wif_input_opt .GT. 0) THEN select_aer_init_opt_3d: select case (aer_init_opt) @@ -2731,9 +2739,10 @@ SUBROUTINE init_domain_rk ( grid & end select select_aer_init_opt_3d - ELSE IF (config_flags%mp_physics .EQ. THOMPSONAERO .and. & + ELSE IF ((config_flags%mp_physics .EQ. THOMPSONAERO & + .OR. config_flags%mp_physics .EQ. RCON_MP_SCHEME) .and. & config_flags%wif_input_opt .EQ. 0 ) THEN - CALL wrf_error_fatal ('wif_input_opt=0 but mp_physics=28' ) + CALL wrf_error_fatal ('wif_input_opt=0 but mp_physics=28 or mp_physics=29' ) END IF if_thompsonaero_3d !========================================================================================= @@ -3114,7 +3123,7 @@ SUBROUTINE init_domain_rk ( grid & DO i = its, MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE IF ( grid%landmask(i,j) .GT. 0.5 .AND. grid%isltyp(i,j) .EQ. grid%isoilwater ) THEN - grid%isltyp(i,j) = 8 + grid%isltyp(i,j) = config_flags%default_soiltype change_soilw = change_soilw + 1 iforce = iforce + 1 ELSE IF ( grid%landmask(i,j) .LT. 0.5 .AND. grid%isltyp(i,j) .NE. grid%isoilwater ) THEN @@ -3125,10 +3134,17 @@ SUBROUTINE init_domain_rk ( grid & END DO END DO IF ( change_soilw .GT. 0 .OR. change_soil .GT. 0 ) THEN - WRITE(a_message,FMT='(A,I4,A,I6)' ) & - 'forcing artificial silty clay loam at ',iforce,' points, out of ',& - (MIN(ide-1,ite)-its+1)*(MIN(jde-1,jte)-jts+1) - CALL wrf_debug(0,a_message) + IF (config_flags%default_soiltype == 8) THEN + WRITE(a_message,FMT='(A,I4,A,I6)' ) & + 'forcing artificial silty clay loam at ',iforce,' points, out of ',& + (MIN(ide-1,ite)-its+1)*(MIN(jde-1,jte)-jts+1) + ELSE + WRITE(a_message,FMT='(A,I4,A,I4,A,I6)' ) & + 'forcing soil type to the user defined default category (',config_flags%default_soiltype,& + ') at ',iforce,' points, out of ',& + (MIN(ide-1,ite)-its+1)*(MIN(jde-1,jte)-jts+1) + ENDIF + CALL wrf_debug(0,a_message) END IF END IF @@ -3154,7 +3170,7 @@ SUBROUTINE init_domain_rk ( grid & (grid%ivgtyp(i,j).NE.13 .AND. grid%ivgtyp(i,j).NE.24 .AND. grid%ivgtyp(i,j).NE.25 .AND. grid%ivgtyp(i,j).NE.26 .AND. grid%ivgtyp(i,j).LT.30)) grid%ivgtyp(i,j)=13 ELSE IF ( MMINLU == "USGS" ) THEN IF ( grid%FRC_URB2D(i,j) .GE. 0.5 .AND. & - grid%ivgtyp(i,j).NE.1 ) grid%ivgtyp(i,j)=1 + grid%ivgtyp(i,j).NE.1 .AND. grid%ivgtyp(i,j).LT.30) grid%ivgtyp(i,j)=1 ENDIF IF ( grid%FRC_URB2D(i,j) == 0. ) THEN @@ -4493,7 +4509,8 @@ SUBROUTINE init_domain_rk ( grid & !.. to read biomass burning aerosol emissions !+---+-----------------------------------------------------------------+ - if_thompsonaero_2d: IF (config_flags%mp_physics .EQ. THOMPSONAERO .AND. & + if_thompsonaero_2d: IF ((config_flags%mp_physics .EQ. THOMPSONAERO & + .OR. config_flags%mp_physics .EQ. RCON_MP_SCHEME) .AND. & config_flags%wif_input_opt .GT. 0) THEN select_aer_init_opt_2d: select case (aer_init_opt) @@ -4782,7 +4799,9 @@ SUBROUTINE init_domain_rk ( grid & !+---+-----------------------------------------------------------------+ IF ( config_flags%mp_physics .EQ. THOMPSON .OR. & - config_flags%mp_physics .EQ. THOMPSONAERO ) THEN + config_flags%mp_physics .EQ. THOMPSONAERO .OR. & + config_flags%mp_physics .EQ. RCON_MP_SCHEME & + ) THEN !..As it occurs up above, temporarily utilizing the v_1 variable, !.. to hold temperature, which it does when time_loop=0. diff --git a/dyn_em/solve_em.F b/dyn_em/solve_em.F index c5f47a50a6..0761df036f 100644 --- a/dyn_em/solve_em.F +++ b/dyn_em/solve_em.F @@ -183,7 +183,8 @@ SUBROUTINE solve_em ( grid , config_flags & LOGICAL :: leapfrog INTEGER :: l,kte,kk LOGICAL :: f_flux ! flag for computing averaged fluxes in cu_gd - REAL :: curr_secs, curr_secs2 + REAL :: curr_secs, curr_secs2, curr_mins2 + REAL(8) :: curr_secs_r8, curr_secs2_r8 INTEGER :: num_sound_steps INTEGER :: idex, jdex REAL :: max_msft @@ -198,6 +199,7 @@ SUBROUTINE solve_em ( grid , config_flags & TYPE(WRFU_TimeInterval) :: tmpTimeInterval, tmpTimeInterval2 REAL :: real_time + REAL(8) :: real_time_r8 LOGICAL :: adapt_step_flag LOGICAL :: fill_w_flag @@ -331,6 +333,9 @@ END SUBROUTINE CMAQ_DRIVER tmpTimeInterval2 = domain_get_current_time ( grid ) - domain_get_start_time ( grid ) curr_secs = real_time(tmpTimeInterval) curr_secs2 = real_time(tmpTimeInterval2) + curr_secs_r8 = real_time_r8(tmpTimeInterval) + curr_secs2_r8 = real_time_r8(tmpTimeInterval2) + curr_mins2 = REAL( curr_secs2_r8 / 60.0d0 ) old_dt = grid%dt ! store old time step for flux averaging code at end of RK loop @@ -811,7 +816,7 @@ END SUBROUTINE CMAQ_DRIVER , ph_tendf, mu_tendf & , tke_tend & , config_flags%use_adaptive_time_step & - , curr_secs & + , curr_secs, curr_mins2 & , psim , psih , gz1oz0 & , chklowq & , cu_act_flag , hol , th_phy & @@ -3724,6 +3729,7 @@ END SUBROUTINE CMAQ_DRIVER & ,P8W=p8w ,P=p_phy ,PI_PHY=pi_phy & & ,RHO=grid%rho ,SPEC_ZONE=grid%spec_zone & & ,SR=grid%sr ,TH=th_phy & + & ,ssat=grid%ssat, ssati=grid%ssati & & ,refl_10cm=grid%refl_10cm & ! hm, 9/22/09 for refl & ,vmi3d=grid%vmi3d & ! for P3 & ,di3d=grid%di3d & ! for P3 @@ -3757,7 +3763,7 @@ END SUBROUTINE CMAQ_DRIVER & ,DGNUM4D=grid%dgnum4d,DGNUMWET4D=grid%dgnumwet4d & !====================== #endif - & ,XLAND=grid%xland,SNOWH=grid%SNOW & !PMA + & ,XLAND=grid%xland,SNOWH=grid%SNOW,XICE=grid%XICE & & ,SPECIFIED=specified_bdy, CHANNEL_SWITCH=channel_bdy & & ,F_RAIN_PHY=grid%f_rain_phy & & ,F_RIMEF_PHY=grid%f_rimef_phy & @@ -3977,7 +3983,10 @@ END SUBROUTINE CMAQ_DRIVER & ,pert_thom_qc=config_flags%pert_thom_qc & & ,pert_thom_qi=config_flags%pert_thom_qi & & ,pert_thom_qs=config_flags%pert_thom_qs & - & ,pert_thom_ni=config_flags%pert_thom_ni ) + & ,pert_thom_ni=config_flags%pert_thom_ni & + & ,cloudnc=grid%cloudnc & + ) + BENCH_END(micro_driver_tim) diff --git a/dyn_em/start_em.F b/dyn_em/start_em.F index 97a5bfcdcf..96057ebdfb 100644 --- a/dyn_em/start_em.F +++ b/dyn_em/start_em.F @@ -2001,6 +2001,7 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read & #endif DEALLOCATE(z_at_q) +DEALLOCATE(dz8w) IF (config_flags%p_lev_diags == PRESS_DIAGS ) THEN CALL wrf_debug ( 200 , ' PLD: pressure level diags' ) diff --git a/external/RSL_LITE/module_dm.F b/external/RSL_LITE/module_dm.F index ea166ae384..578eccc9d9 100644 --- a/external/RSL_LITE/module_dm.F +++ b/external/RSL_LITE/module_dm.F @@ -78,7 +78,7 @@ MODULE module_dm #endif INTERFACE wrf_dm_maxval -#if ( defined(PROMOTE_FLOAT) || ( RWORDSIZE == DWORDSIZE ) ) +#ifdef DOUBLE_PRECISION MODULE PROCEDURE wrf_dm_maxval_real , wrf_dm_maxval_integer #else MODULE PROCEDURE wrf_dm_maxval_real , wrf_dm_maxval_integer, wrf_dm_maxval_doubleprecision @@ -86,7 +86,7 @@ MODULE module_dm END INTERFACE INTERFACE wrf_dm_minval ! gopal's doing -#if ( defined(PROMOTE_FLOAT) || ( RWORDSIZE == DWORDSIZE ) ) +#ifdef DOUBLE_PRECISION MODULE PROCEDURE wrf_dm_minval_real , wrf_dm_minval_integer #else MODULE PROCEDURE wrf_dm_minval_real , wrf_dm_minval_integer, wrf_dm_minval_doubleprecision @@ -1458,7 +1458,7 @@ SUBROUTINE wrf_dm_minval_real ( val, idex, jdex ) # endif END SUBROUTINE wrf_dm_minval_real -#ifndef PROMOTE_FLOAT +#ifndef DOUBLE_PRECISION SUBROUTINE wrf_dm_maxval_doubleprecision ( val, idex, jdex ) # ifndef STUBMPI IMPLICIT NONE diff --git a/external/io_grib2/Makefile b/external/io_grib2/Makefile index aa04914a26..980a56838d 100644 --- a/external/io_grib2/Makefile +++ b/external/io_grib2/Makefile @@ -24,7 +24,7 @@ LIB_DEST = . # C_INCLUDES = -I. CXX_INCLUDES = -I. -F_INCLUDES = -I. -Ig2lib -Ibacio-1.3 -I../io_grib_share +F_INCLUDES = -I. -Ig2lib -Ibacio-1.3 -I../io_grib_share -I../ioapi_share ARFLAGS = cruv FORMAT = $(FREE) diff --git a/external/io_int/io_int.F90 b/external/io_int/io_int.F90 index ab95b49a45..7be1bc04ce 100644 --- a/external/io_int/io_int.F90 +++ b/external/io_int/io_int.F90 @@ -1529,12 +1529,12 @@ SUBROUTINE ext_int_read_field ( DataHandle , DateStr , VarName , Field , FieldTy locMemoryStart , locMemoryEnd , & locPatchStart , locPatchEnd ) IF ( TRIM(locVarName) .EQ. TRIM(VarName) ) THEN - IF ( FieldType .EQ. WRF_REAL ) THEN + IF ( FieldType .EQ. WRF_FLOAT ) THEN CALL rfieldread( DataHandle, Field, MemoryStart, MemoryEnd, PatchStart, PatchEnd ) ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN CALL ifieldread( DataHandle, Field, MemoryStart, MemoryEnd, PatchStart, PatchEnd ) ELSE - CALL wrf_message('io_int.F90: ext_int_read_field: types other than WRF_REAL not supported yet') + CALL wrf_message('io_int.F90: ext_int_read_field: types other than WRF_FLOAT not supported yet') READ( unit=DataHandle ) ENDIF ELSE @@ -1602,7 +1602,7 @@ SUBROUTINE ext_int_write_field ( DataHandle , DateStr , VarName , Field , FieldT inttypesize = itypesize realtypesize = rtypesize - IF ( FieldType .EQ. WRF_REAL .OR. FieldType .EQ. WRF_DOUBLE) THEN + IF ( FieldType .EQ. WRF_FLOAT .OR. FieldType .EQ. WRF_DOUBLE) THEN typesize = rtypesize ELSE IF ( FieldType .EQ. WRF_DOUBLE ) THEN CALL wrf_error_fatal( 'io_int.F90: ext_int_write_field, WRF_DOUBLE not yet supported') @@ -1621,7 +1621,7 @@ SUBROUTINE ext_int_write_field ( DataHandle , DateStr , VarName , Field , FieldT MemoryStart , MemoryEnd , & PatchStart , PatchEnd ) WRITE( unit=DataHandle ) hdrbuf - IF ( FieldType .EQ. WRF_REAL ) THEN + IF ( FieldType .EQ. WRF_FLOAT ) THEN CALL rfieldwrite( DataHandle, Field, MemoryStart, MemoryEnd, PatchStart, PatchEnd ) ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN CALL ifieldwrite( DataHandle, Field, MemoryStart, MemoryEnd, PatchStart, PatchEnd ) diff --git a/external/ioapi_share/makefile b/external/ioapi_share/makefile index a5142e02af..49893377cc 100644 --- a/external/ioapi_share/makefile +++ b/external/ioapi_share/makefile @@ -6,13 +6,8 @@ all: ../../inc/wrf_io_flags.h ../../inc/wrf_status_codes.h # The if statement below modifies WRF data type codes for builds made with # compiler autopromotion of REAL -> DOUBLE. ../../inc/wrf_io_flags.h : wrf_io_flags.h ../../configure.wrf - ( /bin/rm -f ../../inc/wrf_io_flags.h foo_io_flags.h; \ - /bin/cp wrf_io_flags.h foo_io_flags.h; \ - if [ $(RWORDSIZE) -ne $(NATIVE_RWORDSIZE) ] ; then \ - /bin/rm -f foo_io_flags.h; \ - sed -e 's/104/105/' wrf_io_flags.h > foo_io_flags.h ;\ - fi ; \ - /bin/mv foo_io_flags.h ../../inc/wrf_io_flags.h ) + /bin/rm -f ../../inc/wrf_io_flags.h + /bin/cp wrf_io_flags.h ../../inc/wrf_io_flags.h ../../inc/wrf_status_codes.h : wrf_status_codes.h /bin/rm -f ../../inc/wrf_status_codes.h diff --git a/external/ioapi_share/wrf_io_flags.h b/external/ioapi_share/wrf_io_flags.h index a131b5484d..67bb0a02a0 100644 --- a/external/ioapi_share/wrf_io_flags.h +++ b/external/ioapi_share/wrf_io_flags.h @@ -4,7 +4,7 @@ integer, parameter :: WRF_FILE_OPENED_FOR_READ = 103 integer, parameter :: WRF_REAL = 104 integer, parameter :: WRF_DOUBLE = 105 -#ifdef PROMOTE_FLOAT +#ifdef DOUBLE_PRECISION integer, parameter :: WRF_FLOAT=WRF_DOUBLE #else integer, parameter :: WRF_FLOAT=WRF_REAL diff --git a/frame/CMakeLists.txt b/frame/CMakeLists.txt index 4543c4694e..a678cdf1d4 100644 --- a/frame/CMakeLists.txt +++ b/frame/CMakeLists.txt @@ -102,7 +102,8 @@ endif() target_sources( ${PROJECT_NAME}_Core PRIVATE - ${WRF_INCLUDE_FILES} + module_internal_header_util.F + module_configure.F module_driver_constants.F @@ -155,9 +156,11 @@ target_sources( # Disable optimizations on these files always set_source_files_properties( ${nl_dyn_source} + module_comm_nesting_dm.F + DIRECTORY ${PROJECT_SOURCE_DIR} PROPERTIES COMPILE_OPTIONS_OPTIMIZATION - $<$:${WRF_FCNOOPT}> + "$<$:${WRF_FCNOOPT}>" ) install( diff --git a/frame/collect_on_comm.c b/frame/collect_on_comm.c index 15d2c5ef2e..964008533a 100644 --- a/frame/collect_on_comm.c +++ b/frame/collect_on_comm.c @@ -36,11 +36,11 @@ # endif #endif - + int col_on_comm ( int *, int *, void *, int *, void *, int *, int); int dst_on_comm ( int *, int *, void *, int *, void *, int *, int); -void +void COLLECT_ON_COMM ( int * comm, int * typesize , void * inbuf, int *ninbuf , void * outbuf, int * noutbuf ) { @@ -67,8 +67,9 @@ col_on_comm ( int * Fcomm, int * typesize , int *displace ; int noutbuf_loc ; int root_task ; + MPI_Datatype dtype; + int ierr = -1; MPI_Comm *comm, dummy_comm ; - int ierr ; comm = &dummy_comm ; *comm = MPI_Comm_f2c( *Fcomm ) ; @@ -90,28 +91,45 @@ col_on_comm ( int * Fcomm, int * typesize , for ( p = 1 , displace[0] = 0 , noutbuf_loc = recvcounts[0] ; p < ntasks ; p++ ) { displace[p] = displace[p-1]+recvcounts[p-1] ; noutbuf_loc = noutbuf_loc + recvcounts[p] ; + + /* check for overflow: displace is the partial sum of recvcounts, which can overflow for large problems. */ + if (displace[p] < 0) { +#ifndef MS_SUA + fprintf(stderr,"%s %d buffer offset overflow!!\n",__FILE__,__LINE__) ; + fprintf(stderr," ---> p = %d,\n ---> displace[%d] = %d,\n ---> typesize = %d\n", + p, p, displace[p], *typesize); +#endif + MPI_Abort(MPI_COMM_WORLD,1) ; + } } if ( noutbuf_loc > * noutbuf ) { #ifndef MS_SUA fprintf(stderr,"FATAL ERROR: collect_on_comm: noutbuf_loc (%d) > noutbuf (%d)\n", - noutbuf_loc , * noutbuf ) ; + noutbuf_loc , * noutbuf ) ; fprintf(stderr,"WILL NOT perform the collection operation\n") ; #endif MPI_Abort(MPI_COMM_WORLD,1) ; } - /* multiply everything by the size of the type */ - for ( p = 0 ; p < ntasks ; p++ ) { - displace[p] *= *typesize ; - recvcounts[p] *= *typesize ; + } + + /* handle different sized data types appropriately. */ + ierr = MPI_Type_match_size (MPI_TYPECLASS_REAL, *typesize, &dtype); + if (MPI_SUCCESS != ierr) { + ierr = MPI_Type_match_size (MPI_TYPECLASS_INTEGER, *typesize, &dtype); + if (MPI_SUCCESS != ierr) { +#ifndef MS_SUA + fprintf(stderr,"%s %d FATAL ERROR: unhandled typesize = %d!!\n", __FILE__,__LINE__,*typesize) ; +#endif + MPI_Abort(MPI_COMM_WORLD,1) ; } } - ierr = MPI_Gatherv( inbuf , *ninbuf * *typesize , MPI_CHAR , - outbuf , recvcounts , displace, MPI_CHAR , - root_task , *comm ) ; + ierr = MPI_Gatherv( inbuf , *ninbuf, dtype, + outbuf , recvcounts , displace, dtype, + root_task , *comm ) ; #ifndef MS_SUA if ( ierr != 0 ) fprintf(stderr,"%s %d MPI_Gatherv returns %d\n",__FILE__,__LINE__,ierr ) ; #endif @@ -152,6 +170,8 @@ dst_on_comm ( int * Fcomm, int * typesize , int *displace ; int noutbuf_loc ; int root_task ; + MPI_Datatype dtype; + int ierr = -1; MPI_Comm *comm, dummy_comm ; comm = &dummy_comm ; @@ -171,18 +191,34 @@ dst_on_comm ( int * Fcomm, int * typesize , for ( p = 1 , displace[0] = 0 , noutbuf_loc = sendcounts[0] ; p < ntasks ; p++ ) { displace[p] = displace[p-1]+sendcounts[p-1] ; noutbuf_loc = noutbuf_loc + sendcounts[p] ; + + /* check for overflow: displace is the partial sum of sendcounts, which can overflow for large problems. */ + if ( (displace[p] < 0) || (noutbuf_loc < 0) ) { +#ifndef MS_SUA + fprintf(stderr,"%s %d buffer offset overflow!!\n",__FILE__,__LINE__) ; + fprintf(stderr," ---> p = %d,\n ---> displace[%d] = %d,\n ---> noutbuf_loc = %d,\n ---> typesize = %d\n", + p, p, displace[p], noutbuf_loc, *typesize); +#endif + MPI_Abort(MPI_COMM_WORLD,1) ; + } } + } - /* multiply everything by the size of the type */ - for ( p = 0 ; p < ntasks ; p++ ) { - displace[p] *= *typesize ; - sendcounts[p] *= *typesize ; + /* handle different sized data types appropriately. */ + ierr = MPI_Type_match_size (MPI_TYPECLASS_REAL, *typesize, &dtype); + if (MPI_SUCCESS != ierr) { + ierr = MPI_Type_match_size (MPI_TYPECLASS_INTEGER, *typesize, &dtype); + if (MPI_SUCCESS != ierr) { +#ifndef MS_SUA + fprintf(stderr,"%s %d FATAL ERROR: unhandled typesize = %d!!\n", __FILE__,__LINE__,*typesize) ; +#endif + MPI_Abort(MPI_COMM_WORLD,1) ; } } - MPI_Scatterv( inbuf , sendcounts , displace, MPI_CHAR , - outbuf , *noutbuf * *typesize , MPI_CHAR , - root_task , *comm ) ; + MPI_Scatterv( inbuf, sendcounts, displace, dtype, + outbuf, *noutbuf, dtype, + root_task, *comm ) ; free(sendcounts) ; free(displace) ; @@ -241,4 +277,3 @@ rlim_ () } #endif #endif - diff --git a/frame/md_calls.m4 b/frame/md_calls.m4 index 73ce5deef3..69ac289910 100644 --- a/frame/md_calls.m4 +++ b/frame/md_calls.m4 @@ -62,7 +62,7 @@ IF ( Hndl .GT. -1 ) THEN CASE ( IO_NETCDF ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN ifelse($3,real, -`# if ( RWORDSIZE == DWORDSIZE ) +`# ifdef DOUBLE_PRECISION CALL ext_ncd_$1_$2_$6_double$4 ( Hndl, Element, ifelse($6,td,`DateStr,') ifelse($2,var,`Varname,') Data, & ifelse($4,char,,`locCount, ifelse($1,get,`Outcount,')') Status ) # else @@ -87,7 +87,7 @@ ifelse($3,real, #ifdef NETCDFPAR CASE ( IO_NETCDFPAR ) ifelse($3,real, -`# if ( RWORDSIZE == DWORDSIZE ) +`# ifdef DOUBLE_PRECISION CALL ext_ncdpar_$1_$2_$6_double$4 ( Hndl, Element, ifelse($6,td,`DateStr,') ifelse($2,var,`Varname,') Data, & ifelse($4,char,,`locCount, ifelse($1,get,`Outcount,')') Status ) # else @@ -101,7 +101,7 @@ ifelse($3,real, #ifdef PNETCDF CASE ( IO_PNETCDF ) ifelse($3,real, -`# if ( RWORDSIZE == DWORDSIZE ) +`# ifdef DOUBLE_PRECISION CALL ext_pnc_$1_$2_$6_double$4 ( Hndl, Element, ifelse($6,td,`DateStr,') ifelse($2,var,`Varname,') Data, & ifelse($4,char,,`locCount, ifelse($1,get,`Outcount,')') Status ) # else @@ -114,7 +114,7 @@ ifelse($3,real, #ifdef ADIOS2 CASE ( IO_ADIOS2 ) ifelse($3,real, -`# if ( RWORDSIZE == DWORDSIZE ) +`# ifdef DOUBLE_PRECISION CALL ext_adios2_$1_$2_$6_double$4 ( Hndl, Element, ifelse($6,td,`DateStr,') ifelse($2,var,`Varname,') Data, & ifelse($4,char,,`locCount, ifelse($1,get,`Outcount,')') Status ) # else @@ -127,7 +127,7 @@ ifelse($3,real, #ifdef PIO CASE ( IO_PIO ) ifelse($3,real, -`# if ( RWORDSIZE == DWORDSIZE ) +`# ifdef DOUBLE_PRECISION CALL ext_pio_$1_$2_$6_double$4_$5 ( Hndl, Element, ifelse($6,td,`DateStr,') ifelse($2,var,`Varname,') Data, & ifelse($4,char,,`locCount, ifelse($1,get,`Outcount,')') Status ) # else @@ -140,7 +140,7 @@ ifelse($3,real, #ifdef PHDF5 CASE ( IO_PHDF5 ) ifelse($3,real, -`# if ( RWORDSIZE == DWORDSIZE ) +`# ifdef DOUBLE_PRECISION CALL ext_phdf5_$1_$2_$6_double$4 ( Hndl, Element, ifelse($6,td,`DateStr,') ifelse($2,var,`Varname,') Data, & ifelse($4,char,,`locCount, ifelse($1,get,`Outcount,')') Status ) # else @@ -153,7 +153,7 @@ ifelse($3,real, #ifdef ESMFIO CASE ( IO_ESMF ) ifelse($3,real, -`# if ( RWORDSIZE == DWORDSIZE ) +`# ifdef DOUBLE_PRECISION CALL ext_esmf_$1_$2_$6_double$4 ( Hndl, Element, ifelse($6,td,`DateStr,') ifelse($2,var,`Varname,') Data, & ifelse($4,char,,`locCount, ifelse($1,get,`Outcount,')') Status ) # else @@ -166,7 +166,7 @@ ifelse($3,real, #ifdef XXX CASE ( IO_XXX ) ifelse($3,real, -`# if ( RWORDSIZE == DWORDSIZE ) +`# ifdef DOUBLE_PRECISION CALL ext_xxx_$1_$2_$6_double$4 ( Hndl, Element, ifelse($6,td,`DateStr,') ifelse($2,var,`Varname,') Data, & ifelse($4,char,,`locCount, ifelse($1,get,`Outcount,')') Status ) # else @@ -179,7 +179,7 @@ ifelse($3,real, #ifdef YYY CASE ( IO_YYY ) ifelse($3,real, -`# if ( RWORDSIZE == DWORDSIZE ) +`# ifdef DOUBLE_PRECISION CALL ext_yyy_$1_$2_$6_double$4 ( Hndl, Element, ifelse($6,td,`DateStr,') ifelse($2,var,`Varname,') Data, & ifelse($4,char,,`locCount, ifelse($1,get,`Outcount,')') Status ) # else @@ -193,7 +193,7 @@ ifelse($3,real, CASE ( IO_GRIB1 ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN ifelse($3,real, -`# if ( RWORDSIZE == DWORDSIZE ) +`# ifdef DOUBLE_PRECISION CALL ext_gr1_$1_$2_$6_double$4 ( Hndl, Element, ifelse($6,td,`DateStr,') ifelse($2,var,`Varname,') Data, & ifelse($4,char,,`locCount, ifelse($1,get,`Outcount,')') Status ) # else @@ -219,7 +219,7 @@ ifelse($3,real, CASE ( IO_GRIB2 ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN ifelse($3,real, -`# if ( RWORDSIZE == DWORDSIZE ) +`# ifdef DOUBLE_PRECISION CALL ext_gr2_$1_$2_$6_double$4 ( Hndl, Element, ifelse($6,td,`DateStr,') ifelse($2,var,`Varname,') Data, & ifelse($4,char,,`locCount, ifelse($1,get,`Outcount,')') Status ) # else @@ -245,7 +245,7 @@ ifelse($3,real, CASE ( IO_INTIO ) IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN ifelse($3,real, -`# if ( RWORDSIZE == DWORDSIZE ) +`# ifdef DOUBLE_PRECISION CALL ext_int_$1_$2_$6_double$4 ( Hndl, Element, ifelse($6,td,`DateStr,') ifelse($2,var,`Varname,') Data, & ifelse($4,char,,`locCount, ifelse($1,get,`Outcount,')') Status ) # else diff --git a/frame/module_clear_halos.F b/frame/module_clear_halos.F index 88de325ecf..db19e0e5fc 100644 --- a/frame/module_clear_halos.F +++ b/frame/module_clear_halos.F @@ -42,7 +42,7 @@ subroutine clear_ij_halos(grid,how,full_domain) ips, ipe, jps, jpe, kps, kpe logical :: fulldom real :: badR, badR_N,badR_NE,badR_NW,badR_S,badR_SW,badR_SE,badR_E,badR_W -#if (RWORDSIZE==4) +#ifndef DOUBLE_PRECISION double precision :: badD, badD_N,badD_NE,badD_NW,badD_S,badD_SW,badD_SE,badD_E,badD_W #else real :: badD, badD_N,badD_NE,badD_NW,badD_S,badD_SW,badD_SE,badD_E,badD_W diff --git a/frame/module_cpl_oasis3.F b/frame/module_cpl_oasis3.F index f7d96cecad..896de708e1 100644 --- a/frame/module_cpl_oasis3.F +++ b/frame/module_cpl_oasis3.F @@ -22,7 +22,7 @@ MODULE module_cpl_oasis3 TYPE :: FLD_CPL ! Coupling field information CHARACTER(len = 64) :: clname ! Name of the coupling field, jpeighty defined in oasis INTEGER :: nid ! Id of the field -#if ( RWORDSIZE == 8 ) +#ifdef DOUBLE_PRECISION REAL , POINTER, DIMENSION(:,:) :: dbl2d ! 2d array to store received field #else REAL(kind=8), POINTER, DIMENSION(:,:) :: dbl2d ! 2d array to store received field @@ -308,7 +308,7 @@ SUBROUTINE cpl_oasis_snd( kdomwrf, kdomext, kfldid, ksec, pdata ) kdomwrf, kdomext, kfldid, ' ', TRIM(ssnd(kdomwrf,kdomext,kfldid)%clname), ksec CALL wrf_debug(nlevdbg, cltxt) -#if ( RWORDSIZE == 8 ) +#ifdef DOUBLE_PRECISION CALL oasis_put(ssnd(kdomwrf,kdomext,kfldid)%nid, ksec, pdata(:,:) , info) #else CALL oasis_put(ssnd(kdomwrf,kdomext,kfldid)%nid, ksec, DBLE(pdata(:,:)), info) @@ -362,7 +362,7 @@ SUBROUTINE cpl_oasis_rcv( kdomwrf, kdomext, kfldid, ksec, pcplrcv ) CALL wrf_debug(nlevdbg, cltxt) CALL oasis_get( srcv(kdomwrf,kdomext,kfldid)%nid, ksec, srcv(kdomwrf,kdomext,kfldid)%dbl2d, info ) -#if ( RWORDSIZE == 8 ) +#ifdef DOUBLE_PRECISION pcplrcv(:,:) = srcv(kdomwrf,kdomext,kfldid)%dbl2d #else pcplrcv(:,:) = REAL(srcv(kdomwrf,kdomext,kfldid)%dbl2d, kind=4) diff --git a/hydro/CPL/WRF_cpl/CMakeLists.txt b/hydro/CPL/WRF_cpl/CMakeLists.txt index 914191ba5b..c98d242ddc 100644 --- a/hydro/CPL/WRF_cpl/CMakeLists.txt +++ b/hydro/CPL/WRF_cpl/CMakeLists.txt @@ -14,6 +14,8 @@ add_dependencies(hydro_wrf_cpl MPI::MPI_Fortran ) +target_link_libraries( hydro_wrf_cpl PRIVATE hydro_driver ) + target_include_directories(hydro_wrf_cpl PRIVATE $ diff --git a/hydro/CPL/WRF_cpl/module_wrf_HYDRO.F90 b/hydro/CPL/WRF_cpl/module_wrf_HYDRO.F90 index e6882f74eb..8721200ffd 100644 --- a/hydro/CPL/WRF_cpl/module_wrf_HYDRO.F90 +++ b/hydro/CPL/WRF_cpl/module_wrf_HYDRO.F90 @@ -1,23 +1,3 @@ -! Program Name: -! Author(s)/Contact(s): -! Abstract: -! History Log: -! -! -! Usage: -! Parameters: -! Input Files: -! -! Output Files: -! -! -! Condition codes: -! -! If appropriate, descriptive troubleshooting instructions or -! likely causes for failures could be mentioned here with the -! appropriate error code -! -! User controllable options: module module_WRF_HYDRO @@ -106,7 +86,7 @@ subroutine wrf_cpl_HYDRO(HYDRO_dt,grid,its,ite,jts,jte) #ifdef MPP_LAND - call MPI_COMM_DUP(MPI_COMM_WORLD, HYDRO_COMM_WORLD, ierr) + call MPI_Comm_dup(MPI_COMM_WORLD, HYDRO_COMM_WORLD, ierr) call MPP_LAND_INIT(grid%e_we - grid%s_we - 1, grid%e_sn - grid%s_sn - 1) call mpp_land_bcast_int1 (nlst(did)%nsoil) @@ -214,9 +194,9 @@ subroutine wrf_cpl_HYDRO(HYDRO_dt,grid,its,ite,jts,jte) #endif else do k = 1, nlst(did)%nsoil - RT_DOMAIN(did)%STC(:,:,k) = grid%TSLB(its:ite,k,jts:jte) - RT_DOMAIN(did)%smc(:,:,k) = grid%smois(its:ite,k,jts:jte) - RT_DOMAIN(did)%sh2ox(:,:,k) = grid%sh2o(its:ite,k,jts:jte) + RT_DOMAIN(did)%STC(:,:,k) = grid%TSLB(its:ite,k,jts:jte) + RT_DOMAIN(did)%smc(:,:,k) = grid%smois(its:ite,k,jts:jte) + RT_DOMAIN(did)%sh2ox(:,:,k) = grid%sh2o(its:ite,k,jts:jte) end do rt_domain(did)%infxsrt = grid%infxsrt(its:ite,jts:jte) rt_domain(did)%soldrain = grid%soldrain(its:ite,jts:jte) @@ -235,7 +215,7 @@ subroutine wrf_cpl_HYDRO(HYDRO_dt,grid,its,ite,jts,jte) ! update WRF variable after running routing model. grid%sfcheadrt(its:ite,jts:jte) = rt_domain(did)%overland%control%surface_water_head_lsm -! provide groundwater soil flux to WRF for fully coupled simulations (FERSCH 09/2014) +! provide groundwater soil flux to WRF for fully coupled simulations (FERSCH 09/2014) if(nlst(did)%GWBASESWCRT .eq. 3 ) then !Wei Yu: comment the following two lines. Not ready for WRF3.7 release !yw grid%qsgw(its:ite,jts:jte) = gw2d(did)%qsgw @@ -269,7 +249,7 @@ subroutine wrf2lsm (z1,v1,kk1,z,vout,ix,jx,kk,vegtyp) do j = 1, jx do i = 1, ix do k = 1, kk - call interpLayer(Z1,v1(i,1:kk1,j),kk1,Z(k),vout(i,j,k)) + call interpLayer(Z1,v1(i,1:kk1,j),kk1,Z(k),vout(i,j,k)) end do end do end do @@ -291,7 +271,7 @@ subroutine lsm2wrf (z1,v1,kk1,z,vout,ix,jx,kk,vegtyp) do j = 1, jx do i = 1, ix do k = 1, kk - call interpLayer(Z1,v1(i,j,1:kk1),kk1,Z(k),vout(i,k,j)) + call interpLayer(Z1,v1(i,j,1:kk1),kk1,Z(k),vout(i,k,j)) end do end do end do diff --git a/hydro/CPL/WRF_cpl/module_wrf_HYDRO_downscale.F90 b/hydro/CPL/WRF_cpl/module_wrf_HYDRO_downscale.F90 index 4dceba6af5..40ed2ed228 100644 --- a/hydro/CPL/WRF_cpl/module_wrf_HYDRO_downscale.F90 +++ b/hydro/CPL/WRF_cpl/module_wrf_HYDRO_downscale.F90 @@ -1,23 +1,3 @@ -! Program Name: -! Author(s)/Contact(s): -! Abstract: -! History Log: -! -! -! Usage: -! Parameters: -! Input Files: -! -! Output Files: -! -! -! Condition codes: -! -! If appropriate, descriptive troubleshooting instructions or -! likely causes for failures could be mentioned here with the -! appropriate error code -! -! User controllable options: module module_WRF_HYDRO diff --git a/hydro/CPL/WRF_cpl/wrf_drv_HYDRO.F90 b/hydro/CPL/WRF_cpl/wrf_drv_HYDRO.F90 index db86a573e7..1a40920326 100644 --- a/hydro/CPL/WRF_cpl/wrf_drv_HYDRO.F90 +++ b/hydro/CPL/WRF_cpl/wrf_drv_HYDRO.F90 @@ -1,23 +1,3 @@ -! Program Name: -! Author(s)/Contact(s): -! Abstract: -! History Log: -! -! -! Usage: -! Parameters: -! Input Files: -! -! Output Files: -! -! -! Condition codes: -! -! If appropriate, descriptive troubleshooting instructions or -! likely causes for failures could be mentioned here with the -! appropriate error code -! -! User controllable options: !2345678 !ywGW subroutine wrf_drv_HYDRO(HYDRO_dt,grid, config_flags, its,ite,jts,jte) diff --git a/hydro/Data_Rec/CMakeLists.txt b/hydro/Data_Rec/CMakeLists.txt index 7590bd19f2..91cb335b94 100644 --- a/hydro/Data_Rec/CMakeLists.txt +++ b/hydro/Data_Rec/CMakeLists.txt @@ -5,3 +5,4 @@ add_library(hydro_data_rec STATIC module_RT_data.F90 module_namelist.F90 ) +target_link_libraries( hydro_data_rec PRIVATE hydro_mpp ) diff --git a/hydro/Data_Rec/module_RT_data.F90 b/hydro/Data_Rec/module_RT_data.F90 index 01a608d46c..aa2ea32a7c 100644 --- a/hydro/Data_Rec/module_RT_data.F90 +++ b/hydro/Data_Rec/module_RT_data.F90 @@ -1,23 +1,3 @@ -! Program Name: -! Author(s)/Contact(s): -! Abstract: -! History Log: -! -! Usage: -! Parameters: -! Input Files: -! -! Output Files: -! -! -! Condition codes: -! -! If appropriate, descriptive troubleshooting instructions or -! likely causes for failures could be mentioned here with the -! appropriate error code -! -! User controllable options: - Module module_RT_data use module_rt_inc, only: rt_field implicit none diff --git a/hydro/Data_Rec/module_gw_gw2d_data.F90 b/hydro/Data_Rec/module_gw_gw2d_data.F90 index 1784a9950c..6fd2cecb65 100644 --- a/hydro/Data_Rec/module_gw_gw2d_data.F90 +++ b/hydro/Data_Rec/module_gw_gw2d_data.F90 @@ -1,23 +1,3 @@ -! Program Name: -! Author(s)/Contact(s): -! Abstract: -! History Log: -! -! -! Usage: -! Parameters: -! Input Files: -! -! Output Files: -! -! -! Condition codes: -! -! If appropriate, descriptive troubleshooting instructions or -! likely causes for failures could be mentioned here with the -! appropriate error code -! -! User controllable options: module module_gw_gw2d_data implicit none diff --git a/hydro/Data_Rec/module_namelist.F90 b/hydro/Data_Rec/module_namelist.F90 index 51303619c7..c72a4275d3 100644 --- a/hydro/Data_Rec/module_namelist.F90 +++ b/hydro/Data_Rec/module_namelist.F90 @@ -1,23 +1,3 @@ -! Program Name: -! Author(s)/Contact(s): -! Abstract: -! History Log: -! -! Usage: -! Parameters: -! Input Files: -! -! Output Files: -! -! -! Condition codes: -! -! If appropriate, descriptive troubleshooting instructions or -! likely causes for failures could be mentioned here with the -! appropriate error code -! -! User controllable options: - module module_namelist #ifdef MPP_LAND @@ -574,7 +554,6 @@ subroutine read_rt_nlst(nlst) if(channel_option .eq. 4) nlst%rtFlag = 0 ! if(CHANRTSWCRT .eq. 0 .and. SUBRTSWCRT .eq. 0 .and. OVRTSWCRT .eq. 0 .and. GWBASESWCRT .eq. 0) nlst%rtFlag = 0 if(SUBRTSWCRT .eq. 0 .and. OVRTSWCRT .eq. 0 .and. GWBASESWCRT .eq. 0) nlst%rtFlag = 0 - return end subroutine read_rt_nlst subroutine rt_nlst_check(nlst) diff --git a/hydro/Debug_Utilities/CMakeLists.txt b/hydro/Debug_Utilities/CMakeLists.txt index da145d69c1..2f6806af32 100644 --- a/hydro/Debug_Utilities/CMakeLists.txt +++ b/hydro/Debug_Utilities/CMakeLists.txt @@ -2,3 +2,4 @@ add_library(hydro_debug_utils STATIC debug_dump_variable.F90 ) +target_link_libraries( hydro_debug_utils PRIVATE hydro_mpp ) diff --git a/hydro/HYDRO_drv/CMakeLists.txt b/hydro/HYDRO_drv/CMakeLists.txt index e0b1a6f442..fae58f0408 100644 --- a/hydro/HYDRO_drv/CMakeLists.txt +++ b/hydro/HYDRO_drv/CMakeLists.txt @@ -8,8 +8,7 @@ target_link_libraries(hydro_driver PUBLIC hydro_data_rec hydro_routing hydro_debug_utils - PRIVATE - netCDF::netcdff + netCDF::netcdff ) if(WRF_HYDRO_NUDGING STREQUAL "1") diff --git a/hydro/HYDRO_drv/module_HYDRO_drv.F90 b/hydro/HYDRO_drv/module_HYDRO_drv.F90 index 63959f0cd0..a5a6a37df3 100644 --- a/hydro/HYDRO_drv/module_HYDRO_drv.F90 +++ b/hydro/HYDRO_drv/module_HYDRO_drv.F90 @@ -1,148 +1,128 @@ -! Program Name: -! Author(s)/Contact(s): -! Abstract: -! History Log: -! -! Usage: -! Parameters: -! Input Files: -! -! Output Files: -! -! -! Condition codes: -! -! If appropriate, descriptive troubleshooting instructions or -! likely causes for failures could be mentioned here with the -! appropriate error code -! -! User controllable options: - module module_HYDRO_drv #ifdef MPP_LAND - use module_HYDRO_io, only: output_rt, mpp_output_chrt, mpp_output_lakes, mpp_output_chrtgrd, & - restart_out_bi, restart_in_bi, mpp_output_chrt2, mpp_output_lakes2, & - hdtbl_in_nc, hdtbl_out + use module_HYDRO_io, only: output_rt, mpp_output_chrt, mpp_output_lakes, mpp_output_chrtgrd, & + restart_out_bi, restart_in_bi, mpp_output_chrt2, mpp_output_lakes2, & + hdtbl_in_nc, hdtbl_out USE module_mpp_land #else - use module_HYDRO_io, only: output_rt, output_chrt, output_chrt2, output_lakes + use module_HYDRO_io, only: output_rt, output_chrt, output_chrt2, output_lakes #endif - use module_NWM_io, only: output_chrt_NWM, output_rt_NWM, output_lakes_NWM,& - output_chrtout_grd_NWM, output_lsmOut_NWM, & - output_frxstPts, output_chanObs_NWM, output_gw_NWM - use module_HYDRO_io, only: sub_output_gw, restart_out_nc, restart_in_nc, & + use module_NWM_io, only: output_chrt_NWM, output_rt_NWM, output_lakes_NWM,& + output_chrtout_grd_NWM, output_lsmOut_NWM, & + output_frxstPts, output_chanObs_NWM, output_gw_NWM + use module_HYDRO_io, only: sub_output_gw, restart_out_nc, restart_in_nc, & get_file_dimension , get_file_globalatts, get2d_lsm_real, get2d_lsm_vegtyp, get2d_lsm_soltyp, & output_lsm, output_GW_Diag - use module_HYDRO_io, only : output_lakes2 - use module_rt_data, only: rt_domain - use module_GW_baseflow - use module_gw_gw2d - use module_gw_gw2d_data, only: gw2d - use module_channel_routing, only: drive_channel, drive_channel_rsl - use orchestrator_base - use config_base, only: nlst, noah_lsm - use module_routing, only: getChanDim, landrt_ini - use module_HYDRO_utils - use module_lsm_forcing, only: geth_newdate + use module_HYDRO_io, only : output_lakes2 + use module_rt_data, only: rt_domain + use module_GW_baseflow + use module_gw_gw2d + use module_gw_gw2d_data, only: gw2d + use module_channel_routing, only: drive_channel, drive_channel_rsl + use orchestrator_base + use config_base, only: nlst, noah_lsm + use module_routing, only: getChanDim, landrt_ini + use module_HYDRO_utils + use module_lsm_forcing, only: geth_newdate #ifdef WRF_HYDRO_NUDGING - use module_stream_nudging, only: init_stream_nudging + use module_stream_nudging, only: init_stream_nudging #endif - use module_hydro_stop, only: HYDRO_stop - use module_UDMAP, only: get_basn_area_nhd - use netcdf + use module_hydro_stop, only: HYDRO_stop + use module_UDMAP, only: get_basn_area_nhd + use netcdf - implicit none + implicit none #ifdef HYDRO_D - real :: timeOr = 0 - real :: timeSr = 0 - real :: timeCr = 0 - real :: timeGW = 0 - integer :: clock_count_1 = 0 - integer :: clock_count_2 = 0 - integer :: clock_rate = 0 -#endif - integer :: rtout_factor = 0 - - integer, parameter :: r4 = selected_real_kind(4) - real, parameter :: zeroFlt=0.0000000000000000000_r4 - integer, parameter :: r8 = selected_real_kind(8) - real*8, parameter :: zeroDbl=0.0000000000000000000_r8 - - contains - subroutine HYDRO_rst_out(did) + real :: timeOr = 0 + real :: timeSr = 0 + real :: timeCr = 0 + real :: timeGW = 0 + integer :: clock_count_1 = 0 + integer :: clock_count_2 = 0 + integer :: clock_rate = 0 +#endif + integer :: rtout_factor = 0 + + integer, parameter :: r4 = selected_real_kind(4) + real, parameter :: zeroFlt=0.0000000000000000000_r4 + integer, parameter :: r8 = selected_real_kind(8) + real*8, parameter :: zeroDbl=0.0000000000000000000_r8 + +contains + subroutine HYDRO_rst_out(did) #ifdef WRF_HYDRO_NUDGING - use module_stream_nudging, only: output_nudging_last_obs + use module_stream_nudging, only: output_nudging_last_obs #endif - implicit none - integer:: rst_out - integer did, outflag - character(len=19) out_date + implicit none + integer:: rst_out + integer did, outflag + character(len=19) out_date #ifdef MPP_LAND - character(len=19) str_tmp + character(len=19) str_tmp #endif - rst_out = -99 + rst_out = -99 #ifdef MPP_LAND - if(IO_id .eq. my_id) then -#endif - if(nlst(did)%dt .gt. nlst(did)%rst_dt*60) then - call geth_newdate(out_date, nlst(did)%startdate, nint(nlst(did)%dt*rt_domain(did)%rst_counts)) - else - call geth_newdate(out_date, nlst(did)%startdate, nint(nlst(did)%rst_dt*60*rt_domain(did)%rst_counts)) - endif - if ( (nlst(did)%rst_dt .gt. 0) .and. (out_date(1:19) == nlst(did)%olddate(1:19)) ) then - rst_out = 99 - rt_domain(did)%rst_counts = rt_domain(did)%rst_counts + 1 - endif + if(IO_id .eq. my_id) then +#endif + if(nlst(did)%dt .gt. nlst(did)%rst_dt*60) then + call geth_newdate(out_date, nlst(did)%startdate, nint(nlst(did)%dt*rt_domain(did)%rst_counts)) + else + call geth_newdate(out_date, nlst(did)%startdate, nint(nlst(did)%rst_dt*60*rt_domain(did)%rst_counts)) + endif + if ( (nlst(did)%rst_dt .gt. 0) .and. (out_date(1:19) == nlst(did)%olddate(1:19)) ) then + rst_out = 99 + rt_domain(did)%rst_counts = rt_domain(did)%rst_counts + 1 + endif ! restart every month automatically. - if ( (nlst(did)%olddate(9:10) == "01") .and. (nlst(did)%olddate(12:13) == "00") .and. & - (nlst(did)%olddate(15:16) == "00").and. (nlst(did)%olddate(18:19) == "00") .and. & - (nlst(did)%rst_dt .le. 0) ) then - if(nlst(did)%startdate(1:16) .ne. nlst(did)%olddate(1:16) ) then - rst_out = 99 - endif - endif + if ( (nlst(did)%olddate(9:10) == "01") .and. (nlst(did)%olddate(12:13) == "00") .and. & + (nlst(did)%olddate(15:16) == "00").and. (nlst(did)%olddate(18:19) == "00") .and. & + (nlst(did)%rst_dt .le. 0) ) then + if(nlst(did)%startdate(1:16) .ne. nlst(did)%olddate(1:16) ) then + rst_out = 99 + endif + endif #ifdef MPP_LAND - endif - call mpp_land_bcast_int1(rst_out) + endif + call mpp_land_bcast_int1(rst_out) #endif - if(rst_out .gt. 0) then - write(6,*) "yw check output restart at ",nlst(did)%olddate(1:16) + if(rst_out .gt. 0) then + write(6,*) "yw check output restart at ",nlst(did)%olddate(1:16) #ifdef MPP_LAND - if(nlst(did)%rst_bi_out .eq. 1) then - if(my_id .lt. 10) then - write(str_tmp,'(I1)') my_id - else if(my_id .lt. 100) then - write(str_tmp,'(I2)') my_id - else if(my_id .lt. 1000) then - write(str_tmp,'(I3)') my_id - else if(my_id .lt. 10000) then - write(str_tmp,'(I4)') my_id - else if(my_id .lt. 100000) then - write(str_tmp,'(I5)') my_id - else - continue - endif - call mpp_land_bcast_char(16,nlst(did)%olddate(1:16)) - call RESTART_OUT_bi(trim("HYDRO_RST."//nlst(did)%olddate(1:16) & - //"_DOMAIN"//trim(nlst(did)%hgrid)//"."//trim(str_tmp)), did) - else -#endif - call RESTART_OUT_nc(trim("HYDRO_RST."//nlst(did)%olddate(1:16) & - //"_DOMAIN"//trim(nlst(did)%hgrid)), did) + if(nlst(did)%rst_bi_out .eq. 1) then + if(my_id .lt. 10) then + write(str_tmp,'(I1)') my_id + else if(my_id .lt. 100) then + write(str_tmp,'(I2)') my_id + else if(my_id .lt. 1000) then + write(str_tmp,'(I3)') my_id + else if(my_id .lt. 10000) then + write(str_tmp,'(I4)') my_id + else if(my_id .lt. 100000) then + write(str_tmp,'(I5)') my_id + else + continue + endif + call mpp_land_bcast_char(16,nlst(did)%olddate(1:16)) + call RESTART_OUT_bi(trim("HYDRO_RST."//nlst(did)%olddate(1:16) & + //"_DOMAIN"//trim(nlst(did)%hgrid)//"."//trim(str_tmp)), did) + else +#endif + call RESTART_OUT_nc(trim("HYDRO_RST."//nlst(did)%olddate(1:16) & + //"_DOMAIN"//trim(nlst(did)%hgrid)), did) #ifdef MPP_LAND - endif + endif #endif #ifdef WRF_HYDRO_NUDGING - call output_nudging_last_obs + call output_nudging_last_obs #endif - endif + endif - end subroutine HYDRO_rst_out + end subroutine HYDRO_rst_out subroutine HYDRO_out(did, rstflag) @@ -154,11 +134,11 @@ subroutine HYDRO_out(did, rstflag) real, dimension(RT_DOMAIN(did)%NLINKS,2) :: str_out real, dimension(RT_DOMAIN(did)%NLINKS) :: vel_out - ! real, dimension(RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx):: soilmx_tmp, & - ! runoff1x_tmp, runoff2x_tmp, runoff3x_tmp,etax_tmp, & - ! EDIRX_tmp,ECX_tmp,ETTX_tmp,RCX_tmp,HX_tmp,acrain_tmp, & - ! ACSNOM_tmp, esnow2d_tmp, drip2d_tmp,dewfall_tmp, fpar_tmp, & - ! qfx_tmp, prcp_out_tmp, etpndx_tmp +! real, dimension(RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx):: soilmx_tmp, & +! runoff1x_tmp, runoff2x_tmp, runoff3x_tmp,etax_tmp, & +! EDIRX_tmp,ECX_tmp,ETTX_tmp,RCX_tmp,HX_tmp,acrain_tmp, & +! ACSNOM_tmp, esnow2d_tmp, drip2d_tmp,dewfall_tmp, fpar_tmp, & +! qfx_tmp, prcp_out_tmp, etpndx_tmp outflag = -99 @@ -209,13 +189,13 @@ subroutine HYDRO_out(did, rstflag) kt = rt_domain(did)%his_out_counts endif - ! jump the ouput for the initial time when it has restart file from routing. +! jump the ouput for the initial time when it has restart file from routing. rtflag = -99 iniflag = -99 #ifdef MPP_LAND if(IO_id .eq. my_id) then #endif - ! if ( (trim(nlst_rt(did)%restart_file) /= "") .and. ( nlst_rt(did)%startdate(1:19) == nlst_rt(did)%olddate(1:19) ) ) then +! if ( (trim(nlst_rt(did)%restart_file) /= "") .and. ( nlst_rt(did)%startdate(1:19) == nlst_rt(did)%olddate(1:19) ) ) then !#ifndef NCEP_WCOSS ! print*, "yyyywww restart_file = ", trim(nlst_rt(did)%restart_file) !#else @@ -223,7 +203,7 @@ subroutine HYDRO_out(did, rstflag) !#endif if ( nlst(did)%startdate(1:19) == nlst(did)%olddate(1:19) ) iniflag = 1 if ( (trim(nlst(did)%restart_file) /= "") .and. ( nlst(did)%startdate(1:19) == nlst(did)%olddate(1:19) ) ) rtflag = 1 - ! endif +! endif #ifdef MPP_LAND endif call mpp_land_bcast_int1(rtflag) @@ -231,7 +211,7 @@ subroutine HYDRO_out(did, rstflag) #endif - !yw keep the initial time otuput for debug +!yw keep the initial time otuput for debug if(rtflag == 1) then rt_domain(did)%restQSTRM = .false. !!! do not reset QSTRM.. at initial time. if(nlst(did)%t0OutputFlag .eq. 0) return @@ -241,35 +221,35 @@ subroutine HYDRO_out(did, rstflag) if(nlst(did)%t0OutputFlag .eq. 0) return endif - if(nlst(did)%channel_only .eq. 0 .and. nlst(did)%channelBucket_only .eq. 0) then - if(nlst(did)%LSMOUT_DOMAIN .eq. 1) then - if(nlst(did)%io_form_outputs .eq. 0) then - call output_lsm(trim(nlst(did)%olddate(1:4)//nlst(did)%olddate(6:7)//nlst(did)%olddate(9:10) & - //nlst(did)%olddate(12:13)//nlst(did)%olddate(15:16)// & - ".LSMOUT_DOMAIN"//trim(nlst(did)%hgrid)), & - did) - else - call output_lsmOut_NWM(did) + if(nlst(did)%channel_only .eq. 0 .and. nlst(did)%channelBucket_only .eq. 0) then + if(nlst(did)%LSMOUT_DOMAIN .eq. 1) then + if(nlst(did)%io_form_outputs .eq. 0) then + call output_lsm(trim(nlst(did)%olddate(1:4)//nlst(did)%olddate(6:7)//nlst(did)%olddate(9:10) & + //nlst(did)%olddate(12:13)//nlst(did)%olddate(15:16)// & + ".LSMOUT_DOMAIN"//trim(nlst(did)%hgrid)), & + did) + else + call output_lsmOut_NWM(did) + endif endif - endif - end if + end if if(nlst(did)%SUBRTSWCRT .gt. 0 .or. & - nlst(did)%OVRTSWCRT .gt. 0 .or. & - nlst(did)%GWBASESWCRT .gt. 0 .or. & - nlst(did)%CHANRTSWCRT .gt. 0 .or. & - nlst(did)%channel_only .gt. 0 .or. & - nlst(did)%channelBucket_only .gt. 0 ) then + nlst(did)%OVRTSWCRT .gt. 0 .or. & + nlst(did)%GWBASESWCRT .gt. 0 .or. & + nlst(did)%CHANRTSWCRT .gt. 0 .or. & + nlst(did)%channel_only .gt. 0 .or. & + nlst(did)%channelBucket_only .gt. 0 ) then if(nlst(did)%RTOUT_DOMAIN .eq. 1 .and. & - nlst(did)%channel_only .eq. 0 .and. & - nlst(did)%channelBucket_only .eq. 0 ) then + nlst(did)%channel_only .eq. 0 .and. & + nlst(did)%channelBucket_only .eq. 0 ) then if(mod(rtout_factor,3) .eq. 2 .or. & - nlst(did)%io_config_outputs .ne. 5 .and. & - nlst(did)%io_config_outputs .ne. 3) then - ! Output gridded routing variables on National Water Model - ! high-res routing grid + nlst(did)%io_config_outputs .ne. 5 .and. & + nlst(did)%io_config_outputs .ne. 3) then +! Output gridded routing variables on National Water Model +! high-res routing grid if(nlst(did)%io_form_outputs .ne. 0) then call output_rt_NWM(did,nlst(did)%igrid) else @@ -277,8 +257,8 @@ subroutine HYDRO_out(did, rstflag) nlst(did)%igrid, nlst(did)%split_output_count, & RT_DOMAIN(did)%ixrt, RT_DOMAIN(did)%jxrt, & nlst(did)%nsoil, & - ! nlst_rt(did)%startdate, nlst_rt(did)%olddate, - ! rt_domain(did)%subsurface%state%qsubrt,& +! nlst_rt(did)%startdate, nlst_rt(did)%olddate, +! rt_domain(did)%subsurface%state%qsubrt,& nlst(did)%sincedate, nlst(did)%olddate, rt_domain(did)%subsurface%state%qsubrt,& rt_domain(did)%subsurface%properties%zwattablrt,RT_DOMAIN(did)%subsurface%grid_transform%smcrt,& RT_DOMAIN(did)%SUB_RESID, & @@ -295,8 +275,8 @@ subroutine HYDRO_out(did, rstflag) endif ! End check for rtout_factor rtout_factor = rtout_factor + 1 endif - !! JLM disable GW output for NWM. Bring this line back when runtime output options avail. - !! JLM This seems like a more logical place? +!! JLM disable GW output for NWM. Bring this line back when runtime output options avail. +!! JLM This seems like a more logical place? if(nlst(did)%io_form_outputs .ne. 0) then if(nlst(did)%GWBASESWCRT .ne. 0) then if(nlst(did)%channel_only .eq. 0) then @@ -321,7 +301,7 @@ subroutine HYDRO_out(did, rstflag) nlst(did)%igrid, nlst(did)%split_output_count, & RT_DOMAIN(did)%ixrt, RT_DOMAIN(did)%jxrt, & nlst(did)%nsoil, & - ! nlst(did)%startdate, nlst(did)%olddate, & +! nlst(did)%startdate, nlst(did)%olddate, & nlst(did)%sincedate, nlst(did)%olddate, & gw2d(did)%h, rt_domain(did)%subsurface%grid_transform%smcrt, & gw2d(did)%convgw, gw2d(did)%excess, & @@ -332,7 +312,7 @@ subroutine HYDRO_out(did, rstflag) nlst(did)%output_gw) endif - ! BF end gw2d output section +! BF end gw2d output section #ifdef HYDRO_D #ifndef NCEP_WCOSS @@ -345,7 +325,7 @@ subroutine HYDRO_out(did, rstflag) if (nlst(did)%CHANRTSWCRT.eq.1.or.nlst(did)%CHANRTSWCRT.eq.2) then - !ADCHANGE: Change values for within lake reaches to NA +!ADCHANGE: Change values for within lake reaches to NA str_out = RT_DOMAIN(did)%QLINK vel_out = RT_DOMAIN(did)%velocity @@ -357,51 +337,51 @@ subroutine HYDRO_out(did, rstflag) endif end do endif - !ADCHANGE: End +!ADCHANGE: End if(nlst(did)%io_form_outputs .ne. 0) then - ! Call National Water Model output routine for output on NHD forecast points. +! Call National Water Model output routine for output on NHD forecast points. if(nlst(did)%CHRTOUT_DOMAIN .ne. 0) then call output_chrt_NWM(did) endif - ! Call the subroutine to output frxstPts. +! Call the subroutine to output frxstPts. if(nlst(did)%frxst_pts_out .ne. 0) then call output_frxstPts(did) endif - ! Call the subroutine to output CHANOBS +! Call the subroutine to output CHANOBS if(nlst(did)%CHANOBS_DOMAIN .ne. 0) then call output_chanObs_NWM(did) endif else - ! Call traditional output routines - !ADCHANGE: We suspect this routine is broken so default is now output_chrtout2 - ! if(nlst_rt(did)%CHRTOUT_DOMAIN .eq. 1) then - !#ifdef MPP_LAND - ! call mpp_output_chrt( & - ! rt_domain(did)%gnlinks,rt_domain(did)%gnlinksl,rt_domain(did)%map_l2g, & - !#else - ! call output_chrt( & - !#endif - ! nlst_rt(did)%igrid, nlst_rt(did)%split_output_count, & - ! RT_DOMAIN(did)%NLINKS,RT_DOMAIN(did)%ORDER, & - ! nlst_rt(did)%sincedate,nlst_rt(did)%olddate,RT_DOMAIN(did)%CHLON,& - ! RT_DOMAIN(did)%CHLAT, & - ! RT_DOMAIN(did)%HLINK, RT_DOMAIN(did)%ZELEV, & - ! !RT_DOMAIN(did)%QLINK,nlst_rt(did)%DT,Kt, & - ! str_out, nlst_rt(did)%DT,Kt, & - ! RT_DOMAIN(did)%STRMFRXSTPTS,nlst_rt(did)%order_to_write, & - ! RT_DOMAIN(did)%NLINKSL,nlst_rt(did)%channel_option, & - ! rt_domain(did)%gages, rt_domain(did)%gageMiss, & - ! nlst_rt(did)%dt & - !#ifdef WRF_HYDRO_NUDGING - ! , RT_DOMAIN(did)%nudge & - !#endif - ! , RT_DOMAIN(did)%accSfcLatRunoff, RT_DOMAIN(did)%accBucket & - ! , RT_DOMAIN(did)%qSfcLatRunoff, RT_DOMAIN(did)%qBucket & - ! , RT_DOMAIN(did)%qin_gwsubbas & - ! , nlst_rt(did)%UDMP_OPT & - ! ) - ! else +! Call traditional output routines +!ADCHANGE: We suspect this routine is broken so default is now output_chrtout2 +! if(nlst_rt(did)%CHRTOUT_DOMAIN .eq. 1) then +!#ifdef MPP_LAND +! call mpp_output_chrt( & +! rt_domain(did)%gnlinks,rt_domain(did)%gnlinksl,rt_domain(did)%map_l2g, & +!#else +! call output_chrt( & +!#endif +! nlst_rt(did)%igrid, nlst_rt(did)%split_output_count, & +! RT_DOMAIN(did)%NLINKS,RT_DOMAIN(did)%ORDER, & +! nlst_rt(did)%sincedate,nlst_rt(did)%olddate,RT_DOMAIN(did)%CHLON,& +! RT_DOMAIN(did)%CHLAT, & +! RT_DOMAIN(did)%HLINK, RT_DOMAIN(did)%ZELEV, & +! !RT_DOMAIN(did)%QLINK,nlst_rt(did)%DT,Kt, & +! str_out, nlst_rt(did)%DT,Kt, & +! RT_DOMAIN(did)%STRMFRXSTPTS,nlst_rt(did)%order_to_write, & +! RT_DOMAIN(did)%NLINKSL,nlst_rt(did)%channel_option, & +! rt_domain(did)%gages, rt_domain(did)%gageMiss, & +! nlst_rt(did)%dt & +!#ifdef WRF_HYDRO_NUDGING +! , RT_DOMAIN(did)%nudge & +!#endif +! , RT_DOMAIN(did)%accSfcLatRunoff, RT_DOMAIN(did)%accBucket & +! , RT_DOMAIN(did)%qSfcLatRunoff, RT_DOMAIN(did)%qBucket & +! , RT_DOMAIN(did)%qin_gwsubbas & +! , nlst_rt(did)%UDMP_OPT & +! ) +! else if(nlst(did)%CHRTOUT_DOMAIN .gt. 0) then #ifdef MPP_LAND call mpp_output_chrt2(& @@ -414,15 +394,15 @@ subroutine HYDRO_out(did, rstflag) nlst(did)%sincedate,nlst(did)%olddate, & RT_DOMAIN(did)%CHLON, RT_DOMAIN(did)%CHLAT, & RT_DOMAIN(did)%HLINK, RT_DOMAIN(did)%ZELEV, & - !RT_DOMAIN(did)%QLINK,nlst_rt(did)%DT,Kt, & +!RT_DOMAIN(did)%QLINK,nlst_rt(did)%DT,Kt, & str_out, nlst(did)%DT,Kt, & RT_DOMAIN(did)%NLINKSL,nlst(did)%channel_option, & rt_domain(did)%linkid & #ifdef WRF_HYDRO_NUDGING , RT_DOMAIN(did)%nudge & #endif - !, RT_DOMAIN(did)%QLateral, nlst_rt(did)%io_config_outputs, - !RT_DOMAIN(did)%velocity & +!, RT_DOMAIN(did)%QLateral, nlst_rt(did)%io_config_outputs, +!RT_DOMAIN(did)%velocity & , RT_DOMAIN(did)%QLateral, nlst(did)%io_config_outputs, vel_out & , RT_DOMAIN(did)%accSfcLatRunoff, RT_DOMAIN(did)%accBucket & , RT_DOMAIN(did)%qSfcLatRunoff, RT_DOMAIN(did)%qBucket & @@ -440,7 +420,7 @@ subroutine HYDRO_out(did, rstflag) RT_DOMAIN(did)%ixrt,RT_DOMAIN(did)%jxrt, RT_DOMAIN(did)%NLINKS, & RT_DOMAIN(did)%GCH_NETLNK, & nlst(did)%startdate, nlst(did)%olddate, & - !RT_DOMAIN(did)%qlink, nlst_rt(did)%dt, nlst_rt(did)%geo_finegrid_flnm, & +!RT_DOMAIN(did)%qlink, nlst_rt(did)%dt, nlst_rt(did)%geo_finegrid_flnm, & str_out, nlst(did)%dt, nlst(did)%geo_finegrid_flnm, & RT_DOMAIN(did)%gnlinks,RT_DOMAIN(did)%map_l2g, & RT_DOMAIN(did)%g_ixrt,RT_DOMAIN(did)%g_jxrt ) @@ -451,7 +431,7 @@ subroutine HYDRO_out(did, rstflag) endif if (RT_DOMAIN(did)%NLAKES.gt.0) then if(nlst(did)%io_form_outputs .ne. 0) then - ! Output lakes in NWM format +! Output lakes in NWM format if(nlst(did)%outlake .ne. 0) then call output_lakes_NWM(did,nlst(did)%igrid) endif @@ -501,83 +481,83 @@ subroutine HYDRO_out(did, rstflag) end subroutine HYDRO_out - subroutine HYDRO_rst_in(did) + subroutine HYDRO_rst_in(did) integer :: did integer:: flag - flag = -1 + flag = -1 #ifdef MPP_LAND - if(my_id.eq.IO_id) then + if(my_id.eq.IO_id) then #endif - if (trim(nlst(did)%restart_file) /= "") then - flag = 99 - rt_domain(did)%timestep_flag = 99 ! continue run - endif + if (trim(nlst(did)%restart_file) /= "") then + flag = 99 + rt_domain(did)%timestep_flag = 99 ! continue run + endif #ifdef MPP_LAND - endif - call mpp_land_bcast_int1(flag) + endif + call mpp_land_bcast_int1(flag) #endif - nlst(did)%sincedate = nlst(did)%startdate + nlst(did)%sincedate = nlst(did)%startdate - if (flag.eq.99) then + if (flag.eq.99) then #ifdef MPP_LAND - if(my_id.eq.IO_id) then + if(my_id.eq.IO_id) then #endif #ifdef HYDRO_D #ifndef NCEP_WCOSS - write(6,*) "*** read restart data: ",trim(nlst(did)%restart_file) + write(6,*) "*** read restart data: ",trim(nlst(did)%restart_file) #else - write(78,*) "*** read restart data: ",trim(nlst(did)%restart_file) + write(78,*) "*** read restart data: ",trim(nlst(did)%restart_file) #endif #endif #ifdef MPP_LAND - endif + endif #endif #ifdef MPP_LAND - if(nlst(did)%rst_bi_in .eq. 1) then - call RESTART_IN_bi(trim(nlst(did)%restart_file), did) - else + if(nlst(did)%rst_bi_in .eq. 1) then + call RESTART_IN_bi(trim(nlst(did)%restart_file), did) + else #endif - call RESTART_IN_nc(trim(nlst(did)%restart_file), did) + call RESTART_IN_nc(trim(nlst(did)%restart_file), did) #ifdef MPP_LAND - endif + endif #endif !yw if (trim(nlst_rt(did)%restart_file) /= "") then !yw nlst_rt(did)%restart_file = "" !yw endif - endif - end subroutine HYDRO_rst_in + endif + end subroutine HYDRO_rst_in - subroutine HYDRO_time_adv(did) + subroutine HYDRO_time_adv(did) implicit none character(len = 19) :: newdate integer did #ifdef MPP_LAND - if(IO_id.eq.my_id) then + if(IO_id.eq.my_id) then #endif - call geth_newdate(newdate, nlst(did)%olddate, nint( nlst(did)%dt)) - nlst(did)%olddate = newdate + call geth_newdate(newdate, nlst(did)%olddate, nint( nlst(did)%dt)) + nlst(did)%olddate = newdate #ifdef HYDRO_D #ifndef NCEP_WCOSS - write(6,*) "current time is ",newdate + write(6,*) "current time is ",newdate #else - write(78,*) "current time is ",newdate + write(78,*) "current time is ",newdate #endif #endif #ifdef MPP_LAND - endif + endif #endif - end subroutine HYDRO_time_adv + end subroutine HYDRO_time_adv - subroutine HYDRO_exe(did) + subroutine HYDRO_exe(did) implicit none @@ -601,159 +581,159 @@ subroutine HYDRO_exe(did) ! endif -if (nlst(did)%GWBASESWCRT .ne. 0 .or. & - nlst(did)%SUBRTSWCRT .ne. 0 .or. & - nlst(did)%OVRTSWCRT .ne. 0 .or. & - nlst(did)%channel_only .ne. 0 .or. & - nlst(did)%channelBucket_only .ne. 0 ) then + if (nlst(did)%GWBASESWCRT .ne. 0 .or. & + nlst(did)%SUBRTSWCRT .ne. 0 .or. & + nlst(did)%OVRTSWCRT .ne. 0 .or. & + nlst(did)%channel_only .ne. 0 .or. & + nlst(did)%channelBucket_only .ne. 0 ) then - ! step 1) disaggregate specific fields from LSM to Hydro grid - if(nlst(did)%channel_only .eq. 0 .and. nlst(did)%channelBucket_only .eq. 0) then +! step 1) disaggregate specific fields from LSM to Hydro grid + if(nlst(did)%channel_only .eq. 0 .and. nlst(did)%channelBucket_only .eq. 0) then - RT_DOMAIN(did)%overland%streams_and_lakes%surface_water_to_channel = zeroFlt - RT_DOMAIN(did)%LAKE_INFLORT_DUM = rt_domain(did)%overland%streams_and_lakes%surface_water_to_lake + RT_DOMAIN(did)%overland%streams_and_lakes%surface_water_to_channel = zeroFlt + RT_DOMAIN(did)%LAKE_INFLORT_DUM = rt_domain(did)%overland%streams_and_lakes%surface_water_to_lake - if(nlst(did)%SUBRTSWCRT .ne. 0 .or. nlst(did)%OVRTSWCRT .ne. 0) then - call disaggregateDomain_drv(did) - endif - if(nlst(did)%OVRTSWCRT .eq. 0) then - if(nlst(did)%UDMP_OPT .eq. 1) then - call RunOffDisag(RT_DOMAIN(did)%INFXSRT, RT_DOMAIN(did)%landRunOff, & - rt_domain(did)%dist_lsm(:,:,9),rt_domain(did)%overland%properties%distance_to_neighbor(:,:,9), & - RT_DOMAIN(did)%INFXSWGT, nlst(did)%AGGFACTRT, RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx) - endif - endif + if(nlst(did)%SUBRTSWCRT .ne. 0 .or. nlst(did)%OVRTSWCRT .ne. 0) then + call disaggregateDomain_drv(did) + endif + if(nlst(did)%OVRTSWCRT .eq. 0) then + if(nlst(did)%UDMP_OPT .eq. 1) then + call RunOffDisag(RT_DOMAIN(did)%INFXSRT, RT_DOMAIN(did)%landRunOff, & + rt_domain(did)%dist_lsm(:,:,9),rt_domain(did)%overland%properties%distance_to_neighbor(:,:,9), & + RT_DOMAIN(did)%INFXSWGT, nlst(did)%AGGFACTRT, RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx) + endif + endif #ifdef HYDRO_D - call system_clock(count=clock_count_1, count_rate=clock_rate) + call system_clock(count=clock_count_1, count_rate=clock_rate) #endif - endif !! channel_only & channelBucket_only == 0 + endif !! channel_only & channelBucket_only == 0 - ! step 2) - if(nlst(did)%channel_only .eq. 0 .and. nlst(did)%channelBucket_only .eq. 0) then - if(nlst(did)%SUBRTSWCRT .ne.0) then - call SubsurfaceRouting_drv(did) - endif +! step 2) + if(nlst(did)%channel_only .eq. 0 .and. nlst(did)%channelBucket_only .eq. 0) then + if(nlst(did)%SUBRTSWCRT .ne.0) then + call SubsurfaceRouting_drv(did) + endif #ifdef HYDRO_D - call system_clock(count=clock_count_2, count_rate=clock_rate) - timeSr = timeSr + float(clock_count_2-clock_count_1)/float(clock_rate) + call system_clock(count=clock_count_2, count_rate=clock_rate) + timeSr = timeSr + float(clock_count_2-clock_count_1)/float(clock_rate) #ifndef NCEP_WCOSS - write(6,*) "Timing: Subsurface Routing accumulated time--", timeSr + write(6,*) "Timing: Subsurface Routing accumulated time--", timeSr #else - write(78,*) "Timing: Subsurface Routing accumulated time--", timeSr + write(78,*) "Timing: Subsurface Routing accumulated time--", timeSr #endif #endif - end if !! channel_only & channelBucket_only == 0 + end if !! channel_only & channelBucket_only == 0 - ! step 3) todo split - if(nlst(did)%channel_only .eq. 0 .and. nlst(did)%channelBucket_only .eq. 0) then +! step 3) todo split + if(nlst(did)%channel_only .eq. 0 .and. nlst(did)%channelBucket_only .eq. 0) then #ifdef HYDRO_D - call system_clock(count=clock_count_1, count_rate=clock_rate) -#endif - if(nlst(did)%OVRTSWCRT .ne. 0) then - call OverlandRouting_drv(did) - else - !ADCHANGE: Updating landRunoff instead of surface_water_head_routing. This now allows - ! landRunoff to include both infxsrt from the LSM and exfiltration (if subsfc - ! is active) and prevents surface_water_head_routing from inadvertently being - ! passed back to the LSM. - if (nlst(did)%UDMP_OPT .eq. 1) then - ! If subsurface is on, we update landRunOff to include the updated term w/ exfiltration. - ! If subsurface is off, landRunOff does not change from original value so we leave as-is. - if (nlst(did)%SUBRTSWCRT .ne. 0) then - rt_domain(did)%landRunOff = rt_domain(did)%overland%control%infiltration_excess - endif - else - ! If overland is off and subsurface is on, we need to update INFXSRT (LSM grid) - ! since that is what gets fed through the buckets into the channels. So we aggregate - ! the high-res infiltration_excess back to coarse grid. - if (nlst(did)%SUBRTSWCRT .ne. 0) then - call RunoffAggregate(rt_domain(did)%overland%control%infiltration_excess, & - rt_domain(did)%INFXSRT, nlst(did)%AGGFACTRT, & - rt_domain(did)%ix, rt_domain(did)%jx) - endif - endif - ! In either case, if overland is off we need to zero-out surface_water_head since this - ! water is being scraped into channel and should NOT be passed back to the LSM. - rt_domain(did)%overland%control%infiltration_excess = 0. - rt_domain(did)%overland%control%surface_water_head_routing = 0. - endif + call system_clock(count=clock_count_1, count_rate=clock_rate) +#endif + if(nlst(did)%OVRTSWCRT .ne. 0) then + call OverlandRouting_drv(did) + else +!ADCHANGE: Updating landRunoff instead of surface_water_head_routing. This now allows +! landRunoff to include both infxsrt from the LSM and exfiltration (if subsfc +! is active) and prevents surface_water_head_routing from inadvertently being +! passed back to the LSM. + if (nlst(did)%UDMP_OPT .eq. 1) then +! If subsurface is on, we update landRunOff to include the updated term w/ exfiltration. +! If subsurface is off, landRunOff does not change from original value so we leave as-is. + if (nlst(did)%SUBRTSWCRT .ne. 0) then + rt_domain(did)%landRunOff = rt_domain(did)%overland%control%infiltration_excess + endif + else +! If overland is off and subsurface is on, we need to update INFXSRT (LSM grid) +! since that is what gets fed through the buckets into the channels. So we aggregate +! the high-res infiltration_excess back to coarse grid. + if (nlst(did)%SUBRTSWCRT .ne. 0) then + call RunoffAggregate(rt_domain(did)%overland%control%infiltration_excess, & + rt_domain(did)%INFXSRT, nlst(did)%AGGFACTRT, & + rt_domain(did)%ix, rt_domain(did)%jx) + endif + endif +! In either case, if overland is off we need to zero-out surface_water_head since this +! water is being scraped into channel and should NOT be passed back to the LSM. + rt_domain(did)%overland%control%infiltration_excess = 0. + rt_domain(did)%overland%control%surface_water_head_routing = 0. + endif #ifdef HYDRO_D - call system_clock(count=clock_count_2, count_rate=clock_rate) - timeOr = timeOr + float(clock_count_2-clock_count_1)/float(clock_rate) + call system_clock(count=clock_count_2, count_rate=clock_rate) + timeOr = timeOr + float(clock_count_2-clock_count_1)/float(clock_rate) #ifndef NCEP_WCOSS - write(6,*) "Timing: Overland Routing accumulated time--", timeOr + write(6,*) "Timing: Overland Routing accumulated time--", timeOr #else - write(78,*) "Timing: Overland Routing accumulated time--", timeOr + write(78,*) "Timing: Overland Routing accumulated time--", timeOr #endif #endif - RT_DOMAIN(did)%QSTRMVOLRT_TS = rt_domain(did)%overland%streams_and_lakes%surface_water_to_channel - RT_DOMAIN(did)%QSTRMVOLRT_ACC = RT_DOMAIN(did)%QSTRMVOLRT_ACC + RT_DOMAIN(did)%QSTRMVOLRT_TS + RT_DOMAIN(did)%QSTRMVOLRT_TS = rt_domain(did)%overland%streams_and_lakes%surface_water_to_channel + RT_DOMAIN(did)%QSTRMVOLRT_ACC = RT_DOMAIN(did)%QSTRMVOLRT_ACC + RT_DOMAIN(did)%QSTRMVOLRT_TS - RT_DOMAIN(did)%LAKE_INFLORT_TS = rt_domain(did)%overland%streams_and_lakes%surface_water_to_lake-RT_DOMAIN(did)%LAKE_INFLORT_DUM + RT_DOMAIN(did)%LAKE_INFLORT_TS = rt_domain(did)%overland%streams_and_lakes%surface_water_to_lake-RT_DOMAIN(did)%LAKE_INFLORT_DUM #ifdef HYDRO_D - call system_clock(count=clock_count_1, count_rate=clock_rate) + call system_clock(count=clock_count_1, count_rate=clock_rate) #endif - end if !! channel_only & channelBucket_only == 0 + end if !! channel_only & channelBucket_only == 0 - ! step 4) baseflow or groundwater physics - !! channelBucket_only can be anything: the only time you dont run this is if channel_only=1 - if(nlst(did)%channel_only .eq. 0) then - if (nlst(did)%GWBASESWCRT .gt. 0) then - call driveGwBaseflow(did) - endif +! step 4) baseflow or groundwater physics +!! channelBucket_only can be anything: the only time you dont run this is if channel_only=1 + if(nlst(did)%channel_only .eq. 0) then + if (nlst(did)%GWBASESWCRT .gt. 0) then + call driveGwBaseflow(did) + endif #ifdef HYDRO_D - call system_clock(count=clock_count_2, count_rate=clock_rate) - timeGw = timeGw + float(clock_count_2-clock_count_1)/float(clock_rate) + call system_clock(count=clock_count_2, count_rate=clock_rate) + timeGw = timeGw + float(clock_count_2-clock_count_1)/float(clock_rate) #ifndef NCEP_WCOSS - write(6,*) "Timing: GwBaseflow accumulated time--", timeGw + write(6,*) "Timing: GwBaseflow accumulated time--", timeGw #else - write(78,*) "Timing: GwBaseflow accumulated time--", timeGw + write(78,*) "Timing: GwBaseflow accumulated time--", timeGw #endif #endif #ifdef HYDRO_D - call system_clock(count=clock_count_1, count_rate=clock_rate) + call system_clock(count=clock_count_1, count_rate=clock_rate) #endif - end if !! channel_only == 0 + end if !! channel_only == 0 - ! step 5) river channel physics - call driveChannelRouting(did) +! step 5) river channel physics + call driveChannelRouting(did) #ifdef HYDRO_D - call system_clock(count=clock_count_2, count_rate=clock_rate) - timeCr = timeCr + float(clock_count_2-clock_count_1)/float(clock_rate) + call system_clock(count=clock_count_2, count_rate=clock_rate) + timeCr = timeCr + float(clock_count_2-clock_count_1)/float(clock_rate) #ifndef NCEP_WCOSS - write(6,*) "Timing: Channel Routing accumulated time--", timeCr + write(6,*) "Timing: Channel Routing accumulated time--", timeCr #else - write(78,*) "Timing: Channel Routing accumulated time--", timeCr + write(78,*) "Timing: Channel Routing accumulated time--", timeCr #endif #endif - !! if not channel_only - if(nlst(did)%channel_only .eq. 0 .and. nlst(did)%channelBucket_only .eq. 0) then +!! if not channel_only + if(nlst(did)%channel_only .eq. 0 .and. nlst(did)%channelBucket_only .eq. 0) then - ! step 6) aggregate specific fields from Hydro to LSM grid - if (nlst(did)%SUBRTSWCRT .ne.0 .or. nlst(did)%OVRTSWCRT .ne. 0 ) then - call aggregateDomain(did) - endif +! step 6) aggregate specific fields from Hydro to LSM grid + if (nlst(did)%SUBRTSWCRT .ne.0 .or. nlst(did)%OVRTSWCRT .ne. 0 ) then + call aggregateDomain(did) + endif - end if !! channel_only & channelBucket_only == 0 + end if !! channel_only & channelBucket_only == 0 -end if + end if !yw if (nlst_rt(did)%sys_cpl .eq. 2) then - ! advance to next time step +! advance to next time step ! call HYDRO_time_adv(did) - ! output for history +! output for history ! call HYDRO_out(did) !yw endif - call HYDRO_time_adv(did) - call HYDRO_out(did, 1) + call HYDRO_time_adv(did) + call HYDRO_out(did, 1) ! write(90 + my_id,*) "finish calling hydro_exe" @@ -762,292 +742,295 @@ subroutine HYDRO_exe(did) - !! Under channel-only, these variables are not allocated - if(allocated(RT_DOMAIN(did)%SOLDRAIN)) RT_DOMAIN(did)%SOLDRAIN = 0 - if(allocated(rt_domain(did)%subsurface%state%qsubrt)) RT_DOMAIN(did)%subsurface%state%qsubrt = 0 +!! Under channel-only, these variables are not allocated + if(allocated(RT_DOMAIN(did)%SOLDRAIN)) RT_DOMAIN(did)%SOLDRAIN = 0 + if(allocated(rt_domain(did)%subsurface%state%qsubrt)) RT_DOMAIN(did)%subsurface%state%qsubrt = 0 - end subroutine HYDRO_exe + end subroutine HYDRO_exe !---------------------------------------------------- -subroutine driveGwBaseflow(did) + subroutine driveGwBaseflow(did) - implicit none - integer, intent(in) :: did + implicit none + integer, intent(in) :: did - integer :: i, jj, ii + integer :: i, jj, ii - !------------------------------------------------------------------ - !DJG Begin GW/Baseflow Routines - !------------------------------------------------------------------- +!------------------------------------------------------------------ +!DJG Begin GW/Baseflow Routines +!------------------------------------------------------------------- - if (nlst(did)%GWBASESWCRT.ge.1) then ! Switch to activate/specify GW/Baseflow + if (nlst(did)%GWBASESWCRT.ge.1) then ! Switch to activate/specify GW/Baseflow - ! IF (nlst(did)%GWBASESWCRT.GE.1000) THEN ! Switch to activate/specify GW/Baseflow +! IF (nlst(did)%GWBASESWCRT.GE.1000) THEN ! Switch to activate/specify GW/Baseflow - if (nlst(did)%GWBASESWCRT.eq.1 .or. nlst(did)%GWBASESWCRT.eq.2 .or. nlst(did)%GWBASESWCRT.ge.4) then ! Call simple bucket baseflow scheme + if (nlst(did)%GWBASESWCRT.eq.1 .or. nlst(did)%GWBASESWCRT.eq.2 .or. nlst(did)%GWBASESWCRT.ge.4) then ! Call simple bucket baseflow scheme #ifdef HYDRO_D #ifndef NCEP_WCOSS - write(6,*) "*****yw******start simp_gw_buck " + write(6,*) "*****yw******start simp_gw_buck " #else - write(78,*) "*****yw******start simp_gw_buck " -#endif -#endif - - if(nlst(did)%UDMP_OPT .eq. 1) then - call simp_gw_buck_nhd( & - RT_DOMAIN(did)%ix, RT_DOMAIN(did)%jx, & - RT_DOMAIN(did)%ixrt, RT_DOMAIN(did)%jxrt, & - RT_DOMAIN(did)%numbasns, nlst(did)%AGGFACTRT, & - nlst(did)%DT, RT_DOMAIN(did)%INFXSWGT, & - RT_DOMAIN(did)%INFXSRT, RT_DOMAIN(did)%SOLDRAIN, & - rt_domain(did)%overland%properties%distance_to_neighbor(:,:,9), rt_domain(did)%dist_lsm(:,:,9), & - RT_DOMAIN(did)%gw_buck_coeff, RT_DOMAIN(did)%gw_buck_exp, & - RT_DOMAIN(did)%gw_buck_loss, & - RT_DOMAIN(did)%z_max, RT_DOMAIN(did)%z_gwsubbas, & - RT_DOMAIN(did)%qout_gwsubbas, RT_DOMAIN(did)%qin_gwsubbas, & - RT_DOMAIN(did)%qloss_gwsubbas, & - nlst(did)%GWBASESWCRT, nlst(did)%OVRTSWCRT, & + write(78,*) "*****yw******start simp_gw_buck " +#endif +#endif + + if(nlst(did)%UDMP_OPT .eq. 1) then + call simp_gw_buck_nhd( & + RT_DOMAIN(did)%ix, RT_DOMAIN(did)%jx, & + RT_DOMAIN(did)%ixrt, RT_DOMAIN(did)%jxrt, & + RT_DOMAIN(did)%numbasns, nlst(did)%AGGFACTRT, & + nlst(did)%DT, RT_DOMAIN(did)%INFXSWGT, & + RT_DOMAIN(did)%INFXSRT, RT_DOMAIN(did)%SOLDRAIN, & + rt_domain(did)%overland%properties%distance_to_neighbor(:,:,9), rt_domain(did)%dist_lsm(:,:,9), & + RT_DOMAIN(did)%gw_buck_coeff, RT_DOMAIN(did)%gw_buck_exp, & + RT_DOMAIN(did)%gw_buck_loss, & + RT_DOMAIN(did)%z_max, RT_DOMAIN(did)%z_gwsubbas, & + RT_DOMAIN(did)%qout_gwsubbas, RT_DOMAIN(did)%qin_gwsubbas, & + RT_DOMAIN(did)%qloss_gwsubbas, & + nlst(did)%GWBASESWCRT, nlst(did)%OVRTSWCRT, & #ifdef MPP_LAND - RT_DOMAIN(did)%LNLINKSL, & + RT_DOMAIN(did)%LNLINKSL, & #else - RT_DOMAIN(did)%numbasns, & + RT_DOMAIN(did)%numbasns, & #endif - rt_domain(did)%basns_area, & - rt_domain(did)%nhdBuckMask, nlst(did)%bucket_loss, & - nlst(did)%channelBucket_only ) + rt_domain(did)%basns_area, & + rt_domain(did)%nhdBuckMask, nlst(did)%bucket_loss, & + nlst(did)%channelBucket_only ) - else - call simp_gw_buck(RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,RT_DOMAIN(did)%ixrt,& - RT_DOMAIN(did)%jxrt,RT_DOMAIN(did)%numbasns,RT_DOMAIN(did)%gnumbasns,& - RT_DOMAIN(did)%basns_area,& - RT_DOMAIN(did)%basnsInd, RT_DOMAIN(did)%gw_strm_msk_lind, & - RT_DOMAIN(did)%gwsubbasmsk, RT_DOMAIN(did)%INFXSRT, & - RT_DOMAIN(did)%SOLDRAIN, & - RT_DOMAIN(did)%z_gwsubbas,& - RT_DOMAIN(did)%qin_gwsubbas,RT_DOMAIN(did)%qout_gwsubbas,& - RT_DOMAIN(did)%qinflowbase,& - RT_DOMAIN(did)%gw_strm_msk,RT_DOMAIN(did)%gwbas_pix_ct, & - rt_domain(did)%overland%properties%distance_to_neighbor,nlst(did)%DT,& - RT_DOMAIN(did)%gw_buck_coeff,RT_DOMAIN(did)%gw_buck_exp, & - RT_DOMAIN(did)%z_max,& - nlst(did)%GWBASESWCRT,nlst(did)%OVRTSWCRT) - endif + else + call simp_gw_buck(RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,RT_DOMAIN(did)%ixrt,& + RT_DOMAIN(did)%jxrt,RT_DOMAIN(did)%numbasns,RT_DOMAIN(did)%gnumbasns,& + RT_DOMAIN(did)%basns_area,& + RT_DOMAIN(did)%basnsInd, RT_DOMAIN(did)%gw_strm_msk_lind, & + RT_DOMAIN(did)%gwsubbasmsk, RT_DOMAIN(did)%INFXSRT, & + RT_DOMAIN(did)%SOLDRAIN, & + RT_DOMAIN(did)%z_gwsubbas,& + RT_DOMAIN(did)%qin_gwsubbas,RT_DOMAIN(did)%qout_gwsubbas,& + RT_DOMAIN(did)%qinflowbase,& + RT_DOMAIN(did)%gw_strm_msk,RT_DOMAIN(did)%gwbas_pix_ct, & + rt_domain(did)%overland%properties%distance_to_neighbor,nlst(did)%DT,& + RT_DOMAIN(did)%gw_buck_coeff,RT_DOMAIN(did)%gw_buck_exp, & + RT_DOMAIN(did)%z_max,& + nlst(did)%GWBASESWCRT,nlst(did)%OVRTSWCRT) + endif - !! JLM: There's *perhaps* a better location for this output above. - !! If above is better, remove this when runtime output options are avail. - !#ifndef HYDRO_REALTIME - ! call output_GW_Diag(did) - !#endif +!! JLM: There's *perhaps* a better location for this output above. +!! If above is better, remove this when runtime output options are avail. +!#ifndef HYDRO_REALTIME +! call output_GW_Diag(did) +!#endif #ifdef HYDRO_D #ifndef NCEP_WCOSS - write(6,*) "*****yw******end simp_gw_buck " + write(6,*) "*****yw******end simp_gw_buck " #else - write(78,*) "*****yw******end simp_gw_buck " + write(78,*) "*****yw******end simp_gw_buck " #endif #endif - !!!For parameter setup runs output the percolation for each basin, - !!!otherwise comment out this output... - else if (nlst(did)%gwBaseSwCRT .eq. 3) then +!!!For parameter setup runs output the percolation for each basin, +!!!otherwise comment out this output... + else if (nlst(did)%gwBaseSwCRT .eq. 3) then #ifdef HYDRO_D #ifndef NCEP_WCOSS - write(6,*) "*****bf******start 2d_gw_model " + write(6,*) "*****bf******start 2d_gw_model " #else - write(78,*) "*****bf******start 2d_gw_model " + write(78,*) "*****bf******start 2d_gw_model " #endif #endif - ! compute qsgwrt between lsm and gw with namelist selected coupling method - ! qsgwrt is defined on the routing grid and needs to be aggregated for SFLX - if (nlst(did)%gwsoilcpl .GT. 0) THEN +! compute qsgwrt between lsm and gw with namelist selected coupling method +! qsgwrt is defined on the routing grid and needs to be aggregated for SFLX + if (nlst(did)%gwsoilcpl .GT. 0) THEN - call gwSoilFlux(did) + call gwSoilFlux(did) - end if + end if - gw2d(did)%excess = 0. + gw2d(did)%excess = 0. - call gwstep(gw2d(did)%ix, gw2d(did)%jx, gw2d(did)%dx, & - gw2d(did)%ltype, gw2d(did)%elev, gw2d(did)%bot, & - gw2d(did)%hycond, gw2d(did)%poros, gw2d(did)%compres, & - gw2d(did)%ho, gw2d(did)%h, gw2d(did)%convgw, & - gw2d(did)%excess, & - gw2d(did)%ebot, gw2d(did)%eocn, gw2d(did)%dt, & - gw2d(did)%istep) + call gwstep(gw2d(did)%ix, gw2d(did)%jx, gw2d(did)%dx, & + gw2d(did)%ltype, gw2d(did)%elev, gw2d(did)%bot, & + gw2d(did)%hycond, gw2d(did)%poros, gw2d(did)%compres, & + gw2d(did)%ho, gw2d(did)%h, gw2d(did)%convgw, & + gw2d(did)%excess, & + gw2d(did)%ebot, gw2d(did)%eocn, gw2d(did)%dt, & + gw2d(did)%istep) - gw2d(did)%ho = gw2d(did)%h + gw2d(did)%ho = gw2d(did)%h - ! put surface exceeding groundwater to surface routing inflow - rt_domain(did)%overland%control%surface_water_head_routing = rt_domain(did)%overland%control%surface_water_head_routing & - + gw2d(did)%excess*1000. ! convert to mm +! put surface exceeding groundwater to surface routing inflow + rt_domain(did)%overland%control%surface_water_head_routing = rt_domain(did)%overland%control%surface_water_head_routing & + + gw2d(did)%excess*1000. ! convert to mm - ! aggregate qsgw from routing to lsm grid - call aggregateQsgw(did) +! aggregate qsgw from routing to lsm grid + call aggregateQsgw(did) - gw2d(did)%istep = gw2d(did)%istep + 1 + gw2d(did)%istep = gw2d(did)%istep + 1 #ifdef HYDRO_D #ifndef NCEP_WCOSS - write(6,*) "*****bf******end 2d_gw_model " + write(6,*) "*****bf******end 2d_gw_model " #else - write(78,*) "*****bf******end 2d_gw_model " + write(78,*) "*****bf******end 2d_gw_model " #endif #endif - end if + end if - end if !DJG (End if for RTE SWC activation) - !------------------------------------------------------------------ - !DJG End GW/Baseflow Routines - !------------------------------------------------------------------- -end subroutine driveGwBaseflow + end if !DJG (End if for RTE SWC activation) +!------------------------------------------------------------------ +!DJG End GW/Baseflow Routines +!------------------------------------------------------------------- + end subroutine driveGwBaseflow !------------------------------------------- - subroutine driveChannelRouting(did) + subroutine driveChannelRouting(did) - implicit none - integer, intent(in) :: did + implicit none + integer, intent(in) :: did !------------------------------------------------------------------- !------------------------------------------------------------------- !DJG,DNY Begin Channel and Lake Routing Routines !------------------------------------------------------------------- -if (nlst(did)%CHANRTSWCRT.eq.1 .or. nlst(did)%CHANRTSWCRT.eq.2) then - - if(nlst(did)%UDMP_OPT .eq. 1) then - !!! for user defined Reach based Routing method. - - call drive_CHANNEL_RSL(did, nlst(did)%UDMP_OPT,RT_DOMAIN(did)%timestep_flag, RT_DOMAIN(did)%IXRT,RT_DOMAIN(did)%JXRT, & - RT_DOMAIN(did)%LAKE_INFLORT_TS, RT_DOMAIN(did)%QSTRMVOLRT_TS, RT_DOMAIN(did)%TO_NODE, RT_DOMAIN(did)%FROM_NODE, & - RT_DOMAIN(did)%TYPEL, RT_DOMAIN(did)%ORDER, RT_DOMAIN(did)%MAXORDER, RT_DOMAIN(did)%CH_LNKRT, & - rt_domain(did)%overland%streams_and_lakes%lake_mask, nlst(did)%DT, nlst(did)%DTCT, nlst(did)%DTRT_CH, & - RT_DOMAIN(did)%MUSK, RT_DOMAIN(did)%MUSX, RT_DOMAIN(did)%QLINK, & - RT_DOMAIN(did)%CHANLEN, RT_DOMAIN(did)%MannN, RT_DOMAIN(did)%So, RT_DOMAIN(did)%ChSSlp,RT_DOMAIN(did)%Bw, & - RT_DOMAIN(did)%Tw, RT_DOMAIN(did)%Tw_CC, RT_DOMAIN(did)%n_CC, & - RT_DOMAIN(did)%ChannK,& - RT_DOMAIN(did)%RESHT, & - RT_DOMAIN(did)%CVOL, RT_DOMAIN(did)%QLAKEI, & - RT_DOMAIN(did)%QLAKEO, RT_DOMAIN(did)%LAKENODE, & - RT_DOMAIN(did)%QINFLOWBASE, RT_DOMAIN(did)%CHANXI, RT_DOMAIN(did)%CHANYJ, nlst(did)%channel_option, & - RT_DOMAIN(did)%nlinks, RT_DOMAIN(did)%NLINKSL, RT_DOMAIN(did)%LINKID, RT_DOMAIN(did)%node_area, & - RT_DOMAIN(did)%qout_gwsubbas, & - RT_DOMAIN(did)%LAKEIDA, RT_DOMAIN(did)%LAKEIDM, RT_DOMAIN(did)%NLAKES, RT_DOMAIN(did)%LAKEIDX & + if (nlst(did)%CHANRTSWCRT.eq.1 .or. nlst(did)%CHANRTSWCRT.eq.2) then + + if(nlst(did)%UDMP_OPT .eq. 1) then +!!! for user defined Reach based Routing method. + + call drive_CHANNEL_RSL(did, nlst(did)%UDMP_OPT,RT_DOMAIN(did)%timestep_flag, RT_DOMAIN(did)%IXRT,RT_DOMAIN(did)%JXRT, & + RT_DOMAIN(did)%LAKE_INFLORT_TS, RT_DOMAIN(did)%QSTRMVOLRT_TS, RT_DOMAIN(did)%TO_NODE, RT_DOMAIN(did)%FROM_NODE, & + RT_DOMAIN(did)%TYPEL, RT_DOMAIN(did)%ORDER, RT_DOMAIN(did)%MAXORDER, RT_DOMAIN(did)%CH_LNKRT, & + rt_domain(did)%overland%streams_and_lakes%lake_mask, nlst(did)%DT, nlst(did)%DTCT, nlst(did)%DTRT_CH, & + RT_DOMAIN(did)%MUSK, RT_DOMAIN(did)%MUSX, RT_DOMAIN(did)%QLINK, & + RT_DOMAIN(did)%CHANLEN, RT_DOMAIN(did)%MannN, RT_DOMAIN(did)%So, RT_DOMAIN(did)%ChSSlp,RT_DOMAIN(did)%Bw, & + RT_DOMAIN(did)%Tw, RT_DOMAIN(did)%Tw_CC, RT_DOMAIN(did)%n_CC, & + RT_DOMAIN(did)%ChannK,& + RT_DOMAIN(did)%RESHT, & + RT_DOMAIN(did)%CVOL, RT_DOMAIN(did)%QLAKEI, & + RT_DOMAIN(did)%QLAKEO, RT_DOMAIN(did)%LAKENODE, & + RT_DOMAIN(did)%QINFLOWBASE, RT_DOMAIN(did)%CHANXI, RT_DOMAIN(did)%CHANYJ, nlst(did)%channel_option, & + RT_DOMAIN(did)%nlinks, RT_DOMAIN(did)%NLINKSL, RT_DOMAIN(did)%LINKID, RT_DOMAIN(did)%node_area, & + RT_DOMAIN(did)%qout_gwsubbas, & + RT_DOMAIN(did)%LAKEIDA, RT_DOMAIN(did)%LAKEIDM, RT_DOMAIN(did)%NLAKES, RT_DOMAIN(did)%LAKEIDX & #ifdef MPP_LAND - , RT_DOMAIN(did)%nlinks_index, RT_DOMAIN(did)%mpp_nlinks, RT_DOMAIN(did)%yw_mpp_nlinks & - , RT_DOMAIN(did)%LNLINKSL & - , RT_DOMAIN(did)%gtoNode, RT_DOMAIN(did)%toNodeInd, RT_DOMAIN(did)%nToInd & + , RT_DOMAIN(did)%nlinks_index, RT_DOMAIN(did)%mpp_nlinks, RT_DOMAIN(did)%yw_mpp_nlinks & + , RT_DOMAIN(did)%LNLINKSL & + , RT_DOMAIN(did)%gtoNode, RT_DOMAIN(did)%toNodeInd, RT_DOMAIN(did)%nToInd & #endif - , RT_DOMAIN(did)%CH_LNKRT_SL, RT_DOMAIN(did)%landRunOff & + , RT_DOMAIN(did)%CH_LNKRT_SL, RT_DOMAIN(did)%landRunOff & #ifdef WRF_HYDRO_NUDGING - , RT_DOMAIN(did)%nudge & -#endif - , rt_domain(did)%accSfcLatRunoff, rt_domain(did)%accBucket & - , rt_domain(did)%qSfcLatRunoff, rt_domain(did)%qBucket & - , rt_domain(did)%QLateral, rt_domain(did)%velocity & - , rt_domain(did)%qloss & - , RT_DOMAIN(did)%HLINK & - , rt_domain(did)%nlinksize, nlst(did)%OVRTSWCRT & - , nlst(did)%SUBRTSWCRT & - , nlst(did)%channel_only , nlst(did)%channelBucket_only & - , nlst(did)%channel_bypass ) - -else - - call drive_CHANNEL(did, RT_DOMAIN(did)%latval,RT_DOMAIN(did)%lonval, & - RT_DOMAIN(did)%timestep_flag,RT_DOMAIN(did)%IXRT,RT_DOMAIN(did)%JXRT, & - nlst(did)%SUBRTSWCRT, rt_domain(did)%subsurface%state%qsubrt, & - RT_DOMAIN(did)%LAKE_INFLORT_TS, RT_DOMAIN(did)%QSTRMVOLRT_TS,& - RT_DOMAIN(did)%TO_NODE, RT_DOMAIN(did)%FROM_NODE, RT_DOMAIN(did)%TYPEL,& - RT_DOMAIN(did)%ORDER, RT_DOMAIN(did)%MAXORDER, RT_DOMAIN(did)%NLINKS,& - RT_DOMAIN(did)%CH_NETLNK, rt_domain(did)%overland%streams_and_lakes%ch_netrt,RT_DOMAIN(did)%CH_LNKRT,& - rt_domain(did)%overland%streams_and_lakes%lake_mask, nlst(did)%DT, nlst(did)%DTCT, nlst(did)%DTRT_CH,& - RT_DOMAIN(did)%MUSK, RT_DOMAIN(did)%MUSX, RT_DOMAIN(did)%QLINK, & - RT_DOMAIN(did)%QLateral, & - RT_DOMAIN(did)%HLINK, RT_DOMAIN(did)%ELRT,RT_DOMAIN(did)%CHANLEN,& - RT_DOMAIN(did)%MannN,RT_DOMAIN(did)%So, RT_DOMAIN(did)%ChSSlp, & - RT_DOMAIN(did)%Bw,RT_DOMAIN(did)%Tw,RT_DOMAIN(did)%Tw_CC, RT_DOMAIN(did)%n_CC, & - RT_DOMAIN(did)%ChannK,& - RT_DOMAIN(did)%RESHT, & - RT_DOMAIN(did)%ZELEV, RT_DOMAIN(did)%CVOL, & - RT_DOMAIN(did)%NLAKES, RT_DOMAIN(did)%QLAKEI, RT_DOMAIN(did)%QLAKEO,& - RT_DOMAIN(did)%LAKENODE, rt_domain(did)%overland%properties%distance_to_neighbor, & - RT_DOMAIN(did)%QINFLOWBASE, RT_DOMAIN(did)%CHANXI, & - RT_DOMAIN(did)%CHANYJ, nlst(did)%channel_option, & - RT_DOMAIN(did)%RETDEP_CHAN, RT_DOMAIN(did)%NLINKSL, RT_DOMAIN(did)%LINKID, & - RT_DOMAIN(did)%node_area & + , RT_DOMAIN(did)%nudge & +#endif + , rt_domain(did)%accSfcLatRunoff, rt_domain(did)%accBucket & + , rt_domain(did)%qSfcLatRunoff, rt_domain(did)%qBucket & + , rt_domain(did)%QLateral, rt_domain(did)%velocity & + , rt_domain(did)%qloss & + , RT_DOMAIN(did)%HLINK & + , rt_domain(did)%nlinksize, nlst(did)%OVRTSWCRT & + , nlst(did)%SUBRTSWCRT & + , nlst(did)%channel_only , nlst(did)%channelBucket_only & + , nlst(did)%channel_bypass ) + + else + + call drive_CHANNEL(did, RT_DOMAIN(did)%latval,RT_DOMAIN(did)%lonval, & + RT_DOMAIN(did)%timestep_flag,RT_DOMAIN(did)%IXRT,RT_DOMAIN(did)%JXRT, & + nlst(did)%SUBRTSWCRT, rt_domain(did)%subsurface%state%qsubrt, & + RT_DOMAIN(did)%LAKE_INFLORT_TS, RT_DOMAIN(did)%QSTRMVOLRT_TS,& + RT_DOMAIN(did)%TO_NODE, RT_DOMAIN(did)%FROM_NODE, RT_DOMAIN(did)%TYPEL,& + RT_DOMAIN(did)%ORDER, RT_DOMAIN(did)%MAXORDER, RT_DOMAIN(did)%NLINKS,& + RT_DOMAIN(did)%CH_NETLNK, rt_domain(did)%overland%streams_and_lakes%ch_netrt,RT_DOMAIN(did)%CH_LNKRT,& + rt_domain(did)%overland%streams_and_lakes%lake_mask, nlst(did)%DT, nlst(did)%DTCT, nlst(did)%DTRT_CH,& + RT_DOMAIN(did)%MUSK, RT_DOMAIN(did)%MUSX, RT_DOMAIN(did)%QLINK, & + RT_DOMAIN(did)%QLateral, & + RT_DOMAIN(did)%HLINK, RT_DOMAIN(did)%ELRT,RT_DOMAIN(did)%CHANLEN,& + RT_DOMAIN(did)%MannN,RT_DOMAIN(did)%So, RT_DOMAIN(did)%ChSSlp, & + RT_DOMAIN(did)%Bw,RT_DOMAIN(did)%Tw,RT_DOMAIN(did)%Tw_CC, RT_DOMAIN(did)%n_CC, & + RT_DOMAIN(did)%ChannK, & + RT_DOMAIN(did)%RESHT, & + RT_DOMAIN(did)%HRZAREA, RT_DOMAIN(did)%LAKEMAXH, & + RT_DOMAIN(did)%WEIRH, RT_DOMAIN(did)%WEIRC, RT_DOMAIN(did)%WEIRL, & + RT_DOMAIN(did)%ORIFICEC, RT_DOMAIN(did)%ORIFICEA, RT_DOMAIN(did)%ORIFICEE, & + RT_DOMAIN(did)%ZELEV, RT_DOMAIN(did)%CVOL, & + RT_DOMAIN(did)%NLAKES, RT_DOMAIN(did)%QLAKEI, RT_DOMAIN(did)%QLAKEO,& + RT_DOMAIN(did)%LAKENODE, rt_domain(did)%overland%properties%distance_to_neighbor, & + RT_DOMAIN(did)%QINFLOWBASE, RT_DOMAIN(did)%CHANXI, & + RT_DOMAIN(did)%CHANYJ, nlst(did)%channel_option, & + RT_DOMAIN(did)%RETDEP_CHAN, RT_DOMAIN(did)%NLINKSL, RT_DOMAIN(did)%LINKID, & + RT_DOMAIN(did)%node_area, RT_DOMAIN(did)%LAKEIDX & #ifdef MPP_LAND - ,RT_DOMAIN(did)%lake_index,RT_DOMAIN(did)%link_location,& - RT_DOMAIN(did)%mpp_nlinks,RT_DOMAIN(did)%nlinks_index, & - RT_DOMAIN(did)%yw_mpp_nlinks & - , RT_DOMAIN(did)%LNLINKSL & - , rt_domain(did)%gtoNode,rt_domain(did)%toNodeInd,rt_domain(did)%nToInd & -#endif - , rt_domain(did)%CH_LNKRT_SL & - ,nlst(did)%GwBaseSwCRT, gw2d(did)%ho, gw2d(did)%qgw_chanrt, & - nlst(did)%gwChanCondSw, nlst(did)%gwChanCondConstIn, & - nlst(did)%gwChanCondConstOut, rt_domain(did)%velocity, rt_domain(did)%qloss & - ) -endif + ,RT_DOMAIN(did)%lake_index,RT_DOMAIN(did)%link_location,& + RT_DOMAIN(did)%mpp_nlinks,RT_DOMAIN(did)%nlinks_index, & + RT_DOMAIN(did)%yw_mpp_nlinks, & + RT_DOMAIN(did)%LNLINKSL, RT_DOMAIN(did)%LLINKID, & + rt_domain(did)%gtoNode, rt_domain(did)%toNodeInd,rt_domain(did)%nToInd & +#endif + , rt_domain(did)%CH_LNKRT_SL, & + nlst(did)%GwBaseSwCRT, gw2d(did)%ho, gw2d(did)%qgw_chanrt, & + nlst(did)%gwChanCondSw, nlst(did)%gwChanCondConstIn, & + nlst(did)%gwChanCondConstOut, rt_domain(did)%velocity, rt_domain(did)%qloss & + ) + endif - if((nlst(did)%gwBaseSwCRT == 3) .and. (nlst(did)%gwChanCondSw .eq. 1)) then + if((nlst(did)%gwBaseSwCRT == 3) .and. (nlst(did)%gwChanCondSw .eq. 1)) then - ! add/rm channel-aquifer exchange contribution +! add/rm channel-aquifer exchange contribution - gw2d(did)%ho = gw2d(did)%ho & - +(((gw2d(did)%qgw_chanrt*(-1)) * gw2d(did)%dt / gw2d(did)%dx**2) & - / gw2d(did)%poros) + gw2d(did)%ho = gw2d(did)%ho & + +(((gw2d(did)%qgw_chanrt*(-1)) * gw2d(did)%dt / gw2d(did)%dx**2) & + / gw2d(did)%poros) - endif - endif + endif + endif #ifdef HYDRO_D #ifndef NCEP_WCOSS - write(6,*) "*****yw******end drive_CHANNEL " + write(6,*) "*****yw******end drive_CHANNEL " #else - write(78,*) "*****yw******end drive_CHANNEL " + write(78,*) "*****yw******end drive_CHANNEL " #endif #endif - end subroutine driveChannelRouting + end subroutine driveChannelRouting !------------------------------------------------ - subroutine aggregateDomain(did) + subroutine aggregateDomain(did) #ifdef MPP_LAND use module_mpp_land, only: sum_real1, my_id, io_id, numprocs #endif - implicit none - integer, intent(in) :: did + implicit none + integer, intent(in) :: did - integer :: i, j, krt, ixxrt, jyyrt, & - AGGFACYRT, AGGFACXRT + integer :: i, j, krt, ixxrt, jyyrt, & + AGGFACYRT, AGGFACXRT #ifdef HYDRO_D ! ADCHANGE: Water balance variables - integer :: kk - real :: smcrttot1,smctot2,sicetot2 - real :: suminfxsrt1,suminfxs2 + integer :: kk + real :: smcrttot1,smctot2,sicetot2 + real :: suminfxsrt1,suminfxs2 #endif #ifdef HYDRO_D #ifndef NCEP_WCOSS - print *, "Beginning Aggregation..." + print *, "Beginning Aggregation..." #else - write(78,*) "Beginning Aggregation..." + write(78,*) "Beginning Aggregation..." #endif #endif @@ -1057,14 +1040,14 @@ subroutine aggregateDomain(did) suminfxsrt1 = 0. smcrttot1 = 0. do i=1,RT_DOMAIN(did)%IXRT - do j=1,RT_DOMAIN(did)%JXRT - suminfxsrt1 = suminfxsrt1 + rt_domain(did)%overland%control%surface_water_head_routing(I,J) & - / float(RT_DOMAIN(did)%IXRT * RT_DOMAIN(did)%JXRT) - do kk=1,nlst(did)%NSOIL - smcrttot1 = smcrttot1 + rt_domain(did)%subsurface%grid_transform%smcrt(I,J,KK)*RT_DOMAIN(did)%subsurface%properties%sldpth(KK)*1000. & - / float(RT_DOMAIN(did)%IXRT * RT_DOMAIN(did)%JXRT) + do j=1,RT_DOMAIN(did)%JXRT + suminfxsrt1 = suminfxsrt1 + rt_domain(did)%overland%control%surface_water_head_routing(I,J) & + / float(RT_DOMAIN(did)%IXRT * RT_DOMAIN(did)%JXRT) + do kk=1,nlst(did)%NSOIL + smcrttot1 = smcrttot1 + rt_domain(did)%subsurface%grid_transform%smcrt(I,J,KK)*RT_DOMAIN(did)%subsurface%properties%sldpth(KK)*1000. & + / float(RT_DOMAIN(did)%IXRT * RT_DOMAIN(did)%JXRT) + end do end do - end do end do #ifdef MPP_LAND ! not tested @@ -1077,26 +1060,26 @@ subroutine aggregateDomain(did) #endif do J=1,RT_DOMAIN(did)%JX - do I=1,RT_DOMAIN(did)%IX + do I=1,RT_DOMAIN(did)%IX - RT_DOMAIN(did)%SFCHEADAGGRT = 0. + RT_DOMAIN(did)%SFCHEADAGGRT = 0. !DJG Subgrid weighting edit... - RT_DOMAIN(did)%LSMVOL=0. - do KRT=1,nlst(did)%NSOIL + RT_DOMAIN(did)%LSMVOL=0. + do KRT=1,nlst(did)%NSOIL ! SMCAGGRT(KRT) = 0. - RT_DOMAIN(did)%SH2OAGGRT(KRT) = 0. - end do + RT_DOMAIN(did)%SH2OAGGRT(KRT) = 0. + end do - do AGGFACYRT=nlst(did)%AGGFACTRT-1,0,-1 - do AGGFACXRT=nlst(did)%AGGFACTRT-1,0,-1 + do AGGFACYRT=nlst(did)%AGGFACTRT-1,0,-1 + do AGGFACXRT=nlst(did)%AGGFACTRT-1,0,-1 - IXXRT=I*nlst(did)%AGGFACTRT-AGGFACXRT - JYYRT=J*nlst(did)%AGGFACTRT-AGGFACYRT + IXXRT=I*nlst(did)%AGGFACTRT-AGGFACXRT + JYYRT=J*nlst(did)%AGGFACTRT-AGGFACYRT #ifdef MPP_LAND - if(left_id.ge.0) IXXRT=IXXRT+1 - if(down_id.ge.0) JYYRT=JYYRT+1 + if(left_id.ge.0) IXXRT=IXXRT+1 + if(down_id.ge.0) JYYRT=JYYRT+1 #else !yw ???? ! IXXRT=IXXRT+1 @@ -1104,144 +1087,144 @@ subroutine aggregateDomain(did) #endif !State Variables - RT_DOMAIN(did)%SFCHEADAGGRT = RT_DOMAIN(did)%SFCHEADAGGRT & - + rt_domain(did)%overland%control%surface_water_head_routing(IXXRT,JYYRT) + RT_DOMAIN(did)%SFCHEADAGGRT = RT_DOMAIN(did)%SFCHEADAGGRT & + + rt_domain(did)%overland%control%surface_water_head_routing(IXXRT,JYYRT) !DJG Subgrid weighting edit... - RT_DOMAIN(did)%LSMVOL = RT_DOMAIN(did)%LSMVOL & - + rt_domain(did)%overland%control%surface_water_head_routing(IXXRT,JYYRT) & - * rt_domain(did)%overland%properties%distance_to_neighbor(IXXRT,JYYRT,9) + RT_DOMAIN(did)%LSMVOL = RT_DOMAIN(did)%LSMVOL & + + rt_domain(did)%overland%control%surface_water_head_routing(IXXRT,JYYRT) & + * rt_domain(did)%overland%properties%distance_to_neighbor(IXXRT,JYYRT,9) - do KRT=1,nlst(did)%NSOIL + do KRT=1,nlst(did)%NSOIL !DJG SMCAGGRT(KRT)=SMCAGGRT(KRT)+SMCRT(IXXRT,JYYRT,KRT) - RT_DOMAIN(did)%SH2OAGGRT(KRT) = RT_DOMAIN(did)%SH2OAGGRT(KRT) & - + rt_domain(did)%subsurface%grid_transform%smcrt(IXXRT,JYYRT,KRT) - end do + RT_DOMAIN(did)%SH2OAGGRT(KRT) = RT_DOMAIN(did)%SH2OAGGRT(KRT) & + + rt_domain(did)%subsurface%grid_transform%smcrt(IXXRT,JYYRT,KRT) + end do - end do - end do + end do + end do - rt_domain(did)%overland%control%surface_water_head_lsm(I,J) = RT_DOMAIN(did)%SFCHEADAGGRT & - / (nlst(did)%AGGFACTRT**2) + rt_domain(did)%overland%control%surface_water_head_lsm(I,J) = RT_DOMAIN(did)%SFCHEADAGGRT & + / (nlst(did)%AGGFACTRT**2) - do KRT=1,nlst(did)%NSOIL + do KRT=1,nlst(did)%NSOIL !DJG SMC(I,J,KRT)=SMCAGGRT(KRT)/(AGGFACTRT**2) - RT_DOMAIN(did)%SH2OX(I,J,KRT) = RT_DOMAIN(did)%SH2OAGGRT(KRT) & - / (nlst(did)%AGGFACTRT**2) - end do + RT_DOMAIN(did)%SH2OX(I,J,KRT) = RT_DOMAIN(did)%SH2OAGGRT(KRT) & + / (nlst(did)%AGGFACTRT**2) + end do !DJG Calculate subgrid weighting array... - do AGGFACYRT=nlst(did)%AGGFACTRT-1,0,-1 - do AGGFACXRT=nlst(did)%AGGFACTRT-1,0,-1 - IXXRT=I*nlst(did)%AGGFACTRT-AGGFACXRT - JYYRT=J*nlst(did)%AGGFACTRT-AGGFACYRT + do AGGFACYRT=nlst(did)%AGGFACTRT-1,0,-1 + do AGGFACXRT=nlst(did)%AGGFACTRT-1,0,-1 + IXXRT=I*nlst(did)%AGGFACTRT-AGGFACXRT + JYYRT=J*nlst(did)%AGGFACTRT-AGGFACYRT #ifdef MPP_LAND - if(left_id.ge.0) IXXRT=IXXRT+1 - if(down_id.ge.0) JYYRT=JYYRT+1 + if(left_id.ge.0) IXXRT=IXXRT+1 + if(down_id.ge.0) JYYRT=JYYRT+1 #else !yw ??? ! IXXRT=IXXRT+1 ! JYYRT=JYYRT+1 #endif - if (RT_DOMAIN(did)%LSMVOL.gt.0.) then - RT_DOMAIN(did)%INFXSWGT(IXXRT,JYYRT) & - = rt_domain(did)%overland%control%surface_water_head_routing(IXXRT,JYYRT) & - * rt_domain(did)%overland%properties%distance_to_neighbor(IXXRT,JYYRT,9) & - / RT_DOMAIN(did)%LSMVOL - else - RT_DOMAIN(did)%INFXSWGT(IXXRT,JYYRT) & - = 1./FLOAT(nlst(did)%AGGFACTRT**2) - end if + if (RT_DOMAIN(did)%LSMVOL.gt.0.) then + RT_DOMAIN(did)%INFXSWGT(IXXRT,JYYRT) & + = rt_domain(did)%overland%control%surface_water_head_routing(IXXRT,JYYRT) & + * rt_domain(did)%overland%properties%distance_to_neighbor(IXXRT,JYYRT,9) & + / RT_DOMAIN(did)%LSMVOL + else + RT_DOMAIN(did)%INFXSWGT(IXXRT,JYYRT) & + = 1./FLOAT(nlst(did)%AGGFACTRT**2) + end if - do KRT=1,nlst(did)%NSOIL + do KRT=1,nlst(did)%NSOIL !!!yw added for debug - if(rt_domain(did)%subsurface%grid_transform%smcrt(IXXRT,JYYRT,KRT) .lt. 0) then + if(rt_domain(did)%subsurface%grid_transform%smcrt(IXXRT,JYYRT,KRT) .lt. 0) then #ifndef NCEP_WCOSS - print*, "Error negative SMCRT", rt_domain(did)%SH2OWGT(IXXRT,JYYRT,KRT), RT_DOMAIN(did)%subsurface%grid_transform%smcrt(IXXRT,JYYRT,KRT),RT_DOMAIN(did)%SH2OX(I,J,KRT) + print*, "Error negative SMCRT", rt_domain(did)%SH2OWGT(IXXRT,JYYRT,KRT), RT_DOMAIN(did)%subsurface%grid_transform%smcrt(IXXRT,JYYRT,KRT),RT_DOMAIN(did)%SH2OX(I,J,KRT) #else - write(78,*) "WARNING: negative SMCRT", rt_domain(did)%SH2OWGT(IXXRT,JYYRT,KRT), RT_DOMAIN(did)%subsurface%grid_transform%smcrt(IXXRT,JYYRT,KRT),RT_DOMAIN(did)%SH2OX(I,J,KRT) + write(78,*) "WARNING: negative SMCRT", rt_domain(did)%SH2OWGT(IXXRT,JYYRT,KRT), RT_DOMAIN(did)%subsurface%grid_transform%smcrt(IXXRT,JYYRT,KRT),RT_DOMAIN(did)%SH2OX(I,J,KRT) #endif - endif - if(RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT) .lt. 0) then + endif + if(RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT) .lt. 0) then #ifndef NCEP_WCOSS - print *, "Error negative SH2OWGT", rt_domain(did)%SH2OWGT(IXXRT,JYYRT,KRT), RT_DOMAIN(did)%subsurface%grid_transform%smcrt(IXXRT,JYYRT,KRT),RT_DOMAIN(did)%SH2OX(I,J,KRT) + print *, "Error negative SH2OWGT", rt_domain(did)%SH2OWGT(IXXRT,JYYRT,KRT), RT_DOMAIN(did)%subsurface%grid_transform%smcrt(IXXRT,JYYRT,KRT),RT_DOMAIN(did)%SH2OX(I,J,KRT) #else - write(78,*) "WARNING: negative SH2OWGT", rt_domain(did)%SH2OWGT(IXXRT,JYYRT,KRT), RT_DOMAIN(did)%subsurface%grid_transform%smcrt(IXXRT,JYYRT,KRT),RT_DOMAIN(did)%SH2OX(I,J,KRT) + write(78,*) "WARNING: negative SH2OWGT", rt_domain(did)%SH2OWGT(IXXRT,JYYRT,KRT), RT_DOMAIN(did)%subsurface%grid_transform%smcrt(IXXRT,JYYRT,KRT),RT_DOMAIN(did)%SH2OX(I,J,KRT) #endif - endif + endif - IF ( (rt_domain(did)%subsurface%grid_transform%smcrt(IXXRT,JYYRT,KRT) - & - rt_domain(did)%subsurface%grid_transform%smcmaxrt(IXXRT,JYYRT,KRT)) .GT. 0.000001 ) THEN + IF ( (rt_domain(did)%subsurface%grid_transform%smcrt(IXXRT,JYYRT,KRT) - & + rt_domain(did)%subsurface%grid_transform%smcmaxrt(IXXRT,JYYRT,KRT)) .GT. 0.000001 ) THEN #ifdef HYDRO_D #ifndef NCEP_WCOSS - print *, "SMCMAX exceeded upon aggregation...", & - rt_domain(did)%subsurface%grid_transform%smcrt(IXXRT,JYYRT,KRT), & - rt_domain(did)%subsurface%grid_transform%smcmaxrt(IXXRT,JYYRT,KRT) + print *, "SMCMAX exceeded upon aggregation...", & + rt_domain(did)%subsurface%grid_transform%smcrt(IXXRT,JYYRT,KRT), & + rt_domain(did)%subsurface%grid_transform%smcmaxrt(IXXRT,JYYRT,KRT) #else - write(78,*) "FATAL ERROR: SMCMAX exceeded upon aggregation...", & - rt_domain(did)%subsurface%grid_transform%smcrt(IXXRT,JYYRT,KRT), & - rt_domain(did)%subsurface%grid_transform%smcmaxrt(IXXRT,JYYRT,KRT) + write(78,*) "FATAL ERROR: SMCMAX exceeded upon aggregation...", & + rt_domain(did)%subsurface%grid_transform%smcrt(IXXRT,JYYRT,KRT), & + rt_domain(did)%subsurface%grid_transform%smcmaxrt(IXXRT,JYYRT,KRT) #endif #endif - call hydro_stop("In module_HYDRO_drv.F aggregateDomain() - "// & - "SMCMAX exceeded upon aggregation.") - END IF - IF(RT_DOMAIN(did)%SH2OX(I,J,KRT).LT.0.) THEN + call hydro_stop("In module_HYDRO_drv.F aggregateDomain() - "// & + "SMCMAX exceeded upon aggregation.") + END IF + IF(RT_DOMAIN(did)%SH2OX(I,J,KRT).LT.0.) THEN #ifdef HYDRO_D #ifndef NCEP_WCOSS - print *, "Erroneous value of SH2O...", & - RT_DOMAIN(did)%SH2OX(I,J,KRT),I,J,KRT - print *, "Error negative SH2OX", rt_domain(did)%SH2OWGT(IXXRT,JYYRT,KRT), RT_DOMAIN(did)%subsurface%grid_transform%smcrt(IXXRT,JYYRT,KRT),RT_DOMAIN(did)%SH2OX(I,J,KRT) + print *, "Erroneous value of SH2O...", & + RT_DOMAIN(did)%SH2OX(I,J,KRT),I,J,KRT + print *, "Error negative SH2OX", rt_domain(did)%SH2OWGT(IXXRT,JYYRT,KRT), RT_DOMAIN(did)%subsurface%grid_transform%smcrt(IXXRT,JYYRT,KRT),RT_DOMAIN(did)%SH2OX(I,J,KRT) #else - write(78,*) "Erroneous value of SH2O...", & - RT_DOMAIN(did)%SH2OX(I,J,KRT),I,J,KRT - write(78,*) "FATAL ERROR: negative SH2OX", rt_domain(did)%SH2OWGT(IXXRT,JYYRT,KRT), RT_DOMAIN(did)%subsurface%grid_transform%smcrt(IXXRT,JYYRT,KRT),RT_DOMAIN(did)%SH2OX(I,J,KRT) + write(78,*) "Erroneous value of SH2O...", & + RT_DOMAIN(did)%SH2OX(I,J,KRT),I,J,KRT + write(78,*) "FATAL ERROR: negative SH2OX", rt_domain(did)%SH2OWGT(IXXRT,JYYRT,KRT), RT_DOMAIN(did)%subsurface%grid_transform%smcrt(IXXRT,JYYRT,KRT),RT_DOMAIN(did)%SH2OX(I,J,KRT) #endif #endif - call hydro_stop("In module_HYDRO_drv.F aggregateDomain() "// & - "- Error negative SH2OX") - END IF + call hydro_stop("In module_HYDRO_drv.F aggregateDomain() "// & + "- Error negative SH2OX") + END IF - IF ( RT_DOMAIN(did)%SH2OX(I,J,KRT) .gt. 0 ) THEN - RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT) & - = rt_domain(did)%subsurface%grid_transform%smcrt(IXXRT,JYYRT,KRT) & - / RT_DOMAIN(did)%SH2OX(I,J,KRT) - ELSE + IF ( RT_DOMAIN(did)%SH2OX(I,J,KRT) .gt. 0 ) THEN + RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT) & + = rt_domain(did)%subsurface%grid_transform%smcrt(IXXRT,JYYRT,KRT) & + / RT_DOMAIN(did)%SH2OX(I,J,KRT) + ELSE #ifdef HYDRO_D - print *, "Error zero SH2OX", rt_domain(did)%SH2OWGT(IXXRT,JYYRT,KRT), RT_DOMAIN(did)%subsurface%grid_transform%smcrt(IXXRT,JYYRT,KRT),RT_DOMAIN(did)%SH2OX(I,J,KRT) + print *, "Error zero SH2OX", rt_domain(did)%SH2OWGT(IXXRT,JYYRT,KRT), RT_DOMAIN(did)%subsurface%grid_transform%smcrt(IXXRT,JYYRT,KRT),RT_DOMAIN(did)%SH2OX(I,J,KRT) #endif - RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT) = 0.0 - ENDIF + RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT) = 0.0 + ENDIF !?yw - RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT) = max(1.0E-05, RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT)) - end do + RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT) = max(1.0E-05, RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT)) + end do + end do end do - end do - end do + end do end do #ifdef MPP_LAND call MPP_LAND_COM_REAL(RT_DOMAIN(did)%INFXSWGT, & - RT_DOMAIN(did)%IXRT, & - RT_DOMAIN(did)%JXRT, 99) + RT_DOMAIN(did)%IXRT, & + RT_DOMAIN(did)%JXRT, 99) do i = 1, nlst(did)%NSOIL - call MPP_LAND_COM_REAL(RT_DOMAIN(did)%SH2OWGT(:,:,i), & - RT_DOMAIN(did)%IXRT, & - RT_DOMAIN(did)%JXRT, 99) + call MPP_LAND_COM_REAL(RT_DOMAIN(did)%SH2OWGT(:,:,i), & + RT_DOMAIN(did)%IXRT, & + RT_DOMAIN(did)%JXRT, 99) end do #endif !DJG Update SMC with SICE (unchanged) and new value of SH2O from routing... - RT_DOMAIN(did)%SMC = RT_DOMAIN(did)%SH2OX + RT_DOMAIN(did)%SICE + RT_DOMAIN(did)%SMC = RT_DOMAIN(did)%SH2OX + RT_DOMAIN(did)%SICE #ifdef HYDRO_D ! ADCHANGE: START Final water balance variables @@ -1250,16 +1233,16 @@ subroutine aggregateDomain(did) smctot2 = 0. sicetot2 = 0. do i=1,RT_DOMAIN(did)%IX - do j=1,RT_DOMAIN(did)%JX - suminfxs2 = suminfxs2 + rt_domain(did)%overland%control%surface_water_head_lsm(I,J) & - / float(RT_DOMAIN(did)%IX * RT_DOMAIN(did)%JX) - do kk=1,nlst(did)%NSOIL - smctot2 = smctot2 + rt_domain(did)%SMC(I,J,KK)*RT_DOMAIN(did)%subsurface%properties%sldpth(KK)*1000. & - / float(RT_DOMAIN(did)%IX * RT_DOMAIN(did)%JX) - sicetot2 = sicetot2 + rt_domain(did)%SICE(I,J,KK)*RT_DOMAIN(did)%subsurface%properties%sldpth(KK)*1000. & - / float(RT_DOMAIN(did)%IX * RT_DOMAIN(did)%JX) + do j=1,RT_DOMAIN(did)%JX + suminfxs2 = suminfxs2 + rt_domain(did)%overland%control%surface_water_head_lsm(I,J) & + / float(RT_DOMAIN(did)%IX * RT_DOMAIN(did)%JX) + do kk=1,nlst(did)%NSOIL + smctot2 = smctot2 + rt_domain(did)%SMC(I,J,KK)*RT_DOMAIN(did)%subsurface%properties%sldpth(KK)*1000. & + / float(RT_DOMAIN(did)%IX * RT_DOMAIN(did)%JX) + sicetot2 = sicetot2 + rt_domain(did)%SICE(I,J,KK)*RT_DOMAIN(did)%subsurface%properties%sldpth(KK)*1000. & + / float(RT_DOMAIN(did)%IX * RT_DOMAIN(did)%JX) + end do end do - end do end do #ifdef MPP_LAND @@ -1273,104 +1256,104 @@ subroutine aggregateDomain(did) #endif #ifdef MPP_LAND - if (my_id .eq. IO_id) then -#endif - print *, "Agg Mass Bal: " - print *, "WB_AGG!InfxsDiff", suminfxs2-suminfxsrt1 - print *, "WB_AGG!Infxs1", suminfxsrt1 - print *, "WB_AGG!Infxs2", suminfxs2 - print *, "WB_AGG!SMCDiff", smctot2-smcrttot1-sicetot2 - print *, "WB_AGG!SMC1", smcrttot1 - print *, "WB_AGG!SMC2", smctot2 - print *, "WB_AGG!SICE2", sicetot2 - print *, "WB_AGG!Residual", (suminfxs2-suminfxsrt1) + & - (smctot2-smcrttot1-sicetot2) + if (my_id .eq. IO_id) then +#endif + print *, "Agg Mass Bal: " + print *, "WB_AGG!InfxsDiff", suminfxs2-suminfxsrt1 + print *, "WB_AGG!Infxs1", suminfxsrt1 + print *, "WB_AGG!Infxs2", suminfxs2 + print *, "WB_AGG!SMCDiff", smctot2-smcrttot1-sicetot2 + print *, "WB_AGG!SMC1", smcrttot1 + print *, "WB_AGG!SMC2", smctot2 + print *, "WB_AGG!SICE2", sicetot2 + print *, "WB_AGG!Residual", (suminfxs2-suminfxsrt1) + & + (smctot2-smcrttot1-sicetot2) #ifdef MPP_LAND - endif + endif #endif ! END Final water balance variables #endif #ifdef HYDRO_D #ifndef NCEP_WCOSS - print *, "Finished Aggregation..." + print *, "Finished Aggregation..." #else - write(78,*) "Finished Aggregation..." + write(78,*) "Finished Aggregation..." #endif #endif - end subroutine aggregateDomain + end subroutine aggregateDomain - subroutine RunOffDisag(runoff1x_in, runoff1x, area_lsm,cellArea, infxswgt, AGGFACTRT, ix,jx) + subroutine RunOffDisag(runoff1x_in, runoff1x, area_lsm,cellArea, infxswgt, AGGFACTRT, ix,jx) implicit none real, dimension(:,:) :: runoff1x_in, runoff1x, area_lsm, cellArea, infxswgt integer :: i,j,ix,jx,AGGFACYRT, AGGFACXRT, AGGFACTRT, IXXRT, JYYRT do J=1,JX - do I=1,IX - do AGGFACYRT=AGGFACTRT-1,0,-1 - do AGGFACXRT=AGGFACTRT-1,0,-1 - IXXRT=I*AGGFACTRT-AGGFACXRT - JYYRT=J*AGGFACTRT-AGGFACYRT + do I=1,IX + do AGGFACYRT=AGGFACTRT-1,0,-1 + do AGGFACXRT=AGGFACTRT-1,0,-1 + IXXRT=I*AGGFACTRT-AGGFACXRT + JYYRT=J*AGGFACTRT-AGGFACYRT #ifdef MPP_LAND - if(left_id.ge.0) IXXRT=IXXRT+1 - if(down_id.ge.0) JYYRT=JYYRT+1 + if(left_id.ge.0) IXXRT=IXXRT+1 + if(down_id.ge.0) JYYRT=JYYRT+1 #endif !DJG Implement subgrid weighting routine... - if( (runoff1x_in(i,j) .lt. 0) .or. (runoff1x_in(i,j) .gt. 1000) ) then - runoff1x(IXXRT,JYYRT) = 0 - else - runoff1x(IXXRT,JYYRT)=runoff1x_in(i,j)*area_lsm(I,J) & - *INFXSWGT(IXXRT,JYYRT)/cellArea(IXXRT,JYYRT) - endif - - enddo - enddo - enddo + if( (runoff1x_in(i,j) .lt. 0) .or. (runoff1x_in(i,j) .gt. 1000) ) then + runoff1x(IXXRT,JYYRT) = 0 + else + runoff1x(IXXRT,JYYRT)=runoff1x_in(i,j)*area_lsm(I,J) & + *INFXSWGT(IXXRT,JYYRT)/cellArea(IXXRT,JYYRT) + endif + + enddo + enddo + enddo enddo - end subroutine RunOffDisag + end subroutine RunOffDisag ! This routine was extracted from the aggregateDomain routine above to do simple depth aggregation. ! There might be a simpler way. -subroutine RunoffAggregate(runoff_in, runoff_out, aggfactrt, ix, jx) - implicit none - ! Input variables - integer, intent(in) :: aggfactrt, ix, jx - real, intent(in), dimension(:,:) :: runoff_in - real, intent(inout), dimension(:,:) :: runoff_out - ! Local variables - integer :: i, j, aggfacyrt, aggfacxrt, ixxrt, jyyrt - real :: runoffagg - do j=1,jx - do i=1,ix - runoffagg = 0. - do aggfacyrt=aggfactrt-1,0,-1 - do aggfacxrt=aggfactrt-1,0,-1 - ixxrt = i * aggfactrt - aggfacxrt - jyyrt = j * aggfactrt - aggfacyrt + subroutine RunoffAggregate(runoff_in, runoff_out, aggfactrt, ix, jx) + implicit none +! Input variables + integer, intent(in) :: aggfactrt, ix, jx + real, intent(in), dimension(:,:) :: runoff_in + real, intent(inout), dimension(:,:) :: runoff_out +! Local variables + integer :: i, j, aggfacyrt, aggfacxrt, ixxrt, jyyrt + real :: runoffagg + do j=1,jx + do i=1,ix + runoffagg = 0. + do aggfacyrt=aggfactrt-1,0,-1 + do aggfacxrt=aggfactrt-1,0,-1 + ixxrt = i * aggfactrt - aggfacxrt + jyyrt = j * aggfactrt - aggfacyrt #ifdef MPP_LAND - if(left_id.ge.0) ixxrt = ixxrt+1 - if(down_id.ge.0) jyyrt = jyyrt+1 -#endif - runoffagg = runoffagg + runoff_in(ixxrt,jyyrt) - end do - end do - runoff_out(i,j) = runoffagg / (aggfactrt**2) - end do -end do -end subroutine RunoffAggregate - -subroutine HYDRO_ini(ntime, did,ix0,jx0, vegtyp,soltyp) -implicit none -integer ntime, did -integer rst_out, ix,jx + if(left_id.ge.0) ixxrt = ixxrt+1 + if(down_id.ge.0) jyyrt = jyyrt+1 +#endif + runoffagg = runoffagg + runoff_in(ixxrt,jyyrt) + end do + end do + runoff_out(i,j) = runoffagg / (aggfactrt**2) + end do + end do + end subroutine RunoffAggregate + + subroutine HYDRO_ini(ntime, did,ix0,jx0, vegtyp,soltyp) + implicit none + integer ntime, did + integer rst_out, ix,jx ! integer, OPTIONAL:: ix0,jx0 -integer:: ix0,jx0 -integer, dimension(ix0,jx0),optional :: vegtyp, soltyp -integer :: iret, ncid, ascIndId + integer:: ix0,jx0 + integer, dimension(ix0,jx0),optional :: vegtyp, soltyp + integer :: iret, ncid, ascIndId @@ -1379,120 +1362,120 @@ subroutine HYDRO_ini(ntime, did,ix0,jx0, vegtyp,soltyp) !call read_rt_nlst(nlst(did) ) ! Some field of this structure are already initialized by the CPL component (e.g. DT) -call orchestrator%config%init_nlst(did) + call orchestrator%config%init_nlst(did) -if(nlst(did)%rtFlag .eq. 0) return + if(nlst(did)%rtFlag .eq. 0) return !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! get the dimension -call get_file_dimension(trim(nlst(did)%geo_static_flnm), ix,jx) + call get_file_dimension(trim(nlst(did)%geo_static_flnm), ix,jx) #ifdef MPP_LAND -if (nlst(did)%sys_cpl .eq. 1 .or. nlst(did)%sys_cpl .eq. 4) then - !sys_cpl: 1-- coupling with HRLDAS but running offline lsm; - ! 2-- coupling with WRF but do not run offline lsm - ! 3-- coupling with LIS and do not run offline lsm - ! 4: coupling with CLM + if (nlst(did)%sys_cpl .eq. 1 .or. nlst(did)%sys_cpl .eq. 4) then +!sys_cpl: 1-- coupling with HRLDAS but running offline lsm; +! 2-- coupling with WRF but do not run offline lsm +! 3-- coupling with LIS and do not run offline lsm +! 4: coupling with CLM - ! create 2 dimensiaon logical mapping of the CPUs for coupling with CLM or HRLDAS. - call log_map2d() +! create 2 dimensiaon logical mapping of the CPUs for coupling with CLM or HRLDAS. + call log_map2d() - global_nx = ix ! get from land model - global_ny = jx ! get from land model + global_nx = ix ! get from land model + global_ny = jx ! get from land model - call mpp_land_bcast_int1(global_nx) - call mpp_land_bcast_int1(global_ny) + call mpp_land_bcast_int1(global_nx) + call mpp_land_bcast_int1(global_ny) !!! temp set global_nx to ix - rt_domain(did)%ix = global_nx - rt_domain(did)%jx = global_ny + rt_domain(did)%ix = global_nx + rt_domain(did)%jx = global_ny - ! over write the ix and jx - call MPP_LAND_PAR_INI(1,rt_domain(did)%ix,rt_domain(did)%jx,& - nlst(did)%AGGFACTRT) -else - ! coupled with WRF, LIS - numprocs = node_info(1,1) +! over write the ix and jx + call MPP_LAND_PAR_INI(1,rt_domain(did)%ix,rt_domain(did)%jx,& + nlst(did)%AGGFACTRT) + else +! coupled with WRF, LIS + numprocs = node_info(1,1) - call wrf_LAND_set_INIT(node_info,numprocs,nlst(did)%AGGFACTRT) + call wrf_LAND_set_INIT(node_info,numprocs,nlst(did)%AGGFACTRT) - rt_domain(did)%ix = local_nx - rt_domain(did)%jx = local_ny -endif + rt_domain(did)%ix = local_nx + rt_domain(did)%jx = local_ny + endif -rt_domain(did)%g_IXRT=global_rt_nx -rt_domain(did)%g_JXRT=global_rt_ny -rt_domain(did)%ixrt = local_rt_nx -rt_domain(did)%jxrt = local_rt_ny + rt_domain(did)%g_IXRT=global_rt_nx + rt_domain(did)%g_JXRT=global_rt_ny + rt_domain(did)%ixrt = local_rt_nx + rt_domain(did)%jxrt = local_rt_ny #ifdef HYDRO_D #ifndef NCEP_WCOSS -write(6,*) "rt_domain(did)%g_IXRT, rt_domain(did)%g_JXRT, rt_domain(did)%ixrt, rt_domain(did)%jxrt" -write(6,*) rt_domain(did)%g_IXRT, rt_domain(did)%g_JXRT, rt_domain(did)%ixrt, rt_domain(did)%jxrt -write(6,*) "rt_domain(did)%ix, rt_domain(did)%jx " -write(6,*) rt_domain(did)%ix, rt_domain(did)%jx -write(6,*) "global_nx, global_ny, local_nx, local_ny" -write(6,*) global_nx, global_ny, local_nx, local_ny + write(6,*) "rt_domain(did)%g_IXRT, rt_domain(did)%g_JXRT, rt_domain(did)%ixrt, rt_domain(did)%jxrt" + write(6,*) rt_domain(did)%g_IXRT, rt_domain(did)%g_JXRT, rt_domain(did)%ixrt, rt_domain(did)%jxrt + write(6,*) "rt_domain(did)%ix, rt_domain(did)%jx " + write(6,*) rt_domain(did)%ix, rt_domain(did)%jx + write(6,*) "global_nx, global_ny, local_nx, local_ny" + write(6,*) global_nx, global_ny, local_nx, local_ny #else -write(78,*) "rt_domain(did)%g_IXRT, rt_domain(did)%g_JXRT, rt_domain(did)%ixrt, rt_domain(did)%jxrt" -write(78,*) rt_domain(did)%g_IXRT, rt_domain(did)%g_JXRT, rt_domain(did)%ixrt, rt_domain(did)%jxrt -write(78,*) "rt_domain(did)%ix, rt_domain(did)%jx " -write(78,*) rt_domain(did)%ix, rt_domain(did)%jx -write(78,*) "global_nx, global_ny, local_nx, local_ny" -write(78,*) global_nx, global_ny, local_nx, local_ny + write(78,*) "rt_domain(did)%g_IXRT, rt_domain(did)%g_JXRT, rt_domain(did)%ixrt, rt_domain(did)%jxrt" + write(78,*) rt_domain(did)%g_IXRT, rt_domain(did)%g_JXRT, rt_domain(did)%ixrt, rt_domain(did)%jxrt + write(78,*) "rt_domain(did)%ix, rt_domain(did)%jx " + write(78,*) rt_domain(did)%ix, rt_domain(did)%jx + write(78,*) "global_nx, global_ny, local_nx, local_ny" + write(78,*) global_nx, global_ny, local_nx, local_ny #endif #endif #else ! sequential -rt_domain(did)%ix = ix -rt_domain(did)%jx = jx -rt_domain(did)%ixrt = ix*nlst(did)%AGGFACTRT -rt_domain(did)%jxrt = jx*nlst(did)%AGGFACTRT + rt_domain(did)%ix = ix + rt_domain(did)%jx = jx + rt_domain(did)%ixrt = ix*nlst(did)%AGGFACTRT + rt_domain(did)%jxrt = jx*nlst(did)%AGGFACTRT #endif ! allocate rt arrays -call getChanDim(did) + call getChanDim(did) #ifdef HYDRO_D #ifndef NCEP_WCOSS -write(6,*) "finish getChanDim " + write(6,*) "finish getChanDim " #else -write(78,*) "finish getChanDim " + write(78,*) "finish getChanDim " #endif #endif ! ADCHANGE: get global attributes ! need to set these after getChanDim since it allocates rt_domain vals to 0 - call get_file_globalatts(trim(nlst(did)%geo_static_flnm), & - rt_domain(did)%iswater, rt_domain(did)%islake, rt_domain(did)%isurban, rt_domain(did)%isoilwater) + call get_file_globalatts(trim(nlst(did)%geo_static_flnm), & + rt_domain(did)%iswater, rt_domain(did)%islake, rt_domain(did)%isurban, rt_domain(did)%isoilwater) #ifdef HYDRO_D #ifndef NCEP_WCOSS - write(6,*) "hydro_ini: rt_domain(did)%iswater, rt_domain(did)%islake, rt_domain(did)%isurban, rt_domain(did)%isoilwater" - write(6,*) rt_domain(did)%iswater, rt_domain(did)%islake, rt_domain(did)%isurban, rt_domain(did)%isoilwater + write(6,*) "hydro_ini: rt_domain(did)%iswater, rt_domain(did)%islake, rt_domain(did)%isurban, rt_domain(did)%isoilwater" + write(6,*) rt_domain(did)%iswater, rt_domain(did)%islake, rt_domain(did)%isurban, rt_domain(did)%isoilwater #endif #endif -if(nlst(did)%GWBASESWCRT .eq. 3 ) then - call gw2d_allocate(did,& - rt_domain(did)%ixrt,& - rt_domain(did)%jxrt,& - nlst(did)%nsoil) + if(nlst(did)%GWBASESWCRT .eq. 3 ) then + call gw2d_allocate(did,& + rt_domain(did)%ixrt,& + rt_domain(did)%jxrt,& + nlst(did)%nsoil) #ifdef HYDRO_D #ifndef NCEP_WCOSS - write(6,*) "finish gw2d_allocate" + write(6,*) "finish gw2d_allocate" #else - write(78,*) "finish gw2d_allocate" + write(78,*) "finish gw2d_allocate" #endif #endif -endif + endif ! calculate the distance between grids for routing. ! decompose the land parameter/data @@ -1500,104 +1483,104 @@ subroutine HYDRO_ini(ntime, did,ix0,jx0, vegtyp,soltyp) ! ix0= rt_domain(did)%ix ! jx0= rt_domain(did)%jx -if(nlst(did)%channel_only .eq. 0 .and. nlst(did)%channelBucket_only .eq. 0) then - if(present(vegtyp)) then - call lsm_input(did,ix0=ix0,jx0=jx0,vegtyp0=vegtyp,soltyp0=soltyp) - else - call lsm_input(did,ix0=ix0,jx0=jx0) - endif -endif + if(nlst(did)%channel_only .eq. 0 .and. nlst(did)%channelBucket_only .eq. 0) then + if(present(vegtyp)) then + call lsm_input(did,ix0=ix0,jx0=jx0,vegtyp0=vegtyp,soltyp0=soltyp) + else + call lsm_input(did,ix0=ix0,jx0=jx0) + endif + endif #ifdef HYDRO_D #ifndef NCEP_WCOSS -write(6,*) "finish decomposion" + write(6,*) "finish decomposion" #else -write(78,*) "finish decomposion" -#endif -#endif - -if((nlst(did)%channel_only .eq. 1 .or. nlst(did)%channelBucket_only .eq. 1) .and. & - nlst(1)%io_form_outputs .ne. 0) then - !! This is the "decoder ring" for reading channel-only forcing from io_form_outputs=1,2 CHRTOUT files. - !! Only needed on io_id - if(my_id .eq. io_id) then - allocate(rt_domain(did)%ascendIndex(rt_domain(did)%gnlinksl)) - iret = nf90_open(trim(nlst(1)%route_link_f),NF90_NOWRITE,ncid=ncid) - !if(iret .ne. 0) call hdyro_stop - if(iret .ne. 0) call hydro_stop('ERROR: Unable to open RouteLink file for index extraction') - iret = nf90_inq_varid(ncid,'ascendingIndex',ascIndId) - if(iret .ne. 0) call hydro_stop('ERROR: Unable to find ascendingIndex from RouteLink file.') - iret = nf90_get_var(ncid,ascIndId,rt_domain(did)%ascendIndex) - if(iret .ne. 0) call hydro_stop('ERROR: Unable to extract ascendingIndex from RouteLink file.') - iret = nf90_close(ncid) - if(iret .ne. 0) call hydro_stop('ERROR: Unable to close RouteLink file.') - else - allocate(rt_domain(did)%ascendIndex(1)) - rt_domain(did)%ascendIndex(1)=-9 - endif -endif - - -call get_dist_lsm(did) !! always needed (channel_only and channelBucket_only) -if(nlst(did)%channel_only .ne. 1) call get_dist_lrt(did) !! needed forchannelBucket_only + write(78,*) "finish decomposion" +#endif +#endif + + if((nlst(did)%channel_only .eq. 1 .or. nlst(did)%channelBucket_only .eq. 1) .and. & + nlst(1)%io_form_outputs .ne. 0) then +!! This is the "decoder ring" for reading channel-only forcing from io_form_outputs=1,2 CHRTOUT files. +!! Only needed on io_id + if(my_id .eq. io_id) then + allocate(rt_domain(did)%ascendIndex(rt_domain(did)%gnlinksl)) + iret = nf90_open(trim(nlst(1)%route_link_f),NF90_NOWRITE,ncid=ncid) +!if(iret .ne. 0) call hdyro_stop + if(iret .ne. 0) call hydro_stop('ERROR: Unable to open RouteLink file for index extraction') + iret = nf90_inq_varid(ncid,'ascendingIndex',ascIndId) + if(iret .ne. 0) call hydro_stop('ERROR: Unable to find ascendingIndex from RouteLink file.') + iret = nf90_get_var(ncid,ascIndId,rt_domain(did)%ascendIndex) + if(iret .ne. 0) call hydro_stop('ERROR: Unable to extract ascendingIndex from RouteLink file.') + iret = nf90_close(ncid) + if(iret .ne. 0) call hydro_stop('ERROR: Unable to close RouteLink file.') + else + allocate(rt_domain(did)%ascendIndex(1)) + rt_domain(did)%ascendIndex(1)=-9 + endif + endif + + + call get_dist_lsm(did) !! always needed (channel_only and channelBucket_only) + if(nlst(did)%channel_only .ne. 1) call get_dist_lrt(did) !! needed forchannelBucket_only ! rt model initilization -call LandRT_ini(did) + call LandRT_ini(did) -if(nlst(did)%GWBASESWCRT .eq. 3 ) then + if(nlst(did)%GWBASESWCRT .eq. 3 ) then - call gw2d_ini(did,& - nlst(did)%dt,& - nlst(did)%dxrt0) + call gw2d_ini(did,& + nlst(did)%dt,& + nlst(did)%dxrt0) #ifdef HYDRO_D #ifndef NCEP_WCOSS - write(6,*) "finish gw2d_ini" + write(6,*) "finish gw2d_ini" #else - write(78,*) "finish gw2d_ini" + write(78,*) "finish gw2d_ini" #endif #endif -endif + endif #ifdef HYDRO_D #ifndef NCEP_WCOSS -write(6,*) "finish LandRT_ini" + write(6,*) "finish LandRT_ini" #else -write(78,*) "finish LandRT_ini" + write(78,*) "finish LandRT_ini" #endif #endif !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -if(nlst(did)%channel_only .eq. 0 .and. nlst(did)%channelBucket_only .eq. 0) then + if(nlst(did)%channel_only .eq. 0 .and. nlst(did)%channelBucket_only .eq. 0) then - if (nlst(did)%TERADJ_SOLAR.eq.1 .and. nlst(did)%CHANRTSWCRT.ne.2) then ! Perform ter rain adjustment of incoming solar + if (nlst(did)%TERADJ_SOLAR.eq.1 .and. nlst(did)%CHANRTSWCRT.ne.2) then ! Perform ter rain adjustment of incoming solar #ifdef MPP_LAND - call MPP_seq_land_SO8(rt_domain(did)%SO8LD_D,rt_domain(did)%SO8LD_Vmax,& - rt_domain(did)%TERRAIN, rt_domain(did)%dist_lsm,& - rt_domain(did)%ix,rt_domain(did)%jx,global_nx,global_ny) + call MPP_seq_land_SO8(rt_domain(did)%SO8LD_D,rt_domain(did)%SO8LD_Vmax,& + rt_domain(did)%TERRAIN, rt_domain(did)%dist_lsm,& + rt_domain(did)%ix,rt_domain(did)%jx,global_nx,global_ny) #else - call seq_land_SO8(rt_domain(did)%SO8LD_D,rt_domain(did)%SO8LD_Vmax,& - rt_domain(did)%TERRAIN,rt_domain(did)%dist_lsm,& - rt_domain(did)%ix,rt_domain(did)%jx) + call seq_land_SO8(rt_domain(did)%SO8LD_D,rt_domain(did)%SO8LD_Vmax,& + rt_domain(did)%TERRAIN,rt_domain(did)%dist_lsm,& + rt_domain(did)%ix,rt_domain(did)%jx) #endif - endif -endif + endif + endif -if (nlst(did)%GWBASESWCRT .gt. 0) then - if(nlst(did)%UDMP_OPT .eq. 1) then - call get_basn_area_nhd(rt_domain(did)%basns_area) - else - call get_basn_area(did) - endif -endif + if (nlst(did)%GWBASESWCRT .gt. 0) then + if(nlst(did)%UDMP_OPT .eq. 1) then + call get_basn_area_nhd(rt_domain(did)%basns_area) + else + call get_basn_area(did) + endif + endif -if (nlst(did)%CHANRTSWCRT.eq.1 .or. nlst(did)%CHANRTSWCRT .eq. 2 ) then - call get_node_area(did) -endif + if (nlst(did)%CHANRTSWCRT.eq.1 .or. nlst(did)%CHANRTSWCRT .eq. 2 ) then + call get_node_area(did) + endif #ifdef WRF_HYDRO_NUDGING -if(nlst(did)%CHANRTSWCRT .ne. 0) call init_stream_nudging + if(nlst(did)%CHANRTSWCRT .ne. 0) call init_stream_nudging #endif @@ -1609,18 +1592,18 @@ subroutine HYDRO_ini(ntime, did,ix0,jx0, vegtyp,soltyp) ! restart the file - ! jummp the initial time output +! jummp the initial time output ! rt_domain(did)%out_counts = rt_domain(did)%out_counts + 1 ! rt_domain(did)%his_out_counts = rt_domain(did)%his_out_counts + 1 -call HYDRO_rst_in(did) + call HYDRO_rst_in(did) !#ifdef HYDRO_REALTIME -if (trim(nlst(did)%restart_file) == "") then - call HYDRO_out(did, 0) -else - call HYDRO_out(did, 1) -endif + if (trim(nlst(did)%restart_file) == "") then + call HYDRO_out(did, 0) + else + call HYDRO_out(did, 1) + endif !! JLM: This is only currently part 1/2 of a better accumulation tracking strategy. !! The parts: !! 1) (this) zero accumulations on restart/init after any t=0 outputs are written. @@ -1630,25 +1613,25 @@ subroutine HYDRO_ini(ntime, did,ix0,jx0, vegtyp,soltyp) !! This was previously done in HYDRO_rst_in and so output accumulations at time !! zero were getting zeroed and then writtent to file, which looses information. !! Note that nlst_rt(did)%rstrt_swc is not changed at any point in between here and the rst_in. -if(nlst(did)%rstrt_swc.eq.1) then !Switch for rest of restart accum vars... - print *, "Resetting RESTART Accumulation Variables to 0...",nlst(did)%rstrt_swc - ! Under channel-only , these first three variables are not allocated. - if(allocated(rt_domain(did)%overland%streams_and_lakes%surface_water_to_lake)) rt_domain(did)%overland%streams_and_lakes%surface_water_to_lake = zeroFlt - if(allocated(rt_domain(did)%QSTRMVOLRT_ACC)) rt_domain(did)%QSTRMVOLRT_ACC = zeroFlt - ! These variables are optionally allocated, if their output is requested. - if(allocated(rt_domain(did)%accSfcLatRunoff)) rt_domain(did)%accSfcLatRunoff = zeroDbl - if(allocated(rt_domain(did)%accBucket)) rt_domain(did)%accBucket = zeroDbl -end if - -end subroutine HYDRO_ini - - subroutine lsm_input(did,ix0,jx0,vegtyp0,soltyp0) - implicit none - integer did, leng, ncid, ierr_flg - parameter(leng=100) - integer :: i,j, nn - integer, allocatable, dimension(:,:) :: soltyp - real, dimension(leng) :: xdum1, MAXSMC,refsmc,wltsmc + if(nlst(did)%rstrt_swc.eq.1) then !Switch for reset of restart accum vars... + print *, "Resetting RESTART Accumulation Variables to 0...",nlst(did)%rstrt_swc +! Under channel-only , these first three variables are not allocated. + if(allocated(rt_domain(did)%overland%streams_and_lakes%surface_water_to_lake)) rt_domain(did)%overland%streams_and_lakes%surface_water_to_lake = zeroFlt + if(allocated(rt_domain(did)%QSTRMVOLRT_ACC)) rt_domain(did)%QSTRMVOLRT_ACC = zeroFlt +! These variables are optionally allocated, if their output is requested. + if(allocated(rt_domain(did)%accSfcLatRunoff)) rt_domain(did)%accSfcLatRunoff = zeroDbl + if(allocated(rt_domain(did)%accBucket)) rt_domain(did)%accBucket = zeroDbl + end if + + end subroutine HYDRO_ini + + subroutine lsm_input(did,ix0,jx0,vegtyp0,soltyp0) + implicit none + integer did, leng, ncid, ierr_flg + parameter(leng=100) + integer :: i,j, nn + integer, allocatable, dimension(:,:) :: soltyp + real, dimension(leng) :: xdum1, MAXSMC,refsmc,wltsmc integer :: ix0,jx0 integer, dimension(ix0,jx0),OPTIONAL :: vegtyp0, soltyp0 @@ -1656,200 +1639,194 @@ subroutine lsm_input(did,ix0,jx0,vegtyp0,soltyp0) #ifdef HYDRO_D #ifndef NCEP_WCOSS - write(6,*) RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx + write(6,*) RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx #else - write(78,*) RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx + write(78,*) RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx #endif #endif - allocate(soltyp(RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx) ) + allocate(soltyp(RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx) ) - soltyp = 0 - call get2d_lsm_soltyp(soltyp,RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,trim(nlst(did)%geo_static_flnm)) + soltyp = 0 + call get2d_lsm_soltyp(soltyp,RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,trim(nlst(did)%geo_static_flnm)) - call get2d_lsm_real("HGT",RT_DOMAIN(did)%TERRAIN,RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,trim(nlst(did)%geo_static_flnm)) + call get2d_lsm_real("HGT",RT_DOMAIN(did)%TERRAIN,RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,trim(nlst(did)%geo_static_flnm)) - call get2d_lsm_real("XLAT",RT_DOMAIN(did)%lat_lsm,RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,trim(nlst(did)%geo_static_flnm)) - call get2d_lsm_real("XLONG",RT_DOMAIN(did)%lon_lsm,RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,trim(nlst(did)%geo_static_flnm)) - call get2d_lsm_vegtyp(RT_DOMAIN(did)%VEGTYP,RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,trim(nlst(did)%geo_static_flnm)) + call get2d_lsm_real("XLAT",RT_DOMAIN(did)%lat_lsm,RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,trim(nlst(did)%geo_static_flnm)) + call get2d_lsm_real("XLONG",RT_DOMAIN(did)%lon_lsm,RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,trim(nlst(did)%geo_static_flnm)) + call get2d_lsm_vegtyp(RT_DOMAIN(did)%VEGTYP,RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,trim(nlst(did)%geo_static_flnm)) - if(nlst(did)%sys_cpl .eq. 2 ) then - ! coupling with WRF - if(present(soltyp0) ) then - where(VEGTYP0 == rt_domain(did)%iswater .or. VEGTYP0 == rt_domain(did)%islake) soltyp0 = rt_domain(did)%isoilwater - where(soltyp0 == rt_domain(did)%isoilwater) VEGTYP0 = rt_domain(did)%iswater - soltyp = soltyp0 - RT_DOMAIN(did)%VEGTYP = VEGTYP0 - endif + if(nlst(did)%sys_cpl .eq. 2 ) then +! coupling with WRF + if(present(soltyp0) ) then + where(VEGTYP0 == rt_domain(did)%iswater .or. VEGTYP0 == rt_domain(did)%islake) soltyp0 = rt_domain(did)%isoilwater + where(soltyp0 == rt_domain(did)%isoilwater) VEGTYP0 = rt_domain(did)%iswater + soltyp = soltyp0 + RT_DOMAIN(did)%VEGTYP = VEGTYP0 endif + endif - where(RT_DOMAIN(did)%VEGTYP == rt_domain(did)%iswater .or. RT_DOMAIN(did)%VEGTYP == rt_domain(did)%islake) soltyp = rt_domain(did)%isoilwater - where(soltyp == rt_domain(did)%isoilwater) RT_DOMAIN(did)%VEGTYP = rt_domain(did)%iswater + where(RT_DOMAIN(did)%VEGTYP == rt_domain(did)%iswater .or. RT_DOMAIN(did)%VEGTYP == rt_domain(did)%islake) soltyp = rt_domain(did)%isoilwater + where(soltyp == rt_domain(did)%isoilwater) RT_DOMAIN(did)%VEGTYP = rt_domain(did)%iswater ! LKSAT, ! temporary set - RT_DOMAIN(did)%SMCRTCHK = 0 - RT_DOMAIN(did)%SMCAGGRT = 0 - RT_DOMAIN(did)%STCAGGRT = 0 - RT_DOMAIN(did)%SH2OAGGRT = 0 + RT_DOMAIN(did)%SMCRTCHK = 0 + RT_DOMAIN(did)%SMCAGGRT = 0 + RT_DOMAIN(did)%STCAGGRT = 0 + RT_DOMAIN(did)%SH2OAGGRT = 0 - rt_domain(did)%subsurface%properties%zsoil(1:nlst(did)%nsoil) = nlst(did)%zsoil8(1:nlst(did)%nsoil) + rt_domain(did)%subsurface%properties%zsoil(1:nlst(did)%nsoil) = nlst(did)%zsoil8(1:nlst(did)%nsoil) - rt_domain(did)%subsurface%properties%sldpth(1) = abs( RT_DOMAIN(did)%subsurface%properties%zsoil(1) ) - do i = 2, nlst(did)%nsoil - rt_domain(did)%subsurface%properties%sldpth(i) = RT_DOMAIN(did)%subsurface%properties%zsoil(i-1)-RT_DOMAIN(did)%subsurface%properties%zsoil(i) - enddo - rt_domain(did)%subsurface%properties%soldeprt = -1.0*RT_DOMAIN(did)%subsurface%properties%zsoil(nlst(did)%NSOIL) + rt_domain(did)%subsurface%properties%sldpth(1) = abs( RT_DOMAIN(did)%subsurface%properties%zsoil(1) ) + do i = 2, nlst(did)%nsoil + rt_domain(did)%subsurface%properties%sldpth(i) = RT_DOMAIN(did)%subsurface%properties%zsoil(i-1)-RT_DOMAIN(did)%subsurface%properties%zsoil(i) + enddo + rt_domain(did)%subsurface%properties%soldeprt = -1.0*RT_DOMAIN(did)%subsurface%properties%zsoil(nlst(did)%NSOIL) - ierr_flg = 99 - if(trim(nlst(did)%hydrotbl_f) == "") then - call hydro_stop("FATAL ERROR: hydrotbl_f is empty. Please input a netcdf file. ") - endif + ierr_flg = 99 + if(trim(nlst(did)%hydrotbl_f) == "") then + call hydro_stop("FATAL ERROR: hydrotbl_f is empty. Please input a netcdf file. ") + endif #ifdef MPP_LAND - if(my_id .eq. IO_id) then + if(my_id .eq. IO_id) then #endif - ierr_flg = nf90_open(trim(nlst(did)%hydrotbl_f), nf90_NOWRITE, ncid) + ierr_flg = nf90_open(trim(nlst(did)%hydrotbl_f), nf90_NOWRITE, ncid) #ifdef MPP_LAND - endif - call mpp_land_bcast_int1(ierr_flg) + endif + call mpp_land_bcast_int1(ierr_flg) #endif - if( ierr_flg .ne. 0) then - ! input from HYDRO.tbl FILE + if( ierr_flg .ne. 0) then +! input from HYDRO.tbl FILE ! input OV_ROUGH from OVROUGH.TBL #ifdef MPP_LAND - if(my_id .eq. IO_id) then + if(my_id .eq. IO_id) then #endif #ifndef NCEP_WCOSS - open(71,file="HYDRO.TBL", form="formatted") + open(71,file="HYDRO.TBL", form="formatted") !read OV_ROUGH first - read(71,*) nn - read(71,*) - do i = 1, nn - read(71,*) RT_DOMAIN(did)%OV_ROUGH(i) - end do + read(71,*) nn + read(71,*) + do i = 1, nn + read(71,*) RT_DOMAIN(did)%OV_ROUGH(i) + end do !read parameter for LKSAT - read(71,*) nn - read(71,*) - do i = 1, nn - read(71,*) xdum1(i), MAXSMC(i),refsmc(i),wltsmc(i) - end do - close(71) + read(71,*) nn + read(71,*) + do i = 1, nn + read(71,*) xdum1(i), MAXSMC(i),refsmc(i),wltsmc(i) + end do + close(71) #else - open(13, form="formatted") + open(13, form="formatted") !read OV_ROUGH first - read(13,*) nn - read(13,*) - do i = 1, nn - read(13,*) RT_DOMAIN(did)%OV_ROUGH(i) - end do + read(13,*) nn + read(13,*) + do i = 1, nn + read(13,*) RT_DOMAIN(did)%OV_ROUGH(i) + end do !read parameter for LKSAT - read(13,*) nn - read(13,*) - do i = 1, nn - read(13,*) xdum1(i), MAXSMC(i),refsmc(i),wltsmc(i) - end do - close(13) + read(13,*) nn + read(13,*) + do i = 1, nn + read(13,*) xdum1(i), MAXSMC(i),refsmc(i),wltsmc(i) + end do + close(13) #endif #ifdef MPP_LAND - endif - call mpp_land_bcast_real(leng,RT_DOMAIN(did)%OV_ROUGH) - call mpp_land_bcast_real(leng,xdum1) - call mpp_land_bcast_real(leng,MAXSMC) - call mpp_land_bcast_real(leng,refsmc) - call mpp_land_bcast_real(leng,wltsmc) -#endif - - rt_domain(did)%lksat = 0.0 - do j = 1, RT_DOMAIN(did)%jx - do i = 1, RT_DOMAIN(did)%ix - !yw rt_domain(did)%lksat(i,j) = xdum1(soltyp(i,j) ) * 1000.0 - rt_domain(did)%lksat(i,j) = xdum1(soltyp(i,j) ) - rt_domain(did)%SMCMAX1(i,j) = MAXSMC(soltyp(I,J)) - rt_domain(did)%SMCREF1(i,j) = refsmc(soltyp(I,J)) - rt_domain(did)%SMCWLT1(i,j) = wltsmc(soltyp(I,J)) - !ADCHANGE: Add some sanity checks in case calibration knocks the order of these out of sequence. - !The min diffs were pulled from the existing HYDRO.TBL defaults. - !Currently water is 0, so enforcing 0 as the absolute min. - rt_domain(did)%SMCMAX1(i,j) = min(rt_domain(did)%SMCMAX1(i,j), 1.0) - rt_domain(did)%SMCREF1(i,j) = max(min(rt_domain(did)%SMCREF1(i,j), rt_domain(did)%SMCMAX1(i,j) - 0.01), 0.0) - rt_domain(did)%SMCWLT1(i,j) = max(min(rt_domain(did)%SMCWLT1(i,j), rt_domain(did)%SMCREF1(i,j) - 0.01), 0.0) - IF(rt_domain(did)%VEGTYP(i,j) > 0 ) THEN ! created 2d ov_rough - rt_domain(did)%OV_ROUGH2d(i,j) = RT_DOMAIN(did)%OV_ROUGH(rt_domain(did)%VEGTYP(I,J)) - endif - end do - end do - - call hdtbl_out(did) - else - ! input from HYDRO.TBL.nc file - print*, "reading from hydrotbl_f(HYDRO.TBL.nc) file ...." - call hdtbl_in_nc(did) - if (noah_lsm%imperv_option .eq. 9) then - !ADCHANGE: For consistency, mirror urban and param value checks used in table read - where (rt_domain(did)%VEGTYP == rt_domain(did)%isurban) - rt_domain(did)%SMCMAX1 = 0.45 - rt_domain(did)%SMCREF1 = 0.42 - rt_domain(did)%SMCWLT1 = 0.40 - endwhere - endif - where (rt_domain(did)%SMCMAX1 .gt. 1.0) rt_domain(did)%SMCMAX1 = 1.0 - rt_domain(did)%SMCREF1 = max(min(rt_domain(did)%SMCREF1, rt_domain(did)%SMCMAX1 - 0.01), 0.0) - rt_domain(did)%SMCWLT1 = max(min(rt_domain(did)%SMCWLT1, rt_domain(did)%SMCREF1 - 0.01), 0.0) - endif - - rt_domain(did)%soiltyp = soltyp - - if(allocated(soltyp)) deallocate(soltyp) - + endif + call mpp_land_bcast_real(leng,RT_DOMAIN(did)%OV_ROUGH) + call mpp_land_bcast_real(leng,xdum1) + call mpp_land_bcast_real(leng,MAXSMC) + call mpp_land_bcast_real(leng,refsmc) + call mpp_land_bcast_real(leng,wltsmc) +#endif + + rt_domain(did)%lksat = 0.0 + do j = 1, RT_DOMAIN(did)%jx + do i = 1, RT_DOMAIN(did)%ix +!yw rt_domain(did)%lksat(i,j) = xdum1(soltyp(i,j) ) * 1000.0 + rt_domain(did)%lksat(i,j) = xdum1(soltyp(i,j) ) + rt_domain(did)%SMCMAX1(i,j) = MAXSMC(soltyp(I,J)) + rt_domain(did)%SMCREF1(i,j) = refsmc(soltyp(I,J)) + rt_domain(did)%SMCWLT1(i,j) = wltsmc(soltyp(I,J)) +!ADCHANGE: Add some sanity checks in case calibration knocks the order of these out of sequence. +!The min diffs were pulled from the existing HYDRO.TBL defaults. +!Currently water is 0, so enforcing 0 as the absolute min. + rt_domain(did)%SMCMAX1(i,j) = min(rt_domain(did)%SMCMAX1(i,j), 1.0) + rt_domain(did)%SMCREF1(i,j) = max(min(rt_domain(did)%SMCREF1(i,j), rt_domain(did)%SMCMAX1(i,j) - 0.01), 0.0) + rt_domain(did)%SMCWLT1(i,j) = max(min(rt_domain(did)%SMCWLT1(i,j), rt_domain(did)%SMCREF1(i,j) - 0.01), 0.0) + IF(rt_domain(did)%VEGTYP(i,j) > 0 ) THEN ! created 2d ov_rough + rt_domain(did)%OV_ROUGH2d(i,j) = RT_DOMAIN(did)%OV_ROUGH(rt_domain(did)%VEGTYP(I,J)) + endif + end do + end do - end subroutine lsm_input + call hdtbl_out(did) + else +! input from HYDRO.TBL.nc file + print*, "reading from hydrotbl_f(HYDRO.TBL.nc) file ...." + call hdtbl_in_nc(did) + if (noah_lsm%imperv_option .eq. 9) then +!ADCHANGE: For consistency, mirror urban and param value checks used in table read + where (rt_domain(did)%VEGTYP == rt_domain(did)%isurban) + rt_domain(did)%SMCMAX1 = 0.45 + rt_domain(did)%SMCREF1 = 0.42 + rt_domain(did)%SMCWLT1 = 0.40 + endwhere + endif + where (rt_domain(did)%SMCMAX1 .gt. 1.0) rt_domain(did)%SMCMAX1 = 1.0 + rt_domain(did)%SMCREF1 = max(min(rt_domain(did)%SMCREF1, rt_domain(did)%SMCMAX1 - 0.01), 0.0) + rt_domain(did)%SMCWLT1 = max(min(rt_domain(did)%SMCWLT1, rt_domain(did)%SMCREF1 - 0.01), 0.0) + endif + rt_domain(did)%soiltyp = soltyp -end module module_HYDRO_drv + if(allocated(soltyp)) deallocate(soltyp) + end subroutine lsm_input -! stop the job due to the fatal error. -subroutine HYDRO_finish() + subroutine HYDRO_finish() #ifdef MPP_LAND - USE module_mpp_land + use module_mpp_land #endif #ifdef WRF_HYDRO_NUDGING - use module_stream_nudging, only: finish_stream_nudging + use module_stream_nudging, only: finish_stream_nudging #endif - integer :: ierr + integer :: ierr #ifdef WRF_HYDRO_NUDGING - call finish_stream_nudging() + call finish_stream_nudging() #endif #ifndef NCEP_WCOSS - print*, "The model finished successfully......." + print*, "The model finished successfully......." #else - write(78,*) "The model finished successfully......." + write(78,*) "The model finished successfully......." #endif #ifdef MPP_LAND -! call mpp_land_abort() #ifndef NCEP_WCOSS - call flush(6) + call flush(6) #else - call flush(78) - close(78) + call flush(78) + close(78) #endif - call mpp_land_sync() - call MPI_finalize(ierr) - stop + call mpp_land_sync() + call MPI_Finalize(ierr) + stop #else #ifndef WRF_HYDRO_NUDGING - stop !!JLM want to time at the top NoahMP level. + stop !!JLM want to time at the top NoahMP level. #endif #endif + return + end subroutine HYDRO_finish - return -end subroutine HYDRO_finish +end module module_HYDRO_drv diff --git a/hydro/IO/CMakeLists.txt b/hydro/IO/CMakeLists.txt index 3566adc795..fafb14878d 100644 --- a/hydro/IO/CMakeLists.txt +++ b/hydro/IO/CMakeLists.txt @@ -4,6 +4,7 @@ add_library(hydro_netcdf_layer STATIC ) target_link_libraries(hydro_netcdf_layer + PUBLIC MPI::MPI_Fortran netCDF::netcdff ) diff --git a/hydro/IO/netcdf_layer.F90 b/hydro/IO/netcdf_layer.F90 index 850f2e8266..286e9122e0 100644 --- a/hydro/IO/netcdf_layer.F90 +++ b/hydro/IO/netcdf_layer.F90 @@ -43,7 +43,7 @@ end function create_file_signature end type NetCDF_serial_ type, extends(NetCDF_layer_) :: NetCDF_parallel_ - integer :: MPI_communicator + integer :: MPI_Communicator integer :: default_info = MPI_INFO_NULL contains procedure, pass(object) :: create_file => create_file_parallel diff --git a/hydro/MPP/CMakeLists.txt b/hydro/MPP/CMakeLists.txt index 1eb929cc95..d9756c445e 100644 --- a/hydro/MPP/CMakeLists.txt +++ b/hydro/MPP/CMakeLists.txt @@ -6,7 +6,7 @@ add_library(hydro_mpp STATIC hashtable.F90 ) -target_link_libraries(hydro_mpp MPI::MPI_Fortran) +target_link_libraries(hydro_mpp PUBLIC MPI::MPI_Fortran) target_include_directories(hydro_mpp PUBLIC ${MPI_Fortran_MODULE_DIR} ) diff --git a/hydro/MPP/CPL_WRF.F90 b/hydro/MPP/CPL_WRF.F90 index e0e0207870..04332d4113 100644 --- a/hydro/MPP/CPL_WRF.F90 +++ b/hydro/MPP/CPL_WRF.F90 @@ -1,23 +1,3 @@ -! Program Name: -! Author(s)/Contact(s): -! Abstract: -! History Log: -! -! Usage: -! Parameters: -! Input Files: -! -! Output Files: -! -! -! Condition codes: -! -! If appropriate, descriptive troubleshooting instructions or -! likely causes for failures could be mentioned here with the -! appropriate error code -! -! User controllable options: - ! This is used as a coupler with the WRF model. MODULE MODULE_CPL_LAND @@ -67,17 +47,17 @@ subroutine CPL_LAND_INIT(istart,iend,jstart,jend) data cyclic/.false.,.false./ ! not cyclic data reorder/.false./ - CALL mpi_initialized( mpi_inited, ierr ) + call MPI_Initialized( mpi_inited, ierr ) if ( .NOT. mpi_inited ) then - call mpi_init(ierr) - if (ierr /= MPI_SUCCESS) call fatal_error_stop("MPI Error: MPI_INIT failed") - call MPI_COMM_DUP(MPI_COMM_WORLD, HYDRO_COMM_WORLD, ierr) - if (ierr /= MPI_SUCCESS) call fatal_error_stop("MPI Error: MPI_COMM_DUP failed") + call MPI_Init(ierr) + if (ierr /= MPI_SUCCESS) call fatal_error_stop("MPI Error: MPI_Init failed") + call MPI_Comm_dup(MPI_COMM_WORLD, HYDRO_COMM_WORLD, ierr) + if (ierr /= MPI_SUCCESS) call fatal_error_stop("MPI Error: MPI_Comm_dup failed") endif - call MPI_COMM_RANK( HYDRO_COMM_WORLD, my_global_id, ierr ) - call MPI_COMM_SIZE( HYDRO_COMM_WORLD, total_pe_num, ierr ) - if (ierr /= MPI_SUCCESS) call fatal_error_stop("MPI Error: MPI_COMM_RANK and/or MPI_COMM_SIZE failed") + call MPI_Comm_rank( HYDRO_COMM_WORLD, my_global_id, ierr ) + call MPI_Comm_size( HYDRO_COMM_WORLD, total_pe_num, ierr ) + if (ierr /= MPI_SUCCESS) call fatal_error_stop("MPI Error: MPI_Comm_rank and/or MPI_Comm_size failed") allocate(node_info(9,total_pe_num)) @@ -103,12 +83,12 @@ subroutine CPL_LAND_INIT(istart,iend,jstart,jend) dims(0) = 0 dims(1) = 0 do xx=1,total_pe_num - if(node_info(2,xx) .eq. (-1)) then - dims(0) = dims(0)+1 - endif - if(node_info(4,xx) .eq. (-1)) then - dims(1) = dims(1)+1 - endif + if(node_info(2,xx) .eq. (-1)) then + dims(0) = dims(0)+1 + endif + if(node_info(4,xx) .eq. (-1)) then + dims(1) = dims(1)+1 + endif enddo ndim = 2 @@ -118,13 +98,12 @@ subroutine CPL_LAND_INIT(istart,iend,jstart,jend) call MPI_Cart_create(HYDRO_COMM_WORLD, ndim, dims, & cyclic, reorder, cartGridComm, ierr) - call MPI_CART_GET(cartGridComm, 2, dims, cyclic, coords, ierr) + call MPI_Cart_get(cartGridComm, 2, dims, cyclic, coords, ierr) p_up_down = coords(0) p_left_right = coords(1) initialized = .false. ! land model need to be initialized. - return END subroutine CPL_LAND_INIT subroutine send_info() @@ -137,23 +116,22 @@ subroutine send_info() if(my_global_id .eq. 0) then do i = 1, total_pe_num-1 - call mpi_recv(node_info(:,i+1),size,MPI_INTEGER, & + call MPI_Recv(node_info(:,i+1),size,MPI_INTEGER, & i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) enddo else - call mpi_send(node_info(:,my_global_id+1),size, & + call MPI_Send(node_info(:,my_global_id+1),size, & MPI_INTEGER,0,tag,HYDRO_COMM_WORLD,ierr) endif - call MPI_barrier( HYDRO_COMM_WORLD ,ierr) + call MPI_Barrier( HYDRO_COMM_WORLD ,ierr) size = 9 * total_pe_num - call mpi_bcast(node_info,size,MPI_INTEGER, & + call MPI_Bcast(node_info,size,MPI_INTEGER, & 0,HYDRO_COMM_WORLD,ierr) - call MPI_barrier( HYDRO_COMM_WORLD ,ierr) + call MPI_Barrier( HYDRO_COMM_WORLD ,ierr) - return end subroutine send_info subroutine find_left() @@ -170,7 +148,6 @@ subroutine find_left() return endif end do - return end subroutine find_left subroutine find_right() @@ -187,7 +164,6 @@ subroutine find_right() return endif end do - return end subroutine find_right subroutine find_up() @@ -204,7 +180,6 @@ subroutine find_up() return endif end do - return end subroutine find_up subroutine find_down() @@ -221,7 +196,6 @@ subroutine find_down() return endif end do - return end subroutine find_down ! stop the job due to the fatal error. @@ -232,6 +206,5 @@ subroutine fatal_error_stop(msg) call flush(error_unit) CALL MPI_Abort(HYDRO_COMM_WORLD, 1, ierr) call MPI_Finalize(ierr) - return end subroutine fatal_error_stop END MODULE MODULE_CPL_LAND diff --git a/hydro/MPP/module_mpp_GWBUCKET.F90 b/hydro/MPP/module_mpp_GWBUCKET.F90 index 0b121dcf89..a69f800c0c 100644 --- a/hydro/MPP/module_mpp_GWBUCKET.F90 +++ b/hydro/MPP/module_mpp_GWBUCKET.F90 @@ -1,23 +1,3 @@ -! Program Name: -! Author(s)/Contact(s): -! Abstract: -! History Log: -! -! Usage: -! Parameters: -! Input Files: -! -! Output Files: -! -! -! Condition codes: -! -! If appropriate, descriptive troubleshooting instructions or -! likely causes for failures could be mentioned here with the -! appropriate error code -! -! User controllable options: - ! This is used as a coupler with the WRF model. MODULE MODULE_mpp_GWBUCKET @@ -57,7 +37,7 @@ subroutine collectSizeInd(numbasns) if(my_id .ne. IO_id) then tag = 66 - call mpi_send(numbasns,1,MPI_INTEGER, IO_id, & + call MPI_Send(numbasns,1,MPI_INTEGER, IO_id, & tag,HYDRO_COMM_WORLD,ierr) else do i = 0, numprocs - 1 @@ -65,7 +45,7 @@ subroutine collectSizeInd(numbasns) sizeInd(i+1) = numbasns else tag = 66 - call mpi_recv(rcv,1,& + call MPI_Recv(rcv,1,& MPI_INTEGER,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) sizeInd(i+1) = rcv @@ -101,10 +81,10 @@ subroutine gw_write_io_real(numbasns,inV,ind,outV) if(my_id .ne. IO_id) then if(numbasns .gt. 0) then tag = 62 - call mpi_send(inV,numbasns,MPI_REAL, IO_id, & + call MPI_Send(inV,numbasns,MPI_REAL, IO_id, & tag,HYDRO_COMM_WORLD,ierr) tag2 = 63 - call mpi_send(ind,numbasns,MPI_INTEGER8, IO_id, & + call MPI_Send(ind,numbasns,MPI_INTEGER8, IO_id, & tag2,HYDRO_COMM_WORLD,ierr) endif else @@ -117,10 +97,10 @@ subroutine gw_write_io_real(numbasns,inV,ind,outV) if(i .ne. IO_id) then if(sizeInd(i+1) .gt. 0) then tag = 62 - call mpi_recv(vbuff(1:sizeInd(i+1)),sizeInd(i+1),& + call MPI_Recv(vbuff(1:sizeInd(i+1)),sizeInd(i+1),& MPI_REAL,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) tag2 = 63 - call mpi_recv(ibuff(1:sizeInd(i+1)),sizeInd(i+1),& + call MPI_Recv(ibuff(1:sizeInd(i+1)),sizeInd(i+1),& MPI_INTEGER8,i,tag2,HYDRO_COMM_WORLD,mpp_status,ierr) do k = 1, sizeInd(i+1) outV(ibuff(k)) = vbuff(k) @@ -159,10 +139,10 @@ subroutine gw_write_io_int(numbasns,inV,ind,outV) if(my_id .ne. IO_id) then if(numbasns .gt. 0) then tag = 62 - call mpi_send(inV,numbasns,MPI_INTEGER8, IO_id, & + call MPI_Send(inV,numbasns,MPI_INTEGER8, IO_id, & tag,HYDRO_COMM_WORLD,ierr) tag2 = 63 - call mpi_send(ind,numbasns,MPI_INTEGER8, IO_id, & + call MPI_Send(ind,numbasns,MPI_INTEGER8, IO_id, & tag2,HYDRO_COMM_WORLD,ierr) endif else @@ -175,10 +155,10 @@ subroutine gw_write_io_int(numbasns,inV,ind,outV) if(i .ne. IO_id) then if(sizeInd(i+1) .gt. 0) then tag = 62 - call mpi_recv(vbuff(1:sizeInd(i+1)),sizeInd(i+1),& + call MPI_Recv(vbuff(1:sizeInd(i+1)),sizeInd(i+1),& MPI_INTEGER8,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) tag2 = 63 - call mpi_recv(ibuff(1:sizeInd(i+1)),sizeInd(i+1),& + call MPI_Recv(ibuff(1:sizeInd(i+1)),sizeInd(i+1),& MPI_INTEGER8,i,tag2,HYDRO_COMM_WORLD,mpp_status,ierr) do k = 1, sizeInd(i+1) outV(ibuff(k)) = vbuff(k) diff --git a/hydro/MPP/module_mpp_ReachLS.F90 b/hydro/MPP/module_mpp_ReachLS.F90 index ef027c1c33..a5fd079e82 100644 --- a/hydro/MPP/module_mpp_ReachLS.F90 +++ b/hydro/MPP/module_mpp_ReachLS.F90 @@ -1,23 +1,3 @@ -! Program Name: -! Author(s)/Contact(s): -! Abstract: -! History Log: -! -! Usage: -! Parameters: -! Input Files: -! -! Output Files: -! -! -! Condition codes: -! -! If appropriate, descriptive troubleshooting instructions or -! likely causes for failures could be mentioned here with the -! appropriate error code -! -! User controllable options: - ! This is used as a coupler with the WRF model. MODULE MODULE_mpp_ReachLS @@ -102,30 +82,30 @@ subroutine updateLinkV8_mem(LinkV, outV) if(my_id .ne. IO_id) then tag = 101 - call mpi_send(LLINKLEN,1,MPI_INTEGER, IO_id, & + call MPI_Send(LLINKLEN,1,MPI_INTEGER, IO_id, & tag,HYDRO_COMM_WORLD,ierr) if(LLINKLEN .gt. 0) then tag = 102 - call mpi_send(LLINKIDINDX,LLINKLEN,MPI_INTEGER, IO_id, & + call MPI_Send(LLINKIDINDX,LLINKLEN,MPI_INTEGER, IO_id, & tag,HYDRO_COMM_WORLD,ierr) tag = 103 - call mpi_send(LinkV,LLINKLEN,MPI_DOUBLE_PRECISION, IO_id, & + call MPI_Send(LinkV,LLINKLEN,MPI_DOUBLE_PRECISION, IO_id, & tag,HYDRO_COMM_WORLD,ierr) endif else do i = 0, numprocs - 1 if(i .ne. IO_id) then tag = 101 - call mpi_recv(lsize,1,MPI_INTEGER, i, & + call MPI_Recv(lsize,1,MPI_INTEGER, i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) if(lsize .gt. 0) then allocate(lindex(lsize) ) allocate(tmpBuf(lsize) ) tag = 102 - call mpi_recv(lindex,lsize,MPI_INTEGER, i, & + call MPI_Recv(lindex,lsize,MPI_INTEGER, i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) tag = 103 - call mpi_recv(tmpBuf,lsize,& + call MPI_Recv(tmpBuf,lsize,& MPI_DOUBLE_PRECISION,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) do k = 1, lsize gLinkV_r8(lindex(k)) = gLinkV_r8(lindex(k)) + tmpBuf(k) @@ -166,30 +146,30 @@ subroutine updateLinkV4_mem(LinkV, outV) if(my_id .ne. IO_id) then tag = 101 - call mpi_send(LLINKLEN,1,MPI_INTEGER, IO_id, & + call MPI_Send(LLINKLEN,1,MPI_INTEGER, IO_id, & tag,HYDRO_COMM_WORLD,ierr) if(LLINKLEN .gt. 0) then tag = 102 - call mpi_send(LLINKIDINDX,LLINKLEN,MPI_INTEGER, IO_id, & + call MPI_Send(LLINKIDINDX,LLINKLEN,MPI_INTEGER, IO_id, & tag,HYDRO_COMM_WORLD,ierr) tag = 103 - call mpi_send(LinkV,LLINKLEN,MPI_REAL, IO_id, & + call MPI_Send(LinkV,LLINKLEN,MPI_REAL, IO_id, & tag,HYDRO_COMM_WORLD,ierr) endif else do i = 0, numprocs - 1 if(i .ne. IO_id) then tag = 101 - call mpi_recv(lsize,1,MPI_INTEGER, i, & + call MPI_Recv(lsize,1,MPI_INTEGER, i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) if(lsize .gt. 0) then allocate(lindex(lsize) ) allocate(tmpBuf(lsize) ) tag = 102 - call mpi_recv(lindex,lsize,MPI_INTEGER, i, & + call MPI_Recv(lindex,lsize,MPI_INTEGER, i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) tag = 103 - call mpi_recv(tmpBuf,lsize,& + call MPI_Recv(tmpBuf,lsize,& MPI_REAL,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) do k = 1, lsize gLinkV_r4(lindex(k)) = gLinkV_r4(lindex(k)) + tmpBuf(k) @@ -224,14 +204,14 @@ subroutine updateLinkV8(LinkV, outV) if(my_id .ne. IO_id) then tag = 102 - call mpi_send(gLinkV,gnlinksl,MPI_DOUBLE_PRECISION, IO_id, & + call MPI_Send(gLinkV,gnlinksl,MPI_DOUBLE_PRECISION, IO_id, & tag,HYDRO_COMM_WORLD,ierr) else gLinkV_r = gLinkV do i = 0, numprocs - 1 if(i .ne. IO_id) then tag = 102 - call mpi_recv(gLinkV,gnlinksl,& + call MPI_Recv(gLinkV,gnlinksl,& MPI_DOUBLE_PRECISION,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) gLinkV_r = gLinkV_r + gLinkV end if @@ -257,14 +237,14 @@ subroutine updateLinkV4(LinkV, outV) if(my_id .ne. IO_id) then tag = 102 - call mpi_send(gLinkV,gnlinksl,MPI_REAL, IO_id, & + call MPI_Send(gLinkV,gnlinksl,MPI_REAL, IO_id, & tag,HYDRO_COMM_WORLD,ierr) else gLinkV_r = gLinkV do i = 0, numprocs - 1 if(i .ne. IO_id) then tag = 102 - call mpi_recv(gLinkV,gnlinksl,& + call MPI_Recv(gLinkV,gnlinksl,& MPI_REAL,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) gLinkV_r = gLinkV_r + gLinkV end if @@ -280,7 +260,7 @@ subroutine gbcastReal(inV, outV) real, dimension(:) :: inV integer :: ierr call ReachLS_write_io(inV,outV) - call mpi_bcast(outV(1:gnlinksl),gnlinksl,MPI_REAL, & + call MPI_Bcast(outV(1:gnlinksl),gnlinksl,MPI_REAL, & IO_id,HYDRO_COMM_WORLD,ierr) end subroutine gbcastReal @@ -297,7 +277,7 @@ subroutine gbcastReal2_old(index,size1,inV, insize, outV) bsize = linkls_e(i+1) - linkls_s(i+1) + 1 if(linkls_e(i+1) .gt. 0) then if(my_id .eq. i) tmpV(1:bsize) = inV(1:bsize) - call mpi_bcast(tmpV(1:bsize),bsize,MPI_REAL, & + call MPI_Bcast(tmpV(1:bsize),bsize,MPI_REAL, & i,HYDRO_COMM_WORLD,ierr) do j = 1, size1 do k = 1, bsize @@ -324,7 +304,7 @@ subroutine gbcastReal2(index,size1,inV, insize, outV) integer :: ierr, k, i, m, j, bsize outV = 0 call ReachLS_write_io(inV,gbuf) - call mpi_bcast(gbuf,gnlinksl,MPI_REAL, & + call MPI_Bcast(gbuf,gnlinksl,MPI_REAL, & IO_id,HYDRO_COMM_WORLD,ierr) do j = 1, size1 outV(j) = gbuf(index(j)) @@ -340,7 +320,7 @@ subroutine gbcastInt(inV, outV) integer, dimension(:) :: inV integer :: ierr call ReachLS_write_io(inV,outV) - call mpi_bcast(outV(1:gnlinksl),gnlinksl,MPI_INTEGER, & + call MPI_Bcast(outV(1:gnlinksl),gnlinksl,MPI_INTEGER, & IO_id,HYDRO_COMM_WORLD,ierr) end subroutine gbcastInt @@ -350,7 +330,7 @@ subroutine gbcastInt8(inV, outV) integer(kind=int64), dimension(:) :: inV integer :: ierr call ReachLS_write_io(inV,outV) - call mpi_bcast(outV(1:gnlinksl),gnlinksl,MPI_INTEGER8, & + call MPI_Bcast(outV(1:gnlinksl),gnlinksl,MPI_INTEGER8, & IO_id,HYDRO_COMM_WORLD,ierr) end subroutine gbcastInt8 @@ -367,7 +347,7 @@ subroutine getLocalIndx(glinksl,LINKID, LLINKID) call ReachLS_write_io(LINKID,gLinkId) - call mpi_bcast(gLinkId(1:glinksl),glinksl,MPI_INTEGER8, & + call MPI_Bcast(gLinkId(1:glinksl),glinksl,MPI_INTEGER8, & IO_id,HYDRO_COMM_WORLD,ierr) ! The following loops are replaced by a hashtable-based algorithm @@ -406,8 +386,8 @@ subroutine ReachLS_ini(glinksl,nlinksl,linklsS, linklsE) integer :: i, ii, ierr ! get my_id and numprocs - call MPI_COMM_RANK( HYDRO_COMM_WORLD, my_id, ierr ) - call MPI_COMM_SIZE( HYDRO_COMM_WORLD, numprocs, ierr ) + call MPI_Comm_rank( HYDRO_COMM_WORLD, my_id, ierr ) + call MPI_Comm_size( HYDRO_COMM_WORLD, numprocs, ierr ) nlinksl = glinksl / numprocs @@ -473,7 +453,7 @@ subroutine MapGrid2ReachIni(in2d) if(my_id .eq. n-1) then tmpS = sDataRec endif - call mpi_bcast(tmpS,numprocs,MPI_INTEGER, & + call MPI_Bcast(tmpS,numprocs,MPI_INTEGER, & n-1,HYDRO_COMM_WORLD,ierr) rDataRec(n) = tmpS(n) enddo @@ -495,7 +475,7 @@ subroutine ReachLS_decompReal(inV,outV) endif else if(aLinksl(i) .gt. 0) then - call mpi_send(inV(linkls_s(i):linkls_e(i)), & + call MPI_Send(inV(linkls_s(i):linkls_e(i)), & aLinksl(i), & MPI_REAL, i-1 ,tag,HYDRO_COMM_WORLD,ierr) endif @@ -503,7 +483,7 @@ subroutine ReachLS_decompReal(inV,outV) end do else if(aLinksl(my_id+1) .gt. 0) then - call mpi_recv(outV(1:(linkls_e(my_id+1)-linkls_s(my_id+1)+1) ), & !! this one has +1! + call MPI_Recv(outV(1:(linkls_e(my_id+1)-linkls_s(my_id+1)+1) ), & !! this one has +1! aLinksl(my_id+1), & MPI_REAL, io_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr) endif @@ -525,7 +505,7 @@ subroutine ReachLS_decompReal8(inV,outV) endif else if(aLinksl(i) .gt. 0) then - call mpi_send(inV(linkls_s(i):linkls_e(i)), & + call MPI_Send(inV(linkls_s(i):linkls_e(i)), & aLinksl(i), & MPI_REAL8, i-1 ,tag,HYDRO_COMM_WORLD,ierr) endif @@ -533,7 +513,7 @@ subroutine ReachLS_decompReal8(inV,outV) end do else if(aLinksl(my_id+1) .gt. 0) then - call mpi_recv(outV(1:(linkls_e(my_id+1)-linkls_s(my_id+1)+1) ), & !! this one has +1! + call MPI_Recv(outV(1:(linkls_e(my_id+1)-linkls_s(my_id+1)+1) ), & !! this one has +1! aLinksl(my_id+1), & MPI_REAL8, io_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr) endif @@ -555,7 +535,7 @@ subroutine ReachLS_decompInt(inV,outV) endif else if(aLinksl(i) .gt. 0) then - call mpi_send(inV(linkls_s(i):linkls_e(i)), & + call MPI_Send(inV(linkls_s(i):linkls_e(i)), & aLinksl(i), & MPI_INTEGER, i-1,tag,HYDRO_COMM_WORLD,ierr) endif @@ -563,7 +543,7 @@ subroutine ReachLS_decompInt(inV,outV) end do else if(aLinksl(my_id+1) .gt. 0) then - call mpi_recv(outV(1:linkls_e(my_id+1)-linkls_s(my_id+1)+1), & + call MPI_Recv(outV(1:linkls_e(my_id+1)-linkls_s(my_id+1)+1), & alinksl(my_id+1), & MPI_INTEGER, io_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr) endif @@ -587,7 +567,7 @@ subroutine ReachLS_decompInt8(inV,outV) endif else if(aLinksl(i) .gt. 0) then - call mpi_send(inV(linkls_s(i):linkls_e(i)), & + call MPI_Send(inV(linkls_s(i):linkls_e(i)), & aLinksl(i), & MPI_INTEGER8, i-1,tag,HYDRO_COMM_WORLD,ierr) endif @@ -595,7 +575,7 @@ subroutine ReachLS_decompInt8(inV,outV) end do else if(aLinksl(my_id+1) .gt. 0) then - call mpi_recv(outV(1:linkls_e(my_id+1)-linkls_s(my_id+1)+1), & + call MPI_Recv(outV(1:linkls_e(my_id+1)-linkls_s(my_id+1)+1), & alinksl(my_id+1), & MPI_INTEGER8, io_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr) endif @@ -622,8 +602,8 @@ subroutine ReachLS_decompChar(inV,outV) endif else if(aLinksl(i) .gt. 0) then - ! The mpi_send takes what you give it and THEN treats each caracter as an array element. - call mpi_send(inV(linkls_s(i):linkls_e(i)), & + ! The MPI_Send takes what you give it and THEN treats each caracter as an array element. + call MPI_Send(inV(linkls_s(i):linkls_e(i)), & strLen*aLinksl(i), & MPI_CHARACTER, i-1, tag, HYDRO_COMM_WORLD, ierr) endif @@ -631,8 +611,8 @@ subroutine ReachLS_decompChar(inV,outV) end do else if(aLinksl(my_id+1) .gt. 0) then - ! The mpi_recv treats each caracter as an array element. - call mpi_recv(outV(1 : (linkls_e(my_id+1)-linkls_s(my_id+1)+1) ), & !jlm should have +1 + ! The MPI_Recv treats each caracter as an array element. + call MPI_Recv(outV(1 : (linkls_e(my_id+1)-linkls_s(my_id+1)+1) ), & !jlm should have +1 strLen*alinksl(my_id+1), & MPI_CHARACTER, io_id, tag, HYDRO_COMM_WORLD, mpp_status,ierr ) endif @@ -657,7 +637,7 @@ subroutine ReachLS_wReal(inV,outV) else if(aLinksl(i) .gt. 0) then - call mpi_recv(outV(linkls_s(i):linkls_e(i)), & + call MPI_Recv(outV(linkls_s(i):linkls_e(i)), & aLinksl(i), & MPI_REAL,i-1,tag,HYDRO_COMM_WORLD,mpp_status,ierr) endif @@ -667,7 +647,7 @@ subroutine ReachLS_wReal(inV,outV) if(aLinksl(my_id+1) .gt. 0) then tag = 12 ss = size(inv,1) - call mpi_send(inV(1:aLinksl(my_id+1) ), & + call MPI_Send(inV(1:aLinksl(my_id+1) ), & aLinksl(my_id+1), & MPI_REAL,io_id,tag,HYDRO_COMM_WORLD,ierr) endif @@ -691,7 +671,7 @@ subroutine ReachLS_wReal8(inV,outV) else if(aLinksl(i) .gt. 0) then - call mpi_recv(outV(linkls_s(i):linkls_e(i)), & + call MPI_Recv(outV(linkls_s(i):linkls_e(i)), & aLinksl(i), & MPI_REAL8,i-1,tag,HYDRO_COMM_WORLD,mpp_status,ierr) endif @@ -701,7 +681,7 @@ subroutine ReachLS_wReal8(inV,outV) if(aLinksl(my_id+1) .gt. 0) then tag = 12 ss = size(inv,1) - call mpi_send(inV(1:aLinksl(my_id+1) ), & + call MPI_Send(inV(1:aLinksl(my_id+1) ), & aLinksl(my_id+1), & MPI_REAL8,io_id,tag,HYDRO_COMM_WORLD,ierr) endif @@ -725,7 +705,7 @@ subroutine ReachLS_wInt(inV,outV) else if(aLinksl(i) .gt. 0) then tag = 12 - call mpi_recv(outV(linkls_s(i):linkls_e(i)), & + call MPI_Recv(outV(linkls_s(i):linkls_e(i)), & aLinksl(i), & MPI_INTEGER,i-1,tag,HYDRO_COMM_WORLD,mpp_status,ierr) endif @@ -734,7 +714,7 @@ subroutine ReachLS_wInt(inV,outV) else if(aLinksl(my_id+1) .gt. 0) then tag = 12 - call mpi_send(inV(1:aLinksl(my_id+1) ), & + call MPI_Send(inV(1:aLinksl(my_id+1) ), & aLinksl(my_id+1), & MPI_INTEGER,io_id,tag,HYDRO_COMM_WORLD,ierr) endif @@ -757,7 +737,7 @@ subroutine ReachLS_wInt8(inV,outV) else if(aLinksl(i) .gt. 0) then tag = 12 - call mpi_recv(outV(linkls_s(i):linkls_e(i)), & + call MPI_Recv(outV(linkls_s(i):linkls_e(i)), & aLinksl(i), & MPI_INTEGER8,i-1,tag,HYDRO_COMM_WORLD,mpp_status,ierr) endif @@ -766,7 +746,7 @@ subroutine ReachLS_wInt8(inV,outV) else if(aLinksl(my_id+1) .gt. 0) then tag = 12 - call mpi_send(inV(1:aLinksl(my_id+1) ), & + call MPI_Send(inV(1:aLinksl(my_id+1) ), & aLinksl(my_id+1), & MPI_INTEGER8,io_id,tag,HYDRO_COMM_WORLD,ierr) endif @@ -790,7 +770,7 @@ subroutine ReachLS_wInt2(inV,outV,len,glen) else if(aLinksl(i) .gt. 0) then tag = 12 - call mpi_recv(outV(linkls_s(i):linkls_e(i)), & + call MPI_Recv(outV(linkls_s(i):linkls_e(i)), & aLinksl(i), & MPI_INTEGER,i-1,tag,HYDRO_COMM_WORLD,mpp_status,ierr) endif @@ -799,7 +779,7 @@ subroutine ReachLS_wInt2(inV,outV,len,glen) else if(aLinksl(my_id+1) .gt. 0) then tag = 12 - call mpi_send(inV(1:aLinksl(my_id+1) ), & + call MPI_Send(inV(1:aLinksl(my_id+1) ), & aLinksl(my_id+1), & MPI_INTEGER,io_id,tag,HYDRO_COMM_WORLD,ierr) endif @@ -823,7 +803,7 @@ subroutine ReachLS_wReal2(inV,outV,len,glen) else if(aLinksl(i) .gt. 0) then tag = 12 - call mpi_recv(outV(linkls_s(i):linkls_e(i)), & + call MPI_Recv(outV(linkls_s(i):linkls_e(i)), & aLinksl(i), & MPI_REAL,i-1,tag,HYDRO_COMM_WORLD,mpp_status,ierr) endif @@ -832,7 +812,7 @@ subroutine ReachLS_wReal2(inV,outV,len,glen) else if(aLinksl(my_id+1) .gt. 0) then tag = 12 - call mpi_send(inV(1:aLinksl(my_id+1) ), & + call MPI_Send(inV(1:aLinksl(my_id+1) ), & aLinksl(my_id+1), & MPI_REAL,io_id,tag,HYDRO_COMM_WORLD,ierr) endif @@ -857,8 +837,8 @@ subroutine ReachLS_wChar(inV,outV) if(aLinksl(i) .gt. 0) then tag = 12 ! ? seems asymmetric with ReachLS_decompChar - call mpi_recv(outV( linkls_s(i) : linkls_e(i) ), & -! call mpi_recv(outV( ((linkls_s(i)-1)+1) : (linkls_e(i)) ), & + call MPI_Recv(outV( linkls_s(i) : linkls_e(i) ), & +! call MPI_Recv(outV( ((linkls_s(i)-1)+1) : (linkls_e(i)) ), & aLinksl(i), & MPI_CHARACTER, i-1, tag, HYDRO_COMM_WORLD, mpp_status, ierr ) endif @@ -867,8 +847,8 @@ subroutine ReachLS_wChar(inV,outV) else if(aLinksl(my_id+1) .gt. 0) then tag = 12 - ! The mpi_send takes what you give it and THEN treats each caracter as an array element. - call mpi_send(inV(1:aLinksl(my_id+1)), & + ! The MPI_Send takes what you give it and THEN treats each caracter as an array element. + call MPI_Send(inV(1:aLinksl(my_id+1)), & aLinksl(my_id+1), & MPI_CHARACTER, io_id, tag, HYDRO_COMM_WORLD, ierr) endif @@ -1004,7 +984,7 @@ subroutine getToInd(from,to,ind,indLen,gToNodeOut) ToInd(my_id+1) = kk do i = 0, numprocs - 1 - call mpi_bcast(ToInd(i+1),1,MPI_INTEGER8, & + call MPI_Bcast(ToInd(i+1),1,MPI_INTEGER8, & i,HYDRO_COMM_WORLD,ierr) end do @@ -1045,7 +1025,7 @@ subroutine com_decomp1dInt(inV,gsize,outV,lsize) endif else if(ssize .gt. 0 ) then - call mpi_send(inV(start:start+ssize-1), ssize, & + call MPI_Send(inV(start:start+ssize-1), ssize, & MPI_INTEGER, i-1,tag,HYDRO_COMM_WORLD,ierr) endif endif @@ -1058,7 +1038,7 @@ subroutine com_decomp1dInt(inV,gsize,outV,lsize) endif if( lsize .gt. 0) then allocate(outV(lsize) ) - call mpi_recv(outV,lsize, & + call MPI_Recv(outV,lsize, & MPI_INTEGER, io_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr) endif endif @@ -1102,7 +1082,7 @@ subroutine com_decomp1dInt8(inV,gsize,outV,lsize) endif else if(ssize .gt. 0 ) then - call mpi_send(inV(start:start+ssize-1), ssize, & + call MPI_Send(inV(start:start+ssize-1), ssize, & MPI_INTEGER8, i-1,tag,HYDRO_COMM_WORLD,ierr) endif endif @@ -1115,7 +1095,7 @@ subroutine com_decomp1dInt8(inV,gsize,outV,lsize) endif if( lsize .gt. 0) then allocate(outV(lsize) ) - call mpi_recv(outV,lsize, & + call MPI_Recv(outV,lsize, & MPI_INTEGER8, io_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr) endif endif @@ -1154,7 +1134,7 @@ subroutine com_write1dInt(inV,lsize,outV,gsize) endif else if(rsize .gt. 0 ) then - call mpi_recv(outV(start:start+rsize-1), rsize, & + call MPI_Recv(outV(start:start+rsize-1), rsize, & MPI_INTEGER, i-1,tag,HYDRO_COMM_WORLD,mpp_status,ierr) endif endif @@ -1166,7 +1146,7 @@ subroutine com_write1dInt(inV,lsize,outV,gsize) lsize = ncomsize endif if( lsize .gt. 0) then - call mpi_send(inV, lsize, & + call MPI_Send(inV, lsize, & MPI_INTEGER, io_id,tag,HYDRO_COMM_WORLD,ierr) endif endif @@ -1205,7 +1185,7 @@ subroutine com_write1dInt8(inV,lsize,outV,gsize) endif else if(rsize .gt. 0 ) then - call mpi_recv(outV(start:start+rsize-1), rsize, & + call MPI_Recv(outV(start:start+rsize-1), rsize, & MPI_INTEGER8, i-1,tag,HYDRO_COMM_WORLD,mpp_status,ierr) endif endif @@ -1217,7 +1197,7 @@ subroutine com_write1dInt8(inV,lsize,outV,gsize) lsize = ncomsize endif if( lsize .gt. 0) then - call mpi_send(inV, lsize, & + call MPI_Send(inV, lsize, & MPI_INTEGER8, io_id,tag,HYDRO_COMM_WORLD,ierr) endif endif @@ -1259,7 +1239,7 @@ subroutine pack_decomp_int(g1bufid, ndata, nprocs_map, lnsizes, istart,bufid) if(my_id .ne. IO_id) then tag = 72 if(lnsizes(my_id + 1) .gt. 0) then - call mpi_recv(bufid,lnsizes(my_id + 1),& + call MPI_Recv(bufid,lnsizes(my_id + 1),& MPI_INTEGER,io_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr) endif else @@ -1267,7 +1247,7 @@ subroutine pack_decomp_int(g1bufid, ndata, nprocs_map, lnsizes, istart,bufid) if(i .ne. my_id) then tag = 72 if(lnsizes(i+1) .gt. 0) then - call mpi_send(buf(istart(i+1):istart(i+1)+lnsizes(i+1)-1), & + call MPI_Send(buf(istart(i+1):istart(i+1)+lnsizes(i+1)-1), & lnsizes(i+1),MPI_INTEGER,i, tag,HYDRO_COMM_WORLD,ierr) endif else @@ -1315,7 +1295,7 @@ subroutine pack_decomp_int8(g1bufid, ndata, nprocs_map, lnsizes, istart,bufid) if(my_id .ne. IO_id) then tag = 72 if(lnsizes(my_id + 1) .gt. 0) then - call mpi_recv(bufid,lnsizes(my_id + 1),& + call MPI_Recv(bufid,lnsizes(my_id + 1),& MPI_INTEGER8,io_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr) endif else @@ -1323,7 +1303,7 @@ subroutine pack_decomp_int8(g1bufid, ndata, nprocs_map, lnsizes, istart,bufid) if(i .ne. my_id) then tag = 72 if(lnsizes(i+1) .gt. 0) then - call mpi_send(buf(istart(i+1):istart(i+1)+lnsizes(i+1)-1), & + call MPI_Send(buf(istart(i+1):istart(i+1)+lnsizes(i+1)-1), & lnsizes(i+1),MPI_INTEGER8,i, tag,HYDRO_COMM_WORLD,ierr) endif else @@ -1363,7 +1343,7 @@ subroutine pack_decomp_real8(g1bufid, ndata, nprocs_map, lnsizes, istart,bufid) if(my_id .ne. IO_id) then tag = 72 if(lnsizes(my_id + 1) .gt. 0) then - call mpi_recv(bufid,lnsizes(my_id + 1),& + call MPI_Recv(bufid,lnsizes(my_id + 1),& MPI_DOUBLE_PRECISION,io_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr) endif else @@ -1371,7 +1351,7 @@ subroutine pack_decomp_real8(g1bufid, ndata, nprocs_map, lnsizes, istart,bufid) if(i .ne. my_id) then tag = 72 if(lnsizes(i+1) .gt. 0) then - call mpi_send(buf(istart(i+1):istart(i+1)+lnsizes(i+1)-1), & + call MPI_Send(buf(istart(i+1):istart(i+1)+lnsizes(i+1)-1), & lnsizes(i+1),MPI_DOUBLE_PRECISION,i, tag,HYDRO_COMM_WORLD,ierr) endif else @@ -1415,15 +1395,15 @@ subroutine TONODE2RSL (ind,inVar,size,gNLINKSL,NLINKSL,ioVar,flag) end do else tag = 82 - call mpi_recv(tmpSize,1,MPI_INTEGER,i-1,tag,HYDRO_COMM_WORLD,mpp_status,ierr) + call MPI_Recv(tmpSize,1,MPI_INTEGER,i-1,tag,HYDRO_COMM_WORLD,mpp_status,ierr) if(tmpSize .gt. 0) then allocate(buf(tmpSize)) allocate(tmpInd(tmpSize)) tag = 83 - call mpi_recv(tmpInd, tmpSize , & + call MPI_Recv(tmpInd, tmpSize , & MPI_INTEGER,i-1,tag,HYDRO_COMM_WORLD,mpp_status,ierr) tag = 84 - call mpi_recv(buf, tmpSize , & + call MPI_Recv(buf, tmpSize , & MPI_INTEGER,i-1,tag,HYDRO_COMM_WORLD,mpp_status,ierr) do k = 1, tmpSize if(buf(k) .ne. flag) then @@ -1437,13 +1417,13 @@ subroutine TONODE2RSL (ind,inVar,size,gNLINKSL,NLINKSL,ioVar,flag) end do else tag = 82 - call mpi_send(size,1,MPI_INTEGER,io_id,tag,HYDRO_COMM_WORLD,ierr) + call MPI_Send(size,1,MPI_INTEGER,io_id,tag,HYDRO_COMM_WORLD,ierr) if(size .gt. 0) then tag = 83 - call mpi_send(ind(1:size),size, & + call MPI_Send(ind(1:size),size, & MPI_INTEGER,io_id,tag,HYDRO_COMM_WORLD,ierr) tag = 84 - call mpi_send(inVar(1:size),size, & + call MPI_Send(inVar(1:size),size, & MPI_INTEGER,io_id,tag,HYDRO_COMM_WORLD,ierr) endif endif @@ -1480,15 +1460,15 @@ subroutine TONODE2RSL8 (ind,inVar,size,gNLINKSL,NLINKSL,ioVar,flag) end do else tag = 82 - call mpi_recv(tmpSize,1,MPI_INTEGER,i-1,tag,HYDRO_COMM_WORLD,mpp_status,ierr) + call MPI_Recv(tmpSize,1,MPI_INTEGER,i-1,tag,HYDRO_COMM_WORLD,mpp_status,ierr) if(tmpSize .gt. 0) then allocate(buf(tmpSize)) allocate(tmpInd(tmpSize)) tag = 83 - call mpi_recv(tmpInd, tmpSize , & + call MPI_Recv(tmpInd, tmpSize , & MPI_INTEGER,i-1,tag,HYDRO_COMM_WORLD,mpp_status,ierr) tag = 84 - call mpi_recv(buf, tmpSize , & + call MPI_Recv(buf, tmpSize , & MPI_INTEGER8,i-1,tag,HYDRO_COMM_WORLD,mpp_status,ierr) do k = 1, tmpSize if(buf(k) .ne. flag) then @@ -1502,13 +1482,13 @@ subroutine TONODE2RSL8 (ind,inVar,size,gNLINKSL,NLINKSL,ioVar,flag) end do else tag = 82 - call mpi_send(size,1,MPI_INTEGER,io_id,tag,HYDRO_COMM_WORLD,ierr) + call MPI_Send(size,1,MPI_INTEGER,io_id,tag,HYDRO_COMM_WORLD,ierr) if(size .gt. 0) then tag = 83 - call mpi_send(ind(1:size),size, & + call MPI_Send(ind(1:size),size, & MPI_INTEGER,io_id,tag,HYDRO_COMM_WORLD,ierr) tag = 84 - call mpi_send(inVar(1:size),size, & + call MPI_Send(inVar(1:size),size, & MPI_INTEGER8,io_id,tag,HYDRO_COMM_WORLD,ierr) endif endif diff --git a/hydro/MPP/mpp_land.F90 b/hydro/MPP/mpp_land.F90 index 0084a2d166..41698e2b7e 100644 --- a/hydro/MPP/mpp_land.F90 +++ b/hydro/MPP/mpp_land.F90 @@ -1,23 +1,3 @@ -! Program Name: -! Author(s)/Contact(s): -! Abstract: -! History Log: -! -! Usage: -! Parameters: -! Input Files: -! -! Output Files: -! -! -! Condition codes: -! -! If appropriate, descriptive troubleshooting instructions or -! likely causes for failures could be mentioned here with the -! appropriate error code -! -! User controllable options: - !#### This is a module for parallel Land model. MODULE MODULE_MPP_LAND @@ -34,7 +14,7 @@ MODULE MODULE_MPP_LAND integer, public :: global_nx, global_ny, local_nx,local_ny integer, public :: global_rt_nx, global_rt_ny integer, public :: local_rt_nx,local_rt_ny,rt_AGGFACTRT - integer, public :: numprocs ! total process, get by mpi initialization. + integer, public :: numprocs ! total process, get by MPI initialization. integer :: local_startx, local_starty integer :: local_startx_rt, local_starty_rt, local_endx_rt, local_endy_rt @@ -86,8 +66,8 @@ subroutine LOG_MAP2d() data cyclic/.false.,.false./ ! not cyclic data reorder/.false./ - call MPI_COMM_RANK( HYDRO_COMM_WORLD, my_id, ierr ) - call MPI_COMM_SIZE( HYDRO_COMM_WORLD, numprocs, ierr ) + call MPI_Comm_rank( HYDRO_COMM_WORLD, my_id, ierr ) + call MPI_Comm_size( HYDRO_COMM_WORLD, numprocs, ierr ) call getNX_NY(numprocs, left_right_np,up_down_np) if(my_id.eq.IO_id) then @@ -131,14 +111,13 @@ subroutine LOG_MAP2d() call MPI_Cart_create(HYDRO_COMM_WORLD, ndim, dims, & cyclic, reorder, cartGridComm, ierr) - call MPI_CART_GET(cartGridComm, 2, dims, cyclic, coords, ierr) + call MPI_Cart_get(cartGridComm, 2, dims, cyclic, coords, ierr) p_up_down = coords(0) p_left_right = coords(1) np_up_down = up_down_np np_left_right = left_right_np - return end subroutine log_map2d subroutine MPP_LAND_INIT(in_global_nx,in_global_ny) @@ -154,21 +133,20 @@ subroutine MPP_LAND_INIT(in_global_nx,in_global_ny) global_ny = in_global_ny end if - call mpi_initialized( mpi_inited, ierr ) + call MPI_Initialized( mpi_inited, ierr ) if ( .not. mpi_inited ) then - call MPI_INIT_THREAD( MPI_THREAD_FUNNELED, provided, ierr ) - if (ierr /= MPI_SUCCESS) call fatal_error_stop("MPI Error: MPI_INIT failed") - call MPI_COMM_DUP(MPI_COMM_WORLD, HYDRO_COMM_WORLD, ierr) - if (ierr /= MPI_SUCCESS) call fatal_error_stop("MPI Error: MPI_COMM_DUP failed") + call MPI_Init_thread( MPI_THREAD_FUNNELED, provided, ierr ) + if (ierr /= MPI_SUCCESS) call fatal_error_stop("MPI Error: MPI_Init failed") + call MPI_Comm_dup(MPI_COMM_WORLD, HYDRO_COMM_WORLD, ierr) + if (ierr /= MPI_SUCCESS) call fatal_error_stop("MPI Error: MPI_Comm_dup failed") endif - call MPI_COMM_RANK( HYDRO_COMM_WORLD, my_id, ierr ) - call MPI_COMM_SIZE( HYDRO_COMM_WORLD, numprocs, ierr ) - if (ierr /= MPI_SUCCESS) call fatal_error_stop("MPI Error: MPI_COMM_RANK and/or MPI_COMM_SIZE failed") + call MPI_Comm_rank( HYDRO_COMM_WORLD, my_id, ierr ) + call MPI_Comm_size( HYDRO_COMM_WORLD, numprocs, ierr ) + if (ierr /= MPI_SUCCESS) call fatal_error_stop("MPI Error: MPI_Comm_rank and/or MPI_Comm_size failed") ! create 2d logical mapping of the CPU. call log_map2d() - return end subroutine MPP_LAND_INIT @@ -233,7 +211,6 @@ subroutine MPP_LAND_PAR_INI(over_lap,in_global_nx,in_global_ny,AGGFACTRT) write(6,*) "my_id=",my_id,"global_nx=",global_nx write(6,*) "my_id=",my_id,"global_nx=",global_ny #endif - return end subroutine MPP_LAND_PAR_INI subroutine MPP_LAND_LR_COM(in_out_data,NX,NY,flag) @@ -247,26 +224,26 @@ subroutine MPP_LAND_LR_COM(in_out_data,NX,NY,flag) if(right_id .ge. 0) then ! ### send to right first. tag = 11 size = ny - call mpi_send(in_out_data(nx-1,:),size,MPI_REAL, & + call MPI_Send(in_out_data(nx-1,:),size,MPI_REAL, & right_id,tag,HYDRO_COMM_WORLD,ierr) end if if(left_id .ge. 0) then ! receive from left tag = 11 size = ny - call mpi_recv(in_out_data(1,:),size,MPI_REAL, & + call MPI_Recv(in_out_data(1,:),size,MPI_REAL, & left_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr) endif if(left_id .ge. 0 ) then ! ### send to left second. size = ny tag = 21 - call mpi_send(in_out_data(2,:),size,MPI_REAL, & + call MPI_Send(in_out_data(2,:),size,MPI_REAL, & left_id,tag,HYDRO_COMM_WORLD,ierr) endif if(right_id .ge. 0) then ! receive from right tag = 21 size = ny - call mpi_recv(in_out_data(nx,:),size,MPI_REAL,& + call MPI_Recv(in_out_data(nx,:),size,MPI_REAL,& right_id,tag,HYDRO_COMM_WORLD, mpp_status,ierr) endif @@ -275,13 +252,13 @@ subroutine MPP_LAND_LR_COM(in_out_data,NX,NY,flag) if(right_id .ge. 0) then ! ### send to right first. tag = 11 size = 2*ny - call mpi_send(in_out_data(nx-1:nx,:),size,MPI_REAL, & + call MPI_Send(in_out_data(nx-1:nx,:),size,MPI_REAL, & right_id,tag,HYDRO_COMM_WORLD,ierr) end if if(left_id .ge. 0) then ! receive from left tag = 11 size = 2*ny - call mpi_recv(data_r,size,MPI_REAL,left_id,tag, & + call MPI_Recv(data_r,size,MPI_REAL,left_id,tag, & HYDRO_COMM_WORLD,mpp_status,ierr) in_out_data(1,:) = in_out_data(1,:) + data_r(1,:) in_out_data(2,:) = in_out_data(2,:) + data_r(2,:) @@ -290,18 +267,17 @@ subroutine MPP_LAND_LR_COM(in_out_data,NX,NY,flag) if(left_id .ge. 0 ) then ! ### send to left second. size = 2*ny tag = 21 - call mpi_send(in_out_data(1:2,:),size,MPI_REAL, & + call MPI_Send(in_out_data(1:2,:),size,MPI_REAL, & left_id,tag,HYDRO_COMM_WORLD,ierr) endif if(right_id .ge. 0) then ! receive from right tag = 21 size = 2*ny - call mpi_recv(in_out_data(nx-1:nx,:),size,MPI_REAL,& + call MPI_Recv(in_out_data(nx-1:nx,:),size,MPI_REAL,& right_id,tag,HYDRO_COMM_WORLD, mpp_status,ierr) endif endif ! end if black for flag. - return end subroutine MPP_LAND_LR_COM subroutine MPP_LAND_LR_COM8(in_out_data,NX,NY,flag) @@ -315,26 +291,26 @@ subroutine MPP_LAND_LR_COM8(in_out_data,NX,NY,flag) if(right_id .ge. 0) then ! ### send to right first. tag = 11 size = ny - call mpi_send(in_out_data(nx-1,:),size,MPI_DOUBLE_PRECISION, & + call MPI_Send(in_out_data(nx-1,:),size,MPI_DOUBLE_PRECISION, & right_id,tag,HYDRO_COMM_WORLD,ierr) end if if(left_id .ge. 0) then ! receive from left tag = 11 size = ny - call mpi_recv(in_out_data(1,:),size,MPI_DOUBLE_PRECISION, & + call MPI_Recv(in_out_data(1,:),size,MPI_DOUBLE_PRECISION, & left_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr) endif if(left_id .ge. 0 ) then ! ### send to left second. size = ny tag = 21 - call mpi_send(in_out_data(2,:),size,MPI_DOUBLE_PRECISION, & + call MPI_Send(in_out_data(2,:),size,MPI_DOUBLE_PRECISION, & left_id,tag,HYDRO_COMM_WORLD,ierr) endif if(right_id .ge. 0) then ! receive from right tag = 21 size = ny - call mpi_recv(in_out_data(nx,:),size,MPI_DOUBLE_PRECISION,& + call MPI_Recv(in_out_data(nx,:),size,MPI_DOUBLE_PRECISION,& right_id,tag,HYDRO_COMM_WORLD, mpp_status,ierr) endif @@ -343,13 +319,13 @@ subroutine MPP_LAND_LR_COM8(in_out_data,NX,NY,flag) if(right_id .ge. 0) then ! ### send to right first. tag = 11 size = 2*ny - call mpi_send(in_out_data(nx-1:nx,:),size,MPI_DOUBLE_PRECISION, & + call MPI_Send(in_out_data(nx-1:nx,:),size,MPI_DOUBLE_PRECISION, & right_id,tag,HYDRO_COMM_WORLD,ierr) end if if(left_id .ge. 0) then ! receive from left tag = 11 size = 2*ny - call mpi_recv(data_r,size,MPI_DOUBLE_PRECISION,left_id,tag, & + call MPI_Recv(data_r,size,MPI_DOUBLE_PRECISION,left_id,tag, & HYDRO_COMM_WORLD,mpp_status,ierr) in_out_data(1,:) = in_out_data(1,:) + data_r(1,:) in_out_data(2,:) = in_out_data(2,:) + data_r(2,:) @@ -358,18 +334,17 @@ subroutine MPP_LAND_LR_COM8(in_out_data,NX,NY,flag) if(left_id .ge. 0 ) then ! ### send to left second. size = 2*ny tag = 21 - call mpi_send(in_out_data(1:2,:),size,MPI_DOUBLE_PRECISION, & + call MPI_Send(in_out_data(1:2,:),size,MPI_DOUBLE_PRECISION, & left_id,tag,HYDRO_COMM_WORLD,ierr) endif if(right_id .ge. 0) then ! receive from right tag = 21 size = 2*ny - call mpi_recv(in_out_data(nx-1:nx,:),size,MPI_DOUBLE_PRECISION,& + call MPI_Recv(in_out_data(nx-1:nx,:),size,MPI_DOUBLE_PRECISION,& right_id,tag,HYDRO_COMM_WORLD, mpp_status,ierr) endif endif ! end if black for flag. - return end subroutine MPP_LAND_LR_COM8 @@ -393,7 +368,7 @@ subroutine get_local_size(local_nx, local_ny,rt_nx,rt_ny) if(i .ne. my_id) then !block receive from other node. tag = 1 - call mpi_recv(s_r,2,MPI_INTEGER,i, & + call MPI_Recv(s_r,2,MPI_INTEGER,i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) local_nx_size(i+1) = s_r(1) local_ny_size(i+1) = s_r(2) @@ -406,7 +381,7 @@ subroutine get_local_size(local_nx, local_ny,rt_nx,rt_ny) tag = 1 s_r(1) = local_nx s_r(2) = local_ny - call mpi_send(s_r,2,MPI_INTEGER, IO_id, & + call MPI_Send(s_r,2,MPI_INTEGER, IO_id, & tag,HYDRO_COMM_WORLD,ierr) end if @@ -416,7 +391,7 @@ subroutine get_local_size(local_nx, local_ny,rt_nx,rt_ny) if(i .ne. my_id) then !block receive from other node. tag = 2 - call mpi_recv(s_r,2,MPI_INTEGER,i, & + call MPI_Recv(s_r,2,MPI_INTEGER,i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) local_rt_nx_size(i+1) = s_r(1) local_rt_ny_size(i+1) = s_r(2) @@ -429,11 +404,10 @@ subroutine get_local_size(local_nx, local_ny,rt_nx,rt_ny) tag = 2 s_r(1) = rt_nx s_r(2) = rt_ny - call mpi_send(s_r,2,MPI_INTEGER, IO_id, & + call MPI_Send(s_r,2,MPI_INTEGER, IO_id, & tag,HYDRO_COMM_WORLD,ierr) end if - return end subroutine get_local_size @@ -450,26 +424,26 @@ subroutine MPP_LAND_UB_COM(in_out_data,NX,NY,flag) if(up_id .ge. 0 ) then ! ### send to up first. tag = 31 size = nx - call mpi_send(in_out_data(:,ny-1),size,MPI_REAL, & + call MPI_Send(in_out_data(:,ny-1),size,MPI_REAL, & up_id,tag,HYDRO_COMM_WORLD,ierr) endif if(down_id .ge. 0 ) then ! receive from down tag = 31 size = nx - call mpi_recv(in_out_data(:,1),size,MPI_REAL, & + call MPI_Recv(in_out_data(:,1),size,MPI_REAL, & down_id,tag,HYDRO_COMM_WORLD, mpp_status,ierr) endif if(down_id .ge. 0 ) then ! send down. tag = 41 size = nx - call mpi_send(in_out_data(:,2),size,MPI_REAL, & + call MPI_Send(in_out_data(:,2),size,MPI_REAL, & down_id,tag,HYDRO_COMM_WORLD,ierr) endif if(up_id .ge. 0 ) then ! receive from upper tag = 41 size = nx - call mpi_recv(in_out_data(:,ny),size,MPI_REAL, & + call MPI_Recv(in_out_data(:,ny),size,MPI_REAL, & up_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr) endif @@ -478,13 +452,13 @@ subroutine MPP_LAND_UB_COM(in_out_data,NX,NY,flag) if(up_id .ge. 0 ) then ! ### send to up first. tag = 31 size = nx*2 - call mpi_send(in_out_data(:,ny-1:ny),size,MPI_REAL, & + call MPI_Send(in_out_data(:,ny-1:ny),size,MPI_REAL, & up_id,tag,HYDRO_COMM_WORLD,ierr) endif if(down_id .ge. 0 ) then ! receive from down tag = 31 size = nx*2 - call mpi_recv(data_r,size,MPI_REAL, & + call MPI_Recv(data_r,size,MPI_REAL, & down_id,tag,HYDRO_COMM_WORLD, mpp_status,ierr) in_out_data(:,1) = in_out_data(:,1) + data_r(:,1) in_out_data(:,2) = in_out_data(:,2) + data_r(:,2) @@ -493,17 +467,16 @@ subroutine MPP_LAND_UB_COM(in_out_data,NX,NY,flag) if(down_id .ge. 0 ) then ! send down. tag = 41 size = nx*2 - call mpi_send(in_out_data(:,1:2),size,MPI_REAL, & + call MPI_Send(in_out_data(:,1:2),size,MPI_REAL, & down_id,tag,HYDRO_COMM_WORLD,ierr) endif if(up_id .ge. 0 ) then ! receive from upper tag = 41 size = nx * 2 - call mpi_recv(in_out_data(:,ny-1:ny),size,MPI_REAL, & + call MPI_Recv(in_out_data(:,ny-1:ny),size,MPI_REAL, & up_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr) endif endif ! end of block flag - return end subroutine MPP_LAND_UB_COM subroutine MPP_LAND_UB_COM8(in_out_data,NX,NY,flag) @@ -519,26 +492,26 @@ subroutine MPP_LAND_UB_COM8(in_out_data,NX,NY,flag) if(up_id .ge. 0 ) then ! ### send to up first. tag = 31 size = nx - call mpi_send(in_out_data(:,ny-1),size,MPI_DOUBLE_PRECISION, & + call MPI_Send(in_out_data(:,ny-1),size,MPI_DOUBLE_PRECISION, & up_id,tag,HYDRO_COMM_WORLD,ierr) endif if(down_id .ge. 0 ) then ! receive from down tag = 31 size = nx - call mpi_recv(in_out_data(:,1),size,MPI_DOUBLE_PRECISION, & + call MPI_Recv(in_out_data(:,1),size,MPI_DOUBLE_PRECISION, & down_id,tag,HYDRO_COMM_WORLD, mpp_status,ierr) endif if(down_id .ge. 0 ) then ! send down. tag = 41 size = nx - call mpi_send(in_out_data(:,2),size,MPI_DOUBLE_PRECISION, & + call MPI_Send(in_out_data(:,2),size,MPI_DOUBLE_PRECISION, & down_id,tag,HYDRO_COMM_WORLD,ierr) endif if(up_id .ge. 0 ) then ! receive from upper tag = 41 size = nx - call mpi_recv(in_out_data(:,ny),size,MPI_DOUBLE_PRECISION, & + call MPI_Recv(in_out_data(:,ny),size,MPI_DOUBLE_PRECISION, & up_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr) endif @@ -547,13 +520,13 @@ subroutine MPP_LAND_UB_COM8(in_out_data,NX,NY,flag) if(up_id .ge. 0 ) then ! ### send to up first. tag = 31 size = nx*2 - call mpi_send(in_out_data(:,ny-1:ny),size,MPI_DOUBLE_PRECISION, & + call MPI_Send(in_out_data(:,ny-1:ny),size,MPI_DOUBLE_PRECISION, & up_id,tag,HYDRO_COMM_WORLD,ierr) endif if(down_id .ge. 0 ) then ! receive from down tag = 31 size = nx*2 - call mpi_recv(data_r,size,MPI_DOUBLE_PRECISION, & + call MPI_Recv(data_r,size,MPI_DOUBLE_PRECISION, & down_id,tag,HYDRO_COMM_WORLD, mpp_status,ierr) in_out_data(:,1) = in_out_data(:,1) + data_r(:,1) in_out_data(:,2) = in_out_data(:,2) + data_r(:,2) @@ -562,17 +535,16 @@ subroutine MPP_LAND_UB_COM8(in_out_data,NX,NY,flag) if(down_id .ge. 0 ) then ! send down. tag = 41 size = nx*2 - call mpi_send(in_out_data(:,1:2),size,MPI_DOUBLE_PRECISION, & + call MPI_Send(in_out_data(:,1:2),size,MPI_DOUBLE_PRECISION, & down_id,tag,HYDRO_COMM_WORLD,ierr) endif if(up_id .ge. 0 ) then ! receive from upper tag = 41 size = nx * 2 - call mpi_recv(in_out_data(:,ny-1:ny),size,MPI_DOUBLE_PRECISION, & + call MPI_Recv(in_out_data(:,ny-1:ny),size,MPI_DOUBLE_PRECISION, & up_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr) endif endif ! end of block flag - return end subroutine MPP_LAND_UB_COM8 subroutine calculate_start_p() @@ -622,7 +594,7 @@ subroutine calculate_start_p() ! block receive from other node. if(i.ne.my_id) then tag = 1 - call mpi_recv(r_s,2,MPI_INTEGER,i, & + call MPI_Recv(r_s,2,MPI_INTEGER,i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) startx(i+1) = r_s(1) starty(i+1) = r_s(2) @@ -630,7 +602,7 @@ subroutine calculate_start_p() end do else tag = 1 - call mpi_send(r_s,2,MPI_INTEGER, IO_id, & + call MPI_Send(r_s,2,MPI_INTEGER, IO_id, & tag,HYDRO_COMM_WORLD,ierr) end if @@ -643,7 +615,6 @@ subroutine calculate_start_p() local_endx_rt = local_startx_rt + local_rt_nx -1 local_endy_rt = local_starty_rt + local_rt_ny -1 - return end subroutine calculate_start_p subroutine calculate_offset_vectors() @@ -672,7 +643,6 @@ subroutine calculate_offset_vectors() last_offset = last_offset + size_vectors_rt(i) end do - return end subroutine calculate_offset_vectors subroutine decompose_data_real3d (in_buff,out_buff,klevel) @@ -695,8 +665,8 @@ subroutine decompose_data_real (in_buff,out_buff) if(my_id .eq. IO_id) then - ! allocate the buffer to hold data as required by mpi_scatterv - ! be careful with the index range if using array prepared for mpi in fortran (offset_vectors) + ! allocate the buffer to hold data as required by MPI_Scatterv + ! be careful with the index range if using array prepared for MPI in fortran (offset_vectors) allocate(send_buff(0: (global_nx*global_ny) -1),stat = ierr) ! for each sub region in the global buffer linearize the data and place it in the @@ -725,19 +695,18 @@ subroutine decompose_data_real (in_buff,out_buff) ! send the to each process size_vector(mpi_rank+1) data elements ! and store the results in out_buff - call mpi_scatterv(send_buff, size_vectors, offset_vectors, MPI_REAL, & + call MPI_Scatterv(send_buff, size_vectors, offset_vectors, MPI_REAL, & out_buff, size_vectors(my_id+1), MPI_REAL, IO_id, HYDRO_COMM_WORLD, ierr) ! remove the send buffer deallocate(send_buff) else - ! other processes only need to make mpi_scatterv call - call mpi_scatterv(send_buff, size_vectors, offset_vectors, MPI_REAL, & + ! other processes only need to make MPI_Scatterv call + call MPI_Scatterv(send_buff, size_vectors, offset_vectors, MPI_REAL, & out_buff, local_nx*local_ny, MPI_REAL, IO_id, HYDRO_COMM_WORLD, ierr) end if - return end subroutine decompose_data_real @@ -760,16 +729,15 @@ subroutine decompose_data_int (in_buff,out_buff) else ! send data to the rest process. size = local_nx_size(i+1)*local_ny_size(i+1) - call mpi_send(in_buff(ibegin:iend,jbegin:jend),size,& + call MPI_Send(in_buff(ibegin:iend,jbegin:jend),size,& MPI_INTEGER, i,tag,HYDRO_COMM_WORLD,ierr) end if end do else size = local_nx*local_ny - call mpi_recv(out_buff,size,MPI_INTEGER,IO_id, & + call MPI_Recv(out_buff,size,MPI_INTEGER,IO_id, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) end if - return end subroutine decompose_data_int subroutine write_IO_int(in_buff,out_buff) @@ -780,7 +748,7 @@ subroutine write_IO_int(in_buff,out_buff) if(my_id .ne. IO_id) then size = local_nx*local_ny tag = 2 - call mpi_send(in_buff,size,MPI_INTEGER, IO_id, & + call MPI_Send(in_buff,size,MPI_INTEGER, IO_id, & tag,HYDRO_COMM_WORLD,ierr) else do i = 0, numprocs - 1 @@ -793,12 +761,11 @@ subroutine write_IO_int(in_buff,out_buff) else size = local_nx_size(i+1)*local_ny_size(i+1) tag = 2 - call mpi_recv(out_buff(ibegin:iend,jbegin:jend),size,& + call MPI_Recv(out_buff(ibegin:iend,jbegin:jend),size,& MPI_INTEGER,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) end if end do end if - return end subroutine write_IO_int subroutine write_IO_char_head(in, out, imageHead) @@ -819,7 +786,7 @@ subroutine write_IO_char_head(in, out, imageHead) if(my_id .ne. IO_id) then lenSize = imageHead(my_id+1)*len(in(1)) !! some times necessary for character arrays? if(lenSize .eq. 0) return - call mpi_send(in,lenSize,MPI_CHARACTER,IO_id,tag,HYDRO_COMM_WORLD,ierr) + call MPI_Send(in,lenSize,MPI_CHARACTER,IO_id,tag,HYDRO_COMM_WORLD,ierr) else do i = 0, numprocs-1 lenSize = imageHead(i+1)*len(in(1)) !! necessary? @@ -833,7 +800,7 @@ subroutine write_IO_char_head(in, out, imageHead) if(i .eq. IO_id) then out(theStart:theEnd) = in(1:imageHead(i+1)) else - call mpi_recv(out(theStart:theEnd),lenSize,& + call MPI_Recv(out(theStart:theEnd),lenSize,& MPI_CHARACTER,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) end if end do @@ -859,7 +826,7 @@ subroutine write_IO_real(in_buff,out_buff) if(my_id .ne. IO_id) then size = local_nx*local_ny tag = 2 - call mpi_send(in_buff,size,MPI_REAL, IO_id, & + call MPI_Send(in_buff,size,MPI_REAL, IO_id, & tag,HYDRO_COMM_WORLD,ierr) else do i = 0, numprocs - 1 @@ -872,12 +839,11 @@ subroutine write_IO_real(in_buff,out_buff) else size = local_nx_size(i+1)*local_ny_size(i+1) tag = 2 - call mpi_recv(out_buff(ibegin:iend,jbegin:jend),size,& + call MPI_Recv(out_buff(ibegin:iend,jbegin:jend),size,& MPI_REAL,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) end if end do end if - return end subroutine write_IO_real ! subroutine write_IO_RT_real_prev(in_buff,out_buff) @@ -888,7 +854,7 @@ end subroutine write_IO_real ! if(my_id .ne. IO_id) then ! size = local_rt_nx*local_rt_ny ! tag = 2 -! call mpi_send(in_buff,size,MPI_REAL, IO_id, & +! call MPI_Send(in_buff,size,MPI_REAL, IO_id, & ! tag,HYDRO_COMM_WORLD,ierr) ! else ! do i = 0, numprocs - 1 @@ -903,12 +869,11 @@ end subroutine write_IO_real ! else ! size = local_rt_nx_size(i+1)*local_rt_ny_size(i+1) ! tag = 2 -! call mpi_recv(out_buff(ibegin:iend,jbegin:jend),size,& +! call MPI_Recv(out_buff(ibegin:iend,jbegin:jend),size,& ! MPI_REAL,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) ! end if ! end do ! end if -! return ! end subroutine write_IO_RT_real_prev subroutine write_IO_RT_real (in_buff,out_buff) @@ -922,14 +887,14 @@ subroutine write_IO_RT_real (in_buff,out_buff) if(my_id .eq. IO_id) then - ! allocate the buffer to hold data as required by mpi_scatterv + ! allocate the buffer to hold data as required by MPI_Scatterv ! (this will be larger than out_buff due to halo cell overlap) - ! be careful with the index range if using array prepared for mpi in fortran (offset_vectors) + ! be careful with the index range if using array prepared for MPI in fortran (offset_vectors) allocate(recv_buff(0: sum(size_vectors_rt) -1),stat = ierr) ! recieve from each process size_vector(mpi_rank+1) data elements ! and store the results in recv_buffer - call mpi_gatherv(in_buff, size_vectors_rt(my_id+1), MPI_REAL, & + call MPI_Gatherv(in_buff, size_vectors_rt(my_id+1), MPI_REAL, & recv_buff, size_vectors_rt, offset_vectors_rt, MPI_REAL, & IO_id, HYDRO_COMM_WORLD, ierr) @@ -953,12 +918,11 @@ subroutine write_IO_RT_real (in_buff,out_buff) deallocate(recv_buff) else - ! other processes only need to make mpi_gatherv call - call mpi_gatherv(in_buff, local_rt_nx*local_rt_ny, MPI_REAL, & + ! other processes only need to make MPI_Gatherv call + call MPI_Gatherv(in_buff, local_rt_nx*local_rt_ny, MPI_REAL, & recv_buff, size_vectors_rt, offset_vectors_rt, MPI_REAL, & IO_id, HYDRO_COMM_WORLD, ierr) end if - return end subroutine write_IO_RT_real subroutine write_IO_RT_int (in_buff,out_buff) @@ -972,14 +936,14 @@ subroutine write_IO_RT_int (in_buff,out_buff) if(my_id .eq. IO_id) then - ! allocate the buffer to hold data as required by mpi_scatterv + ! allocate the buffer to hold data as required by MPI_Scatterv ! (this will be larger than out_buff due to halo cell overlap) - ! be careful with the index range if using array prepared for mpi in fortran (offset_vectors) + ! be careful with the index range if using array prepared for MPI in fortran (offset_vectors) allocate(recv_buff(0: sum(size_vectors_rt) -1),stat = ierr) ! recieve from each process size_vector(mpi_rank+1) data elements ! and store the results in recv_buffer - call mpi_gatherv(in_buff, size_vectors_rt(my_id+1), MPI_REAL, & + call MPI_Gatherv(in_buff, size_vectors_rt(my_id+1), MPI_REAL, & recv_buff, size_vectors_rt, offset_vectors_rt, MPI_REAL, & IO_id, HYDRO_COMM_WORLD, ierr) @@ -1003,12 +967,11 @@ subroutine write_IO_RT_int (in_buff,out_buff) deallocate(recv_buff) else - ! other processes only need to make mpi_gatherv call - call mpi_gatherv(in_buff, local_rt_nx*local_rt_ny, MPI_INTEGER, & + ! other processes only need to make MPI_Gatherv call + call MPI_Gatherv(in_buff, local_rt_nx*local_rt_ny, MPI_INTEGER, & recv_buff, size_vectors_rt, offset_vectors_rt, MPI_INTEGER, & IO_id, HYDRO_COMM_WORLD, ierr) end if - return end subroutine write_IO_RT_int ! subroutine write_IO_RT_int (in_buff,out_buff) @@ -1020,7 +983,7 @@ end subroutine write_IO_RT_int ! if(my_id .ne. IO_id) then ! size = local_rt_nx*local_rt_ny ! tag = 2 -! call mpi_send(in_buff,size,MPI_INTEGER, IO_id, & +! call MPI_Send(in_buff,size,MPI_INTEGER, IO_id, & ! tag,HYDRO_COMM_WORLD,ierr) ! else ! do i = 0, numprocs - 1 @@ -1035,12 +998,11 @@ end subroutine write_IO_RT_int ! else ! size = local_rt_nx_size(i+1)*local_rt_ny_size(i+1) ! tag = 2 -! call mpi_recv(out_buff(ibegin:iend,jbegin:jend),size,& +! call MPI_Recv(out_buff(ibegin:iend,jbegin:jend),size,& ! MPI_INTEGER,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) ! end if ! end do ! end if -! return ! end subroutine write_IO_RT_int subroutine write_IO_RT_int8(in_buff,out_buff) @@ -1052,7 +1014,7 @@ subroutine write_IO_RT_int8(in_buff,out_buff) if(my_id .ne. IO_id) then size = local_rt_nx*local_rt_ny tag = 2 - call mpi_send(in_buff,size,MPI_INTEGER8, IO_id, & + call MPI_Send(in_buff,size,MPI_INTEGER8, IO_id, & tag,HYDRO_COMM_WORLD,ierr) else do i = 0, numprocs - 1 @@ -1067,20 +1029,18 @@ subroutine write_IO_RT_int8(in_buff,out_buff) else size = local_rt_nx_size(i+1)*local_rt_ny_size(i+1) tag = 2 - call mpi_recv(out_buff(ibegin:iend,jbegin:jend),size,& + call MPI_Recv(out_buff(ibegin:iend,jbegin:jend),size,& MPI_INTEGER8,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) end if end do end if - return end subroutine write_IO_RT_int8 subroutine mpp_land_bcast_log1(inout) logical inout integer ierr - call mpi_bcast(inout,1,MPI_LOGICAL, & + call MPI_Bcast(inout,1,MPI_LOGICAL, & IO_id,HYDRO_COMM_WORLD,ierr) - return end subroutine mpp_land_bcast_log1 @@ -1088,18 +1048,16 @@ subroutine mpp_land_bcast_int(size,inout) integer size integer inout(size) integer ierr - call mpi_bcast(inout,size,MPI_INTEGER, & + call MPI_Bcast(inout,size,MPI_INTEGER, & IO_id,HYDRO_COMM_WORLD,ierr) - return end subroutine mpp_land_bcast_int subroutine mpp_land_bcast_int8(size,inout) integer size integer(kind=int64) inout(size) integer ierr - call mpi_bcast(inout,size,MPI_INTEGER8, & + call MPI_Bcast(inout,size,MPI_INTEGER8, & IO_id,HYDRO_COMM_WORLD,ierr) - return end subroutine mpp_land_bcast_int8 subroutine mpp_land_bcast_int8_1d(inout) @@ -1107,9 +1065,8 @@ subroutine mpp_land_bcast_int8_1d(inout) integer(kind=int64) inout(:) integer ierr len = size(inout,1) - call mpi_bcast(inout,len,MPI_INTEGER8, & + call MPI_Bcast(inout,len,MPI_INTEGER8, & IO_id,HYDRO_COMM_WORLD,ierr) - return end subroutine mpp_land_bcast_int8_1d subroutine mpp_land_bcast_int1d(inout) @@ -1117,9 +1074,8 @@ subroutine mpp_land_bcast_int1d(inout) integer inout(:) integer ierr len = size(inout,1) - call mpi_bcast(inout,len,MPI_INTEGER, & + call MPI_Bcast(inout,len,MPI_INTEGER, & IO_id,HYDRO_COMM_WORLD,ierr) - return end subroutine mpp_land_bcast_int1d subroutine mpp_land_bcast_int1d_root(inout, rootId) @@ -1128,56 +1084,49 @@ subroutine mpp_land_bcast_int1d_root(inout, rootId) integer, intent(in) :: rootId integer ierr len = size(inout,1) - call mpi_bcast(inout,len,MPI_INTEGER,rootId,HYDRO_COMM_WORLD,ierr) - return + call MPI_Bcast(inout,len,MPI_INTEGER,rootId,HYDRO_COMM_WORLD,ierr) end subroutine mpp_land_bcast_int1d_root subroutine mpp_land_bcast_int1(inout) integer inout integer ierr - call mpi_bcast(inout,1,MPI_INTEGER, & + call MPI_Bcast(inout,1,MPI_INTEGER, & IO_id,HYDRO_COMM_WORLD,ierr) - return end subroutine mpp_land_bcast_int1 subroutine mpp_land_bcast_int1_root(inout, rootId) integer inout integer ierr integer, intent(in) :: rootId - call mpi_bcast(inout,1,MPI_INTEGER,rootId,HYDRO_COMM_WORLD,ierr) - return + call MPI_Bcast(inout,1,MPI_INTEGER,rootId,HYDRO_COMM_WORLD,ierr) end subroutine mpp_land_bcast_int1_root subroutine mpp_land_bcast_logical(inout) logical :: inout integer ierr - call mpi_bcast(inout,1,MPI_LOGICAL, & + call MPI_Bcast(inout,1,MPI_LOGICAL, & IO_id,HYDRO_COMM_WORLD,ierr) - return end subroutine mpp_land_bcast_logical subroutine mpp_land_bcast_logical_root(inout, rootId) logical :: inout integer, intent(in) :: rootId integer ierr - call mpi_bcast(inout,1,MPI_LOGICAL,rootId,HYDRO_COMM_WORLD,ierr) - return + call MPI_Bcast(inout,1,MPI_LOGICAL,rootId,HYDRO_COMM_WORLD,ierr) end subroutine mpp_land_bcast_logical_root subroutine mpp_land_bcast_real1(inout) real inout integer ierr - call mpi_bcast(inout,1,MPI_REAL, & + call MPI_Bcast(inout,1,MPI_REAL, & IO_id,HYDRO_COMM_WORLD,ierr) - return end subroutine mpp_land_bcast_real1 subroutine mpp_land_bcast_real1_double(inout) real*8 inout integer ierr - call mpi_bcast(inout,1,MPI_REAL8, & + call MPI_Bcast(inout,1,MPI_REAL8, & IO_id,HYDRO_COMM_WORLD,ierr) - return end subroutine mpp_land_bcast_real1_double subroutine mpp_land_bcast_real_1d(inout) @@ -1185,9 +1134,8 @@ subroutine mpp_land_bcast_real_1d(inout) real inout(:) integer ierr len = size(inout,1) - call mpi_bcast(inout,len,MPI_real, & + call MPI_Bcast(inout,len,MPI_REAL, & IO_id,HYDRO_COMM_WORLD,ierr) - return end subroutine mpp_land_bcast_real_1d subroutine mpp_land_bcast_real_1d_root(inout, rootId) @@ -1196,8 +1144,7 @@ subroutine mpp_land_bcast_real_1d_root(inout, rootId) integer, intent(in) :: rootId integer ierr len = size(inout,1) - call mpi_bcast(inout,len,MPI_real,rootId,HYDRO_COMM_WORLD,ierr) - return + call MPI_Bcast(inout,len,MPI_REAL,rootId,HYDRO_COMM_WORLD,ierr) end subroutine mpp_land_bcast_real_1d_root subroutine mpp_land_bcast_real8_1d(inout) @@ -1205,9 +1152,8 @@ subroutine mpp_land_bcast_real8_1d(inout) real*8 inout(:) integer ierr len = size(inout,1) - call mpi_bcast(inout,len,MPI_double, & + call MPI_Bcast(inout,len,MPI_DOUBLE, & IO_id,HYDRO_COMM_WORLD,ierr) - return end subroutine mpp_land_bcast_real8_1d subroutine mpp_land_bcast_real(size1,inout) @@ -1215,9 +1161,8 @@ subroutine mpp_land_bcast_real(size1,inout) ! real inout(size1) real , dimension(:) :: inout integer ierr, len - call mpi_bcast(inout,size1,MPI_real, & + call MPI_Bcast(inout,size1,MPI_REAL, & IO_id,HYDRO_COMM_WORLD,ierr) - return end subroutine mpp_land_bcast_real subroutine mpp_land_bcast_int2d(inout) @@ -1227,10 +1172,9 @@ subroutine mpp_land_bcast_int2d(inout) length1 = size(inout,1) length2 = size(inout,2) do k = 1, length2 - call mpi_bcast(inout(:,k),length1,MPI_INTEGER, & + call MPI_Bcast(inout(:,k),length1,MPI_INTEGER, & IO_id,HYDRO_COMM_WORLD,ierr) end do - return end subroutine mpp_land_bcast_int2d subroutine mpp_land_bcast_real2(inout) @@ -1240,10 +1184,9 @@ subroutine mpp_land_bcast_real2(inout) length1 = size(inout,1) length2 = size(inout,2) do k = 1, length2 - call mpi_bcast(inout(:,k),length1,MPI_real, & + call MPI_Bcast(inout(:,k),length1,MPI_REAL, & IO_id,HYDRO_COMM_WORLD,ierr) end do - return end subroutine mpp_land_bcast_real2 subroutine mpp_land_bcast_real3d(inout) @@ -1255,29 +1198,26 @@ subroutine mpp_land_bcast_real3d(inout) length3 = size(inout,3) do k = 1, length3 do j = 1, length2 - call mpi_bcast(inout(:,j,k), length1, MPI_real, & + call MPI_Bcast(inout(:,j,k), length1, MPI_REAL, & IO_id, HYDRO_COMM_WORLD, ierr) end do end do - return end subroutine mpp_land_bcast_real3d subroutine mpp_land_bcast_rd(size,inout) integer size real*8 inout(size) integer ierr - call mpi_bcast(inout,size,MPI_REAL8, & + call MPI_Bcast(inout,size,MPI_REAL8, & IO_id,HYDRO_COMM_WORLD,ierr) - return end subroutine mpp_land_bcast_rd subroutine mpp_land_bcast_char(size,inout) integer size character inout(*) integer ierr - call mpi_bcast(inout,size,MPI_CHARACTER, & + call MPI_Bcast(inout,size,MPI_CHARACTER, & IO_id,HYDRO_COMM_WORLD,ierr) - return end subroutine mpp_land_bcast_char subroutine mpp_land_bcast_char_root(size,inout,rootId) @@ -1285,8 +1225,7 @@ subroutine mpp_land_bcast_char_root(size,inout,rootId) character inout(*) integer, intent(in) :: rootId integer ierr - call mpi_bcast(inout,size,MPI_CHARACTER,rootId,HYDRO_COMM_WORLD,ierr) - return + call MPI_Bcast(inout,size,MPI_CHARACTER,rootId,HYDRO_COMM_WORLD,ierr) end subroutine mpp_land_bcast_char_root subroutine mpp_land_bcast_char1d(inout) @@ -1294,9 +1233,8 @@ subroutine mpp_land_bcast_char1d(inout) integer :: lenSize integer :: ierr lenSize = size(inout,1)*len(inout) - call mpi_bcast(inout,lenSize,MPI_CHARACTER, & + call MPI_Bcast(inout,lenSize,MPI_CHARACTER, & IO_id,HYDRO_COMM_WORLD,ierr) - return end subroutine mpp_land_bcast_char1d subroutine mpp_land_bcast_char1d_root(inout,rootId) @@ -1305,8 +1243,7 @@ subroutine mpp_land_bcast_char1d_root(inout,rootId) integer :: lenSize integer :: ierr lenSize = size(inout,1)*len(inout) - call mpi_bcast(inout,lenSize,MPI_CHARACTER,rootId,HYDRO_COMM_WORLD,ierr) - return + call MPI_Bcast(inout,lenSize,MPI_CHARACTER,rootId,HYDRO_COMM_WORLD,ierr) end subroutine mpp_land_bcast_char1d_root subroutine mpp_land_bcast_char1(inout) @@ -1314,9 +1251,8 @@ subroutine mpp_land_bcast_char1(inout) character(len=*) inout integer ierr len = LEN_TRIM(inout) - call mpi_bcast(inout,len,MPI_CHARACTER, & + call MPI_Bcast(inout,len,MPI_CHARACTER, & IO_id,HYDRO_COMM_WORLD,ierr) - return end subroutine mpp_land_bcast_char1 subroutine MPP_LAND_COM_REAL(in_out_data,NX,NY,flag) @@ -1329,7 +1265,6 @@ subroutine MPP_LAND_COM_REAL(in_out_data,NX,NY,flag) call MPP_LAND_LR_COM(in_out_data,NX,NY,flag) call MPP_LAND_UB_COM(in_out_data,NX,NY,flag) - return end subroutine MPP_LAND_COM_REAL subroutine MPP_LAND_COM_REAL8(in_out_data,NX,NY,flag) @@ -1342,7 +1277,6 @@ subroutine MPP_LAND_COM_REAL8(in_out_data,NX,NY,flag) call MPP_LAND_LR_COM8(in_out_data,NX,NY,flag) call MPP_LAND_UB_COM8(in_out_data,NX,NY,flag) - return end subroutine MPP_LAND_COM_REAL8 subroutine MPP_LAND_COM_INTEGER(data,NX,NY,flag) @@ -1358,7 +1292,6 @@ subroutine MPP_LAND_COM_INTEGER(data,NX,NY,flag) call MPP_LAND_UB_COM(in_out_data,NX,NY,flag) data = in_out_data + 0 - return end subroutine MPP_LAND_COM_INTEGER @@ -1375,7 +1308,6 @@ subroutine MPP_LAND_COM_INTEGER8(data,NX,NY,flag) call MPP_LAND_UB_COM(in_out_data,NX,NY,flag) data = in_out_data + 0 - return end subroutine MPP_LAND_COM_INTEGER8 subroutine read_restart_3(unit,nz,out) @@ -1386,7 +1318,6 @@ subroutine read_restart_3(unit,nz,out) do i = 1,nz call decompose_data_real (buf3(:,:,i),out(:,:,i)) end do - return end subroutine read_restart_3 subroutine read_restart_2(unit,out) @@ -1399,7 +1330,6 @@ subroutine read_restart_2(unit,out) if(ierr2 .ne. 0) return call decompose_data_real (buf2,out) - return end subroutine read_restart_2 subroutine read_restart_rt_2(unit,out) @@ -1413,7 +1343,6 @@ subroutine read_restart_rt_2(unit,out) call decompose_RT_real(buf2,out, & global_rt_nx,global_rt_ny,local_rt_nx,local_rt_ny) - return end subroutine read_restart_rt_2 subroutine read_restart_rt_3(unit,nz,out) @@ -1429,7 +1358,6 @@ subroutine read_restart_rt_3(unit,nz,out) call decompose_RT_real (buf3(:,:,i),out(:,:,i),& global_rt_nx,global_rt_ny,local_rt_nx,local_rt_ny) end do - return end subroutine read_restart_rt_3 subroutine write_restart_3(unit,nz,in) @@ -1440,7 +1368,6 @@ subroutine write_restart_3(unit,nz,in) call write_IO_real(in(:,:,i),buf3(:,:,i)) end do if(my_id.eq.IO_id) write(unit) buf3 - return end subroutine write_restart_3 subroutine write_restart_2(unit,in) @@ -1449,7 +1376,6 @@ subroutine write_restart_2(unit,in) in(local_nx,local_ny) call write_IO_real(in,buf2) if(my_id.eq.IO_id) write(unit) buf2 - return end subroutine write_restart_2 subroutine write_restart_rt_2(unit,in) @@ -1458,7 +1384,6 @@ subroutine write_restart_rt_2(unit,in) in(local_rt_nx,local_rt_ny) call write_IO_RT_real(in,buf2) if(my_id.eq.IO_id) write(unit) buf2 - return end subroutine write_restart_rt_2 subroutine write_restart_rt_3(unit,nz,in) @@ -1469,7 +1394,6 @@ subroutine write_restart_rt_3(unit,nz,in) call write_IO_RT_real(in(:,:,i),buf3(:,:,i)) end do if(my_id.eq.IO_id) write(unit) buf3 - return end subroutine write_restart_rt_3 subroutine decompose_RT_real (in_buff,out_buff,g_nx,g_ny,nx,ny) @@ -1496,16 +1420,15 @@ subroutine decompose_RT_real (in_buff,out_buff,g_nx,g_ny,nx,ny) else ! send data to the rest process. size = (iend-ibegin+1)*(jend-jbegin+1) - call mpi_send(in_buff(ibegin:iend,jbegin:jend),size,& + call MPI_Send(in_buff(ibegin:iend,jbegin:jend),size,& MPI_REAL, i,tag,HYDRO_COMM_WORLD,ierr) end if end do else size = nx*ny - call mpi_recv(out_buff,size,MPI_REAL,IO_id, & + call MPI_Recv(out_buff,size,MPI_REAL,IO_id, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) end if - return end subroutine decompose_RT_real subroutine decompose_RT_int (in_buff,out_buff,g_nx,g_ny,nx,ny) @@ -1532,16 +1455,15 @@ subroutine decompose_RT_int (in_buff,out_buff,g_nx,g_ny,nx,ny) else ! send data to the rest process. size = (iend-ibegin+1)*(jend-jbegin+1) - call mpi_send(in_buff(ibegin:iend,jbegin:jend),size,& + call MPI_Send(in_buff(ibegin:iend,jbegin:jend),size,& MPI_INTEGER, i,tag,HYDRO_COMM_WORLD,ierr) end if end do else size = nx*ny - call mpi_recv(out_buff,size,MPI_INTEGER,IO_id, & + call MPI_Recv(out_buff,size,MPI_INTEGER,IO_id, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) end if - return end subroutine decompose_RT_int subroutine decompose_RT_int8 (in_buff,out_buff,g_nx,g_ny,nx,ny) @@ -1568,16 +1490,15 @@ subroutine decompose_RT_int8 (in_buff,out_buff,g_nx,g_ny,nx,ny) else ! send data to the rest process. size = (iend-ibegin+1)*(jend-jbegin+1) - call mpi_send(in_buff(ibegin:iend,jbegin:jend),size,& + call MPI_Send(in_buff(ibegin:iend,jbegin:jend),size,& MPI_INTEGER8, i,tag,HYDRO_COMM_WORLD,ierr) end if end do else size = nx*ny - call mpi_recv(out_buff,size,MPI_INTEGER8,IO_id, & + call MPI_Recv(out_buff,size,MPI_INTEGER8,IO_id, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) end if - return end subroutine decompose_RT_int8 subroutine getNX_NY(nprocs,nx,ny) @@ -1605,7 +1526,6 @@ subroutine getNX_NY(nprocs,nx,ny) end if end if end do - return end subroutine getNX_NY subroutine pack_global_22(in, & @@ -1616,7 +1536,6 @@ subroutine pack_global_22(in, & do i = 1, k call write_IO_real(in(:,:,i),out(:,:,i)) enddo - return end subroutine pack_global_22 @@ -1627,8 +1546,8 @@ subroutine wrf_LAND_set_INIT(info,total_pe,AGGFACTRT) integer :: ierr, status integer i - call MPI_COMM_RANK( HYDRO_COMM_WORLD, my_id, ierr ) - call MPI_COMM_SIZE( HYDRO_COMM_WORLD, numprocs, ierr ) + call MPI_Comm_rank( HYDRO_COMM_WORLD, my_id, ierr ) + call MPI_Comm_size( HYDRO_COMM_WORLD, numprocs, ierr ) if(numprocs .ne. total_pe) then write(6,*) "FATAL ERROR: In wrf_LAND_set_INIT() - numprocs .ne. total_pe ",numprocs, total_pe @@ -1687,13 +1606,11 @@ subroutine wrf_LAND_set_INIT(info,total_pe,AGGFACTRT) enddo call calculate_offset_vectors() - return end subroutine wrf_LAND_set_INIT subroutine getMy_global_id() integer ierr - call MPI_COMM_RANK( HYDRO_COMM_WORLD, my_id, ierr ) - return + call MPI_Comm_rank( HYDRO_COMM_WORLD, my_id, ierr ) end subroutine getMy_global_id subroutine MPP_CHANNEL_COM_REAL(Link_location,ix,jy,Link_V,size,flag) @@ -1897,7 +1814,6 @@ subroutine print_2(unit,in,fm) in(local_nx,local_ny) call write_IO_real(in,buf2) if(my_id.eq.IO_id) write(unit,*) buf2 - return end subroutine print_2 subroutine print_rt_2(unit,in) @@ -1906,7 +1822,6 @@ subroutine print_rt_2(unit,in) in(local_nx,local_ny) call write_IO_real(in,buf2) if(my_id.eq.IO_id) write(unit,*) buf2 - return end subroutine print_rt_2 subroutine mpp_land_max_int1(v) @@ -1919,19 +1834,18 @@ subroutine mpp_land_max_int1(v) if(i .ne. my_id) then !block receive from other node. tag = 101 - call mpi_recv(r1,1,MPI_INTEGER,i, & + call MPI_Recv(r1,1,MPI_INTEGER,i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) if(max <= r1) max = r1 end if end do else tag = 101 - call mpi_send(v,1,MPI_INTEGER, IO_id, & + call MPI_Send(v,1,MPI_INTEGER, IO_id, & tag,HYDRO_COMM_WORLD,ierr) end if call mpp_land_bcast_int1(max) v = max - return end subroutine mpp_land_max_int1 subroutine mpp_land_max_real1(v) @@ -1944,19 +1858,18 @@ subroutine mpp_land_max_real1(v) if(i .ne. my_id) then !block receive from other node. tag = 101 - call mpi_recv(r1,1,MPI_REAL,i, & + call MPI_Recv(r1,1,MPI_REAL,i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) if(max <= r1) max = r1 end if end do else tag = 101 - call mpi_send(v,1,MPI_REAL, IO_id, & + call MPI_Send(v,1,MPI_REAL, IO_id, & tag,HYDRO_COMM_WORLD,ierr) end if call mpp_land_bcast_real1(max) v = max - return end subroutine mpp_land_max_real1 subroutine mpp_same_int1(v) @@ -1968,14 +1881,14 @@ subroutine mpp_same_int1(v) if(i .ne. my_id) then !block receive from other node. tag = 109 - call mpi_recv(r1,1,MPI_INTEGER,i, & + call MPI_Recv(r1,1,MPI_INTEGER,i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) if(v .ne. r1) v = -99 end if end do else tag = 109 - call mpi_send(v,1,MPI_INTEGER, IO_id, & + call MPI_Send(v,1,MPI_INTEGER, IO_id, & tag,HYDRO_COMM_WORLD,ierr) end if call mpp_land_bcast_int1(v) @@ -2014,11 +1927,11 @@ subroutine write_chanel_real(v,map_l2g,gnlinks,nlinks,g_v) !block receive from other node. tag = 109 - call mpi_recv(tmp_map(1:message_len),message_len,MPI_INTEGER,i, & + call MPI_Recv(tmp_map(1:message_len),message_len,MPI_INTEGER,i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) tag = 119 - call mpi_recv(tmp_v(1:message_len),message_len,MPI_REAL,i, & + call MPI_Recv(tmp_v(1:message_len),message_len,MPI_REAL,i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) do k = 1,message_len @@ -2047,10 +1960,10 @@ subroutine write_chanel_real(v,map_l2g,gnlinks,nlinks,g_v) end do else tag = 109 - call mpi_send(map_l2g,nlinks,MPI_INTEGER, IO_id, & + call MPI_Send(map_l2g,nlinks,MPI_INTEGER, IO_id, & tag,HYDRO_COMM_WORLD,ierr) tag = 119 - call mpi_send(v,nlinks,MPI_REAL,IO_id, & + call MPI_Send(v,nlinks,MPI_REAL,IO_id, & tag,HYDRO_COMM_WORLD,ierr) end if @@ -2088,11 +2001,11 @@ subroutine write_chanel_int(v,map_l2g,gnlinks,nlinks,g_v) !block receive from other node. tag = 109 - call mpi_recv(tmp_map(1:message_len),message_len,MPI_INTEGER,i, & + call MPI_Recv(tmp_map(1:message_len),message_len,MPI_INTEGER,i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) tag = 119 - call mpi_recv(tmp_v(1:message_len),message_len,MPI_INTEGER,i, & + call MPI_Recv(tmp_v(1:message_len),message_len,MPI_INTEGER,i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) do k = 1,message_len @@ -2121,10 +2034,10 @@ subroutine write_chanel_int(v,map_l2g,gnlinks,nlinks,g_v) end do else tag = 109 - call mpi_send(map_l2g,nlinks,MPI_INTEGER, IO_id, & + call MPI_Send(map_l2g,nlinks,MPI_INTEGER, IO_id, & tag,HYDRO_COMM_WORLD,ierr) tag = 119 - call mpi_send(v,nlinks,MPI_INTEGER,IO_id, & + call MPI_Send(v,nlinks,MPI_INTEGER,IO_id, & tag,HYDRO_COMM_WORLD,ierr) end if if(allocated(tmp_map)) deallocate(tmp_map) @@ -2162,10 +2075,10 @@ subroutine write_chanel_int8(v,map_l2g,gnlinks,nlinks,g_v) !block receive from other node. tag = 109 - call mpi_recv(tmp_map(1:message_len),message_len,MPI_INTEGER,i, & + call MPI_Recv(tmp_map(1:message_len),message_len,MPI_INTEGER,i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) tag = 119 - call mpi_recv(tmp_v(1:message_len),message_len,MPI_INTEGER8,i, & + call MPI_Recv(tmp_v(1:message_len),message_len,MPI_INTEGER8,i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) do k = 1,message_len @@ -2194,10 +2107,10 @@ subroutine write_chanel_int8(v,map_l2g,gnlinks,nlinks,g_v) end do else tag = 109 - call mpi_send(map_l2g,nlinks,MPI_INTEGER, IO_id, & + call MPI_Send(map_l2g,nlinks,MPI_INTEGER, IO_id, & tag,HYDRO_COMM_WORLD,ierr) tag = 119 - call mpi_send(v,nlinks,MPI_INTEGER8,IO_id, & + call MPI_Send(v,nlinks,MPI_INTEGER8,IO_id, & tag,HYDRO_COMM_WORLD,ierr) end if if(allocated(tmp_map)) deallocate(tmp_map) @@ -2218,10 +2131,10 @@ subroutine write_lake_real(v,nodelist_in,nlakes) if(i .ne. my_id) then !block receive from other node. tag = 129 - call mpi_recv(nodelist,nlakes,MPI_INTEGER,i, & + call MPI_Recv(nodelist,nlakes,MPI_INTEGER,i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) tag = 139 - call mpi_recv(recv(:),nlakes,MPI_REAL,i, & + call MPI_Recv(recv(:),nlakes,MPI_REAL,i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) do k = 1,nlakes @@ -2234,10 +2147,10 @@ subroutine write_lake_real(v,nodelist_in,nlakes) end do else tag = 129 - call mpi_send(nodelist,nlakes,MPI_INTEGER, IO_id, & + call MPI_Send(nodelist,nlakes,MPI_INTEGER, IO_id, & tag,HYDRO_COMM_WORLD,ierr) tag = 139 - call mpi_send(v,nlakes,MPI_REAL,IO_id, & + call MPI_Send(v,nlakes,MPI_REAL,IO_id, & tag,HYDRO_COMM_WORLD,ierr) end if end subroutine write_lake_real @@ -2258,10 +2171,10 @@ subroutine write_lake_char(v,nodelist_in,nlakes) if(i .ne. my_id) then !block receive from other node. tag = 129 - call mpi_recv(nodelist,nlakes,MPI_INTEGER,i, & + call MPI_Recv(nodelist,nlakes,MPI_INTEGER,i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) tag = 139 - call mpi_recv(recv(:),in_len,MPI_CHARACTER,i, & + call MPI_Recv(recv(:),in_len,MPI_CHARACTER,i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) do k = 1,nlakes @@ -2274,10 +2187,10 @@ subroutine write_lake_char(v,nodelist_in,nlakes) end do else tag = 129 - call mpi_send(nodelist,nlakes,MPI_INTEGER, IO_id, & + call MPI_Send(nodelist,nlakes,MPI_INTEGER, IO_id, & tag,HYDRO_COMM_WORLD,ierr) tag = 139 - call mpi_send(v,in_len,MPI_CHARACTER,IO_id, & + call MPI_Send(v,in_len,MPI_CHARACTER,IO_id, & tag,HYDRO_COMM_WORLD,ierr) end if end subroutine write_lake_char @@ -2294,9 +2207,8 @@ subroutine read_rst_crt_r(unit,out,size) 99 continue call mpp_land_bcast_int1(ierr2) if(ierr2 .ne. 0) return - call mpi_bcast(out,size,MPI_REAL, & + call MPI_Bcast(out,size,MPI_REAL, & IO_id,HYDRO_COMM_WORLD,ierr) - return end subroutine read_rst_crt_r subroutine write_rst_crt_r(unit,cd,map_l2g,gnlinks,nlinks) @@ -2305,7 +2217,6 @@ subroutine write_rst_crt_r(unit,cd,map_l2g,gnlinks,nlinks) real g_cd (gnlinks) call write_chanel_real(cd,map_l2g,gnlinks,nlinks, g_cd) write(unit) g_cd - return end subroutine write_rst_crt_r subroutine sum_int1d(vin,nsize) @@ -2317,17 +2228,16 @@ subroutine sum_int1d(vin,nsize) if(my_id .eq. IO_id) then do i = 0, numprocs - 1 if(i .ne. my_id) then - call mpi_recv(recv,nsize,MPI_INTEGER,i, & + call MPI_Recv(recv,nsize,MPI_INTEGER,i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) vin(:) = vin(:) + recv(:) endif end do else - call mpi_send(vin,nsize,MPI_INTEGER,IO_id, & + call MPI_Send(vin,nsize,MPI_INTEGER,IO_id, & tag,HYDRO_COMM_WORLD,ierr) endif call mpp_land_bcast_int1d(vin) - return end subroutine sum_int1d subroutine combine_int1d(vin,nsize, flag) @@ -2339,7 +2249,7 @@ subroutine combine_int1d(vin,nsize, flag) if(my_id .eq. IO_id) then do i = 0, numprocs - 1 if(i .ne. my_id) then - call mpi_recv(recv,nsize,MPI_INTEGER,i, & + call MPI_Recv(recv,nsize,MPI_INTEGER,i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) do k = 1, nsize if(recv(k) .ne. flag) then @@ -2349,11 +2259,10 @@ subroutine combine_int1d(vin,nsize, flag) endif end do else - call mpi_send(vin,nsize,MPI_INTEGER,IO_id, & + call MPI_Send(vin,nsize,MPI_INTEGER,IO_id, & tag,HYDRO_COMM_WORLD,ierr) endif call mpp_land_bcast_int1d(vin) - return end subroutine combine_int1d subroutine combine_int8_1d(vin,nsize, flag) @@ -2365,7 +2274,7 @@ subroutine combine_int8_1d(vin,nsize, flag) if(my_id .eq. IO_id) then do i = 0, numprocs - 1 if(i .ne. my_id) then - call mpi_recv(recv,nsize,MPI_INTEGER8,i, & + call MPI_Recv(recv,nsize,MPI_INTEGER8,i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) do k = 1, nsize if(recv(k) .ne. flag) then @@ -2375,11 +2284,10 @@ subroutine combine_int8_1d(vin,nsize, flag) endif end do else - call mpi_send(vin,nsize,MPI_INTEGER8,IO_id, & + call MPI_Send(vin,nsize,MPI_INTEGER8,IO_id, & tag,HYDRO_COMM_WORLD,ierr) endif call mpp_land_bcast_int8_1d(vin) - return end subroutine combine_int8_1d subroutine sum_real1d(vin,nsize) @@ -2401,19 +2309,18 @@ subroutine sum_real8(vin,nsize) if(my_id .eq. IO_id) then do i = 0, numprocs - 1 if(i .ne. my_id) then - call mpi_recv(recv,nsize,MPI_DOUBLE_PRECISION,i, & + call MPI_Recv(recv,nsize,MPI_DOUBLE_PRECISION,i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) vin(:) = vin(:) + recv(:) endif end do v = vin else - call mpi_send(vin,nsize,MPI_DOUBLE_PRECISION,IO_id, & + call MPI_Send(vin,nsize,MPI_DOUBLE_PRECISION,IO_id, & tag,HYDRO_COMM_WORLD,ierr) endif call mpp_land_bcast_real(nsize,v) vin = v - return end subroutine sum_real8 ! subroutine get_globalDim(ix,g_ix) @@ -2422,15 +2329,14 @@ end subroutine sum_real8 ! ! if ( my_id .eq. IO_id ) then ! g_ix = ix -! call mpi_reduce( MPI_IN_PLACE, g_ix, 4, MPI_INTEGER, & +! call MPI_Reduce( MPI_IN_PLACE, g_ix, 4, MPI_INTEGER, & ! MPI_SUM, 0, HYDRO_COMM_WORLD, ierr ) ! else -! call mpi_reduce( ix, 0, 4, MPI_INTEGER, & +! call MPI_Reduce( ix, 0, 4, MPI_INTEGER, & ! MPI_SUM, 0, HYDRO_COMM_WORLD, ierr ) ! endif ! call mpp_land_bcast_int1(g_ix) ! -! return ! ! end subroutine get_globalDim @@ -2456,28 +2362,27 @@ subroutine gather_1d_real_tmp(vl,s_in,e_in,vg,sg) if(i .ne. my_id) then !block receive from other node. tag = 202 - call mpi_recv(index_s,2,MPI_INTEGER,i, & + call MPI_Recv(index_s,2,MPI_INTEGER,i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) tag = 203 e = index_s(2) s = index_s(1) size = e - s + 1 - call mpi_recv(vg(s:e),size,MPI_REAL, & + call MPI_Recv(vg(s:e),size,MPI_REAL, & i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) endif end do else tag = 202 - call mpi_send(index_s,2,MPI_INTEGER, IO_id, & + call MPI_Send(index_s,2,MPI_INTEGER, IO_id, & tag,HYDRO_COMM_WORLD,ierr) tag = 203 - call mpi_send(vl,size,MPI_REAL,IO_id, & + call MPI_Send(vl,size,MPI_REAL,IO_id, & tag,HYDRO_COMM_WORLD,ierr) end if - return end subroutine gather_1d_real_tmp subroutine sum_real1(inout) @@ -2485,7 +2390,7 @@ subroutine sum_real1(inout) real:: inout, send integer :: ierr send = inout - CALL MPI_ALLREDUCE(send,inout,1,MPI_REAL,MPI_SUM,HYDRO_COMM_WORLD,ierr) + call MPI_Allreduce(send,inout,1,MPI_REAL,MPI_SUM,HYDRO_COMM_WORLD,ierr) end subroutine sum_real1 subroutine sum_double(inout) @@ -2493,8 +2398,8 @@ subroutine sum_double(inout) real*8:: inout, send integer :: ierr send = inout - !yw CALL MPI_ALLREDUCE(send,inout,1,MPI_DOUBLE,MPI_SUM,HYDRO_COMM_WORLD,ierr) - CALL MPI_ALLREDUCE(send,inout,1,MPI_DOUBLE_PRECISION,MPI_SUM,HYDRO_COMM_WORLD,ierr) + !yw call MPI_Allreduce(send,inout,1,MPI_DOUBLE,MPI_SUM,HYDRO_COMM_WORLD,ierr) + call MPI_Allreduce(send,inout,1,MPI_DOUBLE_PRECISION,MPI_SUM,HYDRO_COMM_WORLD,ierr) end subroutine sum_double subroutine mpp_chrt_nlinks_collect(nlinks) @@ -2508,14 +2413,14 @@ subroutine mpp_chrt_nlinks_collect(nlinks) if(my_id .eq. IO_id) then do i = 0,numprocs -1 if(i .ne. my_id) then - call mpi_recv(mpp_nlinks(i+1),1,MPI_INTEGER,i, & + call MPI_Recv(mpp_nlinks(i+1),1,MPI_INTEGER,i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) else mpp_nlinks(i+1) = 0 end if end do else - call mpi_send(nlinks,1,MPI_INTEGER, IO_id, & + call MPI_Send(nlinks,1,MPI_INTEGER, IO_id, & tag,HYDRO_COMM_WORLD,ierr) endif @@ -2589,13 +2494,13 @@ subroutine mpp_collect_1d_int(nlinks,vinout) if(my_id .eq. IO_id) then do i = 0,numprocs -1 if(i .ne. my_id) then - call mpi_recv(buf,nlinks,MPI_INTEGER,i, & + call MPI_Recv(buf,nlinks,MPI_INTEGER,i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) vinout = vinout + buf end if end do else - call mpi_send(vinout,nlinks,MPI_INTEGER, IO_id, & + call MPI_Send(vinout,nlinks,MPI_INTEGER, IO_id, & tag,HYDRO_COMM_WORLD,ierr) endif call mpp_land_bcast_int1d(vinout) @@ -2618,11 +2523,11 @@ subroutine mpp_collect_1d_int_mem(nlinks,vinout) do i = 0,numprocs -1 if(i .ne. my_id) then tag = 120 - call mpi_recv(lsize,1,MPI_INTEGER,i, & + call MPI_Recv(lsize,1,MPI_INTEGER,i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) if(lsize .gt. 0) then tag = 121 - call mpi_recv(tmpBuf(1:lsize),lsize,MPI_INTEGER,i, & + call MPI_Recv(tmpBuf(1:lsize),lsize,MPI_INTEGER,i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) do k = 1, lsize m = tmpBuf(k) @@ -2641,11 +2546,11 @@ subroutine mpp_collect_1d_int_mem(nlinks,vinout) end if end do tag = 120 - call mpi_send(lsize,1,MPI_INTEGER, IO_id, & + call MPI_Send(lsize,1,MPI_INTEGER, IO_id, & tag,HYDRO_COMM_WORLD,ierr) if(lsize .gt. 0) then tag = 121 - call mpi_send(tmpIn(1:lsize),lsize,MPI_INTEGER, IO_id, & + call MPI_Send(tmpIn(1:lsize),lsize,MPI_INTEGER, IO_id, & tag,HYDRO_COMM_WORLD,ierr) endif endif @@ -2664,12 +2569,12 @@ subroutine updateLake_seqInt(in,nsize,in0) tag = 29 if(my_id .ne. IO_id) then - call mpi_send(in,nsize,MPI_INTEGER, IO_id, & + call MPI_Send(in,nsize,MPI_INTEGER, IO_id, & tag,HYDRO_COMM_WORLD,ierr) else do i = 0, numprocs - 1 if(i .ne. IO_id) then - call mpi_recv(tmp,nsize,& + call MPI_Recv(tmp,nsize,& MPI_INTEGER,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) do k = 1, nsize if(in0(k) .ne. tmp(k)) in(k) = tmp(k) @@ -2692,12 +2597,12 @@ subroutine updateLake_seqInt8(in,nsize,in0) tag = 29 if(my_id .ne. IO_id) then - call mpi_send(in,nsize,MPI_INTEGER8, IO_id, & + call MPI_Send(in,nsize,MPI_INTEGER8, IO_id, & tag,HYDRO_COMM_WORLD,ierr) else do i = 0, numprocs - 1 if(i .ne. IO_id) then - call mpi_recv(tmp,nsize,& + call MPI_Recv(tmp,nsize,& MPI_INTEGER8,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) do k = 1, nsize if(in0(k) .ne. tmp(k)) in(k) = tmp(k) @@ -2729,7 +2634,7 @@ subroutine updateLake_seq(in,nsize,in0) allocate(prev(nsize)) if (my_id == IO_id) prev = in0 - call mpi_bcast(prev, nsize, MPI_REAL, IO_id, HYDRO_COMM_WORLD, ierr) + call MPI_Bcast(prev, nsize, MPI_REAL, IO_id, HYDRO_COMM_WORLD, ierr) if (my_id == IO_id) then adjustment = in @@ -2737,7 +2642,7 @@ subroutine updateLake_seq(in,nsize,in0) adjustment = in - prev end if - call mpi_allreduce(adjustment, in, nsize, MPI_REAL, MPI_SUM, HYDRO_COMM_WORLD, ierr) ! TODO: check ierr! + call MPI_Allreduce(adjustment, in, nsize, MPI_REAL, MPI_SUM, HYDRO_COMM_WORLD, ierr) ! TODO: check ierr! deallocate(adjustment) deallocate(prev) @@ -2758,12 +2663,12 @@ subroutine updateLake_seq_char(in,nsize,in0) tag = 29 if(my_id .ne. IO_id) then - call mpi_send(in,in_len,MPI_CHARACTER, IO_id, & + call MPI_Send(in,in_len,MPI_CHARACTER, IO_id, & tag,HYDRO_COMM_WORLD,ierr) else do i = 0, numprocs - 1 if(i .ne. IO_id) then - call mpi_recv(tmp,in_len,& + call MPI_Recv(tmp,in_len,& MPI_CHARACTER,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) do k = 1, nsize if(in0(k) .ne. tmp(k)) in(k) = tmp(k) @@ -2787,19 +2692,19 @@ subroutine updateLake_grid(in,nsize,lake_index) if(my_id .ne. IO_id) then tag = 29 - call mpi_send(in,nsize,MPI_REAL, IO_id, & + call MPI_Send(in,nsize,MPI_REAL, IO_id, & tag,HYDRO_COMM_WORLD,ierr) tag = 30 - call mpi_send(lake_index,nsize,MPI_INTEGER, IO_id, & + call MPI_Send(lake_index,nsize,MPI_INTEGER, IO_id, & tag,HYDRO_COMM_WORLD,ierr) else do i = 0, numprocs - 1 if(i .ne. IO_id) then tag = 29 - call mpi_recv(tmp,nsize,& + call MPI_Recv(tmp,nsize,& MPI_REAL,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) tag = 30 - call mpi_recv(lake_index,nsize,& + call MPI_Recv(lake_index,nsize,& MPI_INTEGER,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) do k = 1, nsize if(lake_index(k) .gt. 0) in(k) = tmp(k) @@ -2824,7 +2729,7 @@ subroutine match1dLake(vin,nsize,flag) if(my_id .eq. IO_id) then do i = 0, numprocs - 1 if(i .ne. my_id) then - call mpi_recv(recv,nsize,MPI_INTEGER,i, & + call MPI_Recv(recv,nsize,MPI_INTEGER,i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) do k = 1, nsize if(recv(k) .eq. flag) vin(k) = flag @@ -2839,25 +2744,23 @@ subroutine match1dLake(vin,nsize,flag) endif end do else - call mpi_send(vin,nsize,MPI_INTEGER,IO_id, & + call MPI_Send(vin,nsize,MPI_INTEGER,IO_id, & tag,HYDRO_COMM_WORLD,ierr) endif call mpp_land_bcast_int1d(vin) - return end subroutine match1dLake subroutine mpp_land_abort() implicit none integer ierr - CALL MPI_ABORT(HYDRO_COMM_WORLD,1,IERR) + call MPI_Abort(HYDRO_COMM_WORLD,1,ierr) end subroutine mpp_land_abort ! mpp_land_abort subroutine mpp_land_sync() implicit none integer ierr - call MPI_barrier( HYDRO_COMM_WORLD ,ierr) + call MPI_Barrier( HYDRO_COMM_WORLD ,ierr) if(ierr .ne. 0) call mpp_land_abort() - return end subroutine mpp_land_sync ! mpp_land_sync subroutine mpp_comm_scalar_real(scalar, fromImage, toImage) @@ -2867,10 +2770,10 @@ subroutine mpp_comm_scalar_real(scalar, fromImage, toImage) integer:: ierr, tag tag=2 if(my_id .eq. fromImage) & - call mpi_send(scalar, 1, MPI_REAL, & + call MPI_Send(scalar, 1, MPI_REAL, & toImage, tag, HYDRO_COMM_WORLD, ierr) if(my_id .eq. toImage) & - call mpi_recv(scalar, 1, MPI_REAL, & + call MPI_Recv(scalar, 1, MPI_REAL, & fromImage, tag, HYDRO_COMM_WORLD, mpp_status, ierr) end subroutine mpp_comm_scalar_real @@ -2882,10 +2785,10 @@ subroutine mpp_comm_scalar_char(scalar, fromImage, toImage) tag=2 length=len(scalar) if(my_id .eq. fromImage) & - call mpi_send(scalar, length, MPI_CHARACTER, & + call MPI_Send(scalar, length, MPI_CHARACTER, & toImage, tag, HYDRO_COMM_WORLD, ierr) if(my_id .eq. toImage) & - call mpi_recv(scalar, length, MPI_CHARACTER, & + call MPI_Recv(scalar, length, MPI_CHARACTER, & fromImage, tag, HYDRO_COMM_WORLD, mpp_status, ierr) end subroutine mpp_comm_scalar_char @@ -2897,14 +2800,14 @@ subroutine mpp_comm_1d_real(vector, fromImage, toImage) integer:: ierr, tag integer:: my_id, numprocs tag=2 - call MPI_COMM_RANK(HYDRO_COMM_WORLD,my_id,ierr) - call MPI_COMM_SIZE(HYDRO_COMM_WORLD,numprocs,ierr) + call MPI_Comm_rank(HYDRO_COMM_WORLD,my_id,ierr) + call MPI_Comm_size(HYDRO_COMM_WORLD,numprocs,ierr) if(numprocs > 1) then if(my_id .eq. fromImage) & - call mpi_send(vector, size(vector), MPI_REAL, & + call MPI_Send(vector, size(vector), MPI_REAL, & toImage, tag, HYDRO_COMM_WORLD, ierr) if(my_id .eq. toImage) & - call mpi_recv(vector, size(vector), MPI_REAL, & + call MPI_Recv(vector, size(vector), MPI_REAL, & fromImage, tag, HYDRO_COMM_WORLD, mpp_status, ierr) endif end subroutine mpp_comm_1d_real @@ -2917,15 +2820,15 @@ subroutine mpp_comm_1d_char(vector, fromImage, toImage) integer:: ierr, tag, totalLength integer:: my_id,numprocs tag=2 - call MPI_COMM_RANK(HYDRO_COMM_WORLD,my_id,ierr) - call MPI_COMM_SIZE(HYDRO_COMM_WORLD,numprocs,ierr) + call MPI_Comm_rank(HYDRO_COMM_WORLD,my_id,ierr) + call MPI_Comm_size(HYDRO_COMM_WORLD,numprocs,ierr) totalLength=len(vector(1))*size(vector,1) if(numprocs > 1) then if(my_id .eq. fromImage) & - call mpi_send(vector, totalLength, MPI_CHARACTER, & + call MPI_Send(vector, totalLength, MPI_CHARACTER, & toImage, tag, HYDRO_COMM_WORLD, ierr) if(my_id .eq. toImage) & - call mpi_recv(vector, totalLength, MPI_CHARACTER, & + call MPI_Recv(vector, totalLength, MPI_CHARACTER, & fromImage, tag, HYDRO_COMM_WORLD, mpp_status, ierr) endif end subroutine mpp_comm_1d_char diff --git a/hydro/OrchestratorLayer/config.F90 b/hydro/OrchestratorLayer/config.F90 index 8188579658..6e6d772959 100644 --- a/hydro/OrchestratorLayer/config.F90 +++ b/hydro/OrchestratorLayer/config.F90 @@ -39,6 +39,17 @@ module config_base integer :: glacier_option integer :: surface_resistance_option + character(len=256) :: forcing_name_T + character(len=256) :: forcing_name_Q + character(len=256) :: forcing_name_U + character(len=256) :: forcing_name_V + character(len=256) :: forcing_name_P + character(len=256) :: forcing_name_LW + character(len=256) :: forcing_name_SW + character(len=256) :: forcing_name_PR + character(len=256) :: forcing_name_SN + character(len=256) :: forcing_name_LF + integer :: soil_data_option = 1 integer :: pedotransfer_option = 0 integer :: crop_option = 0 @@ -112,6 +123,7 @@ module config_base character(len=256) :: route_chan_f="" character(len=256) :: route_link_f="" character(len=256) :: route_lake_f="" + integer :: lake_option logical :: reservoir_persistence_usgs logical :: reservoir_persistence_usace character(len=256) :: reservoir_parameter_file="" @@ -212,168 +224,208 @@ subroutine rt_nlst_check(self) ! ! Go through and make some logical checks for each hydro.namelist option. ! ! Some of these checks will depend on specific options chosen by the user. - if( (self%sys_cpl .lt. 1) .or. (self%sys_cpl .gt. 4) ) then + if ( (self%sys_cpl .lt. 1) .or. (self%sys_cpl .gt. 4) ) then call hydro_stop("hydro.namelist ERROR: Invalid sys_cpl value specified.") - endif - if(len(trim(self%geo_static_flnm)) .eq. 0) then + endif + + if (len(trim(self%geo_static_flnm)) .eq. 0) then call hydro_stop("hydro.namelist ERROR: Please specify a GEO_STATIC_FLNM file.") else inquire(file=trim(self%geo_static_flnm),exist=fileExists) if (.not. fileExists) call hydro_stop('hydro.namelist ERROR: GEO_STATIC_FLNM not found.') endif - if(len(trim(self%geo_finegrid_flnm)) .eq. 0) then + + if (len(trim(self%geo_finegrid_flnm)) .eq. 0) then call hydro_stop("hydro.namelist ERROR: Please specify a GEO_FINEGRID_FLNM file.") else inquire(file=trim(self%geo_finegrid_flnm),exist=fileExists) if (.not. fileExists) call hydro_stop('hydro.namelist ERROR: GEO_FINEGRID_FLNM not found.') endif + !if(len(trim(self%land_spatial_meta_flnm)) .eq. 0) then ! call hydro_stop("hydro.namelist ERROR: Please specify a LAND_SPATIAL_META_FLNM file.") !else ! inquire(file=trim(self%land_spatial_meta_flnm),exist=fileExists) ! if (.not. fileExists) call hydro_stop('hydro.namelist ERROR: LAND_SPATIAL_META_FLNM not found.') !endif - if(len(trim(self%RESTART_FILE)) .ne. 0) then + + if (len(trim(self%RESTART_FILE)) .ne. 0) then inquire(file=trim(self%RESTART_FILE),exist=fileExists) if (.not. fileExists) call hydro_stop('hydro.namelist ERROR:= Hydro RESTART_FILE not found.') endif - if(self%igrid .le. 0) call hydro_stop('hydro.namelist ERROR: Invalid IGRID specified.') - if(self%out_dt .le. 0) call hydro_stop('hydro_namelist ERROR: Invalid out_dt specified.') - if( (self%split_output_count .lt. 0 ) .or. (self%split_output_count .gt. 1) ) then + + if (self%igrid .le. 0) call hydro_stop('hydro.namelist ERROR: Invalid IGRID specified.') + + if (self%out_dt .le. 0) call hydro_stop('hydro_namelist ERROR: Invalid out_dt specified.') + + if ((self%split_output_count .lt. 0 ) .or. (self%split_output_count .gt. 1) ) then call hydro_stop('hydro.namelist ERROR: Invalid SPLIT_OUTPUT_COUNT specified') endif - if( (self%rst_typ .lt. 0 ) .or. (self%rst_typ .gt. 1) ) then + + if ((self%rst_typ .lt. 0 ) .or. (self%rst_typ .gt. 1) ) then call hydro_stop('hydro.namelist ERROR: Invalid rst_typ specified') endif - if( (self%rst_bi_in .lt. 0 ) .or. (self%rst_bi_in .gt. 1) ) then + + if ((self%rst_bi_in .lt. 0 ) .or. (self%rst_bi_in .gt. 1) ) then call hydro_stop('hydro.namelist ERROR: Invalid rst_bi_in specified') endif - if( (self%rst_bi_out .lt. 0 ) .or. (self%rst_bi_out .gt. 1) ) then + + if ((self%rst_bi_out .lt. 0 ) .or. (self%rst_bi_out .gt. 1) ) then call hydro_stop('hydro.namelist ERROR: Invalid rst_bi_out specified') endif - if( (self%RSTRT_SWC .lt. 0 ) .or. (self%RSTRT_SWC .gt. 1) ) then + + if ((self%RSTRT_SWC .lt. 0 ) .or. (self%RSTRT_SWC .gt. 1) ) then call hydro_stop('hydro.namelist ERROR: Invalid RSTRT_SWC specified') endif - if( (self%GW_RESTART .lt. 0 ) .or. (self%GW_RESTART .gt. 1) ) then + + if ((self%GW_RESTART .lt. 0 ) .or. (self%GW_RESTART .gt. 1) ) then call hydro_stop('hydro.namelist ERROR: Invalid GW_RESTART specified') endif - if( (self%order_to_write .lt. 1 ) .or. (self%order_to_write .gt. 12) ) then + + if ((self%order_to_write .lt. 1 ) .or. (self%order_to_write .gt. 12) ) then call hydro_stop('hydro.namelist ERROR: Invalid order_to_write specified') endif - if( (self%io_form_outputs .lt. 0 ) .or. (self%io_form_outputs .gt. 4) ) then + + if ((self%io_form_outputs .lt. 0 ) .or. (self%io_form_outputs .gt. 4) ) then call hydro_stop('hydro.namelist ERROR: Invalid io_form_outputs specified') endif - if( (self%io_config_outputs .lt. 0 ) .or. (self%io_config_outputs .gt. 6) ) then + + if ((self%io_config_outputs .lt. 0 ) .or. (self%io_config_outputs .gt. 6) ) then call hydro_stop('hydro.namelist ERROR: Invalid io_config_outputs specified') endif - if( (self%t0OutputFlag .lt. 0 ) .or. (self%t0OutputFlag .gt. 1) ) then + + if ((self%t0OutputFlag .lt. 0 ) .or. (self%t0OutputFlag .gt. 1) ) then call hydro_stop('hydro.namelist ERROR: Invalid t0OutputFlag specified') endif - if( (self%output_channelBucket_influx .lt. 0 ) .or. (self%output_channelBucket_influx .gt. 3) ) then + + if ((self%output_channelBucket_influx .lt. 0 ) .or. (self%output_channelBucket_influx .gt. 3) ) then call hydro_stop('hydro.namelist ERROR: Invalid output_channelBucket_influx specified') endif - if( (self%CHRTOUT_DOMAIN .lt. 0 ) .or. (self%CHRTOUT_DOMAIN .gt. 1) ) then + + if ((self%CHRTOUT_DOMAIN .lt. 0 ) .or. (self%CHRTOUT_DOMAIN .gt. 1) ) then call hydro_stop('hydro.namelist ERROR: Invalid CHRTOUT_DOMAIN specified') endif - if( (self%CHANOBS_DOMAIN .lt. 0 ) .or. (self%CHANOBS_DOMAIN .gt. 1) ) then + + if ((self%CHANOBS_DOMAIN .lt. 0 ) .or. (self%CHANOBS_DOMAIN .gt. 1) ) then call hydro_stop('hydro.namelist ERROR: Invalid CHANOBS_DOMAIN specified') endif - if( (self%CHRTOUT_GRID .lt. 0 ) .or. (self%CHRTOUT_GRID .gt. 1) ) then + + if ((self%CHRTOUT_GRID .lt. 0 ) .or. (self%CHRTOUT_GRID .gt. 1) ) then call hydro_stop('hydro.namelist ERROR: Invalid CHRTOUT_GRID specified') endif - if( (self%LSMOUT_DOMAIN .lt. 0 ) .or. (self%LSMOUT_DOMAIN .gt. 1) ) then + + if ((self%LSMOUT_DOMAIN .lt. 0 ) .or. (self%LSMOUT_DOMAIN .gt. 1) ) then call hydro_stop('hydro.namelist ERROR: Invalid LSMOUT_DOMAIN specified') endif - if( (self%RTOUT_DOMAIN .lt. 0 ) .or. (self%RTOUT_DOMAIN .gt. 1) ) then + + if ((self%RTOUT_DOMAIN .lt. 0 ) .or. (self%RTOUT_DOMAIN .gt. 1) ) then call hydro_stop('hydro.namelist ERROR: Invalid RTOUT_DOMAIN specified') endif - if( (self%output_gw .lt. 0 ) .or. (self%output_gw .gt. 2) ) then + + if ((self%output_gw .lt. 0 ) .or. (self%output_gw .gt. 2) ) then call hydro_stop('hydro.namelist ERROR: Invalid output_gw specified') endif - if( (self%outlake .lt. 0 ) .or. (self%outlake .gt. 2) ) then + + if ((self%outlake .lt. 0 ) .or. (self%outlake .gt. 2) ) then call hydro_stop('hydro.namelist ERROR: Invalid outlake specified') endif - if( (self%frxst_pts_out .lt. 0 ) .or. (self%frxst_pts_out .gt. 1) ) then + + if ((self%frxst_pts_out .lt. 0 ) .or. (self%frxst_pts_out .gt. 1) ) then call hydro_stop('hydro.namelist ERROR: Invalid frxst_pts_out specified') endif - if(self%TERADJ_SOLAR .ne. 0) then + + if (self%TERADJ_SOLAR .ne. 0) then call hydro_stop('hydro.namelist ERROR: Invalid TERADJ_SOLAR specified') endif ! The default value of nsoil == -999. When channel-only is used, ! nsoil == -999999. In the case of channel-only, skip following block of code. - if(self%NSOIL .le. 0 .and. self%NSOIL .ne. -999999) then + if (self%NSOIL .le. 0 .and. self%NSOIL .ne. -999999) then call hydro_stop('hydro.namelist ERROR: Invalid NSOIL specified.') endif + do i = 1,self%NSOIL - if(self%ZSOIL8(i) .gt. 0) then + if (self%ZSOIL8(i) .gt. 0) then call hydro_stop('hydro.namelist ERROR: Invalid ZSOIL layer depth specified.') endif - if(i .gt. 1) then - if(self%ZSOIL8(i) .ge. self%ZSOIL8(i-1)) then + if (i .gt. 1) then + if (self%ZSOIL8(i) .ge. self%ZSOIL8(i-1)) then call hydro_stop('hydro.namelist ERROR: Invalid ZSOIL layer depth specified.') endif endif end do - if(self%NSOIL .le. 0 .and. self%NSOIL .ne. -999999) then + if (self%NSOIL .le. 0 .and. self%NSOIL .ne. -999999) then call hydro_stop('hydro.namelist ERROR: Invalid NSOIL specified.') endif - if(self%dxrt0 .le. 0) then + if (self%dxrt0 .le. 0) then call hydro_stop('hydro.namelist ERROR: Invalid DXRT specified.') endif - if(self%AGGFACTRT .le. 0) then + + if (self%AGGFACTRT .le. 0) then call hydro_stop('hydro.namelist ERROR: Invalid AGGFACTRT specified.') endif - if(self%DTRT_CH .le. 0) then + + if (self%DTRT_CH .le. 0) then call hydro_stop('hydro.namelist ERROR: Invalid DTRT_CH specified.') endif - if(self%DTRT_TER .le. 0) then + + if (self%DTRT_TER .le. 0) then call hydro_stop('hydro.namelist ERROR: Invalid DTRT_TER specified.') endif - if( (self%SUBRTSWCRT .lt. 0 ) .or. (self%SUBRTSWCRT .gt. 1) ) then + + if ((self%SUBRTSWCRT .lt. 0 ) .or. (self%SUBRTSWCRT .gt. 1) ) then call hydro_stop('hydro.namelist ERROR: Invalid SUBRTSWCRT specified') endif - if( (self%OVRTSWCRT .lt. 0 ) .or. (self%OVRTSWCRT .gt. 1) ) then + + if ((self%OVRTSWCRT .lt. 0 ) .or. (self%OVRTSWCRT .gt. 1) ) then call hydro_stop('hydro.namelist ERROR: Invalid OVRTSWCRT specified') endif - if( (self%OVRTSWCRT .eq. 1 ) .or. (self%SUBRTSWCRT .eq. 1) ) then + + if ((self%OVRTSWCRT .eq. 1 ) .or. (self%SUBRTSWCRT .eq. 1) ) then if( (self%rt_option .lt. 1 ) .or. (self%rt_option .gt. 2) ) then !if(self%rt_option .ne. 1) then call hydro_stop('hydro.namelist ERROR: Invalid rt_option specified') endif endif - if( (self%CHANRTSWCRT .lt. 0 ) .or. (self%CHANRTSWCRT .gt. 1) ) then + + if ((self%CHANRTSWCRT .lt. 0 ) .or. (self%CHANRTSWCRT .gt. 1) ) then call hydro_stop('hydro.namelist ERROR: Invalid CHANRTSWCRT specified') endif - if(self%CHANRTSWCRT .eq. 1) then - if ( self%channel_option .eq. 5 ) then + + if (self%CHANRTSWCRT .eq. 1) then + if (self%channel_option .eq. 5 ) then self%channel_option = 2 self%channel_bypass = .TRUE. endif - if( (self%channel_option .lt. 1 ) .or. (self%channel_option .gt. 3) ) then + if ((self%channel_option .lt. 1 ) .or. (self%channel_option .gt. 3) ) then call hydro_stop('hydro.namelist ERROR: Invalid channel_option specified') endif endif - if( (self%CHANRTSWCRT .eq. 1) .and. (self%channel_option .lt. 3) ) then - if(len(trim(self%route_link_f)) .eq. 0) then + + if ((self%CHANRTSWCRT .eq. 1) .and. (self%channel_option .lt. 3) ) then + if (len(trim(self%route_link_f)) .eq. 0) then call hydro_stop("hydro.namelist ERROR: Please specify a route_link_f file.") else inquire(file=trim(self%route_link_f),exist=fileExists) if (.not. fileExists) call hydro_stop('hydro.namelist ERROR: route_link_f not found.') endif endif - if( (self%bucket_loss .lt. 0 ) .or. (self%bucket_loss .gt. 1) ) then + + if ((self%bucket_loss .lt. 0 ) .or. (self%bucket_loss .gt. 1) ) then call hydro_stop('hydro.namelist ERROR: Invalid bucket_loss specified') endif - if( (self%bucket_loss .eq. 1 ) .and. (self%UDMP_OPT .ne. 1) ) then + + if ((self%bucket_loss .eq. 1 ) .and. (self%UDMP_OPT .ne. 1) ) then call hydro_stop('hydro.namelist ERROR: Bucket loss only available when UDMP=1') endif - if( (self%GWBASESWCRT .lt. 0 ) .or. (self%GWBASESWCRT .gt. 4) ) then + + if ((self%GWBASESWCRT .lt. 0 ) .or. (self%GWBASESWCRT .gt. 4) ) then call hydro_stop('hydro.namelist ERROR: Invalid GWBASESWCRT specified') endif - if( (self%GWBASESWCRT .eq. 1 ) .or. (self%GWBASESWCRT .eq. 4) ) then + + if ((self%GWBASESWCRT .eq. 1 ) .or. (self%GWBASESWCRT .eq. 4) ) then if(len(trim(self%GWBUCKPARM_file)) .eq. 0) then call hydro_stop("hydro.namelist ERROR: Please specify a GWBUCKPARM_file file.") else @@ -381,7 +433,8 @@ subroutine rt_nlst_check(self) if (.not. fileExists) call hydro_stop('hydro.namelist ERROR: GWBUCKPARM_file not found.') endif endif - if( (self%GWBASESWCRT .gt. 0) .and. (self%UDMP_OPT .ne. 1) ) then + + if ((self%GWBASESWCRT .gt. 0) .and. (self%UDMP_OPT .ne. 1) ) then if(len(trim(self%gwbasmskfil)) .eq. 0) then call hydro_stop("hydro.namelist ERROR: Please specify a gwbasmskfil file.") else @@ -389,10 +442,12 @@ subroutine rt_nlst_check(self) if (.not. fileExists) call hydro_stop('hydro.namelist ERROR: gwbasmskfil not found.') endif endif - if( (self%UDMP_OPT .lt. 0 ) .or. (self%UDMP_OPT .gt. 1) ) then + + if ((self%UDMP_OPT .lt. 0 ) .or. (self%UDMP_OPT .gt. 1) ) then call hydro_stop('hydro.namelist ERROR: Invalid UDMP_OPT specified') endif - if(self%UDMP_OPT .gt. 0) then + + if (self%UDMP_OPT .gt. 0) then if(len(trim(self%udmap_file)) .eq. 0) then call hydro_stop("hydro.namelist ERROR: Please specify a udmap_file file.") else @@ -400,70 +455,78 @@ subroutine rt_nlst_check(self) if (.not. fileExists) call hydro_stop('hydro.namelist ERROR: udmap_file not found.') endif endif - if( (self%UDMP_OPT .eq. 1) .and. (self%CHANRTSWCRT .eq. 0) ) then + + if ((self%UDMP_OPT .eq. 1) .and. (self%CHANRTSWCRT .eq. 0) ) then call hydro_stop('hydro.namelist ERROR: User-defined mapping requires channel routing on.') endif - if(self%outlake .ne. 0) then - if(len(trim(self%route_lake_f)) .eq. 0) then - call hydro_stop('hydro.namelist ERROR: You MUST specify a route_lake_f to ouptut and run lakes.') + + if ((self%outlake .ne. 0) .or. (self%lake_option > 0)) then + if (len(trim(self%route_lake_f)) .eq. 0) then + call hydro_stop('hydro.namelist ERROR: You MUST specify a route_lake_f to output and/or run lakes.') endif endif - if(len(trim(self%route_lake_f)) .ne. 0) then + + if (len(trim(self%route_lake_f)) .ne. 0) then inquire(file=trim(self%route_lake_f),exist=fileExists) - if (.not. fileExists) call hydro_stop('hydro.namelist ERROR: route_lake_f not found.') + if (.not. fileExists) call hydro_stop('hydro.namelist ERROR: specified route_lake_f ('//trim(self%route_lake_f)//') not found.') endif - if((self%channel_option .eq. 3) .and. (self%compound_channel)) then + if ((self%channel_option .eq. 3) .and. (self%compound_channel)) then call hydro_stop("Compound channel option not available for diffusive wave routing. ") end if - if(self%reservoir_type_specified) then - if(len(trim(self%reservoir_parameter_file)) .eq. 0) then + if ((self%lake_option .lt. 0) .or. (self%lake_option .gt. 3)) then + print *, self%lake_option + call hydro_stop("Lake Option must be 0 [lakes off], 1 [level pool], or 2 [passthrough], or 3 [reservoir DA]") + end if + + if (self%reservoir_type_specified) then + if (len(trim(self%reservoir_parameter_file)) .eq. 0) then call hydro_stop('hydro.namelist ERROR: You MUST specify a reservoir_parameter_file for & inputs to reservoirs that are not level pool type.') endif - if(len(trim(self%reservoir_parameter_file)) .ne. 0) then + if (len(trim(self%reservoir_parameter_file)) .ne. 0) then inquire(file=trim(self%reservoir_parameter_file),exist=fileExists) if (.not. fileExists) call hydro_stop('hydro.namelist ERROR: reservoir_parameter_file not found.') endif end if - if(self%reservoir_persistence_usgs) then - if(len(trim(self%reservoir_usgs_timeslice_path)) .eq. 0) then + if (self%reservoir_persistence_usgs) then + if (len(trim(self%reservoir_usgs_timeslice_path)) .eq. 0) then call hydro_stop('hydro.namelist ERROR: You MUST specify a reservoir_usgs_timeslice_path for & reservoir USGS persistence capability.') endif - if(len(trim(self%reservoir_parameter_file)) .ne. 0) then + if (len(trim(self%reservoir_parameter_file)) .ne. 0) then inquire(file=trim(self%reservoir_parameter_file),exist=fileExists) if (.not. fileExists) call hydro_stop('hydro.namelist ERROR: reservoir_parameter_file not found.') endif end if - if(self%reservoir_persistence_usace) then - if(len(trim(self%reservoir_usace_timeslice_path)) .eq. 0) then + if (self%reservoir_persistence_usace) then + if (len(trim(self%reservoir_usace_timeslice_path)) .eq. 0) then call hydro_stop('hydro.namelist ERROR: You MUST specify a reservoir_usace_timeslice_path for & reservoir USACE persistence capability.') endif - if(len(trim(self%reservoir_parameter_file)) .ne. 0) then + if (len(trim(self%reservoir_parameter_file)) .ne. 0) then inquire(file=trim(self%reservoir_parameter_file),exist=fileExists) if (.not. fileExists) call hydro_stop('hydro.namelist ERROR: reservoir_parameter_file not found.') endif end if - if(self%reservoir_rfc_forecasts) then - if(len(trim(self%reservoir_parameter_file)) .eq. 0) then + if (self%reservoir_rfc_forecasts) then + if (len(trim(self%reservoir_parameter_file)) .eq. 0) then call hydro_stop('hydro.namelist ERROR: You MUST specify a reservoir_parameter_file for inputs to rfc forecast type reservoirs.') endif - if(len(trim(self%reservoir_rfc_forecasts_time_series_path)) .eq. 0) then + if (len(trim(self%reservoir_rfc_forecasts_time_series_path)) .eq. 0) then call hydro_stop('hydro.namelist ERROR: You MUST specify a reservoir_rfc_forecasts_time_series_path for reservoir rfc forecast capability.') endif - if(len(trim(self%reservoir_parameter_file)) .ne. 0) then + if (len(trim(self%reservoir_parameter_file)) .ne. 0) then inquire(file=trim(self%reservoir_parameter_file),exist=fileExists) if (.not. fileExists) call hydro_stop('hydro.namelist ERROR: reservoir_parameter_file not found.') endif end if - if( (self%imperv_adj .lt. 0 ) .or. (self%imperv_adj .gt. 1) ) then + if ((self%imperv_adj .lt. 0 ) .or. (self%imperv_adj .gt. 1) ) then call hydro_stop('hydro.namelist ERROR: Invalid imperv_adj specified') endif @@ -475,6 +538,8 @@ subroutine init_namelist_rt_field(did) integer, intent(in) :: did integer ierr + character(len=512) :: msg + integer:: RT_OPTION, CHANRTSWCRT, channel_option, & SUBRTSWCRT,OVRTSWCRT,AGGFACTRT, & GWBASESWCRT, GW_RESTART,RSTRT_SWC,TERADJ_SOLAR, & @@ -488,6 +553,7 @@ subroutine init_namelist_rt_field(did) logical :: compound_channel integer :: channel_loss_option = 0 character(len=256) :: route_lake_f="" + integer :: lake_option !0: lakes off 1: level pool 2: passthrough, 3: reservoir da logical :: reservoir_persistence_usgs logical :: reservoir_persistence_usace character(len=256) :: reservoir_parameter_file="" @@ -562,11 +628,8 @@ subroutine init_namelist_rt_field(did) SUBRTSWCRT,OVRTSWCRT,AGGFACTRT, dtrt_ter,dtrt_ch,dxrt,& GwSpinCycles, GwPreCycles, GwSpinUp, GwPreDiag, GwPreDiagInterval, gwIhShift, & GWBASESWCRT, gwChanCondSw, gwChanCondConstIn, gwChanCondConstOut , & - route_topo_f,route_chan_f,route_link_f, compound_channel, channel_loss_option, route_lake_f, & - reservoir_persistence_usgs, reservoir_persistence_usace, reservoir_parameter_file, reservoir_usgs_timeslice_path, & - reservoir_usace_timeslice_path, reservoir_observation_lookback_hours, reservoir_observation_update_time_interval_seconds, & - reservoir_rfc_forecasts, reservoir_rfc_forecasts_time_series_path, reservoir_rfc_forecasts_lookback_hours, & - reservoir_type_specified, route_direction_f,route_order_f,gwbasmskfil, & + route_topo_f,route_chan_f,route_link_f, compound_channel, channel_loss_option, lake_option, route_lake_f, & + route_direction_f,route_order_f,gwbasmskfil, & geo_finegrid_flnm, gwstrmfil,GW_RESTART,RSTRT_SWC,TERADJ_SOLAR, sys_cpl, & order_to_write , rst_typ, rst_bi_in, rst_bi_out, gwsoilcpl, & CHRTOUT_DOMAIN,CHANOBS_DOMAIN,CHRTOUT_GRID,LSMOUT_DOMAIN,& @@ -574,6 +637,12 @@ subroutine init_namelist_rt_field(did) frxst_pts_out, udmap_file, UDMP_OPT, GWBUCKPARM_file, bucket_loss, & io_config_outputs, io_form_outputs, hydrotbl_f, t0OutputFlag, output_channelBucket_influx, imperv_adj + namelist /reservoir_nlist/ & + reservoir_persistence_usgs, reservoir_persistence_usace, reservoir_parameter_file, reservoir_usgs_timeslice_path, & + reservoir_usace_timeslice_path, reservoir_observation_lookback_hours, reservoir_observation_update_time_interval_seconds, & + reservoir_rfc_forecasts, reservoir_rfc_forecasts_time_series_path, reservoir_rfc_forecasts_lookback_hours, & + reservoir_type_specified + #ifdef WRF_HYDRO_NUDGING namelist /NUDGING_nlist/ nudgingParamFile, netwkReExFile, & readTimesliceParallel, temporalPersistence, & @@ -601,6 +670,7 @@ subroutine init_namelist_rt_field(did) compound_channel = .FALSE. channel_loss_option = 0 bucket_loss = 0 + lake_option = -99 reservoir_persistence_usgs = .FALSE. reservoir_persistence_usace = .FALSE. reservoir_observation_lookback_hours = 18 @@ -635,17 +705,23 @@ subroutine init_namelist_rt_field(did) #else open(12, form="FORMATTED") #endif - read(12, HYDRO_nlist, iostat=ierr) - if(ierr .ne. 0) call hydro_stop("HYDRO_nlst namelist error in read_rt_nlst") + read(12, HYDRO_nlist, iostat=ierr, iomsg=msg) + if(ierr .ne. 0) call hydro_stop("HYDRO_nlst namelist error in read_rt_nlst: " // trim(msg)) + + if (lake_option == 3) then + read(12, reservoir_nlist, iostat=ierr, iomsg=msg) + if (ierr /= 0) call hydro_stop("reservoir_nlist namelist error in read_rt_nlst: " // trim(msg)) + end if #ifdef WRF_HYDRO_NUDGING - read(12, NUDGING_nlist, iostat=ierr) - if(ierr .ne. 0) call hydro_stop("NUDGING_nlst namelist error in read_rt_nlst") + read(12, NUDGING_nlist, iostat=ierr, iomsg=msg) + if(ierr .ne. 0) call hydro_stop("NUDGING_nlst namelist error in read_rt_nlst: " // trim(msg)) !! Conditional default values for nuding_nlist if(maxAgePairsBiasPersist .eq. -99999) maxAgePairsBiasPersist = -1*nLastObs #endif close(12) - if (sys_cpl == 1) call read_crocus_namelist(crocus_opts) + + call read_crocus_namelist(crocus_opts) ! #ifdef MPP_LAND ! endif ! #endif @@ -683,6 +759,25 @@ subroutine init_namelist_rt_field(did) nlst(did)%SOLVEG_INITSWC = SOLVEG_INITSWC nlst(did)%reservoir_obs_dir = "testDirectory" + if (lake_option == 3) then + if (reservoir_persistence_usgs .or. reservoir_persistence_usace .or. reservoir_rfc_forecasts) then + reservoir_type_specified = .TRUE. + else + print *, "WARNING: lake_option = 3 (Reservoir DA), but no specific DA option was enabled. Setting lake_option to 1." + end if + lake_option = 1 ! set to 1 either way + end if + + if (lake_option == -99) then + if (route_lake_f /= "") then + print *, "WARNING: lake_option not specified, but route_lake_f specified. Setting lake_option to 1." + lake_option = 1 + else + lake_option = 0 + end if + end if + + nlst(did)%lake_option = lake_option nlst(did)%reservoir_persistence_usgs = reservoir_persistence_usgs nlst(did)%reservoir_persistence_usace = reservoir_persistence_usace nlst(did)%reservoir_parameter_file = reservoir_parameter_file @@ -694,10 +789,6 @@ subroutine init_namelist_rt_field(did) nlst(did)%reservoir_rfc_forecasts_time_series_path = reservoir_rfc_forecasts_time_series_path nlst(did)%reservoir_rfc_forecasts_lookback_hours = reservoir_rfc_forecasts_lookback_hours - if (reservoir_persistence_usgs .or. reservoir_persistence_usace .or. reservoir_rfc_forecasts) then - reservoir_type_specified = .TRUE. - end if - nlst(did)%reservoir_type_specified = reservoir_type_specified write(nlst(did)%hgrid,'(I1)') igrid @@ -827,6 +918,12 @@ subroutine init_namelist_rt_field(did) nlst(did)%noConstInterfBias = noConstInterfBias #endif + ! if lakes have been disabled (lake_option == 0), clear the route_lake_f and output_lakes options + if (nlst(did)%lake_option == 0) then + nlst(did)%route_lake_f = '' + nlst(did)%outlake = 0 + end if + call nlst(did)%check() ! derive rtFlag @@ -888,6 +985,16 @@ subroutine init_noah_lsm_and_wrf_hydro() character(len=256) :: restart_filename_requested = " " integer :: restart_frequency_hours integer :: output_timestep + character(len=256) :: forcing_name_T = "T2D" + character(len=256) :: forcing_name_Q = "Q2D" + character(len=256) :: forcing_name_U = "U2D" + character(len=256) :: forcing_name_V = "V2D" + character(len=256) :: forcing_name_P = "PSFC" + character(len=256) :: forcing_name_LW = "LWDOWN" + character(len=256) :: forcing_name_SW = "SWDOWN" + character(len=256) :: forcing_name_PR = "RAINRATE" + character(len=256) :: forcing_name_SN = "" + character(len=256) :: forcing_name_LF = "" integer :: dynamic_veg_option integer :: canopy_stomatal_resistance_option integer :: btr_option @@ -932,6 +1039,9 @@ subroutine init_noah_lsm_and_wrf_hydro() outdir, & restart_filename_requested, restart_frequency_hours, output_timestep, & + forcing_name_T,forcing_name_Q,forcing_name_U,forcing_name_V,forcing_name_P, & + forcing_name_LW,forcing_name_SW,forcing_name_PR,forcing_name_SN,forcing_name_LF, & + dynamic_veg_option, canopy_stomatal_resistance_option, & btr_option, runoff_option, surface_drag_option, supercooled_water_option, & frozen_soil_option, radiative_transfer_option, snow_albedo_option, & @@ -1030,6 +1140,16 @@ subroutine init_noah_lsm_and_wrf_hydro() noah_lsm%restart_filename_requested = restart_filename_requested noah_lsm%restart_frequency_hours = restart_frequency_hours noah_lsm%output_timestep = output_timestep + noah_lsm%forcing_name_T = forcing_name_T + noah_lsm%forcing_name_Q = forcing_name_Q + noah_lsm%forcing_name_U = forcing_name_U + noah_lsm%forcing_name_V = forcing_name_V + noah_lsm%forcing_name_P = forcing_name_P + noah_lsm%forcing_name_LW = forcing_name_LW + noah_lsm%forcing_name_SW = forcing_name_SW + noah_lsm%forcing_name_PR = forcing_name_PR + noah_lsm%forcing_name_SN = forcing_name_SN + noah_lsm%forcing_name_LF = forcing_name_LF noah_lsm%dynamic_veg_option = dynamic_veg_option noah_lsm%canopy_stomatal_resistance_option = canopy_stomatal_resistance_option noah_lsm%btr_option = btr_option diff --git a/hydro/Routing/CMakeLists.txt b/hydro/Routing/CMakeLists.txt index 307b695ec6..8c40440b07 100644 --- a/hydro/Routing/CMakeLists.txt +++ b/hydro/Routing/CMakeLists.txt @@ -18,6 +18,7 @@ add_library(hydro_routing STATIC ) target_link_libraries(hydro_routing + PRIVATE MPI::MPI_Fortran netCDF::netcdff hydro_mpp diff --git a/hydro/Routing/Noah_distr_routing.F90 b/hydro/Routing/Noah_distr_routing.F90 index 46631cd67b..3de5c5339b 100644 --- a/hydro/Routing/Noah_distr_routing.F90 +++ b/hydro/Routing/Noah_distr_routing.F90 @@ -1,23 +1,3 @@ -! Program Name: -! Author(s)/Contact(s): -! Abstract: -! History Log: -! -! Usage: -! Parameters: -! Input Files: -! -! Output Files: -! -! -! Condition codes: -! -! If appropriate, descriptive troubleshooting instructions or -! likely causes for failures could be mentioned here with the -! appropriate error code -! -! User controllable options: - !DJG ------------------------------------------------ !DJG SUBROUTINE RT_PARM !DJG ------------------------------------------------ @@ -147,7 +127,6 @@ SUBROUTINE GETMAX8DIR(IXX0,JYY0,I,J,H,RETENT_DEP,sox,tmp_gsize,max,XX,YY) IXX8 = I-1 JYY8 = J+1 call GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox(:,:,8),IXX0,JYY0,max,tmp_gsize(8),XX,YY) - RETURN END SUBROUTINE GETMAX8DIR SUBROUTINE GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox & @@ -207,7 +186,6 @@ SUBROUTINE GETSUB8(I, J, XX, YY, wattbl, terrslpNeighbors, distNeighbors, & terrslpNeighbors(I,J,neighIndx), distNeighbors(neighIndx), & maxneighI, maxneighJ, maxneighIndx, maxneighSlp) enddo - RETURN END SUBROUTINE GETSUB8 SUBROUTINE GETSUB8DIR(I, J, selfWattbl, & @@ -341,7 +319,6 @@ SUBROUTINE TER_ADJ_SOL(IX,JX,SO8LD_D,TSLP,SHORT,XLAT,XLONG,olddate,DT) SHORT = SOLDN - return end SUBROUTINE TER_ADJ_SOL !DJG----------------------------------------------------------------------- !DJG END SUBROUTINE TER_ADJ_SOL @@ -507,7 +484,6 @@ subroutine GMT2LOCAL(IX,JX,XLONG,YY,MM,DD,HH,MIN,DT) end do !i-loop end do !j-loop - return end subroutine !DJG----------------------------------------------------------------------- @@ -542,7 +518,6 @@ subroutine JULDAY_CALC(YYYY,MM,DD,JULDAY) JULDAY = LPJULM(MM) + DD end if - RETURN END subroutine JULDAY_CALC !DJG----------------------------------------------------------------------- !DJG END SUBROUTINE JULDAY @@ -595,7 +570,6 @@ subroutine SLOPE_ASPECT(IX,JX,SO8LD_D,TAZI) END DO END DO - RETURN END subroutine SLOPE_ASPECT !DJG----------------------------------------------------------------------- !DJG END SUBROUTINE SLOPE_ASPECT @@ -761,7 +735,6 @@ SUBROUTINE SOLSUB(LONG,LAT,AZ,IN,SC,YY,MO,IDA,IHR,MM,OUT1, & END IF ! End if for daily vs instantaneous values... !DJG----------------------------------------------------------------------- - RETURN END SUBROUTINE SOLSUB !DJG----------------------------------------------------------------------- @@ -833,7 +806,6 @@ subroutine seq_land_SO8(SO8LD_D,Vmax,TERR,dx,ix,jx) enddo enddo Vmax = TANH(Vmax) - return end subroutine seq_land_SO8 #ifdef MPP_LAND @@ -870,7 +842,6 @@ subroutine MPP_seq_land_SO8(SO8LD_D,Vmax,TERRAIN,dx,ix,jx,& endif call decompose_data_int(g_SO8LD_D(:,:,3),SO8LD_D(:,:,3)) call decompose_data_real(g_Vmax,Vmax) - return end subroutine MPP_seq_land_SO8 #endif @@ -1335,5 +1306,4 @@ subroutine time_seconds(i3) call date_and_time(values=time_array) i3 = time_array(4)*24*3600+time_array(5) * 3600 + time_array(6) * 60 + & time_array(7) + 0.001 * time_array(8) - return end subroutine time_seconds diff --git a/hydro/Routing/Reservoirs/Level_Pool/module_levelpool.F90 b/hydro/Routing/Reservoirs/Level_Pool/module_levelpool.F90 index 6e82367516..02bce4f985 100644 --- a/hydro/Routing/Reservoirs/Level_Pool/module_levelpool.F90 +++ b/hydro/Routing/Reservoirs/Level_Pool/module_levelpool.F90 @@ -56,7 +56,8 @@ module module_levelpool subroutine levelpool_init(this, water_elevation, & lake_area, weir_elevation, weir_coeffecient, & weir_length, dam_length, orifice_elevation, orifice_coefficient, & - orifice_area, max_depth, lake_number) + orifice_area, max_depth, lake_number, lake_opt) + implicit none class(levelpool), intent(inout) :: this ! object being initialized real, intent(inout) :: water_elevation ! meters AMSL @@ -69,7 +70,9 @@ subroutine levelpool_init(this, water_elevation, & real, intent(in) :: orifice_coefficient ! orifice coefficient real, intent(in) :: orifice_area ! orifice area (meters^2) real, intent(in) :: max_depth ! max depth of reservoir before overtop (meters) - integer(kind=int64), intent(in) :: lake_number ! lake number + integer(kind=int64), intent(in) :: lake_number ! lake number + integer, intent(in) :: lake_opt ! bypass lake physics (2 to use pass-through) + character(len=15) :: lake_number_string #ifdef RESERVOIR_D @@ -114,7 +117,7 @@ subroutine levelpool_init(this, water_elevation, & call this%properties%init( lake_area, & weir_elevation, weir_coeffecient, weir_length, dam_length, & orifice_elevation, orifice_coefficient, & - orifice_area, max_depth, lake_number ) + orifice_area, max_depth, lake_number, lake_opt ) end if this%pointer_allocation_guard = .true. @@ -169,6 +172,7 @@ subroutine run_levelpool_reservoir(this, previous_timestep_inflow, inflow, & this%state%water_elevation = water_elevation call LEVELPOOL_PHYSICS(this%properties%lake_number, & + this%properties%lake_opt, & previous_timestep_inflow, & this%input%inflow, & this%output%outflow, & @@ -217,7 +221,7 @@ end subroutine run_levelpool_reservoir ! SUBROUTINE LEVELPOOL ! ------------------------------------------------ - subroutine LEVELPOOL_PHYSICS(ln,qi0,qi1,qo1,ql,dt,H,ar,we,maxh,wc,wl,dl,oe,oc,oa) + subroutine LEVELPOOL_PHYSICS(ln,lake_opt,qi0,qi1,qo1,ql,dt,H,ar,we,maxh,wc,wl,dl,oe,oc,oa) !! ---------------------------- argument variables !! All elevations should be relative to a common base (often belev(k)) @@ -238,9 +242,8 @@ subroutine LEVELPOOL_PHYSICS(ln,qi0,qi1,qo1,ql,dt,H,ar,we,maxh,wc,wl,dl,oe,oc,oa real, intent(IN) :: oa ! orifice area (m^2) real, intent(IN) :: maxh ! max depth of reservoir before overtop (m) integer(kind=int64), intent(IN) :: ln ! lake number + integer, intent(in) :: lake_opt ! reservoir physics options (1: levelpool, 2: passthrough) - !!DJG Add lake option switch here...move up to namelist in future versions... - integer :: LAKE_OPT ! Lake model option (move to namelist later) real :: Htmp ! Temporary assign of incoming lake el. (m) !! ---------------------------- local variables @@ -254,22 +257,20 @@ subroutine LEVELPOOL_PHYSICS(ln,qi0,qi1,qo1,ql,dt,H,ar,we,maxh,wc,wl,dl,oe,oc,oa !! ---------------------------- subroutine body: from chow, mad mays. pg. 252 !! -- determine from inflow hydrograph - - !!DJG Set hardwire for LAKE_OPT...move specification of this to namelist in - !future versions... - LAKE_OPT = 2 Htmp = H !temporary set of incoming lake water elevation... !hdiff_vol = 0.0 !qdiff_vol = 0.0 !!DJG IF-block for lake model option 1 - outflow=inflow, 2 - Chow et al level !pool, ..... - if (LAKE_OPT == 1) then ! If-block for simple pass through scheme.... - + if (LAKE_OPT == 2) then ! If-block for simple pass through scheme.... +#ifdef RESERVOIR_D + write(6,*) "LEVELPOOL LAKE_OPT=2, using reservoir passthrough" +#endif qo1 = qi1 ! Set outflow equal to inflow at current time H = Htmp ! Set new lake water elevation to incoming lake el. - else if (LAKE_OPT == 2) then ! If-block for Chow et al level pool scheme + else if (LAKE_OPT == 1) then ! If-block for Chow et al level pool scheme It = qi0 Itdt_3 = qi0 + ((qi1 + ql - qi0) * 0.33) @@ -406,6 +407,7 @@ subroutine LEVELPOOL_PHYSICS(ln,qi0,qi1,qo1,ql,dt,H,ar,we,maxh,wc,wl,dl,oe,oc,oa else ! ELSE for LAKE_OPT.... + call hydro_stop("Invalid lake option supplied to LEVELPOOL_PHYSICS()") endif ! ENDIF for LAKE_OPT.... return diff --git a/hydro/Routing/Reservoirs/Level_Pool/module_levelpool_properties.F90 b/hydro/Routing/Reservoirs/Level_Pool/module_levelpool_properties.F90 index 0e4a9dfc00..7f6b5e0ca7 100644 --- a/hydro/Routing/Reservoirs/Level_Pool/module_levelpool_properties.F90 +++ b/hydro/Routing/Reservoirs/Level_Pool/module_levelpool_properties.F90 @@ -23,6 +23,7 @@ module module_levelpool_properties real :: orifice_area ! orifice area (meters^2) real :: max_depth ! max depth of reservoir before overtop (meters) integer(kind=int64) :: lake_number ! lake number + integer :: lake_opt ! reservoir physics options (1: levelpool, 2: passthrough) contains @@ -36,7 +37,7 @@ module module_levelpool_properties !Level Pool Properties Constructor subroutine levelpool_properties_init(this, lake_area, & weir_elevation, weir_coeffecient, weir_length, dam_length, orifice_elevation, & - orifice_coefficient, orifice_area, max_depth, lake_number) + orifice_coefficient, orifice_area, max_depth, lake_number, lake_opt) implicit none class(levelpool_properties_interface), intent(inout) :: this ! the type object being initialized real, intent(in) :: lake_area ! area of lake (km^2) @@ -49,6 +50,7 @@ subroutine levelpool_properties_init(this, lake_area, & real, intent(in) :: orifice_area ! orifice area (meters^2) real, intent(in) :: max_depth ! max depth of reservoir before overtop (meters) integer(kind=int64), intent(in) :: lake_number ! lake number + integer :: lake_opt ! reservoir physics options (1: levelpool, 2: passthrough) ! Assign the values passed in to a particular level pool reservoir ! properties object's variables. @@ -62,6 +64,7 @@ subroutine levelpool_properties_init(this, lake_area, & this%max_depth = max_depth this%lake_number = lake_number this%dam_length = dam_length + this%lake_opt = lake_opt end subroutine levelpool_properties_init diff --git a/hydro/Routing/Reservoirs/Persistence_Level_Pool_Hybrid/module_persistence_levelpool_hybrid.F90 b/hydro/Routing/Reservoirs/Persistence_Level_Pool_Hybrid/module_persistence_levelpool_hybrid.F90 index 6d4b599b7e..2c475333ab 100644 --- a/hydro/Routing/Reservoirs/Persistence_Level_Pool_Hybrid/module_persistence_levelpool_hybrid.F90 +++ b/hydro/Routing/Reservoirs/Persistence_Level_Pool_Hybrid/module_persistence_levelpool_hybrid.F90 @@ -201,7 +201,7 @@ subroutine hybrid_init(this, water_elevation, & ! Initialize level pool reservoir call this%state%levelpool_ptr%init(water_elevation, lake_area, & weir_elevation, weir_coeffecient, weir_length, dam_length, orifice_elevation, & - orifice_coefficient, orifice_area, lake_max_water_elevation, lake_number) + orifice_coefficient, orifice_area, lake_max_water_elevation, lake_number, 1) end if end subroutine hybrid_init diff --git a/hydro/Routing/Reservoirs/RFC_Forecasts/module_rfc_forecasts.F90 b/hydro/Routing/Reservoirs/RFC_Forecasts/module_rfc_forecasts.F90 index d78d056f8f..127d2badb0 100644 --- a/hydro/Routing/Reservoirs/RFC_Forecasts/module_rfc_forecasts.F90 +++ b/hydro/Routing/Reservoirs/RFC_Forecasts/module_rfc_forecasts.F90 @@ -156,7 +156,7 @@ subroutine rfc_forecasts_init(this, water_elevation, & ! Initialize level pool reservoir call this%state%levelpool_ptr%init(water_elevation, lake_area, & weir_elevation, weir_coeffecient, weir_length, dam_length, orifice_elevation, & - orifice_coefficient, orifice_area, lake_max_water_elevation, lake_number) + orifice_coefficient, orifice_area, lake_max_water_elevation, lake_number, 1) ! Call to initialize time series data object call time_series_data%init(start_date, time_series_path, forecast_lookback_hours, & diff --git a/hydro/Routing/module_GW_baseflow.F90 b/hydro/Routing/module_GW_baseflow.F90 index 0ad973bb60..34c346a078 100644 --- a/hydro/Routing/module_GW_baseflow.F90 +++ b/hydro/Routing/module_GW_baseflow.F90 @@ -1,23 +1,3 @@ -! Program Name: -! Author(s)/Contact(s): -! Abstract: -! History Log: -! -! Usage: -! Parameters: -! Input Files: -! -! Output Files: -! -! -! Condition codes: -! -! If appropriate, descriptive troubleshooting instructions or -! likely causes for failures could be mentioned here with the -! appropriate error code -! -! User controllable options: - module module_GW_baseflow ! use overland_data @@ -234,7 +214,7 @@ subroutine simp_gw_buck_nhd( & if (bucket_loss .eq. 1) then qloss_gwsubbas(bas) = qout_gwsubbas(bas)*loss_fraction(bas) - qout_gwsubbas(bas) = qout_gwsubbas(bas)-qloss_gwsubbas(bas) + qout_gwsubbas(bas) = qout_gwsubbas(bas)-qloss_gwsubbas(bas) endif elseif (GWBASESWCRT.eq.2) then !Pass through/steady-state bucket @@ -251,7 +231,7 @@ subroutine simp_gw_buck_nhd( & !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! if (bucket_loss .eq. 1) then - z_gwsubbas(bas) = z_gwsubbas(bas) - (qout_gwsubbas(bas)+qloss_gwsubbas(bas))*DT/( basns_area(bas) ) ! units (meters) + z_gwsubbas(bas) = z_gwsubbas(bas) - (qout_gwsubbas(bas)+qloss_gwsubbas(bas))*DT/( basns_area(bas) ) ! units (meters) else z_gwsubbas(bas) = z_gwsubbas(bas) - (qout_gwsubbas(bas))*DT/( basns_area(bas) ) ! units (meters) endif @@ -270,7 +250,6 @@ subroutine simp_gw_buck_nhd( & z_gwsubbas_tmp(1:numbasns) = z_gwsubbas(1:numbasns) ! units (meters) - return !------------------------------------------------------------------------------ End subroutine simp_gw_buck_nhd @@ -459,7 +438,7 @@ subroutine simp_gw_buck(ix,jx,ixrt,jxrt,numbasns,gnumbasns,basns_area,basnsInd,g !DJG bug adjust output to be mm and correct area bug... / (ct_bas(bas)*basns_area(bas)) !units(m) z_gwsubbas(bas) = z_gwsubbas(bas) - qout_gwsubbas(bas)*DT/( & - ct_bas(bas)*basns_area(bas))*1000. ! units (mm) + ct_bas(bas)*basns_area(bas))*1000. ! units (mm) !DJG...Combine calculated bucket discharge and amount spilled from bucket... !ADCHANGE: Add in surface runoff as direct pass-through @@ -508,7 +487,6 @@ subroutine simp_gw_buck(ix,jx,ixrt,jxrt,numbasns,gnumbasns,basns_area,basnsInd,g z_gwsubbas = z_gwsubbas_tmp - return !------------------------------------------------------------------------------ End subroutine simp_gw_buck @@ -569,7 +547,6 @@ subroutine pix_ct_1(in_gw_strm_msk,ixrt,jxrt,gwbas_pix_ct,numbasns,gnumbasns,bas end do - return end subroutine pix_ct_1 #endif diff --git a/hydro/Routing/module_HYDRO_io.F90 b/hydro/Routing/module_HYDRO_io.F90 index c8dfc4388c..06083c73b4 100644 --- a/hydro/Routing/module_HYDRO_io.F90 +++ b/hydro/Routing/module_HYDRO_io.F90 @@ -1,24 +1,3 @@ -! Program Name: -! Author(s)/Contact(s): -! Abstract: -! History Log: -! -! Usage: -! Parameters: -! Input Files: -! -! Output Files: -! -! -! Condition codes: -! -! If appropriate, descriptive troubleshooting instructions or -! likely causes for failures could be mentioned here with the -! appropriate error code -! -! User controllable options: -! - module module_HYDRO_io #ifdef MPP_LAND use module_mpp_land @@ -695,7 +674,6 @@ subroutine get_2d_netcdf_cows(var_name,ncid,var, & endif iret = nf90_get_var(ncid, varid, var, start, count) - return end subroutine get_2d_netcdf_cows !--------------------------------------------------------- @@ -1082,7 +1060,6 @@ subroutine get_NLINKSL(NLINKSL, channel_option, route_link_f) end if !end-if is now for channel_option just above, not IF from further up - return end subroutine get_NLINKSL subroutine nreadRT2d_real(var_name, inv, ixrt, jxrt, fileName, fatalErr) @@ -1357,7 +1334,6 @@ subroutine MPP_READ_SIMP_GW(IX,JX,IXRT,JXRT,GWSUBBASMSK,gwbasmskfil,& if(allocated(g_ch_netrt)) deallocate(g_ch_netrt) if(allocated(g_GWSUBBASMSK)) deallocate(g_GWSUBBASMSK) - return end subroutine MPP_READ_SIMP_GW #endif @@ -1437,7 +1413,6 @@ subroutine READ_SIMP_GW(IX,JX,IXRT,JXRT,GWSUBBASMSK,gwbasmskfil,& write(6,*) "numbasns = ", numbasns #endif - return !DJG ----------------------------------------------------- END SUBROUTINE READ_SIMP_GW @@ -1507,7 +1482,6 @@ subroutine SIMP_GW_IND(ix,jx,GWSUBBASMSK,numbasns,gnumbasns,basnsInd) write(6,*) "check numbasns, gnumbasns : ", numbasns, gnumbasns #endif - return end subroutine SIMP_GW_IND subroutine read_GWBUCKPARM (inFile, numbasns, gnumbasns, basnsInd, & @@ -1760,7 +1734,6 @@ subroutine readGW2d(ix, jx, hc, ihead, botelv, por, ltype, ihShift) !bftodo: make filename accessible in namelist - return end subroutine readGW2d !BF @@ -4773,7 +4746,6 @@ subroutine mpp_output_lakes(lake_index,igrid, split_output_count, NLAKES, & qlakei,qlakeo, resht,dtrt_ch,K) end if call mpp_land_sync() - return end subroutine mpp_output_lakes subroutine mpp_output_lakes2(lake_index,igrid, split_output_count, NLAKES, & @@ -4808,7 +4780,6 @@ subroutine mpp_output_lakes2(lake_index,igrid, split_output_count, NLAKES, & qlakei,qlakeo, resht,dtrt_ch,K, LAKEIDM) end if call mpp_land_sync() - return end subroutine mpp_output_lakes2 #endif @@ -5275,7 +5246,6 @@ subroutine mpp_output_chrtgrd(igrid, split_output_count, ixrt,jxrt, & if(allocated(g_qlink)) deallocate(g_qlink) if(allocated(CH_NETLNK)) deallocate(CH_NETLNK) - return end subroutine mpp_output_chrtgrd #endif @@ -5501,7 +5471,6 @@ subroutine get2d_int(var_name,out_buff,ix,jx,fileName, fatalErr) if(fatalErr_local) call hydro_stop(trim(errMsg)) endif - return end subroutine get2d_int subroutine get2d_int8(var_name,out_buff,ix,jx,fileName, fatalErr) @@ -5548,7 +5517,6 @@ subroutine get2d_int8(var_name,out_buff,ix,jx,fileName, fatalErr) if(fatalErr_local) call hydro_stop(trim(errMsg)) endif - return end subroutine get2d_int8 #ifdef MPP_LAND @@ -5632,7 +5600,6 @@ SUBROUTINE MPP_READ_ROUTEDIM(did,g_IXRT,g_JXRT, GCH_NETLNK,GNLINKS,IXRT,JXRT, & end do call mpp_chrt_nlinks_collect(NLINKS) - return end SUBROUTINE MPP_READ_ROUTEDIM @@ -5729,7 +5696,6 @@ SUBROUTINE READ_ROUTING_seq(IXRT,JXRT,ELRT,CH_NETRT,CH_LNKRT,LKSATFAC,route_topo write(6,*) "finish READ_ROUTING_seq" #endif - return !DJG ----------------------------------------------------- END SUBROUTINE READ_ROUTING_seq @@ -5829,7 +5795,6 @@ subroutine output_lsm(outFile,did) endif #endif - return end subroutine output_lsm @@ -6219,7 +6184,6 @@ subroutine RESTART_OUT_nc(outFile,did) #endif iret = nf90_close(ncid) - return end subroutine RESTART_OUT_nc #ifdef MPP_LAND @@ -6426,7 +6390,6 @@ subroutine w_rst_rt_nc2(ncid,ix,jx,inVar,varName) endif #endif - return end subroutine w_rst_rt_nc2 subroutine w_rst_rt_nc3(ncid,ix,jx,NSOIL,inVar, varName) @@ -6461,7 +6424,6 @@ subroutine w_rst_rt_nc3(ncid,ix,jx,NSOIL,inVar, varName) iret = nf90_put_var(ncid, varid, inVar(:,:,k), (/1,1/), (/ix,jx/)) end do #endif - return end subroutine w_rst_rt_nc3 subroutine w_rst_nc2(ncid,ix,jx,inVar,varName) @@ -6482,7 +6444,6 @@ subroutine w_rst_nc2(ncid,ix,jx,inVar,varName) iret = nf90_put_var(ncid, varid, invar, (/1,1/), (/ix,jx/)) #endif - return end subroutine w_rst_nc2 subroutine w_rst_nc3(ncid,ix,jx,NSOIL,inVar, varName) @@ -6518,7 +6479,6 @@ subroutine w_rst_nc3(ncid,ix,jx,NSOIL,inVar, varName) iret = nf90_put_var(ncid, varid, inVar(:,:,k), (/1,1/), (/ix,jx/)) end do #endif - return end subroutine w_rst_nc3 subroutine w_rst_crt_nc1_lake(ncid,n,inVar,varName & @@ -6542,7 +6502,6 @@ subroutine w_rst_crt_nc1_lake(ncid,n,inVar,varName & #ifdef MPP_LAND endif #endif - return end subroutine w_rst_crt_nc1_lake subroutine w_rst_crt_reach_real(ncid,inVar,varName & @@ -6576,7 +6535,6 @@ subroutine w_rst_crt_reach_real(ncid,inVar,varName & iret = nf90_inq_varid(ncid,varName, varid) iret = nf90_put_var(ncid, varid, inVar, (/1/), (/n/)) #endif - return end subroutine w_rst_crt_reach_real @@ -6611,7 +6569,6 @@ subroutine w_rst_crt_reach_real8(ncid,inVar,varName & iret = nf90_inq_varid(ncid,varName, varid) iret = nf90_put_var(ncid, varid, inVar, (/1/), (/n/)) #endif - return end subroutine w_rst_crt_reach_real8 @@ -6639,7 +6596,6 @@ subroutine w_rst_crt_nc1(ncid,n,inVar,varName & #ifdef MPP_LAND endif #endif - return end subroutine w_rst_crt_nc1 subroutine w_rst_crt_nc1g(ncid,n,inVar,varName) @@ -6655,7 +6611,6 @@ subroutine w_rst_crt_nc1g(ncid,n,inVar,varName) #ifdef MPP_LAND endif #endif - return end subroutine w_rst_crt_nc1g subroutine w_rst_gwbucket_real(ncid,numbasns,gnumbasns, & @@ -6936,7 +6891,6 @@ subroutine RESTART_IN_NC(inFile,did) call flush(6) #endif -return end subroutine RESTART_IN_nc @@ -6986,7 +6940,6 @@ subroutine read_rst_nc3(ncid,ix,jx,NSOIL,var,varStr) #endif end do - return end subroutine read_rst_nc3 subroutine read_rst_nc2(ncid,ix,jx,var,varStr) @@ -7022,7 +6975,6 @@ subroutine read_rst_nc2(ncid,ix,jx,var,varStr) var = 0.0 iret = nf90_get_var(ncid, varid, var) #endif - return end subroutine read_rst_nc2 subroutine read_rst_rt_nc3(ncid,ix,jx,NSOIL,var,varStr) @@ -7064,7 +7016,6 @@ subroutine read_rst_rt_nc3(ncid,ix,jx,NSOIL,var,varStr) iret = nf90_get_var(ncid, varid, var(:,:,i)) #endif end do - return end subroutine read_rst_rt_nc3 subroutine read_rst_rt_nc2(ncid,ix,jx,var,varStr) @@ -7095,7 +7046,6 @@ subroutine read_rst_rt_nc2(ncid,ix,jx,var,varStr) #else iret = nf90_get_var(ncid, varid, var) #endif - return end subroutine read_rst_rt_nc2 subroutine read_rt_nc2(ncid,ix,jx,var,varStr) @@ -7138,7 +7088,6 @@ subroutine read_rt_nc2(ncid,ix,jx,var,varStr) #else iret = nf90_get_var(ncid, varid, var) #endif - return end subroutine read_rt_nc2 subroutine read_rst_crt_nc(ncid,var,n,varStr) @@ -7174,7 +7123,6 @@ subroutine read_rst_crt_nc(ncid,var,n,varStr) call mpp_land_bcast_real(n,var) endif #endif - return end subroutine read_rst_crt_nc subroutine read_rst_crt_stream_nc(ncid,var_out,n,varStr,gnlinks,map_l2g) @@ -7228,7 +7176,6 @@ subroutine read_rst_crt_stream_nc(ncid,var_out,n,varStr,gnlinks,map_l2g) #else var_out = var #endif - return end subroutine read_rst_crt_stream_nc subroutine read_rst_crt_reach_nc_real(ncid,var_out,varStr,gnlinksl, fatalErr) @@ -7327,7 +7274,6 @@ subroutine read_rst_crt_reach_nc_real(ncid,var_out,varStr,gnlinksl, fatalErr) if(allocated(var)) deallocate(var) #endif - return end subroutine read_rst_crt_reach_nc_real @@ -7408,7 +7354,6 @@ subroutine read_rst_crt_reach_nc_real8(ncid, var_out, varStr, gnlinksl, fatalErr iret = nf90_get_var(ncid, varid, var_out) if(allocated(var)) deallocate(var) #endif - return end subroutine read_rst_crt_reach_nc_real8 @@ -8864,7 +8809,6 @@ subroutine MPP_READ_CHROUTING_new(& link_location = CH_NETLNK -return end subroutine MPP_READ_CHROUTING_new @@ -10358,8 +10302,8 @@ subroutine read_NSIMLAKES(NLAKES,route_lake_f) endif else !yw for IOC reach based routing, if netcdf lake file is not set from the hydro.namelist, -! we will assume that no lake will be assimulated. - write(6,*) "No lake nectdf file defined. NLAKES is set to be zero." +! we will assume that no lake will be assimilated. + write(6,*) "Lakes have been disabled -- NLAKES will be set to zero." NLAKES = 0 endif #ifdef MPP_LAND diff --git a/hydro/Routing/module_HYDRO_utils.F90 b/hydro/Routing/module_HYDRO_utils.F90 index 2ff1748952..981b852e19 100644 --- a/hydro/Routing/module_HYDRO_utils.F90 +++ b/hydro/Routing/module_HYDRO_utils.F90 @@ -1,23 +1,3 @@ -! Program Name: -! Author(s)/Contact(s): -! Abstract: -! History Log: -! -! Usage: -! Parameters: -! Input Files: -! -! Output Files: -! -! -! Condition codes: -! -! If appropriate, descriptive troubleshooting instructions or -! likely causes for failures could be mentioned here with the -! appropriate error code -! -! User controllable options: - module module_HYDRO_utils use module_RT_data, only: rt_domain use config_base, only: nlst diff --git a/hydro/Routing/module_NWM_io.F90 b/hydro/Routing/module_NWM_io.F90 index efaa6c74a4..43e7da4352 100644 --- a/hydro/Routing/module_NWM_io.F90 +++ b/hydro/Routing/module_NWM_io.F90 @@ -172,7 +172,7 @@ subroutine output_chrt_NWM(domainId) ! If not MPI, then default to 0, which is the I/O ID. if(mppFlag .eq. 1) then #ifdef MPP_LAND - call MPI_COMM_RANK( HYDRO_COMM_WORLD, myId, ierr ) + call MPI_Comm_rank( HYDRO_COMM_WORLD, myId, ierr ) call nwmCheck(diagFlag,ierr,'ERROR: Unable to determine MPI process ID.') #endif else @@ -1144,7 +1144,7 @@ subroutine output_NoahMP_NWM(outDir,iGrid,output_timestep,itime,startdate,date,i ! If not MPI, then default to 0, which is the I/O ID. if(mppFlag .eq. 1) then #ifdef MPP_LAND - call MPI_COMM_RANK( HYDRO_COMM_WORLD, myId, ierr ) + call MPI_Comm_rank( HYDRO_COMM_WORLD, myId, ierr ) call nwmCheck(diagFlag,ierr,'ERROR: Unable to determine MPI process ID.') #endif else @@ -1857,7 +1857,7 @@ subroutine output_rt_NWM(domainId,iGrid) ! If not MPI, then default to 0, which is the I/O ID. if(mppFlag .eq. 1) then #ifdef MPP_LAND - call MPI_COMM_RANK( HYDRO_COMM_WORLD, myId, ierr ) + call MPI_Comm_rank( HYDRO_COMM_WORLD, myId, ierr ) call nwmCheck(diagFlag,ierr,'ERROR: Unable to determine MPI process ID.') #endif else @@ -2433,7 +2433,7 @@ subroutine output_lakes_NWM(domainId,iGrid) ! If not MPI, then default to 0, which is the I/O ID. if(mppFlag .eq. 1) then #ifdef MPP_LAND - call MPI_COMM_RANK( HYDRO_COMM_WORLD, myId, ierr ) + call MPI_Comm_rank( HYDRO_COMM_WORLD, myId, ierr ) call nwmCheck(diagFlag,ierr,'ERROR: Unable to determine MPI process ID.') #endif else @@ -3125,7 +3125,7 @@ subroutine output_chrtout_grd_NWM(domainId,iGrid) ! If not MPI, then default to 0, which is the I/O ID. if(mppFlag .eq. 1) then #ifdef MPP_LAND - call MPI_COMM_RANK( HYDRO_COMM_WORLD, myId, ierr ) + call MPI_Comm_rank( HYDRO_COMM_WORLD, myId, ierr ) call nwmCheck(diagFlag,ierr,'ERROR: Unable to determine MPI process ID.') #endif else @@ -3613,7 +3613,7 @@ subroutine output_lsmOut_NWM(domainId) ! If not MPI, then default to 0, which is the I/O ID. if(mppFlag .eq. 1) then #ifdef MPP_LAND - call MPI_COMM_RANK( HYDRO_COMM_WORLD, myId, ierr ) + call MPI_Comm_rank( HYDRO_COMM_WORLD, myId, ierr ) call nwmCheck(diagFlag,ierr,'ERROR: Unable to determine MPI process ID.') #endif else @@ -4067,7 +4067,7 @@ subroutine output_frxstPts(domainId) ! If not MPI, then default to 0, which is the I/O ID. if(mppFlag .eq. 1) then #ifdef MPP_LAND - call MPI_COMM_RANK( HYDRO_COMM_WORLD, myId, ierr ) + call MPI_Comm_rank( HYDRO_COMM_WORLD, myId, ierr ) call nwmCheck(diagFlag,ierr,'ERROR: Unable to determine MPI process ID.') #endif else @@ -4375,7 +4375,7 @@ subroutine output_chanObs_NWM(domainId) ! If not MPI, then default to 0, which is the I/O ID. if(mppFlag .eq. 1) then #ifdef MPP_LAND - call MPI_COMM_RANK( HYDRO_COMM_WORLD, myId, ierr ) + call MPI_Comm_rank( HYDRO_COMM_WORLD, myId, ierr ) call nwmCheck(diagFlag,ierr,'ERROR: Unable to determine MPI process ID.') #endif else @@ -5090,7 +5090,7 @@ subroutine output_gw_NWM(domainId,iGrid) ! If not MPI, then default to 0, which is the I/O ID. if(mppFlag .eq. 1) then #ifdef MPP_LAND - call MPI_COMM_RANK( HYDRO_COMM_WORLD, myId, ierr ) + call MPI_Comm_rank( HYDRO_COMM_WORLD, myId, ierr ) call nwmCheck(diagFlag,ierr,'ERROR: Unable to determine MPI process ID.') #endif else diff --git a/hydro/Routing/module_RT.F90 b/hydro/Routing/module_RT.F90 index fa3ef00c01..c11be2ca50 100644 --- a/hydro/Routing/module_RT.F90 +++ b/hydro/Routing/module_RT.F90 @@ -1,23 +1,3 @@ -! Program Name: -! Author(s)/Contact(s): -! Abstract: -! History Log: -! -! Usage: -! Parameters: -! Input Files: -! -! Output Files: -! -! -! Condition codes: -! -! If appropriate, descriptive troubleshooting instructions or -! likely causes for failures could be mentioned here with the -! appropriate error code -! -! User controllable options: - MODULE module_Routing #ifdef MPP_LAND use module_gw_baseflow, only: pix_ct_1 @@ -579,7 +559,7 @@ subroutine getChanDim(did) rt_domain(did)%GNLINKSL = 1 rt_domain(did)%NLINKSL = 1 endif - if(nlst(did)%UDMP_OPT .eq. 1) & + if(nlst(did)%UDMP_OPT .eq. 1 .or. nlst(did)%channel_option .eq. 1 .or. nlst(did)%channel_option .eq. 2) & call read_NSIMLAKES(rt_domain(did)%NLAKES,nlst(did)%route_lake_f) call rt_allocate(did,rt_domain(did)%ix,rt_domain(did)%jx,& @@ -587,7 +567,7 @@ subroutine getChanDim(did) return -endif + endif allocate(CH_NETLNK(ixrt,jxrt)) @@ -609,6 +589,11 @@ subroutine getChanDim(did) call get_NLINKSL(rt_domain(did)%NLINKSL, nlst(did)%channel_option, nlst(did)%route_link_f) #endif +if (nlst(did)%lake_option == 0) then + write(6,*) "Lakes have been disabled -- NLAKES will be set to zero." + rt_domain(did)%nlakes = 0 +end if + #ifdef HYDRO_D write(6,*) "before rt_allocate after READ_ROUTEDIM" #endif @@ -635,7 +620,7 @@ subroutine getChanDim(did) endif -if(nlst(did)%UDMP_OPT .eq. 1) then +if(nlst(did)%UDMP_OPT .eq. 1 .or. nlst(did)%channel_option .eq. 1 .or. nlst(did)%channel_option .eq. 2) then call read_NSIMLAKES(rt_domain(did)%NLAKES,nlst(did)%route_lake_f) endif @@ -853,7 +838,8 @@ subroutine LandRT_ini(did) rt_domain(did)%ORIFICEC(lake_index), & rt_domain(did)%ORIFICEA(lake_index), & rt_domain(did)%LAKEMAXH(lake_index), & - rt_domain(did)%LAKEIDM(lake_index) ) + rt_domain(did)%LAKEIDM(lake_index), & + nlst(did)%lake_option) type is (persistence_levelpool_hybrid) call reservoir%init( & diff --git a/hydro/Routing/module_UDMAP.F90 b/hydro/Routing/module_UDMAP.F90 index 0b72a8eb0c..ff621ea31b 100644 --- a/hydro/Routing/module_UDMAP.F90 +++ b/hydro/Routing/module_UDMAP.F90 @@ -1,23 +1,3 @@ -! Program Name: -! Author(s)/Contact(s): -! Abstract: -! History Log: -! -! Usage: -! Parameters: -! Input Files: -! -! Output Files: -! -! -! Condition codes: -! -! If appropriate, descriptive troubleshooting instructions or -! likely causes for failures could be mentioned here with the -! appropriate error code -! -! User controllable options: - ! This subrouting includs the data structure and tools used for NHDPlus network mapping. module module_UDMAP @@ -335,8 +315,8 @@ subroutine UDMP2LOCAL(npid,ix,jx,rtmask, ter_rt_flag) allocate(LUDRSL(LNUMRSL)) allocate( basns_area(LNUMRSL) ) else -! When MPI is performed,for every subdomain in each process, all the links -! are listed and if there is no link in the subdomain then it is calling +! When MPI is performed,for every subdomain in each process, all the links +! are listed and if there is no link in the subdomain then it is calling ! cleanBuf (memory cleaning purposes), this used to print a warning ! that is not necessary for the user to see it, therefore it is been commented out here ! write(6,*) "Warning: no routing links found." @@ -465,7 +445,6 @@ subroutine get_dimension(fileName, ndata,npid) call mpp_land_bcast_int1(ndata) call mpp_land_bcast_int1(npid) #endif - return end subroutine get_dimension subroutine get1d_real8(fileName,var_name,out_buff) @@ -544,17 +523,17 @@ subroutine getUDMP_area(cell_area) do k = 1, LNUMRSL if(LUDRSL(k)%ngrids .gt. 0) then do m = 1, LUDRSL(k)%ngrids - LUDRSL(k)%nodeArea(m) = cell_area(LUDRSL(k)%grid_i(m),LUDRSL(k)%grid_j(m)) + LUDRSL(k)%nodeArea(m) = cell_area(LUDRSL(k)%grid_i(m),LUDRSL(k)%grid_j(m)) enddo endif do m = 1, LUDRSL(k)%ncell - LUDRSL(k)%cellArea(m) = cell_area(LUDRSL(k)%cell_i(m),LUDRSL(k)%cell_j(m)) + LUDRSL(k)%cellArea(m) = cell_area(LUDRSL(k)%cell_i(m),LUDRSL(k)%cell_j(m)) enddo basns_area(k) = 0 do m = 1, LUDRSL(k)%ncell basns_area(k) = basns_area(k) + & - cell_area(LUDRSL(k)%cell_i(m),LUDRSL(k)%cell_j(m)) * LUDRSL(k)%cellWeight(m) + cell_area(LUDRSL(k)%cell_i(m),LUDRSL(k)%cell_j(m)) * LUDRSL(k)%cellWeight(m) enddo end do diff --git a/hydro/Routing/module_channel_routing.F90 b/hydro/Routing/module_channel_routing.F90 index 37f65cbce8..c9d64962a6 100644 --- a/hydro/Routing/module_channel_routing.F90 +++ b/hydro/Routing/module_channel_routing.F90 @@ -1,23 +1,3 @@ -! Program Name: -! Author(s)/Contact(s): -! Abstract: -! History Log: -! -! Usage: -! Parameters: -! Input Files: -! -! Output Files: -! -! -! Condition codes: -! -! If appropriate, descriptive troubleshooting instructions or -! likely causes for failures could be mentioned here with the -! appropriate error code -! -! User controllable options: - MODULE module_channel_routing #ifdef MPP_LAND use module_mpp_land @@ -566,13 +546,13 @@ Subroutine drive_CHANNEL(did, latval,lonval,KT, IXRT,JXRT, SUBRTSWCRT, & LAKE_MSKRT, DT, DTCT, DTRT_CH,MUSK, MUSX, QLINK, & QLateral, & HLINK, ELRT, CHANLEN, MannN, So, ChSSlp, Bw, Tw, Tw_CC, n_CC, & - ChannK, RESHT, & + ChannK, RESHT, HRZAREA, LAKEMAXH, WEIRH, WEIRC, WEIRL, ORIFICEC, ORIFICEA, ORIFICEE, & ZELEV, CVOL, NLAKES, QLAKEI, QLAKEO, LAKENODE, & dist, QINFLOWBASE, CHANXI, CHANYJ, channel_option, RETDEP_CHAN, & - NLINKSL, LINKID, node_area & + NLINKSL, LINKID, node_area, lake_lookup & #ifdef MPP_LAND , lake_index,link_location,mpp_nlinks,nlinks_index,yw_mpp_nlinks & - , LNLINKSL & + , LNLINKSL, LLINKID & , gtoNode,toNodeInd,nToNodeInd & #endif , CH_LNKRT_SL & @@ -639,6 +619,15 @@ Subroutine drive_CHANNEL(did, latval,lonval,KT, IXRT,JXRT, SUBRTSWCRT, & !-- lake params + REAL, INTENT(IN), DIMENSION(NLAKES) :: HRZAREA !-- horizontal area (km^2) + REAL, INTENT(IN), DIMENSION(NLAKES) :: LAKEMAXH !-- maximum lake depth (m^2) + REAL, INTENT(IN), DIMENSION(NLAKES) :: WEIRH !-- lake depth (m^2) + REAL, INTENT(IN), DIMENSION(NLAKES) :: WEIRC !-- weir coefficient + REAL, INTENT(IN), DIMENSION(NLAKES) :: WEIRL !-- weir length (m) + REAL, INTENT(IN), DIMENSION(NLAKES) :: ORIFICEC !-- orrifice coefficient + REAL, INTENT(IN), DIMENSION(NLAKES) :: ORIFICEA !-- orrifice area (m^2) + REAL, INTENT(IN), DIMENSION(NLAKES) :: ORIFICEE !-- orrifce elevation (m) + REAL, INTENT(INOUT), DIMENSION(NLAKES) :: RESHT !-- reservoir height (m) REAL*8, DIMENSION(NLAKES) :: QLAKEI8 !-- lake inflow (cms) REAL, INTENT(INOUT), DIMENSION(NLAKES) :: QLAKEI !-- lake inflow (cms) @@ -652,8 +641,10 @@ Subroutine drive_CHANNEL(did, latval,lonval,KT, IXRT,JXRT, SUBRTSWCRT, & REAL, DIMENSION(NLAKES) :: QLLAKE !-- lateral inflow to lake in diffusion scheme REAL*8, DIMENSION(NLAKES) :: QLLAKE8 !-- lateral inflow to lake in diffusion scheme + integer, intent(in), dimension(:) :: lake_lookup !-- inverse lake index for k->lake mapping + !-- Local Variables - INTEGER :: i,j,k,t,m,jj,kk,KRT,node + INTEGER :: i,j,k,t,m,jj,kk,KRT,node,l_idx, lakeid INTEGER :: DT_STEPS !-- number of timestep in routing REAL :: Qup,Quc !--Q upstream Previous, Q Upstream Current, downstream Previous REAL :: bo !--critical depth, bnd outflow just for testing @@ -671,19 +662,29 @@ Subroutine drive_CHANNEL(did, latval,lonval,KT, IXRT,JXRT, SUBRTSWCRT, & integer(kind=int64) link_location(ixrt,jxrt) real ywtmp(ixrt,jxrt) integer LNLINKSL - real*8, dimension(LNLINKSL) :: LQLateral -! real*4, dimension(LNLINKSL) :: LQLateral + integer(kind=int64), dimension(LNLINKSL) :: LLINKID + real(kind=8), dimension(LNLINKSL) :: LQLateral integer, dimension(:) :: toNodeInd integer(kind=int64), dimension(:,:) :: gtoNode integer :: nToNodeInd real, dimension(nToNodeInd,2) :: gQLINK + real, allocatable,dimension(:) :: tmpQLAKEO, tmpQLAKEI, tmpRESHT #else - real*8, dimension(NLINKS) :: LQLateral !--lateral flow + real(kind=8), dimension(NLINKS) :: LQLateral !--lateral flow #endif integer flag integer :: n, kk2, nt, nsteps ! tmp +#ifdef MPP_LAND + if(my_id == io_id) then +#endif + allocate(tmpQLAKEO(NLAKES)) + allocate(tmpQLAKEI(NLAKES)) + allocate(tmpRESHT(NLAKES)) +#ifdef MPP_LAND + endif +#endif QLAKEIP = 0 QLAKEI8 = 0 HLINKTMP = 0 @@ -791,6 +792,15 @@ Subroutine drive_CHANNEL(did, latval,lonval,KT, IXRT,JXRT, SUBRTSWCRT, & !---------- route other reaches, with upstream inflow tmpQlink = 0.0 +#ifdef MPP_LAND + if(my_id .eq. io_id) then +#endif + tmpQLAKEO = QLAKEO + tmpQLAKEI = QLAKEI + tmpRESHT = RESHT +#ifdef MPP_LAND + endif +#endif do k = 1,NLINKSL ! if (ORDER(k) .gt. 1 ) then !-- exclude first order stream Quc = 0.0 @@ -821,29 +831,39 @@ Subroutine drive_CHANNEL(did, latval,lonval,KT, IXRT,JXRT, SUBRTSWCRT, & end do ! do m #endif - if(TYPEL(k) .eq. 1) then !--link is a reservoir - - ! CALL LEVELPOOL(1,QLINK(k,1), Qup, QLINK(k,1), QLINK(k,2), & - ! QLateral(k), DT, RESHT(k), HRZAREA(k), LAKEMAXH(k), & - ! WEIRC(k), WEIRL(k),ORIFICEE(k), ORIFICEC(k), ORIFICEA(k)) - - elseif (channel_option .eq. 1) then !muskingum routing + if(TYPEL(k) == 1) then !--link is a reservoir + l_idx = lake_lookup(k) + if (l_idx >= 0) then !-- -999 if not a reservoir in the lookup table (belt-and-suspenders check) + call rt_domain(did)%reservoirs(l_idx)%ptr%run(Qup, Quc, 0.0, & + RESHT(l_idx), QLINK(k,2), DTRT_CH, rt_domain(did)%final_reservoir_type(l_idx), & + rt_domain(did)%reservoir_assimilated_value(l_idx), rt_domain(did)%reservoir_assimilated_source_file(l_idx)) + + QLAKEO(l_idx) = QLINK(k,2) !save outflow to lake + QLAKEI(l_idx) = Quc !save inflow to lake + end if + elseif (channel_option .eq. 1) then !muskingum routing Km = MUSK(k) X = MUSX(k) - tmpQLINK(k,2) = MUSKING(k,Qup,(Quc+QLateral(k)),QLINK(k,1),DTRT_CH,Km,X) !upstream plust lateral inflow + tmpQLINK(k,2) = MUSKING(k,Qup,(Quc+QLateral(k)),QLINK(k,1),DTRT_CH,Km,X) !upstream plus lateral inflow elseif (channel_option .eq. 2) then ! muskingum cunge call SUBMUSKINGCUNGE(tmpQLINK(k,2), velocity(k), qloss(k), LINKID(k), & Qup,Quc, QLINK(k,1), QLateral(k), DTRT_CH, So(k), & CHANLEN(k), MannN(k), ChSSlp(k), Bw(k), Tw(k),Tw_CC(k), n_CC(k), HLINK(k), ChannK(k) ) - else + else print *, "FATAL ERROR: no channel option selected" call hydro_stop("In drive_CHANNEL() - no channel option selected") endif ! endif !!! order(1) .ne. 1 end do !--k links +#ifdef MPP_LAND + call updateLake_seq(RESHT,nlakes,tmpRESHT) + call updateLake_seq(QLAKEO,nlakes,tmpQLAKEO) + call updateLake_seq(QLAKEI,nlakes,tmpQLAKEI) +#endif + !yw check ! gQLINK = 0.0 ! call ReachLS_write_io(tmpQLINK(:,2), gQLINK(:,2)) @@ -856,7 +876,7 @@ Subroutine drive_CHANNEL(did, latval,lonval,KT, IXRT,JXRT, SUBRTSWCRT, & ! endif do k = 1, NLINKSL - if(TYPEL(k) .ne. 1) then + if(TYPEL(k) .ne. 2) then QLINK(k,2) = tmpQLINK(k,2) endif QLINK(k,1) = QLINK(k,2) !assing link flow of current to be previous for next time step @@ -1290,7 +1310,13 @@ Subroutine drive_CHANNEL(did, latval,lonval,KT, IXRT,JXRT, SUBRTSWCRT, & if (KT .eq. 1) KT = KT + 1 - +#ifdef MPP_LAND + if (my_id == io_id) then + if(allocated(tmpRESHT)) deallocate(tmpRESHT) + if(allocated(tmpQLAKEO)) deallocate(tmpQLAKEO) + if(allocated(tmpQLAKEI)) deallocate(tmpQLAKEI) + endif +#endif end subroutine drive_CHANNEL ! ---------------------------------------------------------------- @@ -1524,7 +1550,6 @@ subroutine check_lake(unit,cd,lake_index,nlakes) #endif write(unit,*) cd call flush(unit) - return end subroutine check_lake subroutine check_channel(unit,cd,did,nlinks) @@ -1547,7 +1572,6 @@ subroutine check_channel(unit,cd,did,nlinks) #endif call flush(unit) close(unit) - return end subroutine check_channel subroutine smoth121(var,nlinks,maxv_p,from_node,to_node) implicit none @@ -1581,7 +1605,6 @@ subroutine smoth121(var,nlinks,maxv_p,from_node,to_node) endif end do var = vartmp - return end subroutine smoth121 ! SUBROUTINE drive_CHANNEL for NHDPLUS diff --git a/hydro/Routing/module_date_utilities_rt.F90 b/hydro/Routing/module_date_utilities_rt.F90 index d8bc691a29..9ac2cbc335 100644 --- a/hydro/Routing/module_date_utilities_rt.F90 +++ b/hydro/Routing/module_date_utilities_rt.F90 @@ -1,23 +1,3 @@ -! Program Name: -! Author(s)/Contact(s): -! Abstract: -! History Log: -! -! Usage: -! Parameters: -! Input Files: -! -! Output Files: -! -! -! Condition codes: -! -! If appropriate, descriptive troubleshooting instructions or -! likely causes for failures could be mentioned here with the -! appropriate error code -! -! User controllable options: - module Module_Date_utilities_rt use module_hydro_stop, only: HYDRO_stop contains diff --git a/hydro/Routing/module_gw_gw2d.F90 b/hydro/Routing/module_gw_gw2d.F90 index 7d663e7231..ae3ab1a8d6 100644 --- a/hydro/Routing/module_gw_gw2d.F90 +++ b/hydro/Routing/module_gw_gw2d.F90 @@ -1,23 +1,3 @@ -! Program Name: -! Author(s)/Contact(s): -! Abstract: -! History Log: -! -! Usage: -! Parameters: -! Input Files: -! -! Output Files: -! -! -! Condition codes: -! -! If appropriate, descriptive troubleshooting instructions or -! likely causes for failures could be mentioned here with the -! appropriate error code -! -! User controllable options: - !------------------------------------------------------------------------------ ! Benjamin Fersch 2d groundwater model !------------------------------------------------------------------------------ @@ -103,7 +83,6 @@ subroutine gw2d_ini(did,dt,dx) end do - return end subroutine gw2d_ini subroutine gw2d_allocate(did, ix, jx, nsoil) @@ -822,12 +801,12 @@ subroutine gwstep(ix, jx, dx, & #ifdef MPP_LAND -call mpi_reduce(delcur, mpiDelcur, 1, MPI_REAL, MPI_SUM, 0, HYDRO_COMM_WORLD, ierr) -call MPI_COMM_SIZE( HYDRO_COMM_WORLD, mpiSize, ierr ) +call MPI_Reduce(delcur, mpiDelcur, 1, MPI_REAL, MPI_SUM, 0, HYDRO_COMM_WORLD, ierr) +call MPI_Comm_size( HYDRO_COMM_WORLD, mpiSize, ierr ) if(my_id .eq. IO_id) delcur = mpiDelcur/mpiSize -call mpi_bcast(delcur, 1, mpi_real, 0, HYDRO_COMM_WORLD, ierr) +call MPI_Bcast(delcur, 1, MPI_REAL, 0, HYDRO_COMM_WORLD, ierr) #endif @@ -907,10 +886,10 @@ subroutine gwstep(ix, jx, dx, & #ifdef HYDRO_D #ifdef MPP_LAND - call MPI_REDUCE(dtot,gdtot,1, MPI_REAL, MPI_SUM, IO_id, HYDRO_COMM_WORLD, ierr) - call MPI_REDUCE(dtoa,gdtoa,1, MPI_REAL, MPI_SUM, IO_id, HYDRO_COMM_WORLD, ierr) - call MPI_REDUCE(eocn,geocn,1, MPI_REAL, MPI_SUM, IO_id, HYDRO_COMM_WORLD, ierr) - call MPI_REDUCE(ebot,gebot,1, MPI_REAL, MPI_SUM, IO_id, HYDRO_COMM_WORLD, ierr) + call MPI_Reduce(dtot,gdtot,1, MPI_REAL, MPI_SUM, IO_id, HYDRO_COMM_WORLD, ierr) + call MPI_Reduce(dtoa,gdtoa,1, MPI_REAL, MPI_SUM, IO_id, HYDRO_COMM_WORLD, ierr) + call MPI_Reduce(eocn,geocn,1, MPI_REAL, MPI_SUM, IO_id, HYDRO_COMM_WORLD, ierr) + call MPI_Reduce(ebot,gebot,1, MPI_REAL, MPI_SUM, IO_id, HYDRO_COMM_WORLD, ierr) if(my_id .eq. IO_id) then write (*,900) & @@ -931,7 +910,6 @@ subroutine gwstep(ix, jx, dx, & ! /3x,4f9.4,2(9x),e14.4) /3x,5(e14.4)) - return end subroutine gwstep @@ -950,7 +928,6 @@ SUBROUTINE SCOPY (NT, ARR, INCA, BRR, INCB) IB = IB + INCB 10 CONTINUE ! - RETURN END SUBROUTINE SCOPY @@ -1262,11 +1239,11 @@ subroutine parysolv1(c,b,r,ct,pid,z_pid, & ! ! Send (ZSPS,j)th equations. ! ! Receive (ZSPS+1,j)th equations. - call mpi_cart_shift(cartGridComm, rowshift, 1, source, dest, ierr) - call MPI_ISEND(zntmp, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, sendReq, ierr) - call MPI_IRECV( zn, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, recvReq, ierr) - call mpi_wait(sendReq, mpp_status, ierr) - call mpi_wait(recvReq, mpp_status, ierr) + call MPI_Cart_shift(cartGridComm, rowshift, 1, source, dest, ierr) + call MPI_Isend(zntmp, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, sendReq, ierr) + call MPI_Irecv( zn, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, recvReq, ierr) + call MPI_Wait(sendReq, mpp_status, ierr) + call MPI_Wait(recvReq, mpp_status, ierr) #ifdef TIMING tf = click() @@ -1294,9 +1271,9 @@ subroutine parysolv1(c,b,r,ct,pid,z_pid, & #endif ! ! Receive (0,j)th equations. - call mpi_cart_shift(cartGridComm, rowshift, -1, source, dest, ierr) - call MPI_IRECV( zn, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, recvReq, ierr) - call mpi_wait(recvReq, mpp_status, ierr) + call MPI_Cart_shift(cartGridComm, rowshift, -1, source, dest, ierr) + call MPI_Irecv( zn, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, recvReq, ierr) + call MPI_Wait(recvReq, mpp_status, ierr) #ifdef TIMING tf = click() @@ -1328,11 +1305,11 @@ subroutine parysolv1(c,b,r,ct,pid,z_pid, & ! ! Send (ZSPS,j)th equations. ! ! Receive (ZSPS+1,j)th equations. - call mpi_cart_shift(cartGridComm, rowshift, 1, source, dest, ierr) - call MPI_ISEND(zntmp, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, sendReq, ierr) - call MPI_IRECV( zn, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, recvReq, ierr) - call mpi_wait(sendReq, mpp_status, ierr) - call mpi_wait(recvReq, mpp_status, ierr) + call MPI_Cart_shift(cartGridComm, rowshift, 1, source, dest, ierr) + call MPI_Isend(zntmp, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, sendReq, ierr) + call MPI_Irecv( zn, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, recvReq, ierr) + call MPI_Wait(sendReq, mpp_status, ierr) + call MPI_Wait(recvReq, mpp_status, ierr) #ifdef TIMING tf = click() call add_dt(ct,tf,ti,dt) @@ -1362,8 +1339,8 @@ subroutine parysolv1(c,b,r,ct,pid,z_pid, & call add_dt(ct,tf,ti,dt) #endif - call mpi_cart_shift(cartGridComm, rowshift, -1, source, dest, ierr) - call MPI_ISEND(zntmp, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, sendReq, ierr) + call MPI_Cart_shift(cartGridComm, rowshift, -1, source, dest, ierr) + call MPI_Isend(zntmp, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, sendReq, ierr) do 60 j = 1, XSPS ! Backward elimination in (0,j)th equations. @@ -1375,7 +1352,7 @@ subroutine parysolv1(c,b,r,ct,pid,z_pid, & 70 continue 60 continue - call mpi_wait(sendReq, mpp_status, ierr) + call MPI_Wait(sendReq, mpp_status, ierr) else if (z_pid .lt. ZDNS) then @@ -1385,9 +1362,9 @@ subroutine parysolv1(c,b,r,ct,pid,z_pid, & #endif ! ! Receive (ZSPS+1,j)th equations. - call mpi_cart_shift(cartGridComm, rowshift, 1, source, dest, ierr) - call MPI_IRECV( zn, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, recvReq, ierr) - call mpi_wait(recvReq, mpp_status, ierr) + call MPI_Cart_shift(cartGridComm, rowshift, 1, source, dest, ierr) + call MPI_Irecv( zn, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, recvReq, ierr) + call MPI_Wait(recvReq, mpp_status, ierr) #ifdef TIMING tf = click() @@ -1420,11 +1397,11 @@ subroutine parysolv1(c,b,r,ct,pid,z_pid, & ! ! Send (1,j)th equations. ! ! Receive (0,j)th equations. - call mpi_cart_shift(cartGridComm, rowshift, -1, source, dest, ierr) - call MPI_ISEND(zntmp, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, sendReq, ierr) - call MPI_IRECV( zn, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, recvReq, ierr) - call mpi_wait(sendReq, mpp_status, ierr) - call mpi_wait(recvReq, mpp_status, ierr) + call MPI_Cart_shift(cartGridComm, rowshift, -1, source, dest, ierr) + call MPI_Isend(zntmp, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, sendReq, ierr) + call MPI_Irecv( zn, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, recvReq, ierr) + call MPI_Wait(sendReq, mpp_status, ierr) + call MPI_Wait(recvReq, mpp_status, ierr) #ifdef TIMING tf = click() @@ -1450,8 +1427,8 @@ subroutine parysolv1(c,b,r,ct,pid,z_pid, & #endif ! ! Send (ZSPS,j)th equations. - call mpi_cart_shift(cartGridComm, rowshift, 1, source, dest, ierr) - call MPI_ISEND(zntmp, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, sendReq, ierr) + call MPI_Cart_shift(cartGridComm, rowshift, 1, source, dest, ierr) + call MPI_Isend(zntmp, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, sendReq, ierr) #ifdef TIMING tf = click() @@ -1468,7 +1445,7 @@ subroutine parysolv1(c,b,r,ct,pid,z_pid, & 110 continue 100 continue - call mpi_wait(sendReq, mpp_status, ierr) + call MPI_Wait(sendReq, mpp_status, ierr) else @@ -1484,11 +1461,11 @@ subroutine parysolv1(c,b,r,ct,pid,z_pid, & ! ! Send (1,j)th equations. ! ! Receive (0,j)th equations. - call mpi_cart_shift(cartGridComm, rowshift, -1, source, dest, ierr) - call MPI_ISEND(zntmp, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, sendReq, ierr) - call MPI_IRECV( zn, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, recvReq, ierr) - call mpi_wait(sendReq, mpp_status, ierr) - call mpi_wait(recvReq, mpp_status, ierr) + call MPI_Cart_shift(cartGridComm, rowshift, -1, source, dest, ierr) + call MPI_Isend(zntmp, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, sendReq, ierr) + call MPI_Irecv( zn, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, recvReq, ierr) + call MPI_Wait(sendReq, mpp_status, ierr) + call MPI_Wait(recvReq, mpp_status, ierr) #ifdef TIMING tf = click() @@ -1510,7 +1487,6 @@ subroutine parysolv1(c,b,r,ct,pid,z_pid, & endif - return end subroutine @@ -1574,11 +1550,11 @@ subroutine parxsolv1(c,b,r,ct,pid,x_pid, & ! ! Send (i,XSPS)th equations. ! ! Receive (i,(XSPS + 1))th equations. - call mpi_cart_shift(cartGridComm, colshift, 1, source, dest, ierr) - call MPI_ISEND(xntmp, cnt, MPI_REAL, dest, XN_REC, cartGridComm, sendReq, ierr) - call MPI_IRECV( xn, cnt, MPI_REAL, dest, XN_REC, cartGridComm, recvReq, ierr) - call mpi_wait(sendReq, mpp_status, ierr) - call mpi_wait(recvReq, mpp_status, ierr) + call MPI_Cart_shift(cartGridComm, colshift, 1, source, dest, ierr) + call MPI_Isend(xntmp, cnt, MPI_REAL, dest, XN_REC, cartGridComm, sendReq, ierr) + call MPI_Irecv( xn, cnt, MPI_REAL, dest, XN_REC, cartGridComm, recvReq, ierr) + call MPI_Wait(sendReq, mpp_status, ierr) + call MPI_Wait(recvReq, mpp_status, ierr) #ifdef TIMING tf = click() @@ -1609,9 +1585,9 @@ subroutine parxsolv1(c,b,r,ct,pid,x_pid, & #endif ! ! Receive (i,0)th equations. - call mpi_cart_shift(cartGridComm, colshift, -1, source, dest, ierr) - call MPI_IRECV( xn, cnt, MPI_REAL, dest, XN_REC, cartGridComm, recvReq, ierr) - call mpi_wait(recvReq, mpp_status, ierr) + call MPI_Cart_shift(cartGridComm, colshift, -1, source, dest, ierr) + call MPI_Irecv( xn, cnt, MPI_REAL, dest, XN_REC, cartGridComm, recvReq, ierr) + call MPI_Wait(recvReq, mpp_status, ierr) #ifdef TIMING tf = click() @@ -1642,11 +1618,11 @@ subroutine parxsolv1(c,b,r,ct,pid,x_pid, & ! ! Send (i,XSPS)th equations. ! ! Receive (i,(XSPS + 1))th equations. - call mpi_cart_shift(cartGridComm, colshift, 1, source, dest, ierr) - call MPI_ISEND(xntmp, cnt, MPI_REAL, dest, XN_REC, cartGridComm, sendReq, ierr) - call MPI_IRECV( xn, cnt, MPI_REAL, dest, XN_REC, cartGridComm, recvReq, ierr) - call mpi_wait(sendReq, mpp_status, ierr) - call mpi_wait(recvReq, mpp_status, ierr) + call MPI_Cart_shift(cartGridComm, colshift, 1, source, dest, ierr) + call MPI_Isend(xntmp, cnt, MPI_REAL, dest, XN_REC, cartGridComm, sendReq, ierr) + call MPI_Irecv( xn, cnt, MPI_REAL, dest, XN_REC, cartGridComm, recvReq, ierr) + call MPI_Wait(sendReq, mpp_status, ierr) + call MPI_Wait(recvReq, mpp_status, ierr) #ifdef TIMING tf = click() call add_dt(ct,tf,ti,dt) @@ -1675,8 +1651,8 @@ subroutine parxsolv1(c,b,r,ct,pid,x_pid, & tf = click() call add_dt(ct,tf,ti,dt) #endif - call mpi_cart_shift(cartGridComm, colshift, -1, source, dest, ierr) - call MPI_ISEND(xntmp, cnt, MPI_REAL, dest, XN_REC, cartGridComm, sendReq, ierr) + call MPI_Cart_shift(cartGridComm, colshift, -1, source, dest, ierr) + call MPI_Isend(xntmp, cnt, MPI_REAL, dest, XN_REC, cartGridComm, sendReq, ierr) do 60 i = 1, ZSPS ! Backward elimination in (i,0)th equations. @@ -1690,7 +1666,7 @@ subroutine parxsolv1(c,b,r,ct,pid,x_pid, & r(i,j) = r(i,j) - b(i,j)*r(i,XSPS) - c(i,j)*r(i,1) 70 continue - call mpi_wait(sendReq, mpp_status, ierr) + call MPI_Wait(sendReq, mpp_status, ierr) else if (x_pid .lt. XDNS) then @@ -1700,9 +1676,9 @@ subroutine parxsolv1(c,b,r,ct,pid,x_pid, & #endif ! ! Receive (i,XSPS+1)th equations. - call mpi_cart_shift(cartGridComm, colshift, 1, source, dest, ierr) - call MPI_IRECV( xn, cnt, MPI_REAL, dest, XN_REC, cartGridComm, recvReq, ierr) - call mpi_wait(recvReq, mpp_status, ierr) + call MPI_Cart_shift(cartGridComm, colshift, 1, source, dest, ierr) + call MPI_Irecv( xn, cnt, MPI_REAL, dest, XN_REC, cartGridComm, recvReq, ierr) + call MPI_Wait(recvReq, mpp_status, ierr) #ifdef TIMING tf = click() @@ -1732,11 +1708,11 @@ subroutine parxsolv1(c,b,r,ct,pid,x_pid, & #endif ! ! Send (i,1)th equations. ! ! Receive (i,0)th equations. - call mpi_cart_shift(cartGridComm, colshift, -1, source, dest, ierr) - call MPI_ISEND(xntmp, cnt, MPI_REAL, dest, XN_REC, cartGridComm, sendReq, ierr) - call MPI_IRECV( xn, cnt, MPI_REAL, dest, XN_REC, cartGridComm, recvReq, ierr) - call mpi_wait(sendReq, mpp_status, ierr) - call mpi_wait(recvReq, mpp_status, ierr) + call MPI_Cart_shift(cartGridComm, colshift, -1, source, dest, ierr) + call MPI_Isend(xntmp, cnt, MPI_REAL, dest, XN_REC, cartGridComm, sendReq, ierr) + call MPI_Irecv( xn, cnt, MPI_REAL, dest, XN_REC, cartGridComm, recvReq, ierr) + call MPI_Wait(sendReq, mpp_status, ierr) + call MPI_Wait(recvReq, mpp_status, ierr) #ifdef TIMING tf = click() @@ -1762,8 +1738,8 @@ subroutine parxsolv1(c,b,r,ct,pid,x_pid, & #endif ! ! Send (i,XSPS)th equations. - call mpi_cart_shift(cartGridComm, colshift, 1, source, dest, ierr) - call MPI_ISEND(xntmp, cnt, MPI_REAL, dest, XN_REC, cartGridComm, sendReq, ierr) + call MPI_Cart_shift(cartGridComm, colshift, 1, source, dest, ierr) + call MPI_Isend(xntmp, cnt, MPI_REAL, dest, XN_REC, cartGridComm, sendReq, ierr) #ifdef TIMING tf = click() call add_dt(ct,tf,ti,dt) @@ -1781,7 +1757,7 @@ subroutine parxsolv1(c,b,r,ct,pid,x_pid, & r(i,j) = r(i,j) - c(i,j)*r(i,1) - b(i,j)*r(i,XSPS) 110 continue - call mpi_wait(sendReq, mpp_status, ierr) + call MPI_Wait(sendReq, mpp_status, ierr) else @@ -1798,11 +1774,11 @@ subroutine parxsolv1(c,b,r,ct,pid,x_pid, & ! ! Send (i,1)th equations. ! ! Receive (i,0)th equations. - call mpi_cart_shift(cartGridComm, colshift, -1, source, dest, ierr) - call MPI_ISEND(xntmp, cnt, MPI_REAL, dest, XN_REC, cartGridComm, sendReq, ierr) - call MPI_IRECV( xn, cnt, MPI_REAL, dest, XN_REC, cartGridComm, recvReq, ierr) - call mpi_wait(sendReq, mpp_status, ierr) - call mpi_wait(recvReq, mpp_status, ierr) + call MPI_Cart_shift(cartGridComm, colshift, -1, source, dest, ierr) + call MPI_Isend(xntmp, cnt, MPI_REAL, dest, XN_REC, cartGridComm, sendReq, ierr) + call MPI_Irecv( xn, cnt, MPI_REAL, dest, XN_REC, cartGridComm, recvReq, ierr) + call MPI_Wait(sendReq, mpp_status, ierr) + call MPI_Wait(recvReq, mpp_status, ierr) #ifdef TIMING tf = click() @@ -1825,7 +1801,6 @@ subroutine parxsolv1(c,b,r,ct,pid,x_pid, & endif - return end subroutine @@ -2056,7 +2031,6 @@ subroutine sub_n_form(n_xs,n_zs,c,a,b,r,c2,b2,r2,wk,xfac,zfac, & ! stop endif - return end subroutine #endif @@ -2150,7 +2124,6 @@ subroutine sub_tri_solv(n_xs,n_zs,c,a,b,r,x,wk,xfac,zfac,dir) ! stop endif - return end subroutine diff --git a/hydro/Routing/module_lsm_forcing.F90 b/hydro/Routing/module_lsm_forcing.F90 index 1006759629..0fbf9d0428 100644 --- a/hydro/Routing/module_lsm_forcing.F90 +++ b/hydro/Routing/module_lsm_forcing.F90 @@ -1,23 +1,3 @@ -! Program Name: -! Author(s)/Contact(s): -! Abstract: -! History Log: -! -! Usage: -! Parameters: -! Input Files: -! -! Output Files: -! -! -! Condition codes: -! -! If appropriate, descriptive troubleshooting instructions or -! likely causes for failures could be mentioned here with the -! appropriate error code -! -! User controllable options: - module module_lsm_forcing #ifdef MPP_LAND @@ -25,9 +5,9 @@ module module_lsm_forcing #endif use module_HYDRO_io, only: get_2d_netcdf, get_soilcat_netcdf, get2d_int use module_hydro_stop, only:HYDRO_stop + use netcdf implicit none -#include integer :: i_forcing character(len=19) out_date @@ -62,8 +42,8 @@ subroutine READFORC_WRF(flnm,ix,jx,target_date,t,q,u,v,p,lw,sw,pcp,lai,fpar) pcpc = 0 ! Open the NetCDF file. - ierr = nf_open(flnm, NF_NOWRITE, ncid) - if (ierr /= 0) then + ierr = nf90_open(flnm, NF90_NOWRITE, ncid) + if (ierr /= NF90_NOERR) then write(*,'("READFORC_WRF Problem opening netcdf file: ''", A, "''")') trim(flnm) call hydro_stop("In READFORC_WRF() - Problem opening netcdf file") endif @@ -83,7 +63,7 @@ subroutine READFORC_WRF(flnm,ix,jx,target_date,t,q,u,v,p,lw,sw,pcp,lai,fpar) endif call get_2d_netcdf_ruc("LAI", ncid, lai, ix, jx,tlevel, .true., ierr) - ierr = nf_close(ncid) + ierr = nf90_close(ncid) !DJG Add the convective and non-convective rain components (note: conv. comp=0 !for cloud resolving runs...) @@ -103,63 +83,63 @@ subroutine read_hrldas_hdrinfo(geo_static_flnm, ix, jx, land_cat, soil_cat) integer :: iret, ncid, dimid ! Open the NetCDF file. - iret = nf_open(geo_static_flnm, NF_NOWRITE, ncid) + iret = nf90_open(geo_static_flnm, NF90_NOWRITE, ncid) if (iret /= 0) then write(*,'("Problem opening geo_static file: ''", A, "''")') & trim(geo_static_flnm) call hydro_stop("In read_hrldas_hdrinfo() - Problem opening geo_static file") endif - iret = nf_inq_dimid(ncid, "west_east", dimid) + iret = nf90_inq_dimid(ncid, "west_east", dimid) if (iret /= 0) then -! print*, "nf_inq_dimid: west_east" - call hydro_stop("In read_hrldas_hdrinfo() - nf_inq_dimid: west_east problem") +! print*, "nf90_inq_dimid: west_east" + call hydro_stop("In read_hrldas_hdrinfo() - nf90_inq_dimid: west_east problem") endif - iret = nf_inq_dimlen(ncid, dimid, ix) + iret = nf90_inquire_dimension(ncid, dimid, len=ix) if (iret /= 0) then -! print*, "nf_inq_dimlen: west_east" - call hydro_stop("In read_hrldas_hdrinfo() - nf_inq_dimlen: west_east problem") +! print*, "nf90_inq_dimlen: west_east" + call hydro_stop("In read_hrldas_hdrinfo() - nf90_inq_dimlen: west_east problem") endif - iret = nf_inq_dimid(ncid, "south_north", dimid) + iret = nf90_inq_dimid(ncid, "south_north", dimid) if (iret /= 0) then -! print*, "nf_inq_dimid: south_north" - call hydro_stop("In read_hrldas_hdrinfo() - nf_inq_dimid: south_north problem") +! print*, "nf90_inq_dimid: south_north" + call hydro_stop("In read_hrldas_hdrinfo() - nf90_inq_dimid: south_north problem") endif - iret = nf_inq_dimlen(ncid, dimid, jx) + iret = nf90_inquire_dimension(ncid, dimid, len=jx) if (iret /= 0) then - ! print*, "nf_inq_dimlen: south_north" - call hydro_stop("In read_hrldas_hdrinfo() - nf_inq_dimlen: south_north problem") + ! print*, "nf90_inq_dimlen: south_north" + call hydro_stop("In read_hrldas_hdrinfo() - nf90_inq_dimlen: south_north problem") endif - iret = nf_inq_dimid(ncid, "land_cat", dimid) + iret = nf90_inq_dimid(ncid, "land_cat", dimid) if (iret /= 0) then - ! print*, "nf_inq_dimid: land_cat" - call hydro_stop("In read_hrldas_hdrinfo() - nf_inq_dimid: land_cat problem") + ! print*, "nf90_inq_dimid: land_cat" + call hydro_stop("In read_hrldas_hdrinfo() - nf90_inq_dimid: land_cat problem") endif - iret = nf_inq_dimlen(ncid, dimid, land_cat) + iret = nf90_inquire_dimension(ncid, dimid, len=land_cat) if (iret /= 0) then - print*, "nf_inq_dimlen: land_cat" - call hydro_stop("In read_hrldas_hdrinfo() - nf_inq_dimlen: land_cat problem") + print*, "nf90_inq_dimlen: land_cat" + call hydro_stop("In read_hrldas_hdrinfo() - nf90_inq_dimlen: land_cat problem") endif - iret = nf_inq_dimid(ncid, "soil_cat", dimid) + iret = nf90_inq_dimid(ncid, "soil_cat", dimid) if (iret /= 0) then - ! print*, "nf_inq_dimid: soil_cat" - call hydro_stop("In read_hrldas_hdrinfo() - nf_inq_dimid: soil_cat problem") + ! print*, "nf90_inq_dimid: soil_cat" + call hydro_stop("In read_hrldas_hdrinfo() - nf90_inq_dimid: soil_cat problem") endif - iret = nf_inq_dimlen(ncid, dimid, soil_cat) + iret = nf90_inquire_dimension(ncid, dimid, len=soil_cat) if (iret /= 0) then - ! print*, "nf_inq_dimlen: soil_cat" - call hydro_stop("In read_hrldas_hdrinfo() - nf_inq_dimlen: soil_cat problem") + ! print*, "nf90_inq_dimlen: soil_cat" + call hydro_stop("In read_hrldas_hdrinfo() - nf90_inq_dimlen: soil_cat problem") endif - iret = nf_close(ncid) + iret = nf90_close(ncid) end subroutine read_hrldas_hdrinfo @@ -183,18 +163,18 @@ subroutine readland_hrldas(geo_static_flnm,ix,jx,land_cat,soil_cat,vegtyp,soltyp integer :: islake, iswater, isoilwater ! Open the NetCDF file. - ierr = nf_open(geo_static_flnm, NF_NOWRITE, ncid) + ierr = nf90_open(geo_static_flnm, NF90_NOWRITE, ncid) - if (ierr /= 0) then + if (ierr /= NF90_NOERR) then write(*,'("Problem opening geo_static file: ''", A, "''")') trim(geo_static_flnm) call hydro_stop("In readland_hrldas() - Problem opening geo_static file") endif flag = -99 - ierr = nf_inq_varid(ncid,"XLAT", varid) + ierr = nf90_inq_varid(ncid,"XLAT", varid) flag = 1 if(ierr .ne. 0) then - ierr = nf_inq_varid(ncid,"XLAT_M", varid) + ierr = nf90_inq_varid(ncid,"XLAT_M", varid) if(ierr .ne. 0) then ! write(6,*) "XLAT not found from wrfstatic file. " call hydro_stop("In readland_hrldas() - XLAT not found from wrfstatic file") @@ -257,26 +237,26 @@ subroutine readland_hrldas(geo_static_flnm,ix,jx,land_cat,soil_cat,vegtyp,soltyp endif - ierr = NF_GET_ATT_INT(ncid, NF_GLOBAL, 'ISWATER', iswater) - if (ierr /= 0) then + ierr = nf90_get_att(ncid, NF90_GLOBAL, 'ISWATER', iswater) + if (ierr /= NF90_NOERR) then call hydro_stop("In readland_hrldas() - Attribute ISWATER unable to be read from geo_static_flnm") endif - ierr = NF_GET_ATT_INT(ncid, NF_GLOBAL, 'ISOILWATER', isoilwater) - if (ierr /= 0) then + ierr = nf90_get_att(ncid, NF90_GLOBAL, 'ISOILWATER', isoilwater) + if (ierr /= NF90_NOERR) then call hydro_stop("In readland_hrldas() - Attribute ISOILWATER unable to be read from geo_static_flnm") endif - ierr = NF_GET_ATT_INT(ncid, NF_GLOBAL, 'ISLAKE', islake) - if (ierr /= 0) then + ierr = nf90_get_att(ncid, NF90_GLOBAL, 'ISLAKE', islake) + if (ierr /= NF90_NOERR) then call hydro_stop("In readland_hrldas() - Attribute ISLAKE unable to be read from geo_static_flnm") endif ! Close the NetCDF file - ierr = nf_close(ncid) - if (ierr /= 0) then - print*, "MODULE_NOAHLSM_HRLDAS_INPUT: READLAND_HRLDAS: NF_CLOSE" - call hydro_stop("In readland_hrldas() - NF_CLOSE problem") + ierr = nf90_close(ncid) + if (ierr /= NF90_NOERR) then + print*, "MODULE_NOAHLSM_HRLDAS_INPUT: READLAND_HRLDAS: NF90_CLOSE" + call hydro_stop("In readland_hrldas() - NF90_CLOSE problem") endif write(6, *) "readland_hrldas: ISLAKE ISWATER ISOILWATER", islake, iswater, isoilwater @@ -309,21 +289,20 @@ subroutine get_2d_netcdf_ruc(var_name,ncid,var, & count(1) = ix count(2) = jx start(4) = tlevel - ierr = nf_inq_varid(ncid, var_name, varid) + ierr = nf90_inq_varid(ncid, var_name, varid) - if (ierr /= 0) then + if (ierr /= NF90_NOERR) then if (fatal_IF_ERROR) then - print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_2d_netcdf_ruc:nf_inq_varid ", trim(var_name) - call hydro_stop("In get_2d_netcdf_ruc() - nf_inq_varid problem") + print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_2d_netcdf_ruc:nf90_inq_varid ", trim(var_name) + call hydro_stop("In get_2d_netcdf_ruc() - nf90_inq_varid problem") else return endif endif - ierr = nf_get_vara_real(ncid, varid, start,count,var) + ierr = nf90_get_var(ncid, varid, var, start, count) - return end subroutine get_2d_netcdf_ruc @@ -341,20 +320,19 @@ subroutine get_2d_netcdf_cows(var_name,ncid,var, & count(1) = ix count(2) = jx start(4) = tlevel - iret = nf_inq_varid(ncid, var_name, varid) + iret = nf90_inq_varid(ncid, var_name, varid) if (iret /= 0) then if (fatal_IF_ERROR) then - print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_2d_netcdf_cows:nf_inq_varid" - call hydro_stop("In get_2d_netcdf_cows() - nf_inq_varid problem") + print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_2d_netcdf_cows:nf90_inq_varid" + call hydro_stop("In get_2d_netcdf_cows() - nf90_inq_varid problem") else ierr = iret return endif endif - iret = nf_get_vara_real(ncid, varid, start,count,var) + iret = nf90_get_var(ncid, varid, var, start,count) - return end subroutine get_2d_netcdf_cows @@ -387,8 +365,8 @@ subroutine readinit_hrldas(netcdf_flnm, ix, jx, nsoil, target_date, & logical :: found_canwat, found_skintemp, found_weasd, found_stemp, found_smois ! Open the NetCDF file. - ierr = nf_open(netcdf_flnm, NF_NOWRITE, ncid) - if (ierr /= 0) then + ierr = nf90_open(netcdf_flnm, NF90_NOWRITE, ncid) + if (ierr /= NF90_NOERR) then write(*,'("READINIT Problem opening netcdf file: ''", A, "''")') & trim(netcdf_flnm) call hydro_stop("In readinit_hrldas()- Problem opening netcdf file") @@ -437,19 +415,32 @@ subroutine readinit_hrldas(netcdf_flnm, ix, jx, nsoil, target_date, & sh2o = smc - ierr = nf_close(ncid) + ierr = nf90_close(ncid) end subroutine readinit_hrldas - subroutine READFORC_HRLDAS(flnm,ix,jx,target_date, t,q,u,v,p,lw,sw,pcp,lai,fpar) + subroutine READFORC_HRLDAS(flnm,ix,jx,target_date, & + forcing_name_T,forcing_name_Q,forcing_name_U,forcing_name_V,forcing_name_P, & + forcing_name_LW,forcing_name_SW,forcing_name_PR,forcing_name_SN, forcing_name_LF,& + t,q,u,v,p,lw,sw,pcp,lai,snowbl,fpar) implicit none character(len=*), intent(in) :: flnm integer, intent(in) :: ix integer, intent(in) :: jx character(len=*), intent(in) :: target_date + character(len=256), intent(in) :: forcing_name_T + character(len=256), intent(in) :: forcing_name_Q + character(len=256), intent(in) :: forcing_name_U + character(len=256), intent(in) :: forcing_name_V + character(len=256), intent(in) :: forcing_name_P + character(len=256), intent(in) :: forcing_name_LW + character(len=256), intent(in) :: forcing_name_SW + character(len=256), intent(in) :: forcing_name_PR + character(len=256), intent(in) :: forcing_name_SN + character(len=256), intent(in) :: forcing_name_LF real, dimension(ix,jx), intent(out) :: t real, dimension(ix,jx), intent(out) :: q real, dimension(ix,jx), intent(out) :: u @@ -460,33 +451,46 @@ subroutine READFORC_HRLDAS(flnm,ix,jx,target_date, t,q,u,v,p,lw,sw,pcp,lai,fpar) real, dimension(ix,jx), intent(out) :: pcp real, dimension(ix,jx), intent(inout) :: lai real, dimension(ix,jx), intent(inout) :: fpar - + real, dimension(ix,jx), intent(inout) :: snowbl + real, dimension(:,:), allocatable :: liqfrac character(len=256) :: units integer :: ierr integer :: ncid ! Open the NetCDF file. - ierr = nf_open(trim(flnm), NF_NOWRITE, ncid) - if (ierr /= 0) then + ierr = nf90_open(trim(flnm), NF90_NOWRITE, ncid) + if (ierr /= NF90_NOERR) then write(*,'("READFORC Problem opening netcdf file: ''", A, "''")') trim(flnm) call hydro_stop("In READFORC_HRLDAS() - Problem opening netcdf file") endif - call get_2d_netcdf("T2D", ncid, t, units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("Q2D", ncid, q, units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("U2D", ncid, u, units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("V2D", ncid, v, units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("PSFC", ncid, p, units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("LWDOWN", ncid, lw, units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("SWDOWN", ncid, sw, units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("RAINRATE",ncid, pcp, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf(trim(forcing_name_T), ncid, t, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf(trim(forcing_name_Q), ncid, q, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf(trim(forcing_name_U), ncid, u, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf(trim(forcing_name_V), ncid, v, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf(trim(forcing_name_P), ncid, p, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf(trim(forcing_name_lw), ncid, lw, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf(trim(forcing_name_sw), ncid, sw, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf(trim(forcing_name_pr),ncid, pcp, units, ix, jx, .TRUE., ierr) call get_2d_netcdf("VEGFRA", ncid, fpar, units, ix, jx, .FALSE., ierr) if (ierr == 0) then if(maxval(fpar) .gt. 10 .and. maxval(fpar) .lt. 10000) fpar = fpar * 1.E-2 endif + call get_2d_netcdf("LAI", ncid, lai, units, ix, jx, .FALSE., ierr) + call get_2d_netcdf(trim(forcing_name_SN), ncid, snowbl,units, ix, jx, .FALSE., ierr) + if (ierr /= NF90_NOERR) then + allocate(liqfrac(ix,jx)) + call get_2d_netcdf(trim(forcing_name_LF), ncid, liqfrac, units, ix, jx, .FALSE., ierr) + if (ierr == 0) then + snowbl = (1.0 - liqfrac) * pcp + else + snowbl = 0.0 ! since is liqfrac is not present it is equal to 1.0 + end if + deallocate(liqfrac) + end if - ierr = nf_close(ncid) + ierr = nf90_close(ncid) end subroutine READFORC_HRLDAS @@ -551,7 +555,7 @@ subroutine READFORC_MDV(flnm,ix,jx,pcp,mmflag,ierr_flg) !open NetCDF file... - ierr_flg = nf_open(flnm, NF_NOWRITE, ncid) + ierr_flg = nf90_open(flnm, NF90_NOWRITE, ncid) if (ierr_flg /= 0) then #ifdef HYDRO_D write(*,'("READFORC_MDV Problem opening netcdf file: ''",A,"''")') & @@ -560,13 +564,13 @@ subroutine READFORC_MDV(flnm,ix,jx,pcp,mmflag,ierr_flg) return end if - ierr = nf_inq_varid(ncid, "precip", varid) - if(ierr /= 0) ierr_flg = ierr - if (ierr /= 0) then - ierr = nf_inq_varid(ncid, "precip_rate", varid) !recheck variable name... - if (ierr /= 0) then - ierr = nf_inq_varid(ncid, "RAINRATE", varid) !recheck variable name... - if (ierr /= 0) then + ierr = nf90_inq_varid(ncid, "precip", varid) + if(ierr /= NF90_NOERR) ierr_flg = ierr + if (ierr /= NF90_NOERR) then + ierr = nf90_inq_varid(ncid, "precip_rate", varid) !recheck variable name... + if (ierr /= NF90_NOERR) then + ierr = nf90_inq_varid(ncid, "RAINRATE", varid) !recheck variable name... + if (ierr /= NF90_NOERR) then #ifdef HYDRO_D write(*,'("READFORC_MDV Problem reading precip netcdf file: ''", A,"''")') & trim(flnm) @@ -576,10 +580,10 @@ subroutine READFORC_MDV(flnm,ix,jx,pcp,mmflag,ierr_flg) ierr_flg = ierr mmflag = 1 end if - ierr = nf_get_var_real(ncid, varid, pcp) - ierr = nf_close(ncid) + ierr = nf90_get_var(ncid, varid, pcp) + ierr = nf90_close(ncid) - if (ierr /= 0) then + if (ierr /= NF90_NOERR) then #ifdef HYDRO_D write(*,'("READFORC_MDV Problem reading netcdf file: ''", A,"''")') trim(flnm) #endif @@ -612,18 +616,18 @@ subroutine READFORC_NAMPCP(flnm,ix,jx,pcp,k,product) !open NetCDF file... if (k.eq.1.) then - ierr = nf_open(flnm, NF_NOWRITE, ncid) - if (ierr /= 0) then + ierr = nf90_open(flnm, NF90_NOWRITE, ncid) + if (ierr /= NF90_NOERR) then write(*,'("READFORC_NAMPCP1 Problem opening netcdf file: ''",A, "''")') & trim(flnm) call hydro_stop("In READFORC_NAMPCP() - Problem opening netcdf file") end if - ierr = nf_inq_varid(ncid, trim(product), varid) - ierr = nf_get_var_real(ncid, varid, buf) - ierr = nf_close(ncid) + ierr = nf90_inq_varid(ncid, trim(product), varid) + ierr = nf90_get_var(ncid, varid, buf) + ierr = nf90_close(ncid) - if (ierr /= 0) then + if (ierr /= NF90_NOERR) then write(*,'("READFORC_NAMPCP2 Problem reading netcdf file: ''", A,"''")') & trim(flnm) call hydro_stop("In READFORC_NAMPCP() - Problem reading netcdf file") @@ -670,8 +674,8 @@ subroutine READFORC_COWS(flnm,ix,jx,target_date, t,q,u,p,lw,sw,pcp,tlevel) integer :: ncid ! Open the NetCDF file. - ierr = nf_open(flnm, NF_NOWRITE, ncid) - if (ierr /= 0) then + ierr = nf90_open(flnm, NF90_NOWRITE, ncid) + if (ierr /= NF90_NOERR) then write(*,'("READFORC_COWS Problem opening netcdf file: ''", A, "''")') trim(flnm) call hydro_stop("In READFORC_COWS() - Problem opening netcdf file") endif @@ -685,7 +689,7 @@ subroutine READFORC_COWS(flnm,ix,jx,target_date, t,q,u,p,lw,sw,pcp,tlevel) call get_2d_netcdf_cows("RAIN", ncid, pcp, ix, jx,tlevel, .TRUE., ierr) !yw call get_2d_netcdf_cows("V2D", ncid, v, ix, jx,tlevel, .TRUE., ierr) - ierr = nf_close(ncid) + ierr = nf90_close(ncid) end subroutine READFORC_COWS @@ -710,8 +714,8 @@ subroutine READFORC_RUC(flnm,ix,jx,target_date,t,q,u,v,p,lw,sw,pcp) tlevel = 1 ! Open the NetCDF file. - ierr = nf_open(flnm, NF_NOWRITE, ncid) - if (ierr /= 0) then + ierr = nf90_open(flnm, NF90_NOWRITE, ncid) + if (ierr /= NF90_NOERR) then write(*,'("READFORC_RUC Problem opening netcdf file: ''", A, "''")') trim(flnm) call hydro_stop("In READFORC_RUC() - Problem opening netcdf file") endif @@ -726,7 +730,7 @@ subroutine READFORC_RUC(flnm,ix,jx,target_date,t,q,u,v,p,lw,sw,pcp) call get_2d_netcdf_ruc("RAINC", ncid, pcpc, ix, jx,tlevel, .true., ierr) call get_2d_netcdf_ruc("RAINNC", ncid, pcp, ix, jx,tlevel, .true., ierr) - ierr = nf_close(ncid) + ierr = nf90_close(ncid) !DJG Add the convective and non-convective rain components (note: conv. comp=0 @@ -757,14 +761,14 @@ subroutine READSNOW_FORC(flnm,ix,jx,weasd,snodep) ! Open the NetCDF file. - ierr = nf_open(flnm, NF_NOWRITE, ncid) - if (ierr /= 0) then + ierr = nf90_open(flnm, NF90_NOWRITE, ncid) + if (ierr /= NF90_NOERR) then write(*,'("READSNOW Problem opening netcdf file: ''", A, "''")') trim(flnm) call hydro_stop("In READSNOW_FORC() - Problem opening netcdf file") endif call get_2d_netcdf("WEASD", ncid, tmp, units, ix, jx, .FALSE., ierr) - if (ierr /= 0) then + if (ierr /= NF90_NOERR) then call get_2d_netcdf("SNOW", ncid, tmp, units, ix, jx, .FALSE., ierr) if (ierr == 0) then units = "mm" @@ -781,12 +785,12 @@ subroutine READSNOW_FORC(flnm,ix,jx,weasd,snodep) endif endif - if (ierr /= 0) then + if (ierr /= NF90_NOERR) then print *, "!!!!! NO WEASD present in input file...initialize to 0." endif call get_2d_netcdf("SNODEP", ncid, tmp, units, ix, jx, .FALSE., ierr) - if (ierr /= 0) then + if (ierr /= NF90_NOERR) then ! Quick assumption regarding snow depth. call get_2d_netcdf("SNOWH", ncid, tmp, units, ix, jx, .FALSE., ierr) if(ierr .eq. 0) then @@ -797,7 +801,7 @@ subroutine READSNOW_FORC(flnm,ix,jx,weasd,snodep) snodep = tmp endif - if (ierr /= 0) then + if (ierr /= NF90_NOERR) then ! Quick assumption regarding snow depth. !yw snodep = weasd * 10. where(snodep .lt. weasd) snodep = weasd*10 !set lower bound to correct bi-lin interp err... @@ -806,7 +810,7 @@ subroutine READSNOW_FORC(flnm,ix,jx,weasd,snodep) !DJG check for erroneous neg WEASD or SNOWD due to offline interpolation... where(snodep .lt. 0) snodep = 0 where(weasd .lt. 0) weasd = 0 - ierr = nf_close(ncid) + ierr = nf90_close(ncid) end subroutine READSNOW_FORC @@ -817,7 +821,7 @@ subroutine get2d_hrldas(inflnm,ix,jx,nsoil,smc,stc,sh2ox,cmc,t1,weasd,snodep) real,dimension(ix,jx,nsoil):: smc,stc,sh2ox character(len=*), intent(in) :: inflnm character(len=256):: units - iret = nf_open(trim(inflnm), NF_NOWRITE, ncid) + iret = nf90_open(trim(inflnm), NF90_NOWRITE, ncid) if(iret .ne. 0 )then write(6,*) "Error: failed to open file :",trim(inflnm) call hydro_stop("In get2d_hrldas() - failed to open file") @@ -855,8 +859,7 @@ subroutine get2d_hrldas(inflnm,ix,jx,nsoil,smc,stc,sh2ox,cmc,t1,weasd,snodep) call get2d_hrldas_real("SOIL_W_7", ncid, SH2OX(:,:,7), ix, jx) call get2d_hrldas_real("SOIL_W_8", ncid, SH2OX(:,:,8), ix, jx) - iret = nf_close(ncid) - return + iret = nf90_close(ncid) end subroutine get2d_hrldas subroutine get2d_hrldas_real(var_name,ncid,out_buff,ix,jx) @@ -864,9 +867,8 @@ subroutine get2d_hrldas_real(var_name,ncid,out_buff,ix,jx) integer ::iret,varid,ncid,ix,jx real out_buff(ix,jx) character(len=*), intent(in) :: var_name - iret = nf_inq_varid(ncid,trim(var_name), varid) - iret = nf_get_var_real(ncid, varid, out_buff) - return + iret = nf90_inq_varid(ncid,trim(var_name), varid) + iret = nf90_get_var(ncid, varid, out_buff) end subroutine get2d_hrldas_real subroutine read_stage4(flnm,IX,JX,pcp) @@ -875,14 +877,14 @@ subroutine read_stage4(flnm,IX,JX,pcp) character(len=*), intent(in) :: flnm character(len=256) :: units - ierr = nf_open(flnm, NF_NOWRITE, ncid) + ierr = nf90_open(flnm, NF90_NOWRITE, ncid) if(ierr .ne. 0) then call hydro_stop("In read_stage4() - failed to open stage4 file.") endif call get_2d_netcdf("RAINRATE",ncid, buf, units, ix, jx, .TRUE., ierr) - ierr = nf_close(ncid) + ierr = nf90_close(ncid) do j = 1, jx do i = 1, ix if(buf(i,j) .lt. 0) then @@ -891,7 +893,6 @@ subroutine read_stage4(flnm,IX,JX,pcp) end do end do pcp = buf - return END subroutine read_stage4 @@ -900,28 +901,39 @@ END subroutine read_stage4 subroutine read_hydro_forcing_seq( & indir,olddate,hgrid, & ix,jx,forc_typ,snow_assim, & + forcing_name_T,forcing_name_Q,forcing_name_U,forcing_name_V,forcing_name_P, & + forcing_name_LW,forcing_name_SW,forcing_name_PR,forcing_name_SN, forcing_name_LF,& T2,q2x,u,v,pres,xlong,short,prcp1,& - lai,fpar,snodep,dt,k,prcp_old) + lai,snowbl,fpar,snodep,dt,k,prcp_old) ! This subrouting is going to read different forcing. implicit none ! in variable character(len=*) :: olddate,hgrid,indir character(len=256) :: filename integer :: ix,jx,forc_typ,k,snow_assim ! k is time loop + character(len=256), intent(in) :: forcing_name_T + character(len=256), intent(in) :: forcing_name_Q + character(len=256), intent(in) :: forcing_name_U + character(len=256), intent(in) :: forcing_name_V + character(len=256), intent(in) :: forcing_name_P + character(len=256), intent(in) :: forcing_name_LW + character(len=256), intent(in) :: forcing_name_SW + character(len=256), intent(in) :: forcing_name_PR + character(len=256), intent(in) :: forcing_name_SN + character(len=256), intent(in) :: forcing_name_LF real,dimension(ix,jx):: T2,q2x,u,v,pres,xlong,short,prcp1,& prcpnew,weasd,snodep,prcp0,prcp2,prcp_old real :: dt, wrf_dt ! tmp variable character(len=256) :: inflnm, inflnm2, product integer :: i,j,mmflag,ierr_flg - real,dimension(ix,jx):: lai,fpar + real,dimension(ix,jx):: lai,snowbl,fpar character(len=4) nwxst_t logical :: fexist inflnm = trim(indir)//"/"//& olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& ".LDASIN_DOMAIN"//hgrid - !!!DJG... Call READFORC_(variable) Subroutine for forcing data... !!!DJG HRLDAS Format Forcing with hour format filename (NOTE: precip must be in mm/s!!!) if(FORC_TYP.eq.1) then @@ -937,8 +949,11 @@ subroutine read_hydro_forcing_seq( & call hydro_stop("In read_hydro_forcing_seq") endif - CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & - PRES,XLONG,SHORT,PRCP1,LAI,FPAR) + CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE, & + forcing_name_T,forcing_name_Q,forcing_name_U,forcing_name_V,forcing_name_P, & + forcing_name_LW,forcing_name_SW,forcing_name_PR,forcing_name_SN, forcing_name_LF,& + T2,Q2X,U,V, & + PRES,XLONG,SHORT,PRCP1,LAI,snowbl,FPAR) end if @@ -956,8 +971,11 @@ subroutine read_hydro_forcing_seq( & print*, "no forcing data found", inflnm call hydro_stop("In read_hydro_forcing_seq() - no forcing data found") endif - CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & - PRES,XLONG,SHORT,PRCP1,LAI,FPAR) + CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE, & + forcing_name_T,forcing_name_Q,forcing_name_U,forcing_name_V,forcing_name_P, & + forcing_name_LW,forcing_name_SW,forcing_name_PR,forcing_name_SN, forcing_name_LF,& + T2,Q2X,U,V, & + PRES,XLONG,SHORT,PRCP1,LAI,snowbl,FPAR) end if @@ -1142,8 +1160,11 @@ subroutine read_hydro_forcing_seq( & print*, "reading forcing data at this time", inflnm #endif - CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & - PRES,XLONG,SHORT,PRCP1,LAI,FPAR) + CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE,& + forcing_name_T,forcing_name_Q,forcing_name_U,forcing_name_V,forcing_name_P, & + forcing_name_LW,forcing_name_SW,forcing_name_PR,forcing_name_SN, forcing_name_LF,& + T2,Q2X,U,V, & + PRES,XLONG,SHORT,PRCP1,LAI,snowbl,FPAR) PRCP_old = PRCP1 ! This assigns new precip to last precip as a fallback for missing data... endif @@ -1649,7 +1670,6 @@ subroutine mpp_readland_hrldas(geo_static_flnm,& call decompose_data_real(g_TERRAIN,TERRAIN) call decompose_data_real(g_LATITUDE,LATITUDE) call decompose_data_real(g_LONGITUDE,LONGITUDE) - return end subroutine mpp_readland_hrldas @@ -1675,7 +1695,6 @@ subroutine MPP_READSNOW_FORC(flnm,ix,jx,OLDDATE,weasd,snodep,& call decompose_data_real(g_WEASD,WEASD) call decompose_data_real(g_SNODEP,SNODEP) - return end subroutine MPP_READSNOW_FORC subroutine MPP_DEEPGW_HRLDAS(ix,jx,in_SMCMAX,& @@ -1712,15 +1731,16 @@ subroutine MPP_DEEPGW_HRLDAS(ix,jx,in_SMCMAX,& call decompose_data_real(g_sh2ox(:,:,k),out_sh2ox(:,:,k)) end do - return end subroutine MPP_DEEPGW_HRLDAS subroutine read_hydro_forcing_mpp( & indir,olddate,hgrid, & ix,jx,forc_typ,snow_assim, & + forcing_name_T,forcing_name_Q,forcing_name_U,forcing_name_V,forcing_name_P, & + forcing_name_LW,forcing_name_SW,forcing_name_PR,forcing_name_SN, forcing_name_LF,& T2,q2x,u,v,pres,xlong,short,prcp1,& - lai,fpar,snodep,dt,k,prcp_old) + lai,snowbl,fpar,snodep,dt,k,prcp_old) ! This subrouting is going to read different forcing. @@ -1729,14 +1749,24 @@ subroutine read_hydro_forcing_mpp( & character(len=*) :: olddate,hgrid,indir character(len=256) :: filename integer :: ix,jx,forc_typ,k,snow_assim ! k is time loop + character(len=256), intent(in) :: forcing_name_T + character(len=256), intent(in) :: forcing_name_Q + character(len=256), intent(in) :: forcing_name_U + character(len=256), intent(in) :: forcing_name_V + character(len=256), intent(in) :: forcing_name_P + character(len=256), intent(in) :: forcing_name_LW + character(len=256), intent(in) :: forcing_name_SW + character(len=256), intent(in) :: forcing_name_PR + character(len=256), intent(in) :: forcing_name_SN + character(len=256), intent(in) :: forcing_name_LF real,dimension(ix,jx):: T2,q2x,u,v,pres,xlong,short,prcp1,& - prcpnew,lai,fpar,snodep,prcp_old + prcpnew,lai,snowbl,fpar,snodep,prcp_old real :: dt ! tmp variable character(len=256) :: inflnm, product integer :: i,j,mmflag real,dimension(global_nx,global_ny):: g_T2,g_Q2X,g_U,g_V,g_XLONG, & - g_SHORT,g_PRCP1,g_PRES,g_lai,g_snodep,g_prcp_old, g_fpar + g_SHORT,g_PRCP1,g_PRES,g_lai,g_snowbl,g_snodep,g_prcp_old, g_fpar integer flag @@ -1752,6 +1782,7 @@ subroutine read_hydro_forcing_mpp( & call write_io_real(prcp_old,g_PRCP_old) call write_io_real(lai,g_lai) + call write_io_real(snowbl,g_snowbl) call write_io_real(fpar,g_fpar) call write_io_real(snodep,g_snodep) @@ -1761,8 +1792,10 @@ subroutine read_hydro_forcing_mpp( & call read_hydro_forcing_seq( & indir,olddate,hgrid,& global_nx,global_ny,forc_typ,snow_assim, & + forcing_name_T,forcing_name_Q,forcing_name_U,forcing_name_V,forcing_name_P, & + forcing_name_LW,forcing_name_SW,forcing_name_PR,forcing_name_SN, forcing_name_LF,& g_T2,g_q2x,g_u,g_v,g_pres,g_xlong,g_short,g_prcp1,& - g_lai,g_fpar,g_snodep,dt,k,g_prcp_old) + g_lai,g_snowbl,g_fpar,g_snodep,dt,k,g_prcp_old) #ifdef HYDRO_D write(6,*) "finish read forcing,olddate ",olddate #endif @@ -1782,7 +1815,6 @@ subroutine read_hydro_forcing_mpp( & call decompose_data_real(g_fpar,fpar) call decompose_data_real(g_snodep,snodep) - return end subroutine read_hydro_forcing_mpp #endif @@ -2252,21 +2284,33 @@ end subroutine geth_newdate subroutine read_hydro_forcing_mpp1( & indir,olddate,hgrid, & ix,jx,forc_typ,snow_assim, & + forcing_name_T,forcing_name_Q,forcing_name_U,forcing_name_V,forcing_name_P, & + forcing_name_LW,forcing_name_SW,forcing_name_PR,forcing_name_SN, forcing_name_LF,& T2,q2x,u,v,pres,xlong,short,prcp1,& - lai,fpar,snodep,dt,k,prcp_old) + lai,snowbl,fpar,snodep,dt,k,prcp_old) ! This subrouting is going to read different forcing. implicit none ! in variable character(len=*) :: olddate,hgrid,indir character(len=256) :: filename integer :: ix,jx,forc_typ,k,snow_assim ! k is time loop +character(len=256), intent(in) :: forcing_name_T +character(len=256), intent(in) :: forcing_name_Q +character(len=256), intent(in) :: forcing_name_U +character(len=256), intent(in) :: forcing_name_V +character(len=256), intent(in) :: forcing_name_P +character(len=256), intent(in) :: forcing_name_LW +character(len=256), intent(in) :: forcing_name_SW +character(len=256), intent(in) :: forcing_name_PR +character(len=256), intent(in) :: forcing_name_SN +character(len=256), intent(in) :: forcing_name_LF real,dimension(ix,jx):: T2,q2x,u,v,pres,xlong,short,prcp1,& prcpnew,weasd,snodep,prcp0,prcp2,prcp_old real :: dt, wrf_dt ! tmp variable character(len=256) :: inflnm, inflnm2, product integer :: i,j,mmflag,ierr_flg -real,dimension(ix,jx):: lai,fpar +real,dimension(ix,jx):: lai,snowbl,fpar character(len=4) nwxst_t logical :: fexist @@ -2274,10 +2318,10 @@ subroutine read_hydro_forcing_mpp1( & olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& ".LDASIN_DOMAIN"//hgrid + !!!DJG... Call READFORC_(variable) Subroutine for forcing data... !!!DJG HRLDAS Format Forcing with hour format filename (NOTE: precip must be in mm/s!!!) - !!! FORC_TYPE 1 ============================================================================ if(FORC_TYP.eq.1) then !!Create forcing data filename... @@ -2299,8 +2343,11 @@ subroutine read_hydro_forcing_mpp1( & #ifdef HYDRO_D print*, "read forcing data at ", OLDDATE, trim(inflnm) #endif - call READFORC_HRLDAS_mpp(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & - PRES,XLONG,SHORT,PRCP1,LAI,FPAR) + call READFORC_HRLDAS_mpp(inflnm,IX,JX,OLDDATE, & + forcing_name_T,forcing_name_Q,forcing_name_U,forcing_name_V,forcing_name_P, & + forcing_name_LW,forcing_name_SW,forcing_name_PR,forcing_name_SN, forcing_name_LF,& + T2,Q2X,U,V, & + PRES,XLONG,SHORT,PRCP1,LAI,snowbl,FPAR) where(PRCP1 .lt. 0) PRCP1= 0 ! set minimum to be 0 where(PRCP1 .gt. 0.138889) PRCP1= 0.138889 ! set maximum to be 500 mm/h @@ -2325,8 +2372,11 @@ subroutine read_hydro_forcing_mpp1( & print*, "no forcing data found", inflnm call hydro_stop("In read_hydro_forcing_mpp1() - no forcing data found") endif - call READFORC_HRLDAS_mpp(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & - PRES,XLONG,SHORT,PRCP1,LAI,FPAR) + call READFORC_HRLDAS_mpp(inflnm,IX,JX,OLDDATE,& + forcing_name_T,forcing_name_Q,forcing_name_U,forcing_name_V,forcing_name_P, & + forcing_name_LW,forcing_name_SW,forcing_name_PR,forcing_name_SN, forcing_name_LF,& + T2,Q2X,U,V, & + PRES,XLONG,SHORT,PRCP1,LAI,snowbl,FPAR) where(PRCP1 .lt. 0) PRCP1= 0 ! set minimum to be 0 where(PRCP1 .gt. 0.138889) PRCP1= 0.138889 ! set maximum to be 500 mm/h @@ -2539,8 +2589,11 @@ subroutine read_hydro_forcing_mpp1( & print*, "reading forcing data at this time", inflnm #endif - call READFORC_HRLDAS_mpp(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & - PRES,XLONG,SHORT,PRCP1,LAI,FPAR) + call READFORC_HRLDAS_mpp(inflnm,IX,JX,OLDDATE,& + forcing_name_T,forcing_name_Q,forcing_name_U,forcing_name_V,forcing_name_P, & + forcing_name_LW,forcing_name_SW,forcing_name_PR,forcing_name_SN, forcing_name_LF,& + T2,Q2X,U,V, & + PRES,XLONG,SHORT,PRCP1,LAI,snowbl,FPAR) PRCP_old = PRCP1 ! This assigns new precip to last precip as a fallback for missing data... endif @@ -2729,13 +2782,26 @@ end subroutine read_hydro_forcing_mpp1 - subroutine READFORC_HRLDAS_mpp(flnm,ix,jx,target_date, t,q,u,v,p,lw,sw,pcp,lai,fpar) + subroutine READFORC_HRLDAS_mpp(flnm,ix,jx,target_date, & + forcing_name_T,forcing_name_Q,forcing_name_U,forcing_name_V,forcing_name_P, & + forcing_name_LW,forcing_name_SW,forcing_name_PR,forcing_name_SN, forcing_name_LF,& + t,q,u,v,p,lw,sw,pcp,lai,snowbl,fpar) implicit none character(len=*), intent(in) :: flnm integer, intent(in) :: ix integer, intent(in) :: jx character(len=*), intent(in) :: target_date + character(len=256), intent(in) :: forcing_name_T + character(len=256), intent(in) :: forcing_name_Q + character(len=256), intent(in) :: forcing_name_U + character(len=256), intent(in) :: forcing_name_V + character(len=256), intent(in) :: forcing_name_P + character(len=256), intent(in) :: forcing_name_LW + character(len=256), intent(in) :: forcing_name_SW + character(len=256), intent(in) :: forcing_name_PR + character(len=256), intent(in) :: forcing_name_SN + character(len=256), intent(in) :: forcing_name_LF real, dimension(ix,jx), intent(out) :: t real, dimension(ix,jx), intent(out) :: q real, dimension(ix,jx), intent(out) :: u @@ -2745,6 +2811,7 @@ subroutine READFORC_HRLDAS_mpp(flnm,ix,jx,target_date, t,q,u,v,p,lw,sw,pcp,lai,f real, dimension(ix,jx), intent(out) :: sw real, dimension(ix,jx), intent(out) :: pcp real, dimension(ix,jx), intent(inout) :: lai + real, dimension(ix,jx), intent(inout) :: snowbl real, dimension(ix,jx), intent(inout) :: fpar character(len=256) :: units @@ -2754,36 +2821,38 @@ subroutine READFORC_HRLDAS_mpp(flnm,ix,jx,target_date, t,q,u,v,p,lw,sw,pcp,lai,f ! Open the NetCDF file. #ifdef MPP_LAND real, allocatable, dimension(:,:):: buf2 + real, allocatable, dimension(:,:) :: liqfrac + if(my_id .eq. io_id) then allocate(buf2(global_nx,global_ny)) else allocate(buf2(1,1)) endif if(my_id .eq. io_id) then - ierr = nf_open(trim(flnm), NF_NOWRITE, ncid) + ierr = nf90_open(trim(flnm), NF90_NOWRITE, ncid) endif call mpp_land_bcast_int1(ierr) - if (ierr /= 0) then + if (ierr /= NF90_NOERR) then write(*,'("READFORC Problem opening netcdf file: ''", A, "''")') trim(flnm) call hydro_stop("In READFORC_HRLDAS_mpp() - Problem opening netcdf file") endif - if(my_id .eq. io_id ) call get_2d_netcdf("T2D", ncid,buf2, units, global_nx, global_ny, .TRUE., ierr) + if(my_id .eq. io_id ) call get_2d_netcdf(trim(forcing_name_T), ncid,buf2, units, global_nx, global_ny, .TRUE., ierr) call decompose_data_real (buf2,t) - if(my_id .eq. io_id ) call get_2d_netcdf("Q2D", ncid,buf2, units, global_nx, global_ny, .TRUE., ierr) + if(my_id .eq. io_id ) call get_2d_netcdf(trim(forcing_name_Q), ncid,buf2, units, global_nx, global_ny, .TRUE., ierr) call decompose_data_real (buf2,q) - if(my_id .eq. io_id ) call get_2d_netcdf("U2D", ncid,buf2, units, global_nx, global_ny, .TRUE., ierr) + if(my_id .eq. io_id ) call get_2d_netcdf(trim(forcing_name_U), ncid,buf2, units, global_nx, global_ny, .TRUE., ierr) call decompose_data_real (buf2,u) - if(my_id .eq. io_id ) call get_2d_netcdf("V2D", ncid,buf2, units, global_nx, global_ny, .TRUE., ierr) + if(my_id .eq. io_id ) call get_2d_netcdf(trim(forcing_name_V), ncid,buf2, units, global_nx, global_ny, .TRUE., ierr) call decompose_data_real (buf2,v) - if(my_id .eq. io_id ) call get_2d_netcdf("PSFC", ncid,buf2, units, global_nx, global_ny, .TRUE., ierr) + if(my_id .eq. io_id ) call get_2d_netcdf(trim(forcing_name_P), ncid,buf2, units, global_nx, global_ny, .TRUE., ierr) call decompose_data_real (buf2,p) - if(my_id .eq. io_id ) call get_2d_netcdf("LWDOWN", ncid,buf2, units, global_nx, global_ny, .TRUE., ierr) + if(my_id .eq. io_id ) call get_2d_netcdf(trim(forcing_name_LW), ncid,buf2, units, global_nx, global_ny, .TRUE., ierr) call decompose_data_real (buf2,lw) - if(my_id .eq. io_id ) call get_2d_netcdf("SWDOWN", ncid,buf2, units, global_nx, global_ny, .TRUE., ierr) + if(my_id .eq. io_id ) call get_2d_netcdf(trim(forcing_name_SW), ncid,buf2, units, global_nx, global_ny, .TRUE., ierr) call decompose_data_real (buf2,sw) - if(my_id .eq. io_id ) call get_2d_netcdf("RAINRATE", ncid,buf2, units, global_nx, global_ny, .TRUE., ierr) + if(my_id .eq. io_id ) call get_2d_netcdf(trim(forcing_name_PR), ncid,buf2, units, global_nx, global_ny, .TRUE., ierr) call decompose_data_real (buf2,pcp) if(my_id .eq. io_id ) then call get_2d_netcdf("VEGFRA", ncid,buf2, units, global_nx, global_ny, .FALSE., ierr) @@ -2796,32 +2865,60 @@ subroutine READFORC_HRLDAS_mpp(flnm,ix,jx,target_date, t,q,u,v,p,lw,sw,pcp,lai,f if(my_id .eq. io_id ) call get_2d_netcdf("LAI", ncid, buf2, units, global_nx, global_ny, .FALSE., ierr) call mpp_land_bcast_int1(ierr) if(ierr == 0) call decompose_data_real (buf2,lai) + if(my_id .eq. io_id ) call get_2d_netcdf(trim(forcing_name_SN), ncid, buf2, units, global_nx, global_ny, .FALSE., ierr) + call mpp_land_bcast_int1(ierr) + if (ierr == 0) then + call decompose_data_real (buf2,snowbl) + else + if(my_id .eq. io_id ) call get_2d_netcdf(trim(forcing_name_LF), ncid, buf2, units, global_nx, global_ny, .FALSE., ierr) + call mpp_land_bcast_int1(ierr) + if(ierr == 0) then + allocate(liqfrac(ix,jx)) + call decompose_data_real (buf2,liqfrac) + snowbl = (1.0 - liqfrac) * pcp + deallocate(liqfrac) + else + snowbl = 0.0 ! since if liqfrac is not present it defaults to 1.0 + end if + end if deallocate(buf2) #else - ierr = nf_open(trim(flnm), NF_NOWRITE, ncid) - if (ierr /= 0) then + ierr = nf90_open(trim(flnm), NF90_NOWRITE, ncid) + if (ierr /= NF90_NOERR) then write(*,'("READFORC Problem opening netcdf file: ''", A, "''")') trim(flnm) call hydro_stop("READFORC_HRLDAS") endif - call get_2d_netcdf("T2D", ncid, t, units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("Q2D", ncid, q, units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("U2D", ncid, u, units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("V2D", ncid, v, units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("PSFC", ncid, p, units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("LWDOWN", ncid, lw, units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("SWDOWN", ncid, sw, units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("RAINRATE",ncid, pcp, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf(trim(forcing_name_T), ncid, t, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf(trim(forcing_name_Q), ncid, q, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf(trim(forcing_name_U), ncid, u, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf(trim(forcing_name_V), ncid, v, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf(trim(forcing_name_P), ncid, p, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf(trim(forcing_name_LW), ncid, lw, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf(trim(forcing_name_SW), ncid, sw, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf(trim(forcing_name_PR),ncid, pcp, units, ix, jx, .TRUE., ierr) call get_2d_netcdf("VEGFRA", ncid, fpar, units, ix, jx, .FALSE., ierr) if (ierr == 0) then if(maxval(fpar) .gt. 10 .and. maxval(fpar) .lt. 10000) fpar = fpar * 1.E-2 endif + call get_2d_netcdf("LAI", ncid, lai, units, ix, jx, .FALSE., ierr) -#endif + call get_2d_netcdf(trim(forcing_name_SN), ncid, snowbl,units, ix, jx, .FALSE., ierr) + if (ierr /= NF90_NOERR) then + allocate(liqfrac(ix,jx)) + call get_2d_netcdf(trim(forcing_name_LF), ncid, liqfrac, units, ix, jx, .FALSE., ierr) + if (ierr == 0) then + snowbl = (1.0 - liqfrac) * pcp + else + snowbl = 0.0 ! since if liqfrac is not present it is set to 1.0 + end if + deallocate(liqfrac) + end if - ierr = nf_close(ncid) +#endif + ierr = nf90_close(ncid) end subroutine READFORC_HRLDAS_mpp subroutine READFORC_WRF_mpp(flnm,ix,jx,target_date,t,q,u,v,p,lw,sw,pcp,lai,fpar) @@ -2854,9 +2951,9 @@ subroutine READFORC_WRF_mpp(flnm,ix,jx,target_date,t,q,u,v,p,lw,sw,pcp,lai,fpar) ! Open the NetCDF file. - if(my_id .eq. io_id) ierr = nf_open(flnm, NF_NOWRITE, ncid) + if(my_id .eq. io_id) ierr = nf90_open(flnm, NF90_NOWRITE, ncid) call mpp_land_bcast_int1(ierr) - if (ierr /= 0) then + if (ierr /= NF90_NOERR) then write(*,'("READFORC_WRF Problem opening netcdf file: ''", A, "''")') trim(flnm) call hydro_stop("In READFORC_WRF_mpp() - Problem opening netcdf file") endif @@ -2893,8 +2990,8 @@ subroutine READFORC_WRF_mpp(flnm,ix,jx,target_date,t,q,u,v,p,lw,sw,pcp,lai,fpar) #else ! Open the NetCDF file. - ierr = nf_open(flnm, NF_NOWRITE, ncid) - if (ierr /= 0) then + ierr = nf90_open(flnm, NF90_NOWRITE, ncid) + if (ierr /= NF90_NOERR) then write(*,'("READFORC_WRF Problem opening netcdf file: ''", A, "''")') trim(flnm) call hydro_stop("In READFORC_WRF_mpp() - Problem opening netcdf file") endif @@ -2917,7 +3014,7 @@ subroutine READFORC_WRF_mpp(flnm,ix,jx,target_date,t,q,u,v,p,lw,sw,pcp,lai,fpar) pcp=pcp+pcpc ! assumes pcpc=0 for resolved convection... - ierr = nf_close(ncid) + ierr = nf90_close(ncid) end subroutine READFORC_WRF_mpp @@ -2952,7 +3049,7 @@ subroutine READFORC_MDV_mpp(flnm,ix,jx,pcp,mmflag,ierr_flg) #ifdef MPP_LAND if(my_id .eq. io_id) then #endif - ierr_flg = nf_open(flnm, NF_NOWRITE, ncid) + ierr_flg = nf90_open(flnm, NF90_NOWRITE, ncid) #ifdef MPP_LAND endif call mpp_land_bcast_int1(ierr_flg) @@ -2969,31 +3066,31 @@ subroutine READFORC_MDV_mpp(flnm,ix,jx,pcp,mmflag,ierr_flg) #ifdef MPP_LAND if(my_id .eq. io_id) then #endif - ierr = nf_inq_varid(ncid, "precip", varid) + ierr = nf90_inq_varid(ncid, "precip", varid) #ifdef MPP_LAND endif call mpp_land_bcast_int1(ierr) #endif - if(ierr /= 0) ierr_flg = ierr - if (ierr /= 0) then + if(ierr /= NF90_NOERR) ierr_flg = ierr + if (ierr /= NF90_NOERR) then #ifdef MPP_LAND if(my_id .eq. io_id) then #endif - ierr = nf_inq_varid(ncid, "precip_rate", varid) !recheck variable name... + ierr = nf90_inq_varid(ncid, "precip_rate", varid) !recheck variable name... #ifdef MPP_LAND endif call mpp_land_bcast_int1(ierr) #endif - if (ierr /= 0) then + if (ierr /= NF90_NOERR) then #ifdef MPP_LAND if(my_id .eq. io_id) then #endif - ierr = nf_inq_varid(ncid, "RAINRATE", varid) !recheck variable name... + ierr = nf90_inq_varid(ncid, "RAINRATE", varid) !recheck variable name... #ifdef MPP_LAND endif call mpp_land_bcast_int1(ierr) #endif - if (ierr /= 0) then + if (ierr /= NF90_NOERR) then write(*,'("READFORC_MDV Problem reading precip netcdf file: ''", A,"''")') & trim(flnm) #ifdef MPP_LAND @@ -3007,18 +3104,18 @@ subroutine READFORC_MDV_mpp(flnm,ix,jx,pcp,mmflag,ierr_flg) end if #ifdef MPP_LAND if(my_id .eq. io_id) then - ierr = nf_get_var_real(ncid, varid, buf2) + ierr = nf90_get_var(ncid, varid, buf2) endif call mpp_land_bcast_int1(ierr) if(ierr ==0) call decompose_data_real (buf2,pcp) deallocate(buf2) #else - ierr = nf_get_var_real(ncid, varid, pcp) + ierr = nf90_get_var(ncid, varid, pcp) #endif - if (ierr /= 0) then + if (ierr /= NF90_NOERR) then write(*,'("READFORC_MDV Problem reading netcdf file: ''", A,"''")') trim(flnm) end if - ierr = nf_close(ncid) + ierr = nf90_close(ncid) end subroutine READFORC_MDV_mpp @@ -3048,12 +3145,12 @@ subroutine READSNOW_FORC_mpp(flnm,ix,jx,weasd,snodep) #ifdef MPP_LAND if(my_id .eq. io_id) then #endif - ierr = nf_open(flnm, NF_NOWRITE, ncid) + ierr = nf90_open(flnm, NF90_NOWRITE, ncid) #ifdef MPP_LAND endif call mpp_land_bcast_int1(ierr) #endif - if (ierr /= 0) then + if (ierr /= NF90_NOERR) then write(*,'("READSNOW Problem opening netcdf file: ''", A, "''")') trim(flnm) call hydro_stop("In READSNOW_FORC_mpp() - Problem opening netcdf file") endif @@ -3067,7 +3164,7 @@ subroutine READSNOW_FORC_mpp(flnm,ix,jx,weasd,snodep) #else call get_2d_netcdf("WEASD", ncid, tmp, units, ix, jx, .FALSE., ierr) #endif - if (ierr /= 0) then + if (ierr /= NF90_NOERR) then call get_2d_netcdf("SNOW", ncid, tmp, units, ix, jx, .FALSE., ierr) if (ierr == 0) then units = "mm" @@ -3086,7 +3183,7 @@ subroutine READSNOW_FORC_mpp(flnm,ix,jx,weasd,snodep) endif endif - if (ierr /= 0) then + if (ierr /= NF90_NOERR) then print *, "!!!!! NO WEASD present in input file...initialize to 0." endif #ifdef MPP_LAND @@ -3098,7 +3195,7 @@ subroutine READSNOW_FORC_mpp(flnm,ix,jx,weasd,snodep) #else call get_2d_netcdf("SNODEP", ncid, tmp, units, ix, jx, .FALSE., ierr) #endif - if (ierr /= 0) then + if (ierr /= NF90_NOERR) then ! Quick assumption regarding snow depth. #ifdef MPP_LAND @@ -3120,7 +3217,7 @@ subroutine READSNOW_FORC_mpp(flnm,ix,jx,weasd,snodep) snodep = tmp endif - if (ierr /= 0) then + if (ierr /= NF90_NOERR) then ! Quick assumption regarding snow depth. !yw snodep = weasd * 10. where(snodep .lt. weasd) snodep = weasd*10 !set lower bound to correct bi-lin interp err... @@ -3129,7 +3226,7 @@ subroutine READSNOW_FORC_mpp(flnm,ix,jx,weasd,snodep) !DJG check for erroneous neg WEASD or SNOWD due to offline interpolation... where(snodep .lt. 0) snodep = 0 where(weasd .lt. 0) weasd = 0 - ierr = nf_close(ncid) + ierr = nf90_close(ncid) end subroutine READSNOW_FORC_mpp @@ -3189,7 +3286,7 @@ subroutine read_ldasout(olddate,hgrid, indir, dt,ix,jx,infxsrt,soldrain) ! read file1 #ifdef MPP_LAND if(my_id .eq. io_id) then - ierr = nf_open(trim(inflnm), NF_NOWRITE, ncid) + ierr = nf90_open(trim(inflnm), NF90_NOWRITE, ncid) call get_2d_netcdf("SFCRNOFF", ncid, gArr, units, global_nx, global_ny, .TRUE., ierr) endif call decompose_data_real (gArr,infxsrt) @@ -3198,18 +3295,18 @@ subroutine read_ldasout(olddate,hgrid, indir, dt,ix,jx,infxsrt,soldrain) endif call decompose_data_real (gArr,soldrain) if(my_id .eq. io_id) then - ierr = nf_close(ncid) + ierr = nf90_close(ncid) endif #else - ierr = nf_open(trim(inflnm), NF_NOWRITE, ncid) + ierr = nf90_open(trim(inflnm), NF90_NOWRITE, ncid) call get_2d_netcdf("SFCRNOFF", ncid, infxsrt, units, ix, jx, .TRUE., ierr) call get_2d_netcdf("UGDRNOFF", ncid, soldrain, units, ix, jx, .TRUE., ierr) - ierr = nf_close(ncid) + ierr = nf90_close(ncid) #endif ! read file2 #ifdef MPP_LAND if(my_id .eq. io_id) then - ierr = nf_open(trim(inflnm2), NF_NOWRITE, ncid) + ierr = nf90_open(trim(inflnm2), NF90_NOWRITE, ncid) call get_2d_netcdf("SFCRNOFF", ncid, gArr, units, global_nx, global_ny, .TRUE., ierr) endif call decompose_data_real (gArr,infxsrt2) @@ -3218,13 +3315,13 @@ subroutine read_ldasout(olddate,hgrid, indir, dt,ix,jx,infxsrt,soldrain) endif call decompose_data_real (gArr,soldrain2) if(my_id .eq. io_id) then - ierr = nf_close(ncid) + ierr = nf90_close(ncid) endif #else - ierr = nf_open(trim(inflnm2), NF_NOWRITE, ncid) + ierr = nf90_open(trim(inflnm2), NF90_NOWRITE, ncid) call get_2d_netcdf("SFCRNOFF", ncid, infxsrt2, units, ix, jx, .TRUE., ierr) call get_2d_netcdf("UGDRNOFF", ncid, soldrain2, units, ix, jx, .TRUE., ierr) - ierr = nf_close(ncid) + ierr = nf90_close(ncid) #endif infxsrt = infxsrt2 - infxsrt @@ -3284,15 +3381,15 @@ subroutine read_ldasout_seq(olddate,hgrid, indir, dt,ix,jx,infxsrt,soldrain) call hydro_stop( "LDASOUT input Error") endif ! read file1 - ierr = nf_open(trim(inflnm), NF_NOWRITE, ncid) + ierr = nf90_open(trim(inflnm), NF90_NOWRITE, ncid) call get_2d_netcdf("SFCRNOFF", ncid, infxsrt, units, ix, jx, .TRUE., ierr) call get_2d_netcdf("UGDRNOFF", ncid, soldrain, units, ix, jx, .TRUE., ierr) - ierr = nf_close(ncid) + ierr = nf90_close(ncid) ! read file2 - ierr = nf_open(trim(inflnm2), NF_NOWRITE, ncid) + ierr = nf90_open(trim(inflnm2), NF90_NOWRITE, ncid) call get_2d_netcdf("SFCRNOFF", ncid, infxsrt2, units, ix, jx, .TRUE., ierr) call get_2d_netcdf("UGDRNOFF", ncid, soldrain2, units, ix, jx, .TRUE., ierr) - ierr = nf_close(ncid) + ierr = nf90_close(ncid) infxsrt = infxsrt2 - infxsrt soldrain = soldrain2 - soldrain diff --git a/hydro/Routing/module_reservoir_routing.F90 b/hydro/Routing/module_reservoir_routing.F90 index b2b20b459e..bc157b2ba9 100644 --- a/hydro/Routing/module_reservoir_routing.F90 +++ b/hydro/Routing/module_reservoir_routing.F90 @@ -1,5 +1,5 @@ ! Intended purpose is to provide a module for all subroutines related to -! reservoir routing, including active management, level pool, and integrating live +! reservoir routing, including active management, level pool, and integrating live ! data feeds. As of NWMv2.0, this module stub can read in a timeslice file ! to incorporate data from external sources, should a data service become available. @@ -83,7 +83,7 @@ subroutine read_reservoir_obs(domainId) ! If not MPI, then default to 0, which is the I/O ID. if(mppFlag .eq. 1) then #ifdef MPP_LAND - call MPI_COMM_RANK( HYDRO_COMM_WORLD, myId, ierr ) + call MPI_Comm_rank( HYDRO_COMM_WORLD, myId, ierr ) call nwmCheck(diagFlag,ierr,'ERROR: Unable to determine MPI process ID.') #endif else @@ -92,7 +92,7 @@ subroutine read_reservoir_obs(domainId) ! Open up and read in the NetCDF file containing disharge data. if(myId .eq. 0) then - ! Initialize our missing flag to 0. If at any point we don't find a file, + ! Initialize our missing flag to 0. If at any point we don't find a file, ! the flag value will go to 1 to indicate no files were found. missingFlag = 0 diff --git a/hydro/nudging/module_date_utils_nudging.F90 b/hydro/nudging/module_date_utils_nudging.F90 index 45ad66738c..ce27082bfa 100644 --- a/hydro/nudging/module_date_utils_nudging.F90 +++ b/hydro/nudging/module_date_utils_nudging.F90 @@ -1,23 +1,3 @@ -! Program Name: -! Author(s)/Contact(s): -! Abstract: -! History Log: -! -! Usage: -! Parameters: -! Input Files: -! -! Output Files: -! -! -! Condition codes: -! -! If appropriate, descriptive troubleshooting instructions or -! likely causes for failures could be mentioned here with the -! appropriate error code -! -! User controllable options: - module module_date_utils_nudging use module_hydro_stop, only: HYDRO_stop contains diff --git a/hydro/nudging/module_nudging_io.F90 b/hydro/nudging/module_nudging_io.F90 index f29920ab8d..80f8780e1e 100644 --- a/hydro/nudging/module_nudging_io.F90 +++ b/hydro/nudging/module_nudging_io.F90 @@ -1,23 +1,3 @@ -! Program Name: -! Author(s)/Contact(s): -! Abstract: -! History Log: -! -! Usage: -! Parameters: -! Input Files: -! -! Output Files: -! -! -! Condition codes: -! -! If appropriate, descriptive troubleshooting instructions or -! likely causes for failures could be mentioned here with the -! appropriate error code -! -! User controllable options: - module module_nudging_io use netcdf diff --git a/hydro/nudging/module_nudging_utils.F90 b/hydro/nudging/module_nudging_utils.F90 index 3afe2108af..255840bf60 100644 --- a/hydro/nudging/module_nudging_utils.F90 +++ b/hydro/nudging/module_nudging_utils.F90 @@ -1,23 +1,3 @@ -! Program Name: -! Author(s)/Contact(s): -! Abstract: -! History Log: -! -! Usage: -! Parameters: -! Input Files: -! -! Output Files: -! -! -! Condition codes: -! -! If appropriate, descriptive troubleshooting instructions or -! likely causes for failures could be mentioned here with the -! appropriate error code -! -! User controllable options: - module module_nudging_utils real :: totalNudgeTime diff --git a/hydro/nudging/module_stream_nudging.F90 b/hydro/nudging/module_stream_nudging.F90 index c52dc7dee8..84b6a3910a 100644 --- a/hydro/nudging/module_stream_nudging.F90 +++ b/hydro/nudging/module_stream_nudging.F90 @@ -1,23 +1,3 @@ -! Program Name: -! Author(s)/Contact(s): -! Abstract: -! History Log: -! -! Usage: -! Parameters: -! Input Files: -! -! Output Files: -! -! -! Condition codes: -! -! If appropriate, descriptive troubleshooting instructions or -! likely causes for failures could be mentioned here with the -! appropriate error code -! -! User controllable options: - module module_stream_nudging use config_base, only: nlst diff --git a/hydro/template/HYDRO/hydro.namelist b/hydro/template/HYDRO/hydro.namelist index 54821f10fa..97683ae50c 100644 --- a/hydro/template/HYDRO/hydro.namelist +++ b/hydro/template/HYDRO/hydro.namelist @@ -154,10 +154,40 @@ compound_channel = .FALSE. ! Switch to activate channel-loss option (0=no, 1=yes) [Requires Kchan in RouteLink] ! channel_loss_option = 0 +! Lake / Reservoir options (0=lakes off, 1=level pool (typical default), +! 2=passthrough, 3=reservoir DA [see &reservoir_nlist below]) +lake_option = 1 + ! Specify the lake parameter file (e.g.: "LAKEPARM.nc"). ! Note REQUIRED if lakes are on. route_lake_f = "./DOMAIN/LAKEPARM.nc" +! Switch to activate baseflow bucket model...(0=none, 1=exp. bucket, 2=pass-through, +! 4=exp. bucket with area normalized parameters) +! Option 4 is currently only supported if using reach-based routing with UDMP=1. +GWBASESWCRT = 1 + +! Switch to activate bucket model loss (0=no, 1=yes) +! This option is currently only supported if using reach-based routing with UDMP=1. +bucket_loss = 0 + +! Groundwater/baseflow 2d mask specified on land surface model grid (e.g.: "GWBASINS.nc") +! Note: Only required if baseflow model is active (1 or 2) and UDMP_OPT=0. +gwbasmskfil = "./DOMAIN/GWBASINS.nc" + +! Groundwater bucket parameter file (e.g.: "GWBUCKPARM.nc") +GWBUCKPARM_file = "./DOMAIN/GWBUCKPARM.nc" + +! User defined mapping, such as NHDPlus: 0=no (default), 1=yes +UDMP_OPT = 0 + +! If on, specify the user-defined mapping file (e.g.: "spatialweights.nc") +!udmap_file = "./DOMAIN/spatialweights.nc" + +/ + +&reservoir_nlist + ! Specify the reservoir parameter file reservoir_parameter_file = "./DOMAIN/persistence_parm.nc" @@ -190,28 +220,6 @@ reservoir_rfc_forecasts_time_series_path = "./rfc_timeseries/" ! Specify lookback hours to read reservoir RFC forecasts reservoir_rfc_forecasts_lookback_hours = 28 -! Switch to activate baseflow bucket model...(0=none, 1=exp. bucket, 2=pass-through, -! 4=exp. bucket with area normalized parameters) -! Option 4 is currently only supported if using reach-based routing with UDMP=1. -GWBASESWCRT = 1 - -! Switch to activate bucket model loss (0=no, 1=yes) -! This option is currently only supported if using reach-based routing with UDMP=1. -bucket_loss = 0 - -! Groundwater/baseflow 2d mask specified on land surface model grid (e.g.: "GWBASINS.nc") -! Note: Only required if baseflow model is active (1 or 2) and UDMP_OPT=0. -gwbasmskfil = "./DOMAIN/GWBASINS.nc" - -! Groundwater bucket parameter file (e.g.: "GWBUCKPARM.nc") -GWBUCKPARM_file = "./DOMAIN/GWBUCKPARM.nc" - -! User defined mapping, such as NHDPlus: 0=no (default), 1=yes -UDMP_OPT = 0 - -! If on, specify the user-defined mapping file (e.g.: "spatialweights.nc") -!udmap_file = "./DOMAIN/spatialweights.nc" - / &NUDGING_nlist diff --git a/hydro/template/NoahMP/namelist.hrldas b/hydro/template/NoahMP/namelist.hrldas index c760fe65bb..a3a3da702c 100644 --- a/hydro/template/NoahMP/namelist.hrldas +++ b/hydro/template/NoahMP/namelist.hrldas @@ -64,6 +64,18 @@ rst_bi_in = 0 !0: use netcdf input restart file rst_bi_out = 0 !0: use netcdf output restart file !1: use parallel io for outputting multiple restart files (1 per core) +! Forcing input variable names +forcing_name_T = "T2D" +forcing_name_Q = "Q2D" +forcing_name_U = "U2D" +forcing_name_V = "V2D" +forcing_name_P = "PSFC" +forcing_name_LW = "LWDOWN" +forcing_name_SW = "SWDOWN" +forcing_name_PR = "RAINRATE" +forcing_name_SN = "" +forcing_name_LF = "LQFRAC" + / &WRF_HYDRO_OFFLINE diff --git a/hydro/utils/CMakeLists.txt b/hydro/utils/CMakeLists.txt index 923017f10d..b6d2e57540 100644 --- a/hydro/utils/CMakeLists.txt +++ b/hydro/utils/CMakeLists.txt @@ -18,3 +18,4 @@ add_library(hydro_utils STATIC module_version.F90 module_hydro_stop.F90 ) +target_link_libraries(hydro_utils PRIVATE MPI::MPI_Fortran) diff --git a/hydro/utils/module_hydro_stop.F90 b/hydro/utils/module_hydro_stop.F90 index 724d61dcea..c4b25a21af 100644 --- a/hydro/utils/module_hydro_stop.F90 +++ b/hydro/utils/module_hydro_stop.F90 @@ -14,7 +14,7 @@ subroutine HYDRO_stop(msg) ierr = 1 #ifndef NCEP_WCOSS !#ifdef HYDRO_D !! PLEASE NEVER UNCOMMENT THIS IFDEF, it's just one incredibly useful string. - write(6,*) "The job is stopped due to the fatal error. ", trim(msg) + write(6,'(a)') "The job has stopped due to a fatal error: ", trim(msg) call flush(6) !#endif #else @@ -35,7 +35,7 @@ subroutine HYDRO_stop(msg) ! call flush(my_id+90) call mpp_land_abort() - call MPI_finalize(ierr) + call MPI_Finalize(ierr) #else stop "FATAL ERROR: Program stopped. Recompile with environment variable HYDRO_D set to 1 for enhanced debug information." #endif diff --git a/inc/version_decl b/inc/version_decl index 20fb319054..83813f5c12 100644 --- a/inc/version_decl +++ b/inc/version_decl @@ -1 +1 @@ - CHARACTER (LEN=*), PARAMETER :: release_version = 'V4.6.1' + CHARACTER (LEN=*), PARAMETER :: release_version = 'V4.7.0' diff --git a/main/CMakeLists.txt b/main/CMakeLists.txt index b0ec69d7f0..d6b2d627b5 100644 --- a/main/CMakeLists.txt +++ b/main/CMakeLists.txt @@ -5,15 +5,8 @@ add_compile_options ( "${PROJECT_COMPILE_OPTIONS}" ) add_compile_definitions( "${PROJECT_COMPILE_DEFINITIONS}" ) # First make true executables -if ( ${WRF_CORE} STREQUAL "PLUS" ) - add_executable( - wrfplus - wrf.F - module_wrf_top.F - ) - list( APPEND FOLDER_COMPILE_TARGETS wrfplus ) -else() - # I believe this is always made if not WRF PLUS or ESMF +if ( ${WRF_CORE} STREQUAL "PLUS" OR ${WRF_CASE} STREQUAL "EM_REAL" ) + add_executable( wrf wrf.F @@ -31,46 +24,48 @@ else() # list( APPEND FOLDER_COMPILE_TARGETS em_wrf_SST_ESMF ) endif() -# Use case info from higher CMakeLists.txt -set( MODULE_FILE ${PROJECT_SOURCE_DIR}/dyn_em/module_initialize_${WRF_CASE_MODULE}.F ) +if ( ${WRF_CORE} STREQUAL "ARW" ) -if ( ${WRF_CASE} STREQUAL "EM_REAL" ) - add_executable( - ndown - ndown_em.F - ${MODULE_FILE} - ) - add_executable( - tc - tc_em.F - ${MODULE_FILE} + # Use case info from higher CMakeLists.txt + set( MODULE_FILE ${PROJECT_SOURCE_DIR}/dyn_em/module_initialize_${WRF_CASE_MODULE}.F ) + + if ( ${WRF_CASE} STREQUAL "EM_REAL" ) + add_executable( + ndown + ndown_em.F + ${MODULE_FILE} + ) + add_executable( + tc + tc_em.F + ${MODULE_FILE} + ) + add_executable( + real + real_em.F + ${MODULE_FILE} ) - add_executable( - real - real_em.F - ${MODULE_FILE} - ) - list( APPEND FOLDER_COMPILE_TARGETS ndown tc real ) + list( APPEND FOLDER_COMPILE_TARGETS ndown tc real ) -elseif( NOT ${WRF_GENERAL_IDEAL_CASE} ) # Not general ideal and not real - # All others are variants of ideal - add_executable( - ideal - ideal_em.F - ${MODULE_FILE} - ) - list( APPEND FOLDER_COMPILE_TARGETS ideal ) -else() - # greater than or equal to general ideal case - add_executable( - ideal - ideal_em.F - ${PROJECT_SOURCE_DIR}/dyn_em/module_initialize_ideal.F - ) - list( APPEND FOLDER_COMPILE_TARGETS ideal ) + elseif( NOT ${WRF_GENERAL_IDEAL_CASE} ) # Not general ideal and not real + # All others are variants of ideal + add_executable( + ideal + ideal_em.F + ${MODULE_FILE} + ) + list( APPEND FOLDER_COMPILE_TARGETS ideal ) + else() + # greater than or equal to general ideal case + add_executable( + ideal + ideal_em.F + ${PROJECT_SOURCE_DIR}/dyn_em/module_initialize_ideal.F + ) + list( APPEND FOLDER_COMPILE_TARGETS ideal ) + endif() endif() - foreach ( TARGET ${FOLDER_COMPILE_TARGETS} ) set_target_properties( ${TARGET} @@ -154,3 +149,13 @@ wrf_setup_files( DEST_PATH ${CMAKE_INSTALL_PREFIX}/run/ ) + +if ( ${WRF_CORE} STREQUAL "PLUS" ) + wrf_setup_target_new_name( + TARGET wrf + DEST_PATH ${CMAKE_INSTALL_PREFIX}/run + NEW_NAME wrfplus + USE_SYMLINKS + + ) +endif() diff --git a/main/depend.common b/main/depend.common index 9ca1327f5f..0d34bd218b 100644 --- a/main/depend.common +++ b/main/depend.common @@ -663,13 +663,13 @@ module_bl_gfsedmf.o: \ module_gfs_physcons.o -module_bl_mynn.o: \ - module_bl_mynn_common.o +module_bl_mynnedmf.o: \ + module_bl_mynnedmf_common.o -module_bl_mynn_wrapper.o: \ - module_bl_mynn.o \ - module_bl_mynn_common.o +module_bl_mynnedmf_driver.o: \ + module_bl_mynnedmf.o \ + module_bl_mynnedmf_common.o module_bl_gwdo.o: \ @@ -735,7 +735,6 @@ module_bl_camuwpbl_driver.o: \ module_sf_mynn.o: \ - module_bl_mynn.o \ ../share/module_model_constants.o \ ../frame/module_wrf_error.o @@ -971,6 +970,14 @@ module_mp_thompson.o: \ module_mp_radar.o +module_mp_rcon.o: \ + ../frame/module_domain.o \ + ../share/module_model_constants.o \ + ../frame/module_timing.o \ + ../frame/module_wrf_error.o \ + module_mp_radar.o + + module_mp_nssl_2mom.o: \ ../frame/module_wrf_error.o \ ../share/module_model_constants.o @@ -1300,8 +1307,8 @@ module_physics_init.o: \ module_bl_acm.o \ module_bl_myjpbl.o \ module_bl_qnsepbl.o \ - module_bl_mynn.o \ - module_bl_mynn_wrapper.o \ + module_bl_mynnedmf.o \ + module_bl_mynnedmf_driver.o \ module_bl_myjurb.o \ module_bl_boulac.o \ module_bl_camuwpbl_driver.o \ @@ -1335,6 +1342,7 @@ module_physics_init.o: \ module_fdda_spnudging.o \ module_fddaobs_rtfdda.o \ module_mp_thompson.o \ + module_mp_rcon.o \ module_mp_gsfcgce.o \ module_mp_gsfcgce_4ice_nuwrf.o \ module_mp_morr_two_moment.o \ @@ -1381,6 +1389,7 @@ module_microphysics_driver.o: \ module_mp_wsm6r.o \ module_mp_fer_hires.o \ module_mp_thompson.o \ + module_mp_rcon.o \ module_mp_gsfcgce.o \ module_mp_gsfcgce_4ice_nuwrf.o \ module_mp_morr_two_moment.o \ @@ -1476,8 +1485,8 @@ module_pbl_driver.o: \ module_bl_camuwpbl_driver.o \ module_bl_gfs.o \ module_bl_gfsedmf.o \ - module_bl_mynn.o \ - module_bl_mynn_wrapper.o \ + module_bl_mynnedmf.o \ + module_bl_mynnedmf_driver.o \ module_bl_fogdes.o \ module_bl_gwdo.o \ module_bl_gwdo_gsl.o \ @@ -2780,8 +2789,7 @@ module_bl_mfshconvpbl.o: \ ../share/module_model_constants.o -module_bl_mynn_common.o: \ - module_gfs_machine.o \ +module_bl_mynnedmf_common.o: \ ../share/module_model_constants.o \ ccpp_kind_types.o diff --git a/main/real_em.F b/main/real_em.F index 796a0ac219..0a0075c100 100644 --- a/main/real_em.F +++ b/main/real_em.F @@ -15,7 +15,7 @@ PROGRAM real_data USE module_configure, ONLY : grid_config_rec_type, model_config_rec, & initial_config, get_config_as_buffer, set_config_as_buffer USE module_timing - USE module_state_description, ONLY : realonly, THOMPSONAERO + USE module_state_description, ONLY : realonly, THOMPSONAERO, RCON_MP_SCHEME #ifdef NO_LEAP_CALENDAR USE module_symbols_util, ONLY: wrfu_cal_noleap #else @@ -802,7 +802,7 @@ SUBROUTINE assemble_output ( grid , config_flags , loop , time_loop_max , curren ALLOCATE ( qbdy3dtemp2(ims:ime,kms:kme,jms:jme) ) ALLOCATE ( mbdy2dtemp2(ims:ime,1:1, jms:jme) ) - IF (config_flags%mp_physics.eq.THOMPSONAERO .AND. config_flags%aer_init_opt .gt. 0) THEN + IF ((config_flags%mp_physics.eq.THOMPSONAERO .OR. config_flags%mp_physics.eq.RCON_MP_SCHEME) .AND. config_flags%aer_init_opt .gt. 0) THEN IF ( ALLOCATED ( qn1bdy3dtemp1 ) ) DEALLOCATE ( qn1bdy3dtemp1 ) IF ( ALLOCATED ( qn2bdy3dtemp1 ) ) DEALLOCATE ( qn2bdy3dtemp1 ) IF ( ALLOCATED ( qn1bdy3dtemp2 ) ) DEALLOCATE ( qn1bdy3dtemp2 ) @@ -885,7 +885,7 @@ SUBROUTINE assemble_output ( grid , config_flags , loop , time_loop_max , curren END DO END DO - IF (config_flags%mp_physics.eq.THOMPSONAERO .AND. config_flags%aer_init_opt .gt. 0) THEN + IF ((config_flags%mp_physics.eq.THOMPSONAERO .OR. config_flags%mp_physics.eq.RCON_MP_SCHEME).AND. config_flags%aer_init_opt .gt. 0) THEN CALL couple ( grid%mu_2 , grid%mub , qn1bdy3dtemp1 , grid%scalar(:,:,:,P_QNWFA) , 't' , grid%msfty , & grid%c1h, grid%c2h, grid%c1h, grid%c2h, & ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe ) @@ -965,7 +965,7 @@ SUBROUTINE assemble_output ( grid , config_flags , loop , time_loop_max , curren ims , ime , jms , jme , 1 , 1 , & ips , ipe , jps , jpe , 1 , 1 ) - IF (config_flags%mp_physics.eq.THOMPSONAERO .AND. config_flags%aer_init_opt .gt. 0) THEN + IF ((config_flags%mp_physics.eq.THOMPSONAERO .OR. config_flags%mp_physics.eq.RCON_MP_SCHEME) .AND. config_flags%aer_init_opt .gt. 0) THEN CALL stuff_bdy ( qn1bdy3dtemp1 , grid%scalar_bxs(:,:,:,P_QNWFA), grid%scalar_bxe(:,:,:,P_QNWFA), & grid%scalar_bys(:,:,:,P_QNWFA), grid%scalar_bye(:,:,:,P_QNWFA), & 'T' , spec_bdy_width , & @@ -1071,7 +1071,7 @@ SUBROUTINE assemble_output ( grid , config_flags , loop , time_loop_max , curren END DO END DO - IF (config_flags%mp_physics.eq.THOMPSONAERO .AND. config_flags%aer_init_opt .gt. 0) THEN + IF ((config_flags%mp_physics.eq.THOMPSONAERO .OR. config_flags%mp_physics.eq.RCON_MP_SCHEME) .AND. config_flags%aer_init_opt .gt. 0) THEN CALL couple ( grid%mu_2 , grid%mub , qn1bdy3dtemp2 , grid%scalar(:,:,:,P_QNWFA) , 't' , grid%msfty , & grid%c1h, grid%c2h, grid%c1h, grid%c2h, & ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe ) @@ -1168,7 +1168,7 @@ SUBROUTINE assemble_output ( grid , config_flags , loop , time_loop_max , curren ids , ide , jds , jde , 1 , 1 , & ims , ime , jms , jme , 1 , 1 , & ips , ipe , jps , jpe , 1 , 1 ) - IF (config_flags%mp_physics.eq.THOMPSONAERO .AND. config_flags%aer_init_opt .gt. 0) THEN + IF ((config_flags%mp_physics.eq.THOMPSONAERO .OR. config_flags%mp_physics.eq.RCON_MP_SCHEME) .AND. config_flags%aer_init_opt .gt. 0) THEN CALL stuff_bdytend ( qn1bdy3dtemp2 , qn1bdy3dtemp1 , REAL(interval_seconds) , & grid%scalar_btxs(:,:,:,P_QNWFA), grid%scalar_btxe(:,:,:,P_QNWFA), & grid%scalar_btys(:,:,:,P_QNWFA), grid%scalar_btye(:,:,:,P_QNWFA), & @@ -1306,7 +1306,7 @@ SUBROUTINE assemble_output ( grid , config_flags , loop , time_loop_max , curren END DO END DO - IF (config_flags%mp_physics.eq.THOMPSONAERO .AND. config_flags%aer_init_opt .gt. 0) THEN + IF ((config_flags%mp_physics.eq.THOMPSONAERO .OR. config_flags%mp_physics.eq.RCON_MP_SCHEME) .AND. config_flags%aer_init_opt .gt. 0) THEN DO j = jps , jpe DO k = kps , kpe DO i = ips , ipe @@ -1383,7 +1383,7 @@ SUBROUTINE assemble_output ( grid , config_flags , loop , time_loop_max , curren ims , ime , jms , jme , 1 , 1 , & ips , ipe , jps , jpe , 1 , 1 ) - IF (config_flags%mp_physics.eq.THOMPSONAERO .AND. config_flags%aer_init_opt .gt. 0) THEN + IF ((config_flags%mp_physics.eq.THOMPSONAERO .OR. config_flags%mp_physics.eq.RCON_MP_SCHEME) .AND. config_flags%aer_init_opt .gt. 0) THEN CALL stuff_bdy ( qn1bdy3dtemp1 , grid%scalar_bxs(:,:,:,P_QNWFA), grid%scalar_bxe(:,:,:,P_QNWFA), & grid%scalar_bys(:,:,:,P_QNWFA), grid%scalar_bye(:,:,:,P_QNWFA), & 'T' , spec_bdy_width , & diff --git a/phys/CMakeLists.txt b/phys/CMakeLists.txt index d3df6a28e0..eb58544ca5 100644 --- a/phys/CMakeLists.txt +++ b/phys/CMakeLists.txt @@ -42,9 +42,6 @@ target_sources( module_bl_mrf.F module_bl_myjpbl.F module_bl_myjurb.F - module_bl_mynn.F - module_bl_mynn_common.F - module_bl_mynn_wrapper.F module_bl_qnsepbl.F module_bl_shinhong.F module_bl_temf.F @@ -156,9 +153,11 @@ target_sources( module_mp_ntu.F module_mp_p3.F module_mp_radar.F + module_mp_rcon.F module_mp_SBM_polar_radar.F module_mp_sbu_ylin.F module_mp_thompson.F + module_mp_udm.F module_mp_wdm5.F module_mp_wdm6.F module_mp_wdm7.F @@ -263,6 +262,11 @@ target_sources( physics_mmm/mp_wsm6.F90 physics_mmm/mp_wsm6_effectRad.F90 physics_mmm/sf_sfclayrev.F90 + + # MYNN-EDMF + MYNN-EDMF/module_bl_mynnedmf.F90 + MYNN-EDMF/WRF/module_bl_mynnedmf_common.F90 + MYNN-EDMF/WRF/module_bl_mynnedmf_driver.F90 ) diff --git a/phys/MYNN-EDMF b/phys/MYNN-EDMF new file mode 160000 index 0000000000..90f36c2525 --- /dev/null +++ b/phys/MYNN-EDMF @@ -0,0 +1 @@ +Subproject commit 90f36c25259ec1960b24325f5b29ac7c5adeac73 diff --git a/phys/Makefile b/phys/Makefile index a7fb3dafe4..5eda61c111 100644 --- a/phys/Makefile +++ b/phys/Makefile @@ -43,9 +43,9 @@ MODULES = \ module_bl_myjpbl.o \ module_bl_qnsepbl.o \ module_bl_acm.o \ - module_bl_mynn_common.o \ - module_bl_mynn.o \ - module_bl_mynn_wrapper.o \ + module_bl_mynnedmf_common.o \ + module_bl_mynnedmf.o \ + module_bl_mynnedmf_driver.o \ module_bl_fogdes.o \ module_bl_gwdo.o \ module_bl_gwdo_gsl.o \ @@ -97,6 +97,7 @@ MODULES = \ module_mp_etanew.o \ module_mp_fer_hires.o \ module_mp_thompson.o \ + module_mp_rcon.o \ module_fire_emis.o \ module_mp_SBM_polar_radar.o \ module_mp_full_sbm.o \ @@ -113,6 +114,7 @@ MODULES = \ module_mp_wdm5.o \ module_mp_wdm6.o \ module_mp_wdm7.o \ + module_mp_udm.o \ module_mp_ntu.o \ module_mp_cammgmp_driver.o \ module_ra_sw.o \ @@ -249,6 +251,7 @@ LIBTARGET = physics TARGETDIR = ./ $(LIBTARGET) : + (cd .. && ./tools/manage_externals/checkout_externals --externals ./arch/Externals.cfg) $(MAKE) $(J) non_nmm ; \ $(AR) $(ARFLAGS) ../main/$(LIBWRFLIB) $(MODULES) $(OBJS) \ $(FIRE_MODULES) $(DIAGNOSTIC_MODULES_EM) $(PHYSMMM_MODULES) @@ -270,7 +273,17 @@ submodules : else \ echo No action required for NoahMP submodule ; \ fi - + @if [ \( ! -f module_bl_mynnedmf.F \) -o \( ! -f module_bl_mynedmf_common.F \) -o \ + \( ! -f module_bl_mynnedmf_driver.F \) ] ; then \ + echo Pulling in MYNN-EDMF submodule ; \ + ( cd .. ; git submodule update --init --recursive ) ; \ + ln -sf MYNN-EDMF/module_bl_mynnedmf.F90 module_bl_mynnedmf.F ; \ + ln -sf MYNN-EDMF/WRF/module_bl_mynnedmf_common.F90 module_bl_mynnedmf_common.F ; \ + ln -sf MYNN-EDMF/WRF/module_bl_mynnedmf_driver.F90 module_bl_mynnedmf_driver.F ; \ + else \ + echo No action required for MYNN-EDMF submodule ; \ + fi + clean: @ echo 'use the clean script' diff --git a/phys/ccpp_kind_types.F b/phys/ccpp_kind_types.F index 9360bbf67e..5647ce0362 100644 --- a/phys/ccpp_kind_types.F +++ b/phys/ccpp_kind_types.F @@ -1,5 +1,5 @@ module ccpp_kind_types -#if ( RWORDSIZE == 4 ) +#ifndef DOUBLE_PRECISION integer, parameter :: kind_phys = selected_real_kind(6) #else integer, parameter :: kind_phys = selected_real_kind(12) diff --git a/phys/module_bl_keps.F b/phys/module_bl_keps.F index 8c5be78733..c804d65321 100644 --- a/phys/module_bl_keps.F +++ b/phys/module_bl_keps.F @@ -1073,16 +1073,16 @@ subroutine surface_bl_pra_ri(kms,kme,kts,kte,dz,z,rho,g,cp,z0,sflux,raten,pi1d,p zz=(zl1+z0)/zl1 zol1 = max(b_ric*psim*psim/psih,rimin) if(sfcflg)then - zol1 = min(zol1,-zfmin) + zol1 = zz*min(zol1,-zfmin) else - zol1 = max(zol1,zfmin) + zol1 = zz*max(zol1,zfmin) endif hol1 = zol1*pblh/zl1*sfcfrac if(sfcflg)then - phim = (1.-aphi16*zol1*zz)**(-1./4.) - phih = (1.-aphi16*zol1*zz)**(-1./2.) - phieps=1.-zol1*zz + phim = (1.-aphi16*zol1)**(-1./4.) + phih = (1.-aphi16*zol1)**(-1./2.) + phieps=1.-zol1 phim_sl = (1.-aphi16*hol1)**(-1./4.) phih_sl = (1.-aphi16*hol1)**(-1./2.) bfx0 = max(sflux,0.) @@ -1093,9 +1093,9 @@ subroutine surface_bl_pra_ri(kms,kme,kts,kte,dz,z,rho,g,cp,z0,sflux,raten,pi1d,p else phim_sl = (1.+aphi5*hol1) phih_sl= phim_sl - phim=(1.+aphi5*zol1*zz) - phieps=(1+2.5*(zol1*zz)**0.6)**(3./2.) - phih= phim_sl + phim=(1.+aphi5*zol1) + phieps=(1+2.5*(zol1)**0.6)**(3./2.) + phih= phim wstar3=0. wstar3_2=0. endif diff --git a/phys/module_bl_mynn.F b/phys/module_bl_mynn.F deleted file mode 100644 index c1ea9c6417..0000000000 --- a/phys/module_bl_mynn.F +++ /dev/null @@ -1,7743 +0,0 @@ -!>\file module_bl_mynn.F90 -!! This file contains the entity of MYNN-EDMF PBL scheme. -! ********************************************************************** -! * An improved Mellor-Yamada turbulence closure model * -! * * -! * Original author: M. Nakanishi (N.D.A), naka@nda.ac.jp * -! * Translated into F90 and implemented in WRF-ARW by: * -! * Mariusz Pagowski (NOAA-GSL) * -! * Subsequently developed by: * -! * Joseph Olson, Jaymes Kenyon (NOAA/GSL), * -! * Wayne Angevine (NOAA/CSL), Kay Suselj (NASA/JPL), * -! * Franciano Puhales (UFSM), Laura Fowler (NCAR), * -! * Elynn Wu (UCSD), and Jordan Schnell (NOAA/GSL) * -! * * -! * Contents: * -! * * -! * mynn_bl_driver - main subroutine which calls all other routines * -! * -------------- * -! * 1. mym_initialize (to be called once initially) * -! * gives the closure constants and initializes the turbulent * -! * quantities. * -! * 2. get_pblh * -! * Calculates the boundary layer height * -! * 3. scale_aware * -! * Calculates scale-adaptive tapering functions * -! * 4. mym_condensation * -! * determines the liquid water content and the cloud fraction * -! * diagnostically. * -! * 5. dmp_mf * -! * Calls the (nonlocal) mass-flux component * -! * 6. ddmf_jpl * -! * Calls the downdraft mass-flux component * -! * (-) mym_level2 (called in the other subroutines) * -! * calculates the stability functions at Level 2. * -! * (-) mym_length (called in the other subroutines) * -! * calculates the master length scale. * -! * 7. mym_turbulence * -! * calculates the vertical diffusivity coefficients and the * -! * production terms for the turbulent quantities. * -! * 8. mym_predict * -! * predicts the turbulent quantities at the next step. * -! * * -! * call mym_initialize * -! * | * -! * |<----------------+ * -! * | | * -! * call get_pblh | * -! * call scale_aware | * -! * call mym_condensation | * -! * call dmp_mf | * -! * call ddmf_jpl | * -! * call mym_turbulence | * -! * call mym_predict | * -! * | | * -! * |-----------------+ * -! * | * -! * end * -! * * -! * Variables worthy of special mention: * -! * tref : Reference temperature * -! * thl : Liquid water potential temperature * -! * qw : Total water (water vapor+liquid water) content * -! * ql : Liquid water content * -! * vt, vq : Functions for computing the buoyancy flux * -! * qke : 2 * TKE * -! * el : mixing length * -! * * -! * If the water contents are unnecessary, e.g., in the case of * -! * ocean models, thl is the potential temperature and qw, ql, vt * -! * and vq are all zero. * -! * * -! * Grid arrangement: * -! * k+1 +---------+ * -! * | | i = 1 - nx * -! * (k) | * | k = 1 - nz * -! * | | * -! * k +---------+ * -! * i (i) i+1 * -! * * -! * All the predicted variables are defined at the center (*) of * -! * the grid boxes. The diffusivity coefficients and two of their * -! * components (el and stability functions sh & sm) are, however, * -! * defined on the walls of the grid boxes. * -! * # Upper boundary values are given at k=nz. * -! * * -! * References: * -! * 1. Nakanishi, M., 2001: * -! * Boundary-Layer Meteor., 99, 349-378. * -! * 2. Nakanishi, M. and H. Niino, 2004: * -! * Boundary-Layer Meteor., 112, 1-31. * -! * 3. Nakanishi, M. and H. Niino, 2006: * -! * Boundary-Layer Meteor., 119, 397-407. * -! * 4. Nakanishi, M. and H. Niino, 2009: * -! * Jour. Meteor. Soc. Japan, 87, 895-912. * -! * 5. Olson J. and coauthors, 2019: A description of the * -! * MYNN-EDMF scheme and coupling to other components in * -! * WRF-ARW. NOAA Tech. Memo. OAR GSD, 61, 37 pp., * -! * https://doi.org/10.25923/n9wm-be49. * -! * 6. Puhales, Franciano S. and coauthors, 2020: Turbulent * -! * Kinetic Energy Budget for MYNN-EDMF PBL Scheme in WRF model.* -! * Universidade Federal de Santa Maria Technical Note. 9 pp. * -! ********************************************************************** -! ================================================================== -! Notes on original implementation into WRF-ARW -! changes to original code: -! 1. code is 1D (in z) -! 2. option to advect TKE, but not the covariances and variances -! 3. Cranck-Nicholson replaced with the implicit scheme -! 4. removed terrain-dependent grid since input in WRF in actual -! distances in z[m] -! 5. cosmetic changes to adhere to WRF standard (remove common blocks, -! intent etc) -!------------------------------------------------------------------- -! Further modifications post-implementation -! -! 1. Addition of BouLac mixing length in the free atmosphere. -! 2. Changed the turbulent mixing length to be integrated from the -! surface to the top of the BL + a transition layer depth. -! v3.4.1: Option to use Kitamura/Canuto modification which removes -! the critical Richardson number and negative TKE (default). -! Hybrid PBL height diagnostic, which blends a theta-v-based -! definition in neutral/convective BL and a TKE-based definition -! in stable conditions. -! TKE budget output option -! v3.5.0: TKE advection option (bl_mynn_tkeadvect) -! v3.5.1: Fog deposition related changes. -! v3.6.0: Removed fog deposition from the calculation of tendencies -! Added mixing of qc, qi, qni -! Added output for wstar, delta, TKE_PBL, & KPBL for correct -! coupling to shcu schemes -! v3.8.0: Added subgrid scale cloud output for coupling to radiation -! schemes (activated by setting icloud_bl =1 in phys namelist). -! Added WRF_DEBUG prints (at level 3000) -! Added Tripoli and Cotton (1981) correction. -! Added namelist option bl_mynn_cloudmix to test effect of mixing -! cloud species (default = 1: on). -! Added mass-flux option (bl_mynn_edmf, = 1 for DMP mass-flux, 0: off). -! Related options: -! bl_mynn_edmf_mom = 1 : activate momentum transport in MF scheme -! bl_mynn_edmf_tke = 1 : activate TKE transport in MF scheme -! Added mixing length option (bl_mynn_mixlength, see notes below) -! Added more sophisticated saturation checks, following Thompson scheme -! Added new cloud PDF option (bl_mynn_cloudpdf = 2) from Chaboureau -! and Bechtold (2002, JAS, with mods) -! Added capability to mix chemical species when env variable -! WRF_CHEM = 1, thanks to Wayne Angevine. -! Added scale-aware mixing length, following Junshi Ito's work -! Ito et al. (2015, BLM). -! v3.9.0 Improvement to the mass-flux scheme (dynamic number of plumes, -! better plume/cloud depth, significant speed up, better cloud -! fraction). -! Added Stochastic Parameter Perturbation (SPP) implementation. -! Many miscellaneous tweaks to the mixing lengths and stratus -! component of the subgrid clouds. -! v.4.0 Removed or added alternatives to WRF-specific functions/modules -! for the sake of portability to other models. -! the sake of portability to other models. -! Further refinement of mass-flux scheme from SCM experiments with -! Wayne Angevine: switch to linear entrainment and back to -! Simpson and Wiggert-type w-equation. -! Addition of TKE production due to radiation cooling at top of -! clouds (proto-version); not activated by default. -! Some code rewrites to move if-thens out of loops in an attempt to -! improve computational efficiency. -! New tridiagonal solver, which is supposedly 14% faster and more -! conservative. Impact seems very small. -! Many miscellaneous tweaks to the mixing lengths and stratus -! component of the subgrid-scale (SGS) clouds. -! v4.1 Big improvements in downward SW radiation due to revision of subgrid clouds -! - better cloud fraction and subgrid scale mixing ratios. -! - may experience a small cool bias during the daytime now that high -! SW-down bias is greatly reduced... -! Some tweaks to increase the turbulent mixing during the daytime for -! bl_mynn_mixlength option 2 to alleviate cool bias (very small impact). -! Improved ensemble spread from changes to SPP in MYNN -! - now perturbing eddy diffusivity and eddy viscosity directly -! - now perturbing background rh (in SGS cloud calc only) -! - now perturbing entrainment rates in mass-flux scheme -! Added IF checks (within IFDEFS) to protect mixchem code from being used -! when HRRR smoke is used (no impact on regular non-wrf chem use) -! Important bug fix for wrf chem when transporting chemical species in MF scheme -! Removed 2nd mass-flux scheme (no only bl_mynn_edmf = 1, no option 2) -! Removed unused stochastic code for mass-flux scheme -! Changed mass-flux scheme to be integrated on interface levels instead of -! mass levels - impact is small -! Added option to mix 2nd moments in MYNN as opposed to the scalar_pblmix option. -! - activated with bl_mynn_mixscalars = 1; this sets scalar_pblmix = 0 -! - added tridagonal solver used in scalar_pblmix option to duplicate tendencies -! - this alone changes the interface call considerably from v4.0. -! Slight revision to TKE production due to radiation cooling at top of clouds -! Added the non-Guassian buoyancy flux function of Bechtold and Siebesma (1998, JAS). -! - improves TKE in SGS clouds -! Added heating due to dissipation of TKE (small impact, maybe + 0.1 C daytime PBL temp) -! Misc changes made for FV3/MPAS compatibility -! v4.2 A series of small tweaks to help reduce a cold bias in the PBL: -! - slight increase in diffusion in convective conditions -! - relaxed criteria for mass-flux activation/strength -! - added capability to cycle TKE for continuity in hourly updating HRRR -! - added effects of compensational environmental subsidence in mass-flux scheme, -! which resulted in tweaks to detrainment rates. -! Bug fix for diagnostic-decay of SGS clouds - noticed by Greg Thompson. This has -! a very small, but primarily positive, impact on SW-down biases. -! Tweak to calculation of KPBL - urged by Laura Fowler - to make more intuitive. -! Tweak to temperature range of blending for saturation check (water to ice). This -! slightly reduces excessive SGS clouds in polar region. No impact warm clouds. -! Added namelist option bl_mynn_output (0 or 1) to suppress or activate the -! allocation and output of 10 3D variables. Most people will want this -! set to 0 (default) to save memory and disk space. -! Added new array qi_bl as opposed to using qc_bl for both SGS qc and qi. This -! gives us more control of the magnitudes which can be confounded by using -! a single array. As a results, many subroutines needed to be modified, -! especially mym_condensation. -! Added the blending of the stratus component of the SGS clouds to the mass-flux -! clouds to account for situations where stratus and cumulus may exist in the -! grid cell. -! Misc small-impact bugfixes: -! 1) dz was incorrectly indexed in mym_condensation -! 2) configurations with icloud_bl = 0 were using uninitialized arrays -! v4.5 / CCPP -! This version includes many modifications that proved valuable in the global -! framework and removes some key lingering bugs in the mixing of chemical species. -! TKE Budget output fixed (Puhales, 2020-12) -! New option for stability function: (Puhales, 2020-12) -! bl_mynn_stfunc = 0 (original, Kansas-type function, Paulson, 1970 ) -! bl_mynn_stfunc = 1 (expanded range, same as used for Jimenez et al (MWR) -! see the Technical Note for this implementation (small impact). -! Improved conservation of momentum and higher-order moments. -! Important bug fixes for mixing of chemical species. -! Addition of pressure-gradient effects on updraft momentum transport. -! Addition of bl_mynn_closure option = 2.5, 2.6, or 3.0 -! Addition of higher-order moments for sigma when using -! bl_mynn_cloudpdf = 2 (Chab-Becht). -! Removed WRF_CHEM dependencies. -! Many miscellaneous tweaks. -! v4.6 / CCPP -! Some code optimization. Removed many conditions from loops. Redesigned the mass- -! flux scheme to use 8 plumes instead of a variable n plumes. This results in -! the removal of the output variable "nudprafts" and adds maxwidth and ztop_plume. -! Revision option bl_mynn_cloudpdf = 2, which now ensures cloud fractions for all -! optically relevant mixing ratios (tip from Greg Thompson). Also, added flexibility -! for tuning near-surface cloud fractions to remove excess fog/low ceilings. -! Now outputs all SGS cloud mixing ratios as grid-mean values, not in-cloud. This -! results in a change in the pre-radiation code to no longer multiply mixing ratios -! by cloud fractions. -! Bug fix for the momentum transport. -! Lots of code cleanup: removal of test code, comments, changing text case, etc. -! Many misc tuning/tweaks. -! -! Many of these changes are now documented in references listed above. -!==================================================================== - -MODULE module_bl_mynn - - use module_bl_mynn_common,only: & - cp , cpv , cliq , cice , & - p608 , ep_2 , ep_3 , gtr , & - grav , g_inv , karman , p1000mb , & - rcp , r_d , r_v , rk , & - rvovrd , svp1 , svp2 , svp3 , & - xlf , xlv , xls , xlscp , & - xlvcp , tv0 , tv1 , tref , & - zero , half , one , two , & - onethird , twothirds , tkmin , t0c , & - tice , kind_phys - - - IMPLICIT NONE - -!=================================================================== -! From here on, these are MYNN-specific parameters: -! The parameters below depend on stability functions of module_sf_mynn. - real(kind_phys), parameter :: cphm_st=5.0, cphm_unst=16.0, & - cphh_st=5.0, cphh_unst=16.0 - -! Closure constants - real(kind_phys), parameter :: & - &pr = 0.74, & - &g1 = 0.235, & ! NN2009 = 0.235 - &b1 = 24.0, & - &b2 = 15.0, & ! CKmod NN2009 - &c2 = 0.729, & ! 0.729, & !0.75, & - &c3 = 0.340, & ! 0.340, & !0.352, & - &c4 = 0.0, & - &c5 = 0.2, & - &a1 = b1*( 1.0-3.0*g1 )/6.0, & -! &c1 = g1 -1.0/( 3.0*a1*b1**(1.0/3.0) ), & - &c1 = g1 -1.0/( 3.0*a1*2.88449914061481660), & - &a2 = a1*( g1-c1 )/( g1*pr ), & - &g2 = b2/b1*( 1.0-c3 ) +2.0*a1/b1*( 3.0-2.0*c2 ) - - real(kind_phys), parameter :: & - &cc2 = 1.0-c2, & - &cc3 = 1.0-c3, & - &e1c = 3.0*a2*b2*cc3, & - &e2c = 9.0*a1*a2*cc2, & - &e3c = 9.0*a2*a2*cc2*( 1.0-c5 ), & - &e4c = 12.0*a1*a2*cc2, & - &e5c = 6.0*a1*a1 - -! Constants for min tke in elt integration (qmin), max z/L in els (zmax), -! and factor for eddy viscosity for TKE (Kq = Sqfac*Km): - real(kind_phys), parameter :: qmin=0.0, zmax=1.0, Sqfac=3.0 -! Note that the following mixing-length constants are now specified in mym_length -! &cns=3.5, alp1=0.23, alp2=0.3, alp3=3.0, alp4=10.0, alp5=0.2 - - real(kind_phys), parameter :: qkemin=1.e-3 - real(kind_phys), parameter :: tliq = 269. !all hydrometeors are liquid when T > tliq - -! Constants for cloud PDF (mym_condensation) - real(kind_phys), parameter :: rr2=0.7071068, rrp=0.3989423 - - !>Use Canuto/Kitamura mod (remove Ric and negative TKE) (1:yes, 0:no) - !!For more info, see Canuto et al. (2008 JAS) and Kitamura (Journal of the - !!Meteorological Society of Japan, Vol. 88, No. 5, pp. 857-864, 2010). - !!Note that this change required further modification of other parameters - !!above (c2, c3). If you want to remove this option, set c2 and c3 constants - !!(above) back to NN2009 values (see commented out lines next to the - !!parameters above). This only removes the negative TKE problem - !!but does not necessarily improve performance - neutral impact. - real(kind_phys), parameter :: CKmod=1. - - !>Use Ito et al. (2015, BLM) scale-aware (0: no, 1: yes). Note that this also has impacts - !!on the cloud PDF and mass-flux scheme, using LES-derived similarity function. - real(kind_phys), parameter :: scaleaware=1. - - !>Of the following the options, use one OR the other, not both. - !>Adding top-down diffusion driven by cloud-top radiative cooling - integer, parameter :: bl_mynn_topdown = 0 - !>Option to activate downdrafts, from Elynn Wu (0: deactive, 1: active) - integer, parameter :: bl_mynn_edmf_dd = 0 - - !>Option to activate heating due to dissipation of TKE (to activate, set to 1.0) - integer, parameter :: dheat_opt = 1 - - !Option to activate environmental subsidence in mass-flux scheme - logical, parameter :: env_subs = .false. - - !Option to switch flux-profile relationship for surface (from Puhales et al. 2020) - !0: use original Dyer-Hicks, 1: use Cheng-Brustaert and Blended COARE - integer, parameter :: bl_mynn_stfunc = 1 - - !option to print out more stuff for debugging purposes - logical, parameter :: debug_code = .false. - integer, parameter :: idbg = 23 !specific i-point to write out - - ! Used in WRF-ARW module_physics_init.F - integer :: mynn_level - - -CONTAINS - -! ================================================================== -!>\ingroup gsd_mynn_edmf -!! This subroutine is the GSD MYNN-EDNF PBL driver routine,which -!! encompassed the majority of the subroutines that comprise the -!! procedures that ultimately solve for tendencies of -!! \f$U, V, \theta, q_v, q_c, and q_i\f$. -!!\section gen_mynn_bl_driver GSD mynn_bl_driver General Algorithm -!> @{ - SUBROUTINE mynn_bl_driver( & - &initflag,restart,cycling, & - &delt,dz,dx,znt, & - &u,v,w,th,sqv3d,sqc3d,sqi3d, & - &sqs3d,qnc,qni, & - &qnwfa,qnifa,qnbca,ozone, & - &p,exner,rho,t3d, & - &xland,ts,qsfc,ps, & - &ust,ch,hfx,qfx,rmol,wspd, & - &uoce,voce, & !ocean current - &qke,qke_adv, & - &sh3d,sm3d, & - &nchem,kdvel,ndvel, & !smoke/chem variables - &chem3d,vdep, & - &frp,emis_ant_no, & - &mix_chem,enh_mix, & !note: these arrays/flags are still under development - &rrfs_sd,smoke_dbg, & !end smoke/chem variables - &tsq,qsq,cov, & - &rublten,rvblten,rthblten, & - &rqvblten,rqcblten,rqiblten, & - &rqncblten,rqniblten,rqsblten, & - &rqnwfablten,rqnifablten, & - &rqnbcablten,dozone, & - &exch_h,exch_m, & - &pblh,kpbl, & - &el_pbl, & - &dqke,qwt,qshear,qbuoy,qdiss, & - &qc_bl,qi_bl,cldfra_bl, & - &bl_mynn_tkeadvect, & - &tke_budget, & - &bl_mynn_cloudpdf, & - &bl_mynn_mixlength, & - &icloud_bl, & - &closure, & - &bl_mynn_edmf, & - &bl_mynn_edmf_mom, & - &bl_mynn_edmf_tke, & - &bl_mynn_mixscalars, & - &bl_mynn_output, & - &bl_mynn_cloudmix,bl_mynn_mixqt, & - &edmf_a,edmf_w,edmf_qt, & - &edmf_thl,edmf_ent,edmf_qc, & - &sub_thl3D,sub_sqv3D, & - &det_thl3D,det_sqv3D, & - &maxwidth,maxMF,ztop_plume, & - &ktop_plume, & - &spp_pbl,pattern_spp_pbl, & - &rthraten, & - &FLAG_QC,FLAG_QI,FLAG_QNC, & - &FLAG_QNI,FLAG_QS, & - &FLAG_QNWFA,FLAG_QNIFA, & - &FLAG_QNBCA,FLAG_OZONE, & - &IDS,IDE,JDS,JDE,KDS,KDE, & - &IMS,IME,JMS,JME,KMS,KME, & - &ITS,ITE,JTS,JTE,KTS,KTE ) - -!------------------------------------------------------------------- - - integer, intent(in) :: initflag - !INPUT NAMELIST OPTIONS: - logical, intent(in) :: restart,cycling - integer, intent(in) :: tke_budget - integer, intent(in) :: bl_mynn_cloudpdf - integer, intent(in) :: bl_mynn_mixlength - integer, intent(in) :: bl_mynn_edmf - logical, intent(in) :: bl_mynn_tkeadvect - integer, intent(in) :: bl_mynn_edmf_mom - integer, intent(in) :: bl_mynn_edmf_tke - integer, intent(in) :: bl_mynn_mixscalars - integer, intent(in) :: bl_mynn_output - integer, intent(in) :: bl_mynn_cloudmix - integer, intent(in) :: bl_mynn_mixqt - integer, intent(in) :: icloud_bl - real(kind_phys), intent(in) :: closure - - logical, intent(in) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC,& - FLAG_QNWFA,FLAG_QNIFA,FLAG_QNBCA, & - FLAG_OZONE,FLAG_QS - - logical, intent(in) :: mix_chem,enh_mix,rrfs_sd,smoke_dbg - - integer, intent(in) :: & - & IDS,IDE,JDS,JDE,KDS,KDE & - &,IMS,IME,JMS,JME,KMS,KME & - &,ITS,ITE,JTS,JTE,KTS,KTE - -#ifdef HARDCODE_VERTICAL -# define kts 1 -# define kte HARDCODE_VERTICAL -#endif - -! initflag > 0 for TRUE -! else for FALSE -! closure : <= 2.5; Level 2.5 -! 2.5< and <3; Level 2.6 -! = 3; Level 3 - -! SGT: Changed this to use assumed shape arrays (dimension(:,:,:)) with no "optional" arguments -! to prevent a crash on Cheyenne. Do not change it back without testing if the code runs -! on Cheyenne with the GNU compiler. - - real(kind_phys), intent(in) :: delt - real(kind_phys), dimension(ims:ime), intent(in) :: dx - real(kind_phys), dimension(ims:ime,kms:kme), intent(in) :: dz, & - &u,v,w,th,sqv3D,p,exner,rho,T3D - real(kind_phys), dimension(ims:ime,kms:kme), optional, intent(in) :: & - &sqc3D,sqi3D,sqs3D,qni,qnc,qnwfa,qnifa,qnbca - real(kind_phys), dimension(ims:ime,kms:kme), optional,intent(in):: ozone - real(kind_phys), dimension(ims:ime), intent(in):: ust, & - &ch,qsfc,ps,wspd - real(kind_phys), dimension(ims:ime,kms:kme), intent(inout) :: & - &Qke,Tsq,Qsq,Cov,qke_adv - real(kind_phys), dimension(ims:ime,kms:kme), intent(inout) :: & - &rublten,rvblten,rthblten,rqvblten,rqcblten, & - &rqiblten,rqsblten,rqniblten,rqncblten, & - &rqnwfablten,rqnifablten,rqnbcablten - real(kind_phys), dimension(ims:ime,kms:kme), intent(inout) :: dozone - real(kind_phys), dimension(ims:ime,kms:kme), intent(in) :: rthraten - - real(kind_phys), dimension(ims:ime,kms:kme), intent(out) :: exch_h,exch_m - real(kind_phys), dimension(ims:ime), intent(in) :: xland, & - &ts,znt,hfx,qfx,uoce,voce - - !These 10 arrays are only allocated when bl_mynn_output > 0 - real(kind_phys), dimension(ims:ime,kms:kme), optional, intent(inout) :: & - & edmf_a,edmf_w,edmf_qt,edmf_thl,edmf_ent,edmf_qc, & - & sub_thl3D,sub_sqv3D,det_thl3D,det_sqv3D - -! real, dimension(ims:ime,kms:kme) :: & -! & edmf_a_dd,edmf_w_dd,edmf_qt_dd,edmf_thl_dd,edmf_ent_dd,edmf_qc_dd - - real(kind_phys), dimension(ims:ime), intent(inout) :: pblh - real(kind_phys), dimension(ims:ime), intent(inout) :: rmol - - real(kind_phys), dimension(ims:ime) :: psig_bl,psig_shcu - - integer,dimension(ims:ime),intent(inout) :: & - &KPBL,ktop_plume - - real(kind_phys), dimension(ims:ime), intent(out) :: & - &maxmf,maxwidth,ztop_plume - - real(kind_phys), dimension(ims:ime,kms:kme), intent(inout) :: el_pbl - - real(kind_phys), dimension(ims:ime,kms:kme), optional, intent(inout) :: & - &qWT,qSHEAR,qBUOY,qDISS,dqke - ! 3D budget arrays are not allocated when tke_budget == 0 - ! 1D (local) budget arrays are used for passing between subroutines. - real(kind_phys), dimension(kts:kte) :: & - &qwt1,qshear1,qbuoy1,qdiss1,dqke1,diss_heat - - real(kind_phys), dimension(ims:ime,kms:kme), intent(out) :: Sh3D,Sm3D - - real(kind_phys), dimension(ims:ime,kms:kme), intent(inout) :: & - &qc_bl,qi_bl,cldfra_bl - real(kind_phys), dimension(kts:kte) :: qc_bl1D,qi_bl1D, & - &cldfra_bl1D,qc_bl1D_old,qi_bl1D_old,cldfra_bl1D_old - -! smoke/chemical arrays - integer, intent(IN ) :: nchem, kdvel, ndvel - real(kind_phys), dimension(ims:ime,kms:kme,nchem), optional, intent(inout) :: chem3d - real(kind_phys), dimension(ims:ime, ndvel), optional, intent(in) :: vdep - real(kind_phys), dimension(ims:ime), optional, intent(in) :: frp,EMIS_ANT_NO - !local - real(kind_phys), dimension(kts:kte ,nchem) :: chem1 - real(kind_phys), dimension(kts:kte+1,nchem) :: s_awchem1 - real(kind_phys), dimension(ndvel) :: vd1 - integer :: ic - -!local vars - integer :: ITF,JTF,KTF, IMD,JMD - integer :: i,j,k,kproblem - real(kind_phys), dimension(kts:kte) :: & - &thl,tl,qv1,qc1,qi1,qs1,sqw, & - &el, dfm, dfh, dfq, tcd, qcd, pdk, pdt, pdq, pdc, & - &vt, vq, sgm, kzero - real(kind_phys), dimension(kts:kte) :: & - &thetav,sh,sm,u1,v1,w1,p1, & - &ex1,dz1,th1,tk1,rho1,qke1,tsq1,qsq1,cov1, & - &sqv,sqi,sqc,sqs, & - &du1,dv1,dth1,dqv1,dqc1,dqi1,dqs1,ozone1, & - &k_m1,k_h1,qni1,dqni1,qnc1,dqnc1,qnwfa1,qnifa1, & - &qnbca1,dqnwfa1,dqnifa1,dqnbca1,dozone1 - - !mass-flux variables - real(kind_phys), dimension(kts:kte) :: & - &dth1mf,dqv1mf,dqc1mf,du1mf,dv1mf - real(kind_phys), dimension(kts:kte) :: & - &edmf_a1,edmf_w1,edmf_qt1,edmf_thl1, & - &edmf_ent1,edmf_qc1 - real(kind_phys), dimension(kts:kte) :: & - &edmf_a_dd1,edmf_w_dd1,edmf_qt_dd1,edmf_thl_dd1, & - &edmf_ent_dd1,edmf_qc_dd1 - real(kind_phys), dimension(kts:kte) :: & - &sub_thl,sub_sqv,sub_u,sub_v, & - &det_thl,det_sqv,det_sqc,det_u,det_v - real(kind_phys), dimension(kts:kte+1) :: & - &s_aw1,s_awthl1,s_awqt1, & - &s_awqv1,s_awqc1,s_awu1,s_awv1,s_awqke1, & - &s_awqnc1,s_awqni1,s_awqnwfa1,s_awqnifa1, & - &s_awqnbca1 - real(kind_phys), dimension(kts:kte+1) :: & - &sd_aw1,sd_awthl1,sd_awqt1, & - &sd_awqv1,sd_awqc1,sd_awu1,sd_awv1,sd_awqke1 - - real(kind_phys), dimension(kts:kte+1) :: zw - real(kind_phys) :: cpm,sqcg,flt,fltv,flq,flqv,flqc, & - &pmz,phh,exnerg,zet,phi_m, & - &afk,abk,ts_decay, qc_bl2, qi_bl2, & - &th_sfc,wsp - - !top-down diffusion - real(kind_phys), dimension(ITS:ITE) :: maxKHtopdown - real(kind_phys), dimension(kts:kte) :: KHtopdown,TKEprodTD - - logical :: INITIALIZE_QKE,problem - - ! Stochastic fields - integer, intent(in) :: spp_pbl - real(kind_phys), dimension(ims:ime,kms:kme), optional, intent(in) :: pattern_spp_pbl - real(kind_phys), dimension(kts:kte) :: rstoch_col - - ! Substepping TKE - integer :: nsub - real(kind_phys) :: delt2 - - - if (debug_code) then !check incoming values - do i=its,ite - problem = .false. - do k=kts,kte - wsp = sqrt(u(i,k)**2 + v(i,k)**2) - if (abs(hfx(i)) > 1200. .or. abs(qfx(i)) > 0.001 .or. & - wsp > 200. .or. t3d(i,k) > 360. .or. t3d(i,k) < 160. .or. & - sqv3d(i,k)< 0.0 .or. sqc3d(i,k)< 0.0 ) then - kproblem = k - problem = .true. - print*,"Incoming problem at: i=",i," k=1" - print*," QFX=",qfx(i)," HFX=",hfx(i) - print*," wsp=",wsp," T=",t3d(i,k) - print*," qv=",sqv3d(i,k)," qc=",sqc3d(i,k) - print*," u*=",ust(i)," wspd=",wspd(i) - print*," xland=",xland(i)," ts=",ts(i) - print*," z/L=",0.5*dz(i,1)*rmol(i)," ps=",ps(i) - print*," znt=",znt(i)," dx=",dx(i) - endif - enddo - if (problem) then - print*,"===tk:",t3d(i,max(kproblem-3,1):min(kproblem+3,kte)) - print*,"===qv:",sqv3d(i,max(kproblem-3,1):min(kproblem+3,kte)) - print*,"===qc:",sqc3d(i,max(kproblem-3,1):min(kproblem+3,kte)) - print*,"===qi:",sqi3d(i,max(kproblem-3,1):min(kproblem+3,kte)) - print*,"====u:",u(i,max(kproblem-3,1):min(kproblem+3,kte)) - print*,"====v:",v(i,max(kproblem-3,1):min(kproblem+3,kte)) - endif - enddo - endif - -!*** Begin debugging - IMD=(IMS+IME)/2 - JMD=(JMS+JME)/2 -!*** End debugging - - JTF=JTE - ITF=ITE - KTF=KTE - - IF (bl_mynn_output > 0) THEN !research mode - edmf_a(its:ite,kts:kte)=0. - edmf_w(its:ite,kts:kte)=0. - edmf_qt(its:ite,kts:kte)=0. - edmf_thl(its:ite,kts:kte)=0. - edmf_ent(its:ite,kts:kte)=0. - edmf_qc(its:ite,kts:kte)=0. - sub_thl3D(its:ite,kts:kte)=0. - sub_sqv3D(its:ite,kts:kte)=0. - det_thl3D(its:ite,kts:kte)=0. - det_sqv3D(its:ite,kts:kte)=0. - - !edmf_a_dd(its:ite,kts:kte)=0. - !edmf_w_dd(its:ite,kts:kte)=0. - !edmf_qt_dd(its:ite,kts:kte)=0. - !edmf_thl_dd(its:ite,kts:kte)=0. - !edmf_ent_dd(its:ite,kts:kte)=0. - !edmf_qc_dd(its:ite,kts:kte)=0. - ENDIF - ktop_plume(its:ite)=0 !int - ztop_plume(its:ite)=0. - maxwidth(its:ite)=0. - maxmf(its:ite)=0. - maxKHtopdown(its:ite)=0. - kzero(kts:kte)=0. - - ! DH* CHECK HOW MUCH OF THIS INIT IF-BLOCK IS ACTUALLY NEEDED FOR RESTARTS -!> - Within the MYNN-EDMF, there is a dependecy check for the first time step, -!! If true, a three-dimensional initialization loop is entered. Within this loop, -!! several arrays are initialized and k-oriented (vertical) subroutines are called -!! at every i and j point, corresponding to the x- and y- directions, respectively. - IF (initflag > 0 .and. .not.restart) THEN - - !Test to see if we want to initialize qke - IF ( (restart .or. cycling)) THEN - IF (MAXVAL(QKE(its:ite,kts)) < 0.0002) THEN - INITIALIZE_QKE = .TRUE. - !print*,"QKE is too small, must initialize" - ELSE - INITIALIZE_QKE = .FALSE. - !print*,"Using background QKE, will not initialize" - ENDIF - ELSE ! not cycling or restarting: - INITIALIZE_QKE = .TRUE. - !print*,"not restart nor cycling, must initialize QKE" - ENDIF - - if (.not.restart .or. .not.cycling) THEN - Sh3D(its:ite,kts:kte)=0. - Sm3D(its:ite,kts:kte)=0. - el_pbl(its:ite,kts:kte)=0. - tsq(its:ite,kts:kte)=0. - qsq(its:ite,kts:kte)=0. - cov(its:ite,kts:kte)=0. - cldfra_bl(its:ite,kts:kte)=0. - qc_bl(its:ite,kts:kte)=0. - qke(its:ite,kts:kte)=0. - else - qc_bl1D(kts:kte)=0.0 - qi_bl1D(kts:kte)=0.0 - cldfra_bl1D(kts:kte)=0.0 - end if - dqc1(kts:kte)=0.0 - dqi1(kts:kte)=0.0 - dqni1(kts:kte)=0.0 - dqnc1(kts:kte)=0.0 - dqnwfa1(kts:kte)=0.0 - dqnifa1(kts:kte)=0.0 - dqnbca1(kts:kte)=0.0 - dozone1(kts:kte)=0.0 - qc_bl1D_old(kts:kte)=0.0 - cldfra_bl1D_old(kts:kte)=0.0 - edmf_a1(kts:kte)=0.0 - edmf_w1(kts:kte)=0.0 - edmf_qc1(kts:kte)=0.0 - edmf_a_dd1(kts:kte)=0.0 - edmf_w_dd1(kts:kte)=0.0 - edmf_qc_dd1(kts:kte)=0.0 - sgm(kts:kte)=0.0 - vt(kts:kte)=0.0 - vq(kts:kte)=0.0 - - DO k=KTS,KTE - DO i=ITS,ITF - exch_m(i,k)=0. - exch_h(i,k)=0. - ENDDO - ENDDO - - IF (tke_budget .eq. 1) THEN - DO k=KTS,KTE - DO i=ITS,ITF - qWT(i,k)=0. - qSHEAR(i,k)=0. - qBUOY(i,k)=0. - qDISS(i,k)=0. - dqke(i,k)=0. - ENDDO - ENDDO - ENDIF - - DO i=ITS,ITF - if (FLAG_QI ) then - sqi(:)=sqi3D(i,:) - else - sqi = 0.0 - endif - if (FLAG_QS ) then - sqs(:)=sqs3D(i,:) - else - sqs = 0.0 - endif - if (icloud_bl > 0) then - cldfra_bl1d(:)=cldfra_bl(i,:) - qc_bl1d(:)=qc_bl(i,:) - qi_bl1d(:)=qi_bl(i,:) - endif - - do k=KTS,KTE !KTF - dz1(k)=dz(i,k) - u1(k) = u(i,k) - v1(k) = v(i,k) - w1(k) = w(i,k) - th1(k)=th(i,k) - tk1(k)=T3D(i,k) - ex1(k)=exner(i,k) - rho1(k)=rho(i,k) - sqc(k)=sqc3D(i,k) !/(1.+qv(i,k)) - sqv(k)=sqv3D(i,k) !/(1.+qv(i,k)) - thetav(k)=th(i,k)*(1.+p608*sqv(k)) - !keep snow out for now - increases ceiling bias - sqw(k)=sqv(k)+sqc(k)+sqi(k)!+sqs(k) - thl(k)=th1(k) - xlvcp/ex1(k)*sqc(k) & - & - xlscp/ex1(k)*(sqi(k))!+sqs(k)) - !Use form from Tripoli and Cotton (1981) with their - !suggested min temperature to improve accuracy. - !thl(k)=th(i,k)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k) & - ! & - xlscp/MAX(tk1(k),TKmin)*sqi(k)) - - IF (k==kts) THEN - zw(k)=0. - ELSE - zw(k)=zw(k-1)+dz(i,k-1) - ENDIF - IF (INITIALIZE_QKE) THEN - !Initialize tke for initial PBLH calc only - using - !simple PBLH form of Koracin and Berkowicz (1988, BLM) - !to linearly taper off tke towards top of PBL. - qke1(k)=5.*ust(i) * MAX((ust(i)*700. - zw(k))/(MAX(ust(i),0.01)*700.), 0.01) - ELSE - qke1(k)=qke(i,k) - ENDIF - el(k)=el_pbl(i,k) - sh(k)=Sh3D(i,k) - sm(k)=Sm3D(i,k) - tsq1(k)=tsq(i,k) - qsq1(k)=qsq(i,k) - cov1(k)=cov(i,k) - if (spp_pbl==1) then - rstoch_col(k)=pattern_spp_pbl(i,k) - else - rstoch_col(k)=0.0 - endif - - ENDDO - - zw(kte+1)=zw(kte)+dz(i,kte) - -!> - Call get_pblh() to calculate hybrid (\f$\theta_{v}-TKE\f$) PBL height. - CALL GET_PBLH(KTS,KTE,PBLH(i),thetav,& - & Qke1,zw,dz1,xland(i),KPBL(i)) - -!> - Call scale_aware() to calculate similarity functions for scale-adaptive control -!! (\f$P_{\sigma-PBL}\f$ and \f$P_{\sigma-shcu}\f$). - IF (scaleaware > 0.) THEN - CALL SCALE_AWARE(dx(i),PBLH(i),Psig_bl(i),Psig_shcu(i)) - ELSE - Psig_bl(i)=1.0 - Psig_shcu(i)=1.0 - ENDIF - - ! DH* CHECK IF WE CAN DO WITHOUT CALLING THIS ROUTINE FOR RESTARTS -!> - Call mym_initialize() to initializes the mixing length, TKE, \f$\theta^{'2}\f$, -!! \f$q^{'2}\f$, and \f$\theta^{'}q^{'}\f$. These variables are calculated after -!! obtaining prerequisite variables by calling the following subroutines from -!! within mym_initialize(): mym_level2() and mym_length(). - CALL mym_initialize ( & - &kts,kte,xland(i), & - &dz1, dx(i), zw, & - &u1, v1, thl, sqv, & - &PBLH(i), th1, thetav, sh, sm, & - &ust(i), rmol(i), & - &el, Qke1, Tsq1, Qsq1, Cov1, & - &Psig_bl(i), cldfra_bl1D, & - &bl_mynn_mixlength, & - &edmf_w1,edmf_a1, & - &INITIALIZE_QKE, & - &spp_pbl,rstoch_col ) - - IF (.not.restart) THEN - !UPDATE 3D VARIABLES - DO k=KTS,KTE !KTF - el_pbl(i,k)=el(k) - sh3d(i,k)=sh(k) - sm3d(i,k)=sm(k) - qke(i,k)=qke1(k) - tsq(i,k)=tsq1(k) - qsq(i,k)=qsq1(k) - cov(i,k)=cov1(k) - ENDDO - !initialize qke_adv array if using advection - IF (bl_mynn_tkeadvect) THEN - DO k=KTS,KTE - qke_adv(i,k)=qke1(k) - ENDDO - ENDIF - ENDIF - -!*** Begin debugging -! IF(I==IMD .AND. J==JMD)THEN -! PRINT*,"MYNN DRIVER INIT: k=",1," sh=",sh(k) -! PRINT*," sqw=",sqw(k)," thl=",thl(k)," k_m=",exch_m(i,k) -! PRINT*," xland=",xland(i)," rmol=",rmol(i)," ust=",ust(i) -! PRINT*," qke=",qke(i,k)," el=",el_pbl(i,k)," tsq=",Tsq(i,k) -! PRINT*," PBLH=",PBLH(i)," u=",u(i,k)," v=",v(i,k) -! ENDIF -!*** End debugging - - ENDDO !end i-loop - - ENDIF ! end initflag - -!> - After initializing all required variables, the regular procedures -!! performed at every time step are ready for execution. - !ACF- copy qke_adv array into qke if using advection - IF (bl_mynn_tkeadvect) THEN - qke=qke_adv - ENDIF - - DO i=ITS,ITF - !Initialize some arrays - if (tke_budget .eq. 1) then - dqke(i,:)=qke(i,:) - endif - if (FLAG_QI ) then - sqi(:)=sqi3D(i,:) - else - sqi = 0.0 - endif - if (FLAG_QS ) then - sqs(:)=sqs3D(i,:) - else - sqs = 0.0 - endif - if (icloud_bl > 0) then - CLDFRA_BL1D(:)=CLDFRA_BL(i,:) - QC_BL1D(:) =QC_BL(i,:) - QI_BL1D(:) =QI_BL(i,:) - cldfra_bl1D_old(:)=cldfra_bl(i,:) - qc_bl1D_old(:)=qc_bl(i,:) - qi_bl1D_old(:)=qi_bl(i,:) - else - CLDFRA_BL1D =0.0 - QC_BL1D =0.0 - QI_BL1D =0.0 - cldfra_bl1D_old=0.0 - qc_bl1D_old =0.0 - qi_bl1D_old =0.0 - endif - dz1(kts:kte) =dz(i,kts:kte) - u1(kts:kte) =u(i,kts:kte) - v1(kts:kte) =v(i,kts:kte) - w1(kts:kte) =w(i,kts:kte) - th1(kts:kte) =th(i,kts:kte) - tk1(kts:kte) =T3D(i,kts:kte) - p1(kts:kte) =p(i,kts:kte) - ex1(kts:kte) =exner(i,kts:kte) - rho1(kts:kte) =rho(i,kts:kte) - sqv(kts:kte) =sqv3D(i,kts:kte) !/(1.+qv(i,kts:kte)) - sqc(kts:kte) =sqc3D(i,kts:kte) !/(1.+qv(i,kts:kte)) - qv1(kts:kte) =sqv(kts:kte)/(1.-sqv(kts:kte)) - qc1(kts:kte) =sqc(kts:kte)/(1.-sqv(kts:kte)) - qi1(kts:kte) =sqi(kts:kte)/(1.-sqv(kts:kte)) - qs1(kts:kte) =sqs(kts:kte)/(1.-sqv(kts:kte)) - dqc1(kts:kte) =0.0 - dqi1(kts:kte) =0.0 - dqs1(kts:kte) =0.0 - dqni1(kts:kte) =0.0 - dqnc1(kts:kte) =0.0 - dqnwfa1(kts:kte)=0.0 - dqnifa1(kts:kte)=0.0 - dqnbca1(kts:kte)=0.0 - dozone1(kts:kte)=0.0 - IF (FLAG_QNI ) THEN - qni1(kts:kte)=qni(i,kts:kte) - ELSE - qni1(kts:kte)=0.0 - ENDIF - IF (FLAG_QNC ) THEN - qnc1(kts:kte)=qnc(i,kts:kte) - ELSE - qnc1(kts:kte)=0.0 - ENDIF - IF (FLAG_QNWFA ) THEN - qnwfa1(kts:kte)=qnwfa(i,kts:kte) - ELSE - qnwfa1(kts:kte)=0.0 - ENDIF - IF (FLAG_QNIFA ) THEN - qnifa1(kts:kte)=qnifa(i,kts:kte) - ELSE - qnifa1(kts:kte)=0.0 - ENDIF - IF (FLAG_QNBCA ) THEN - qnbca1(kts:kte)=qnbca(i,kts:kte) - ELSE - qnbca1(kts:kte)=0.0 - ENDIF - IF (FLAG_OZONE ) THEN - ozone1(kts:kte)=ozone(i,kts:kte) - ELSE - ozone1(kts:kte)=0.0 - ENDIF - el(kts:kte) =el_pbl(i,kts:kte) - qke1(kts:kte)=qke(i,kts:kte) - sh(kts:kte) =sh3d(i,kts:kte) - sm(kts:kte) =sm3d(i,kts:kte) - tsq1(kts:kte)=tsq(i,kts:kte) - qsq1(kts:kte)=qsq(i,kts:kte) - cov1(kts:kte)=cov(i,kts:kte) - if (spp_pbl==1) then - rstoch_col(kts:kte)=pattern_spp_pbl(i,kts:kte) - else - rstoch_col(kts:kte)=0.0 - endif - !edmf - edmf_a1 =0.0 - edmf_w1 =0.0 - edmf_qc1 =0.0 - s_aw1 =0.0 - s_awthl1 =0.0 - s_awqt1 =0.0 - s_awqv1 =0.0 - s_awqc1 =0.0 - s_awu1 =0.0 - s_awv1 =0.0 - s_awqke1 =0.0 - s_awqnc1 =0.0 - s_awqni1 =0.0 - s_awqnwfa1 =0.0 - s_awqnifa1 =0.0 - s_awqnbca1 =0.0 - ![EWDD] - edmf_a_dd1 =0.0 - edmf_w_dd1 =0.0 - edmf_qc_dd1=0.0 - sd_aw1 =0.0 - sd_awthl1 =0.0 - sd_awqt1 =0.0 - sd_awqv1 =0.0 - sd_awqc1 =0.0 - sd_awu1 =0.0 - sd_awv1 =0.0 - sd_awqke1 =0.0 - sub_thl =0.0 - sub_sqv =0.0 - sub_u =0.0 - sub_v =0.0 - det_thl =0.0 - det_sqv =0.0 - det_sqc =0.0 - det_u =0.0 - det_v =0.0 - - do k = kts,kte - if (k==kts) then - zw(k)=0. - else - zw(k)=zw(k-1)+dz(i,k-1) - endif - !keep snow out for now - increases ceiling bias - sqw(k)= sqv(k)+sqc(k)+sqi(k)!+sqs(k) - thl(k)= th1(k) - xlvcp/ex1(k)*sqc(k) & - & - xlscp/ex1(k)*(sqi(k))!+sqs(k)) - !Use form from Tripoli and Cotton (1981) with their - !suggested min temperature to improve accuracy. - !thl(k)=th(i,k)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k) & - ! & - xlscp/MAX(tk1(k),TKmin)*sqi(k)) - thetav(k)=th1(k)*(1.+p608*sqv(k)) - enddo ! end k - zw(kte+1)=zw(kte)+dz(i,kte) - - !initialize smoke/chem arrays (if used): - if ( mix_chem ) then - do ic = 1,ndvel - vd1(ic) = vdep(i,ic) ! dry deposition velocity - enddo - do k = kts,kte - do ic = 1,nchem - chem1(k,ic) = chem3d(i,k,ic) - enddo - enddo - else - do ic = 1,ndvel - vd1(ic) = 0. ! dry deposition velocity - enddo - do k = kts,kte - do ic = 1,nchem - chem1(k,ic) = 0. - enddo - enddo - endif - s_awchem1(kts:kte+1,1:nchem) = 0.0 - -!> - Call get_pblh() to calculate the hybrid \f$\theta_{v}-TKE\f$ -!! PBL height diagnostic. - CALL GET_PBLH(KTS,KTE,PBLH(i),thetav,& - & Qke1,zw,dz1,xland(i),KPBL(i)) - -!> - Call scale_aware() to calculate the similarity functions, -!! \f$P_{\sigma-PBL}\f$ and \f$P_{\sigma-shcu}\f$, to control -!! the scale-adaptive behaviour for the local and nonlocal -!! components, respectively. - if (scaleaware > 0.) then - call SCALE_AWARE(dx(i),PBLH(i),Psig_bl(i),Psig_shcu(i)) - else - Psig_bl(i)=1.0 - Psig_shcu(i)=1.0 - endif - - sqcg= 0.0 !ill-defined variable; qcg has been removed - cpm=cp*(1.+0.84*qv1(kts)) - exnerg=(ps(i)/p1000mb)**rcp - - !----------------------------------------------------- - !ORIGINAL CODE - !flt = hfx(i)/( rho(i,kts)*cpm ) & - ! +xlvcp*ch(i)*(sqc(kts)/exner(i,kts) -sqcg/exnerg) - !flq = qfx(i)/ rho(i,kts) & - ! -ch(i)*(sqc(kts) -sqcg ) - !----------------------------------------------------- - flqv = qfx(i)/rho1(kts) - flqc = 0.0 !currently no sea-spray fluxes, fog settling handled elsewhere - th_sfc = ts(i)/ex1(kts) - - ! TURBULENT FLUX FOR TKE BOUNDARY CONDITIONS - flq =flqv+flqc !! LATENT - flt =hfx(i)/(rho1(kts)*cpm )-xlvcp*flqc/ex1(kts) !! Temperature flux - fltv=flt + flqv*p608*th_sfc !! Virtual temperature flux - - ! Update 1/L using updated sfc heat flux and friction velocity - rmol(i) = -karman*gtr*fltv/max(ust(i)**3,1.0e-6) - zet = 0.5*dz(i,kts)*rmol(i) - zet = MAX(zet, -20.) - zet = MIN(zet, 20.) - !if(i.eq.idbg)print*,"updated z/L=",zet - if (bl_mynn_stfunc == 0) then - !Original Kansas-type stability functions - if ( zet >= 0.0 ) then - pmz = 1.0 + (cphm_st-1.0) * zet - phh = 1.0 + cphh_st * zet - else - pmz = 1.0/ (1.0-cphm_unst*zet)**0.25 - zet - phh = 1.0/SQRT(1.0-cphh_unst*zet) - end if - else - !Updated stability functions (Puhales, 2020) - phi_m = phim(zet) - pmz = phi_m - zet - phh = phih(zet) - end if - -!> - Call mym_condensation() to calculate the nonconvective component -!! of the subgrid cloud fraction and mixing ratio as well as the functions -!! used to calculate the buoyancy flux. Different cloud PDFs can be -!! selected by use of the namelist parameter \p bl_mynn_cloudpdf. - - call mym_condensation (kts,kte, & - &dx(i),dz1,zw,xland(i), & - &thl,sqw,sqv,sqc,sqi,sqs, & - &p1,ex1,tsq1,qsq1,cov1, & - &Sh,el,bl_mynn_cloudpdf, & - &qc_bl1D,qi_bl1D,cldfra_bl1D, & - &PBLH(i),HFX(i), & - &Vt, Vq, th1, sgm, rmol(i), & - &spp_pbl, rstoch_col ) - -!> - Add TKE source driven by cloud top cooling -!! Calculate the buoyancy production of TKE from cloud-top cooling when -!! \p bl_mynn_topdown =1. - if (bl_mynn_topdown.eq.1) then - call topdown_cloudrad(kts,kte,dz1,zw,fltv, & - &xland(i),kpbl(i),PBLH(i), & - &sqc,sqi,sqw,thl,th1,ex1,p1,rho1,thetav, & - &cldfra_bl1D,rthraten(i,:), & - &maxKHtopdown(i),KHtopdown,TKEprodTD ) - else - maxKHtopdown(i) = 0.0 - KHtopdown(kts:kte) = 0.0 - TKEprodTD(kts:kte) = 0.0 - endif - - if (bl_mynn_edmf > 0) then - !PRINT*,"Calling DMP Mass-Flux: i= ",i - call DMP_mf( & - &kts,kte,delt,zw,dz1,p1,rho1, & - &bl_mynn_edmf_mom, & - &bl_mynn_edmf_tke, & - &bl_mynn_mixscalars, & - &u1,v1,w1,th1,thl,thetav,tk1, & - &sqw,sqv,sqc,qke1, & - &qnc1,qni1,qnwfa1,qnifa1,qnbca1, & - &ex1,Vt,Vq,sgm, & - &ust(i),flt,fltv,flq,flqv, & - &PBLH(i),KPBL(i),DX(i), & - &xland(i),th_sfc, & - ! now outputs - tendencies - ! &,dth1mf,dqv1mf,dqc1mf,du1mf,dv1mf & - ! outputs - updraft properties - &edmf_a1,edmf_w1,edmf_qt1, & - &edmf_thl1,edmf_ent1,edmf_qc1, & - ! for the solver - &s_aw1,s_awthl1,s_awqt1, & - &s_awqv1,s_awqc1, & - &s_awu1,s_awv1,s_awqke1, & - &s_awqnc1,s_awqni1, & - &s_awqnwfa1,s_awqnifa1,s_awqnbca1, & - &sub_thl,sub_sqv, & - &sub_u,sub_v, & - &det_thl,det_sqv,det_sqc, & - &det_u,det_v, & - ! chem/smoke mixing - &nchem,chem1,s_awchem1, & - &mix_chem, & - &qc_bl1D,cldfra_bl1D, & - &qc_bl1D_old,cldfra_bl1D_old, & - &FLAG_QC,FLAG_QI, & - &FLAG_QNC,FLAG_QNI, & - &FLAG_QNWFA,FLAG_QNIFA,FLAG_QNBCA, & - &Psig_shcu(i), & - &maxwidth(i),ktop_plume(i), & - &maxmf(i),ztop_plume(i), & - &spp_pbl,rstoch_col ) - endif - - if (bl_mynn_edmf_dd == 1) then - call DDMF_JPL(kts,kte,delt,zw,dz1,p1, & - &u1,v1,th1,thl,thetav,tk1, & - &sqw,sqv,sqc,rho1,ex1, & - &ust(i),flt,flq, & - &PBLH(i),KPBL(i), & - &edmf_a_dd1,edmf_w_dd1,edmf_qt_dd1, & - &edmf_thl_dd1,edmf_ent_dd1, & - &edmf_qc_dd1, & - &sd_aw1,sd_awthl1,sd_awqt1, & - &sd_awqv1,sd_awqc1,sd_awu1,sd_awv1, & - &sd_awqke1, & - &qc_bl1d,cldfra_bl1d, & - &rthraten(i,:) ) - endif - - !Capability to substep the eddy-diffusivity portion - !do nsub = 1,2 - delt2 = delt !*0.5 !only works if topdown=0 - - call mym_turbulence( & - &kts,kte,xland(i),closure, & - &dz1, DX(i), zw, & - &u1, v1, thl, thetav, sqc, sqw, & - &qke1, tsq1, qsq1, cov1, & - &vt, vq, & - &rmol(i), flt, fltv, flq, & - &PBLH(i),th1, & - &Sh,Sm,el, & - &Dfm,Dfh,Dfq, & - &Tcd,Qcd,Pdk, & - &Pdt,Pdq,Pdc, & - &qWT1,qSHEAR1,qBUOY1,qDISS1, & - &tke_budget, & - &Psig_bl(i),Psig_shcu(i), & - &cldfra_bl1D,bl_mynn_mixlength, & - &edmf_w1,edmf_a1, & - &TKEprodTD, & - &spp_pbl,rstoch_col ) - -!> - Call mym_predict() to solve TKE and -!! \f$\theta^{'2}, q^{'2}, and \theta^{'}q^{'}\f$ -!! for the following time step. - call mym_predict(kts,kte,closure, & - &delt2, dz1, & - &ust(i), flt, flq, pmz, phh, & - &el, dfq, rho1, pdk, pdt, pdq, pdc, & - &Qke1, Tsq1, Qsq1, Cov1, & - &s_aw1, s_awqke1, bl_mynn_edmf_tke, & - &qWT1, qDISS1, tke_budget ) - - if (dheat_opt > 0) then - do k=kts,kte-1 - ! Set max dissipative heating rate to 7.2 K per hour - diss_heat(k) = MIN(MAX(1.0*(qke1(k)**1.5)/(b1*MAX(0.5*(el(k)+el(k+1)),1.))/cp, 0.0),0.002) - ! Limit heating above 100 mb: - diss_heat(k) = diss_heat(k) * exp(-10000./MAX(p1(k),1.)) - enddo - diss_heat(kte) = 0. - else - diss_heat(1:kte) = 0. - endif - -!> - Call mynn_tendencies() to solve for tendencies of -!! \f$U, V, \theta, q_{v}, q_{c}, and q_{i}\f$. - call mynn_tendencies(kts,kte,i, & - &delt, dz1, rho1, & - &u1, v1, th1, tk1, qv1, & - &qc1, qi1, kzero, qnc1, qni1, & !kzero replaces qs1 - not mixing snow - &ps(i), p1, ex1, thl, & - &sqv, sqc, sqi, kzero, sqw, & !kzero replaces sqs - not mixing snow - &qnwfa1, qnifa1, qnbca1, ozone1, & - &ust(i),flt,flq,flqv,flqc, & - &wspd(i),uoce(i),voce(i), & - &tsq1, qsq1, cov1, & - &tcd, qcd, & - &dfm, dfh, dfq, & - &Du1, Dv1, Dth1, Dqv1, & - &Dqc1, Dqi1, Dqs1, Dqnc1, Dqni1, & - &Dqnwfa1, Dqnifa1, Dqnbca1, & - &Dozone1, & - &diss_heat, & - ! mass flux components - &s_aw1,s_awthl1,s_awqt1, & - &s_awqv1,s_awqc1,s_awu1,s_awv1, & - &s_awqnc1,s_awqni1, & - &s_awqnwfa1,s_awqnifa1,s_awqnbca1, & - &sd_aw1,sd_awthl1,sd_awqt1, & - &sd_awqv1,sd_awqc1, & - &sd_awu1,sd_awv1, & - &sub_thl,sub_sqv, & - &sub_u,sub_v, & - &det_thl,det_sqv,det_sqc, & - &det_u,det_v, & - &FLAG_QC,FLAG_QI,FLAG_QNC, & - &FLAG_QNI,FLAG_QS, & - &FLAG_QNWFA,FLAG_QNIFA, & - &FLAG_QNBCA,FLAG_OZONE, & - &cldfra_bl1d, & - &bl_mynn_cloudmix, & - &bl_mynn_mixqt, & - &bl_mynn_edmf, & - &bl_mynn_edmf_mom, & - &bl_mynn_mixscalars ) - - - if ( mix_chem ) then - if ( rrfs_sd ) then - call mynn_mix_chem(kts,kte,i, & - &delt, dz1, pblh(i), & - &nchem, kdvel, ndvel, & - &chem1, vd1, & - &rho1,flt, & - &tcd, qcd, & - &dfh, & - &s_aw1,s_awchem1, & - &emis_ant_no(i), & - &frp(i), rrfs_sd, & - &enh_mix, smoke_dbg ) - else - call mynn_mix_chem(kts,kte,i, & - &delt, dz1, pblh(i), & - &nchem, kdvel, ndvel, & - &chem1, vd1, & - &rho1,flt, & - &tcd, qcd, & - &dfh, & - &s_aw1,s_awchem1, & - &zero, & - &zero, rrfs_sd, & - &enh_mix, smoke_dbg ) - endif - do ic = 1,nchem - do k = kts,kte - chem3d(i,k,ic) = max(1.e-12, chem1(k,ic)) - enddo - enddo - endif - - call retrieve_exchange_coeffs(kts,kte, & - &dfm, dfh, dz1, K_m1, K_h1 ) - - !UPDATE 3D ARRAYS - exch_m(i,kts:kte) =k_m1(kts:kte) - exch_h(i,kts:kte) =k_h1(kts:kte) - rublten(i,kts:kte) =du1(kts:kte) - rvblten(i,kts:kte) =dv1(kts:kte) - rthblten(i,kts:kte)=dth1(kts:kte) - rqvblten(i,kts:kte)=dqv1(kts:kte) - if (bl_mynn_cloudmix > 0) then - if (flag_qc) rqcblten(i,kts:kte)=dqc1(kts:kte) - if (flag_qi) rqiblten(i,kts:kte)=dqi1(kts:kte) - if (flag_qs) rqsblten(i,kts:kte)=dqs1(kts:kte) - else - if (flag_qc) rqcblten(i,:)=0. - if (flag_qi) rqiblten(i,:)=0. - if (flag_qs) rqsblten(i,:)=0. - endif - if (bl_mynn_cloudmix > 0 .and. bl_mynn_mixscalars > 0) then - if (flag_qnc) rqncblten(i,kts:kte) =dqnc1(kts:kte) - if (flag_qni) rqniblten(i,kts:kte) =dqni1(kts:kte) - if (flag_qnwfa) rqnwfablten(i,kts:kte)=dqnwfa1(kts:kte) - if (flag_qnifa) rqnifablten(i,kts:kte)=dqnifa1(kts:kte) - if (flag_qnbca) rqnbcablten(i,kts:kte)=dqnbca1(kts:kte) - else - if (flag_qnc) rqncblten(i,:) =0. - if (flag_qni) rqniblten(i,:) =0. - if (flag_qnwfa) rqnwfablten(i,:)=0. - if (flag_qnifa) rqnifablten(i,:)=0. - if (flag_qnbca) rqnbcablten(i,:)=0. - endif - dozone(i,kts:kte)=dozone1(kts:kte) - if (icloud_bl > 0) then - qc_bl(i,kts:kte) =qc_bl1D(kts:kte) - qi_bl(i,kts:kte) =qi_bl1D(kts:kte) - cldfra_bl(i,kts:kte)=cldfra_bl1D(kts:kte) - endif - el_pbl(i,kts:kte)=el(kts:kte) - qke(i,kts:kte) =qke1(kts:kte) - tsq(i,kts:kte) =tsq1(kts:kte) - qsq(i,kts:kte) =qsq1(kts:kte) - cov(i,kts:kte) =cov1(kts:kte) - sh3d(i,kts:kte) =sh(kts:kte) - sm3d(i,kts:kte) =sm(kts:kte) - - if (tke_budget .eq. 1) then - !! TKE budget is now given in m**2/s**-3 (Puhales, 2020) - !! Lower boundary condtions (using similarity relationships such as the prognostic equation for Qke) - k=kts - qSHEAR1(k) =4.*(ust(i)**3*phi_m/(karman*dz(i,k)))-qSHEAR1(k+1) !! staggered - qBUOY1(k) =4.*(-ust(i)**3*zet/(karman*dz(i,k)))-qBUOY1(k+1) !! staggered - !! unstaggering SHEAR and BUOY and trasfering all TKE budget to 3D array - do k = kts,kte-1 - qSHEAR(i,k)=0.5*(qSHEAR1(k)+qSHEAR1(k+1)) !!! unstaggering in z - qBUOY(i,k) =0.5*(qBUOY1(k)+qBUOY1(k+1)) !!! unstaggering in z - qWT(i,k) =qWT1(k) - qDISS(i,k) =qDISS1(k) - dqke(i,k) =(qke1(k)-dqke(i,k))*0.5/delt - enddo - !! Upper boundary conditions - k=kte - qSHEAR(i,k) =0. - qBUOY(i,k) =0. - qWT(i,k) =0. - qDISS(i,k) =0. - dqke(i,k) =0. - endif - - !update updraft/downdraft properties - if (bl_mynn_output > 0) then !research mode == 1 - if (bl_mynn_edmf > 0) then - edmf_a(i,kts:kte) =edmf_a1(kts:kte) - edmf_w(i,kts:kte) =edmf_w1(kts:kte) - edmf_qt(i,kts:kte) =edmf_qt1(kts:kte) - edmf_thl(i,kts:kte) =edmf_thl1(kts:kte) - edmf_ent(i,kts:kte) =edmf_ent1(kts:kte) - edmf_qc(i,kts:kte) =edmf_qc1(kts:kte) - sub_thl3D(i,kts:kte)=sub_thl(kts:kte) - sub_sqv3D(i,kts:kte)=sub_sqv(kts:kte) - det_thl3D(i,kts:kte)=det_thl(kts:kte) - det_sqv3D(i,kts:kte)=det_sqv(kts:kte) - endif - !if (bl_mynn_edmf_dd > 0) THEN - ! edmf_a_dd(i,kts:kte) =edmf_a_dd1(kts:kte) - ! edmf_w_dd(i,kts:kte) =edmf_w_dd1(kts:kte) - ! edmf_qt_dd(i,kts:kte) =edmf_qt_dd1(kts:kte) - ! edmf_thl_dd(i,kts:kte)=edmf_thl_dd1(kts:kte) - ! edmf_ent_dd(i,kts:kte)=edmf_ent_dd1(kts:kte) - ! edmf_qc_dd(i,kts:kte) =edmf_qc_dd1(kts:kte) - !endif - endif - - !*** Begin debug prints - if ( debug_code .and. (i .eq. idbg)) THEN - if ( ABS(QFX(i))>.001)print*,& - "SUSPICIOUS VALUES AT: i=",i," QFX=",QFX(i) - if ( ABS(HFX(i))>1100.)print*,& - "SUSPICIOUS VALUES AT: i=",i," HFX=",HFX(i) - do k = kts,kte - IF ( sh(k) < 0. .OR. sh(k)> 200.)print*,& - "SUSPICIOUS VALUES AT: i,k=",i,k," sh=",sh(k) - IF ( ABS(vt(k)) > 2.0 )print*,& - "SUSPICIOUS VALUES AT: i,k=",i,k," vt=",vt(k) - IF ( ABS(vq(k)) > 7000.)print*,& - "SUSPICIOUS VALUES AT: i,k=",i,k," vq=",vq(k) - IF ( qke(i,k) < -1. .OR. qke(i,k)> 200.)print*,& - "SUSPICIOUS VALUES AT: i,k=",i,k," qke=",qke(i,k) - IF ( el_pbl(i,k) < 0. .OR. el_pbl(i,k)> 1500.)print*,& - "SUSPICIOUS VALUES AT: i,k=",i,k," el_pbl=",el_pbl(i,k) - IF ( exch_m(i,k) < 0. .OR. exch_m(i,k)> 2000.)print*,& - "SUSPICIOUS VALUES AT: i,k=",i,k," exxch_m=",exch_m(i,k) - IF (icloud_bl > 0) then - IF ( cldfra_bl(i,k) < 0.0 .OR. cldfra_bl(i,k)> 1.)THEN - PRINT*,"SUSPICIOUS VALUES: CLDFRA_BL=",cldfra_bl(i,k)," qc_bl=",QC_BL(i,k) - ENDIF - ENDIF - - !IF (I==IMD .AND. J==JMD) THEN - ! PRINT*,"MYNN DRIVER END: k=",k," sh=",sh(k) - ! PRINT*," sqw=",sqw(k)," thl=",thl(k)," exch_m=",exch_m(i,k) - ! PRINT*," xland=",xland(i)," rmol=",rmol(i)," ust=",ust(i) - ! PRINT*," qke=",qke(i,k)," el=",el_pbl(i,k)," tsq=",tsq(i,k) - ! PRINT*," PBLH=",PBLH(i)," u=",u(i,k)," v=",v(i,k) - ! PRINT*," vq=",vq(k)," vt=",vt(k) - !ENDIF - enddo !end-k - endif - - enddo !end i-loop - -!ACF copy qke into qke_adv if using advection - IF (bl_mynn_tkeadvect) THEN - qke_adv=qke - ENDIF -!ACF-end - -#ifdef HARDCODE_VERTICAL -# undef kts -# undef kte -#endif - - END SUBROUTINE mynn_bl_driver -!> @} - -!======================================================================= -! SUBROUTINE mym_initialize: -! -! Input variables: -! iniflag : <>0; turbulent quantities will be initialized -! = 0; turbulent quantities have been already -! given, i.e., they will not be initialized -! nx, nz : Dimension sizes of the -! x and z directions, respectively -! tref : Reference temperature (K) -! dz(nz) : Vertical grid spacings (m) -! # dz(nz)=dz(nz-1) -! zw(nz+1) : Heights of the walls of the grid boxes (m) -! # zw(1)=0.0 and zw(k)=zw(k-1)+dz(k-1) -! exner(nx,nz) : Exner function at zw*h+zg (J/kg K) -! defined by c_p*( p_basic/1000hPa )^kappa -! This is usually computed by integrating -! d(pi0)/dz = -h*g/tref. -! rmo(nx) : Inverse of the Obukhov length (m^(-1)) -! flt, flq(nx) : Turbulent fluxes of potential temperature and -! total water, respectively: -! flt=-u_*Theta_* (K m/s) -! flq=-u_*qw_* (kg/kg m/s) -! ust(nx) : Friction velocity (m/s) -! pmz(nx) : phi_m-zeta at z1*h+z0, where z1 (=0.5*dz(1)) -! is the first grid point above the surafce, z0 -! the roughness length and zeta=(z1*h+z0)*rmo -! phh(nx) : phi_h at z1*h+z0 -! u, v(nx,nz) : Components of the horizontal wind (m/s) -! thl(nx,nz) : Liquid water potential temperature -! (K) -! qw(nx,nz) : Total water content Q_w (kg/kg) -! -! Output variables: -! ql(nx,nz) : Liquid water content (kg/kg) -! vt, vq(nx,nz) : Functions for computing the buoyancy flux -! qke(nx,nz) : Twice the turbulent kinetic energy q^2 -! (m^2/s^2) -! tsq(nx,nz) : Variance of Theta_l (K^2) -! qsq(nx,nz) : Variance of Q_w -! cov(nx,nz) : Covariance of Theta_l and Q_w (K) -! el(nx,nz) : Master length scale L (m) -! defined on the walls of the grid boxes -! -! Work arrays: see subroutine mym_level2 -! pd?(nx,nz,ny) : Half of the production terms at Level 2 -! defined on the walls of the grid boxes -! qkw(nx,nz,ny) : q on the walls of the grid boxes (m/s) -! -! # As to dtl, ...gh, see subroutine mym_turbulence. -! -!------------------------------------------------------------------- - -!>\ingroup gsd_mynn_edmf -!! This subroutine initializes the mixing length, TKE, \f$\theta^{'2}\f$, -!! \f$q^{'2}\f$, and \f$\theta^{'}q^{'}\f$. -!!\section gen_mym_ini GSD MYNN-EDMF mym_initialize General Algorithm -!> @{ - SUBROUTINE mym_initialize ( & - & kts,kte,xland, & - & dz, dx, zw, & - & u, v, thl, qw, & -! & ust, rmo, pmz, phh, flt, flq, & - & zi, theta, thetav, sh, sm, & - & ust, rmo, el, & - & Qke, Tsq, Qsq, Cov, Psig_bl, cldfra_bl1D, & - & bl_mynn_mixlength, & - & edmf_w1,edmf_a1, & - & INITIALIZE_QKE, & - & spp_pbl,rstoch_col) -! -!------------------------------------------------------------------- - - integer, intent(in) :: kts,kte - integer, intent(in) :: bl_mynn_mixlength - logical, intent(in) :: INITIALIZE_QKE -! real(kind_phys), intent(in) :: ust, rmo, pmz, phh, flt, flq - real(kind_phys), intent(in) :: rmo, Psig_bl, xland - real(kind_phys), intent(in) :: dx, ust, zi - real(kind_phys), dimension(kts:kte), intent(in) :: dz - real(kind_phys), dimension(kts:kte+1), intent(in) :: zw - real(kind_phys), dimension(kts:kte), intent(in) :: u,v,thl,& - &qw,cldfra_bl1D,edmf_w1,edmf_a1 - real(kind_phys), dimension(kts:kte), intent(out) :: tsq,qsq,cov - real(kind_phys), dimension(kts:kte), intent(inout) :: el,qke - real(kind_phys), dimension(kts:kte) :: & - &ql,pdk,pdt,pdq,pdc,dtl,dqw,dtv, & - &gm,gh,sm,sh,qkw,vt,vq - integer :: k,l,lmax - real(kind_phys):: phm,vkz,elq,elv,b1l,b2l,pmz=1.,phh=1., & - &flt=0.,fltv=0.,flq=0.,tmpq - real(kind_phys), dimension(kts:kte) :: theta,thetav - real(kind_phys), dimension(kts:kte) :: rstoch_col - integer ::spp_pbl - -!> - At first ql, vt and vq are set to zero. - DO k = kts,kte - ql(k) = 0.0 - vt(k) = 0.0 - vq(k) = 0.0 - END DO -! -!> - Call mym_level2() to calculate the stability functions at level 2. - CALL mym_level2 ( kts,kte, & - & dz, & - & u, v, thl, thetav, qw, & - & ql, vt, vq, & - & dtl, dqw, dtv, gm, gh, sm, sh ) -! -! ** Preliminary setting ** - - el (kts) = 0.0 - IF (INITIALIZE_QKE) THEN - !qke(kts) = ust**2 * ( b1*pmz )**(2.0/3.0) - qke(kts) = 1.5 * ust**2 * ( b1*pmz )**(2.0/3.0) - DO k = kts+1,kte - !qke(k) = 0.0 - !linearly taper off towards top of pbl - qke(k)=qke(kts)*MAX((ust*700. - zw(k))/(MAX(ust,0.01)*700.), 0.01) - ENDDO - ENDIF -! - phm = phh*b2 / ( b1*pmz )**(1.0/3.0) - tsq(kts) = phm*( flt/ust )**2 - qsq(kts) = phm*( flq/ust )**2 - cov(kts) = phm*( flt/ust )*( flq/ust ) -! - DO k = kts+1,kte - vkz = karman*zw(k) - el (k) = vkz/( 1.0 + vkz/100.0 ) -! qke(k) = 0.0 -! - tsq(k) = 0.0 - qsq(k) = 0.0 - cov(k) = 0.0 - END DO -! -! ** Initialization with an iterative manner ** -! ** lmax is the iteration count. This is arbitrary. ** - lmax = 5 -! - DO l = 1,lmax -! -!> - call mym_length() to calculate the master length scale. - CALL mym_length ( & - & kts,kte,xland, & - & dz, dx, zw, & - & rmo, flt, fltv, flq, & - & vt, vq, & - & u, v, qke, & - & dtv, & - & el, & - & zi,theta, & - & qkw,Psig_bl,cldfra_bl1D, & - & bl_mynn_mixlength, & - & edmf_w1,edmf_a1 ) -! - DO k = kts+1,kte - elq = el(k)*qkw(k) - pdk(k) = elq*( sm(k)*gm(k) + & - & sh(k)*gh(k) ) - pdt(k) = elq* sh(k)*dtl(k)**2 - pdq(k) = elq* sh(k)*dqw(k)**2 - pdc(k) = elq* sh(k)*dtl(k)*dqw(k) - END DO -! -! ** Strictly, vkz*h(i,j) -> karman*( 0.5*dz(1)*h(i,j)+z0 ) ** - vkz = karman*0.5*dz(kts) - elv = 0.5*( el(kts+1)+el(kts) ) / vkz - IF (INITIALIZE_QKE)THEN - !qke(kts) = ust**2 * ( b1*pmz*elv )**(2.0/3.0) - qke(kts) = 1.0 * MAX(ust,0.02)**2 * ( b1*pmz*elv )**(2.0/3.0) - ENDIF - - phm = phh*b2 / ( b1*pmz/elv**2 )**(1.0/3.0) - tsq(kts) = phm*( flt/ust )**2 - qsq(kts) = phm*( flq/ust )**2 - cov(kts) = phm*( flt/ust )*( flq/ust ) - - DO k = kts+1,kte-1 - b1l = b1*0.25*( el(k+1)+el(k) ) - !tmpq=MAX(b1l*( pdk(k+1)+pdk(k) ),qkemin) - !add MIN to limit unreasonable QKE - tmpq=MIN(MAX(b1l*( pdk(k+1)+pdk(k) ),qkemin),125.) -! PRINT *,'tmpqqqqq',tmpq,pdk(k+1),pdk(k) - IF (INITIALIZE_QKE)THEN - qke(k) = tmpq**twothirds - ENDIF - - IF ( qke(k) .LE. 0.0 ) THEN - b2l = 0.0 - ELSE - b2l = b2*( b1l/b1 ) / SQRT( qke(k) ) - END IF - - tsq(k) = b2l*( pdt(k+1)+pdt(k) ) - qsq(k) = b2l*( pdq(k+1)+pdq(k) ) - cov(k) = b2l*( pdc(k+1)+pdc(k) ) - END DO - - END DO - -!! qke(kts)=qke(kts+1) -!! tsq(kts)=tsq(kts+1) -!! qsq(kts)=qsq(kts+1) -!! cov(kts)=cov(kts+1) - - IF (INITIALIZE_QKE)THEN - qke(kts)=0.5*(qke(kts)+qke(kts+1)) - qke(kte)=qke(kte-1) - ENDIF - tsq(kte)=tsq(kte-1) - qsq(kte)=qsq(kte-1) - cov(kte)=cov(kte-1) - -! -! RETURN - - END SUBROUTINE mym_initialize -!> @} - -! -! ================================================================== -! SUBROUTINE mym_level2: -! -! Input variables: see subroutine mym_initialize -! -! Output variables: -! dtl(nx,nz,ny) : Vertical gradient of Theta_l (K/m) -! dqw(nx,nz,ny) : Vertical gradient of Q_w -! dtv(nx,nz,ny) : Vertical gradient of Theta_V (K/m) -! gm (nx,nz,ny) : G_M divided by L^2/q^2 (s^(-2)) -! gh (nx,nz,ny) : G_H divided by L^2/q^2 (s^(-2)) -! sm (nx,nz,ny) : Stability function for momentum, at Level 2 -! sh (nx,nz,ny) : Stability function for heat, at Level 2 -! -! These are defined on the walls of the grid boxes. -! - -!>\ingroup gsd_mynn_edmf -!! This subroutine calculates the level 2, non-dimensional wind shear -!! \f$G_M\f$ and vertical temperature gradient \f$G_H\f$ as well as -!! the level 2 stability funcitons \f$S_h\f$ and \f$S_m\f$. -!!\param kts horizontal dimension -!!\param kte vertical dimension -!!\param dz vertical grid spacings (\f$m\f$) -!!\param u west-east component of the horizontal wind (\f$m s^{-1}\f$) -!!\param v south-north component of the horizontal wind (\f$m s^{-1}\f$) -!!\param thl liquid water potential temperature -!!\param qw total water content \f$Q_w\f$ -!!\param ql liquid water content (\f$kg kg^{-1}\f$) -!!\param vt -!!\param vq -!!\param dtl vertical gradient of \f$\theta_l\f$ (\f$K m^{-1}\f$) -!!\param dqw vertical gradient of \f$Q_w\f$ -!!\param dtv vertical gradient of \f$\theta_V\f$ (\f$K m^{-1}\f$) -!!\param gm \f$G_M\f$ divided by \f$L^{2}/q^{2}\f$ (\f$s^{-2}\f$) -!!\param gh \f$G_H\f$ divided by \f$L^{2}/q^{2}\f$ (\f$s^{-2}\f$) -!!\param sm stability function for momentum, at Level 2 -!!\param sh stability function for heat, at Level 2 -!!\section gen_mym_level2 GSD MYNN-EDMF mym_level2 General Algorithm -!! @ { - SUBROUTINE mym_level2 (kts,kte, & - & dz, & - & u, v, thl, thetav, qw, & - & ql, vt, vq, & - & dtl, dqw, dtv, gm, gh, sm, sh ) -! -!------------------------------------------------------------------- - - integer, intent(in) :: kts,kte - -#ifdef HARDCODE_VERTICAL -# define kts 1 -# define kte HARDCODE_VERTICAL -#endif - - real(kind_phys), dimension(kts:kte), intent(in) :: dz - real(kind_phys), dimension(kts:kte), intent(in) :: u,v, & - &thl,qw,ql,vt,vq,thetav - real(kind_phys), dimension(kts:kte), intent(out) :: & - &dtl,dqw,dtv,gm,gh,sm,sh - - integer :: k - - real(kind_phys):: rfc,f1,f2,rf1,rf2,smc,shc, & - &ri1,ri2,ri3,ri4,duz,dtz,dqz,vtt,vqq,dtq,dzk, & - &afk,abk,ri,rf - - real(kind_phys):: a2fac - -! ev = 2.5e6 -! tv0 = 0.61*tref -! tv1 = 1.61*tref -! gtr = 9.81/tref -! - rfc = g1/( g1+g2 ) - f1 = b1*( g1-c1 ) +3.0*a2*( 1.0 -c2 )*( 1.0-c5 ) & - & +2.0*a1*( 3.0-2.0*c2 ) - f2 = b1*( g1+g2 ) -3.0*a1*( 1.0 -c2 ) - rf1 = b1*( g1-c1 )/f1 - rf2 = b1* g1 /f2 - smc = a1 /a2* f1/f2 - shc = 3.0*a2*( g1+g2 ) -! - ri1 = 0.5/smc - ri2 = rf1*smc - ri3 = 4.0*rf2*smc -2.0*ri2 - ri4 = ri2**2 -! - DO k = kts+1,kte - dzk = 0.5 *( dz(k)+dz(k-1) ) - afk = dz(k)/( dz(k)+dz(k-1) ) - abk = 1.0 -afk - duz = ( u(k)-u(k-1) )**2 +( v(k)-v(k-1) )**2 - duz = duz /dzk**2 - dtz = ( thl(k)-thl(k-1) )/( dzk ) - dqz = ( qw(k)-qw(k-1) )/( dzk ) -! - vtt = 1.0 +vt(k)*abk +vt(k-1)*afk ! Beta-theta in NN09, Eq. 39 - vqq = tv0 +vq(k)*abk +vq(k-1)*afk ! Beta-q - dtq = vtt*dtz +vqq*dqz - !Alternatively, use theta-v without the SGS clouds - !dtq = ( thetav(k)-thetav(k-1) )/( dzk ) -! - dtl(k) = dtz - dqw(k) = dqz - dtv(k) = dtq -!? dtv(i,j,k) = dtz +tv0*dqz -!? : +( xlv/pi0(i,j,k)-tv1 ) -!? : *( ql(i,j,k)-ql(i,j,k-1) )/( dzk*h(i,j) ) -! - gm (k) = duz - gh (k) = -dtq*gtr -! -! ** Gradient Richardson number ** - ri = -gh(k)/MAX( duz, 1.0e-10 ) - - !a2fac is needed for the Canuto/Kitamura mod - IF (CKmod .eq. 1) THEN - a2fac = 1./(1. + MAX(ri,0.0)) - ELSE - a2fac = 1. - ENDIF - - rfc = g1/( g1+g2 ) - f1 = b1*( g1-c1 ) +3.0*a2*a2fac *( 1.0 -c2 )*( 1.0-c5 ) & - & +2.0*a1*( 3.0-2.0*c2 ) - f2 = b1*( g1+g2 ) -3.0*a1*( 1.0 -c2 ) - rf1 = b1*( g1-c1 )/f1 - rf2 = b1* g1 /f2 - smc = a1 /(a2*a2fac)* f1/f2 - shc = 3.0*(a2*a2fac)*( g1+g2 ) - - ri1 = 0.5/smc - ri2 = rf1*smc - ri3 = 4.0*rf2*smc -2.0*ri2 - ri4 = ri2**2 - -! ** Flux Richardson number ** - rf = MIN( ri1*( ri + ri2-SQRT(ri**2 - ri3*ri + ri4) ), rfc ) -! - sh (k) = shc*( rfc-rf )/( 1.0-rf ) - sm (k) = smc*( rf1-rf )/( rf2-rf ) * sh(k) - END DO -! -! RETURN - -#ifdef HARDCODE_VERTICAL -# undef kts -# undef kte -#endif - - END SUBROUTINE mym_level2 -!! @} - -! ================================================================== -! SUBROUTINE mym_length: -! -! Input variables: see subroutine mym_initialize -! -! Output variables: see subroutine mym_initialize -! -! Work arrays: -! elt(nx,ny) : Length scale depending on the PBL depth (m) -! vsc(nx,ny) : Velocity scale q_c (m/s) -! at first, used for computing elt -! -! NOTE: the mixing lengths are meant to be calculated at the full- -! sigmal levels (or interfaces beween the model layers). -! -!>\ingroup gsd_mynn_edmf -!! This subroutine calculates the mixing lengths. - SUBROUTINE mym_length ( & - & kts,kte,xland, & - & dz, dx, zw, & - & rmo, flt, fltv, flq, & - & vt, vq, & - & u1, v1, qke, & - & dtv, & - & el, & - & zi, theta, qkw, & - & Psig_bl, cldfra_bl1D, & - & bl_mynn_mixlength, & - & edmf_w1,edmf_a1 ) - -!------------------------------------------------------------------- - - integer, intent(in) :: kts,kte - -#ifdef HARDCODE_VERTICAL -# define kts 1 -# define kte HARDCODE_VERTICAL -#endif - - integer, intent(in) :: bl_mynn_mixlength - real(kind_phys), dimension(kts:kte), intent(in) :: dz - real(kind_phys), dimension(kts:kte+1), intent(in) :: zw - real(kind_phys), intent(in) :: rmo,flt,fltv,flq,Psig_bl,xland - real(kind_phys), intent(in) :: dx,zi - real(kind_phys), dimension(kts:kte), intent(in) :: u1,v1, & - &qke,vt,vq,cldfra_bl1D,edmf_w1,edmf_a1 - real(kind_phys), dimension(kts:kte), intent(out) :: qkw, el - real(kind_phys), dimension(kts:kte), intent(in) :: dtv - real(kind_phys):: elt,vsc - real(kind_phys), dimension(kts:kte), intent(in) :: theta - real(kind_phys), dimension(kts:kte) :: qtke,elBLmin,elBLavg,thetaw - real(kind_phys):: wt,wt2,zi2,h1,h2,hs,elBLmin0,elBLavg0,cldavg - - ! THE FOLLOWING CONSTANTS ARE IMPORTANT FOR REGULATING THE - ! MIXING LENGTHS: - real(kind_phys):: cns, & !< for surface layer (els) in stable conditions - alp1, & !< for turbulent length scale (elt) - alp2, & !< for buoyancy length scale (elb) - alp3, & !< for buoyancy enhancement factor of elb - alp4, & !< for surface layer (els) in unstable conditions - alp5, & !< for BouLac mixing length or above PBLH - alp6 !< for mass-flux/ - - !THE FOLLOWING LIMITS DO NOT DIRECTLY AFFECT THE ACTUAL PBLH. - !THEY ONLY IMPOSE LIMITS ON THE CALCULATION OF THE MIXING LENGTH - !SCALES SO THAT THE BOULAC MIXING LENGTH (IN FREE ATMOS) DOES - !NOT ENCROACH UPON THE BOUNDARY LAYER MIXING LENGTH (els, elb & elt). - real(kind_phys), parameter :: minzi = 300. !< min mixed-layer height - real(kind_phys), parameter :: maxdz = 750. !< max (half) transition layer depth - !! =0.3*2500 m PBLH, so the transition - !! layer stops growing for PBLHs > 2.5 km. - real(kind_phys), parameter :: mindz = 300. !< 300 !min (half) transition layer depth - - !SURFACE LAYER LENGTH SCALE MODS TO REDUCE IMPACT IN UPPER BOUNDARY LAYER - real(kind_phys), parameter :: ZSLH = 100. !< Max height correlated to surface conditions (m) - real(kind_phys), parameter :: CSL = 2. !< CSL = constant of proportionality to L O(1) - real(kind_phys), parameter :: qke_elb_min = 0.018 - - integer :: i,j,k - real(kind_phys):: afk,abk,zwk,zwk1,dzk,qdz,vflx,bv,tau_cloud, & - & wstar,elb,els,elf,el_stab,el_mf,el_stab_mf,elb_mf, & - & PBLH_PLUS_ENT,Uonset,Ugrid,wt_u,el_les - real(kind_phys), parameter :: ctau = 1000. !constant for tau_cloud - -! tv0 = 0.61*tref -! gtr = 9.81/tref - - SELECT CASE(bl_mynn_mixlength) - - CASE (0) ! ORIGINAL MYNN MIXING LENGTH + BouLac - - cns = 2.7 - alp1 = 0.23 - alp2 = 1.0 - alp3 = 5.0 - alp4 = 100. - alp5 = 0.3 - - ! Impose limits on the height integration for elt and the transition layer depth - zi2 = MIN(10000.,zw(kte-2)) !originally integrated to model top, not just 10 km. - h1=MAX(0.3*zi2,mindz) - h1=MIN(h1,maxdz) ! 1/2 transition layer depth - h2=h1/2.0 ! 1/4 transition layer depth - - qkw(kts) = SQRT(MAX(qke(kts), qkemin)) - DO k = kts+1,kte - afk = dz(k)/( dz(k)+dz(k-1) ) - abk = 1.0 -afk - qkw(k) = SQRT(MAX(qke(k)*abk+qke(k-1)*afk, qkemin)) - END DO - - elt = 1.0e-5 - vsc = 1.0e-5 - - ! ** Strictly, zwk*h(i,j) -> ( zwk*h(i,j)+z0 ) ** - k = kts+1 - zwk = zw(k) - DO WHILE (zwk .LE. zi2+h1) - dzk = 0.5*( dz(k)+dz(k-1) ) - qdz = MAX( qkw(k)-qmin, 0.03 )*dzk - elt = elt +qdz*zwk - vsc = vsc +qdz - k = k+1 - zwk = zw(k) - END DO - - elt = alp1*elt/vsc - vflx = ( vt(kts)+1.0 )*flt +( vq(kts)+tv0 )*flq - vsc = ( gtr*elt*MAX( vflx, 0.0 ) )**onethird - - ! ** Strictly, el(i,k=1) is not zero. ** - el(kts) = 0.0 - zwk1 = zw(kts+1) - - DO k = kts+1,kte - zwk = zw(k) !full-sigma levels - - ! ** Length scale limited by the buoyancy effect ** - IF ( dtv(k) .GT. 0.0 ) THEN - bv = SQRT( gtr*dtv(k) ) - elb = alp2*qkw(k) / bv & - & *( 1.0 + alp3/alp2*& - &SQRT( vsc/( bv*elt ) ) ) - elf = alp2 * qkw(k)/bv - - ELSE - elb = 1.0e10 - elf = elb - ENDIF - - ! ** Length scale in the surface layer ** - IF ( rmo .GT. 0.0 ) THEN - els = karman*zwk/(1.0+cns*MIN( zwk*rmo, zmax )) - ELSE - els = karman*zwk*( 1.0 - alp4* zwk*rmo )**0.2 - END IF - - ! ** HARMONC AVERGING OF MIXING LENGTH SCALES: - ! el(k) = MIN(elb/( elb/elt+elb/els+1.0 ),elf) - ! el(k) = elb/( elb/elt+elb/els+1.0 ) - - wt=.5*TANH((zwk - (zi2+h1))/h2) + .5 - - el(k) = MIN(elb/( elb/elt+elb/els+1.0 ),elf) - - END DO - - CASE (1) !NONLOCAL (using BouLac) FORM OF MIXING LENGTH - - ugrid = sqrt(u1(kts)**2 + v1(kts)**2) - uonset= 15. - wt_u = (1.0 - min(max(ugrid - uonset, 0.0)/30.0, 0.5)) - cns = 3.5 - alp1 = 0.23 - alp2 = 0.3 - alp3 = 2.5 * wt_u !taper off bouyancy enhancement in shear-driven pbls - alp4 = 5.0 - alp5 = 0.3 - alp6 = 50. - - ! Impose limits on the height integration for elt and the transition layer depth - zi2 = MAX(zi,300.) !minzi) - h1 = MAX(0.3*zi2,300.) - h1 = MIN(h1,600.) ! 1/2 transition layer depth - h2 = h1/2.0 ! 1/4 transition layer depth - - qtke(kts) = MAX(0.5*qke(kts), 0.5*qkemin) !tke at full sigma levels - thetaw(kts) = theta(kts) !theta at full-sigma levels - qkw(kts) = SQRT(MAX(qke(kts), qkemin)) - - DO k = kts+1,kte - afk = dz(k)/( dz(k)+dz(k-1) ) - abk = 1.0 -afk - qkw(k) = SQRT(MAX(qke(k)*abk+qke(k-1)*afk, qkemin)) - qtke(k) = max(0.5*(qkw(k)**2), 0.005) ! q -> TKE - thetaw(k)= theta(k)*abk + theta(k-1)*afk - END DO - - elt = 1.0e-5 - vsc = 1.0e-5 - - ! ** Strictly, zwk*h(i,j) -> ( zwk*h(i,j)+z0 ) ** - k = kts+1 - zwk = zw(k) - DO WHILE (zwk .LE. zi2+h1) - dzk = 0.5*( dz(k)+dz(k-1) ) - qdz = min(max( qkw(k)-qmin, 0.01 ), 30.0)*dzk - elt = elt +qdz*zwk - vsc = vsc +qdz - k = k+1 - zwk = zw(k) - END DO - - elt = MIN( MAX( alp1*elt/vsc, 8.), 400.) - !avoid use of buoyancy flux functions which are ill-defined at the surface - !vflx = ( vt(kts)+1.0 )*flt + ( vq(kts)+tv0 )*flq - vflx = fltv - vsc = ( gtr*elt*MAX( vflx, 0.0 ) )**onethird - - ! ** Strictly, el(i,j,1) is not zero. ** - el(kts) = 0.0 - zwk1 = zw(kts+1) !full-sigma levels - - ! COMPUTE BouLac mixing length - CALL boulac_length(kts,kte,zw,dz,qtke,thetaw,elBLmin,elBLavg) - - DO k = kts+1,kte - zwk = zw(k) !full-sigma levels - - ! ** Length scale limited by the buoyancy effect ** - IF ( dtv(k) .GT. 0.0 ) THEN - bv = max( sqrt( gtr*dtv(k) ), 0.0001) - elb = MAX(alp2*max(qkw(k), qke_elb_min), & - & alp6*edmf_a1(k-1)*edmf_w1(k-1)) / bv & - & *( 1.0 + alp3*SQRT( vsc/(bv*elt) ) ) - elb = MIN(elb, zwk) - elf = 1.0 * max(qkw(k), qke_elb_min)/bv - elBLavg(k) = MAX(elBLavg(k), alp6*edmf_a1(k-1)*edmf_w1(k-1)/bv) - ELSE - elb = 1.0e10 - elf = elb - ENDIF - - ! ** Length scale in the surface layer ** - IF ( rmo .GT. 0.0 ) THEN - els = karman*zwk/(1.0+cns*MIN( zwk*rmo, zmax )) - ELSE - els = karman*zwk*( 1.0 - alp4* zwk*rmo )**0.2 - END IF - - ! ** NOW BLEND THE MIXING LENGTH SCALES: - wt=.5*TANH((zwk - (zi2+h1))/h2) + .5 - - !add blending to use BouLac mixing length in free atmos; - !defined relative to the PBLH (zi) + transition layer (h1) - !el(k) = MIN(elb/( elb/elt+elb/els+1.0 ),elf) - !try squared-blending - but take out elb (makes it underdiffusive) - !el(k) = SQRT( els**2/(1. + (els**2/elt**2) +(els**2/elb**2))) - el(k) = sqrt( els**2/(1. + (els**2/elt**2))) - el(k) = min(el(k), elb) - el(k) = min(el(k), elf) - el(k) = el(k)*(1.-wt) + alp5*elBLavg(k)*wt - - ! include scale-awareness, except for original MYNN - el(k) = el(k)*Psig_bl - - END DO - - CASE (2) !Local (mostly) mixing length formulation - - Uonset = 3.5 + dz(kts)*0.1 - Ugrid = sqrt(u1(kts)**2 + v1(kts)**2) - cns = 3.5 !JOE-test * (1.0 - MIN(MAX(Ugrid - Uonset, 0.0)/10.0, 1.0)) - alp1 = 0.22 - alp2 = 0.30 - alp3 = 2.0 - alp4 = 5.0 - alp5 = alp2 !like alp2, but for free atmosphere - alp6 = 50.0 !used for MF mixing length - - ! Impose limits on the height integration for elt and the transition layer depth - !zi2=MAX(zi,minzi) - zi2=MAX(zi, 300.) - !h1=MAX(0.3*zi2,mindz) - !h1=MIN(h1,maxdz) ! 1/2 transition layer depth - h1=MAX(0.3*zi2,300.) - h1=MIN(h1,600.) - h2=h1*0.5 ! 1/4 transition layer depth - - qtke(kts)=MAX(0.5*qke(kts), 0.5*qkemin) !tke at full sigma levels - qkw(kts) = SQRT(MAX(qke(kts), qkemin)) - - DO k = kts+1,kte - afk = dz(k)/( dz(k)+dz(k-1) ) - abk = 1.0 -afk - qkw(k) = SQRT(MAX(qke(k)*abk+qke(k-1)*afk, qkemin)) - qtke(k) = 0.5*qkw(k)**2 ! qkw -> TKE - END DO - - elt = 1.0e-5 - vsc = 1.0e-5 - - ! ** Strictly, zwk*h(i,j) -> ( zwk*h(i,j)+z0 ) ** - PBLH_PLUS_ENT = MAX(zi+h1, 100.) - k = kts+1 - zwk = zw(k) - DO WHILE (zwk .LE. PBLH_PLUS_ENT) - dzk = 0.5*( dz(k)+dz(k-1) ) - qdz = min(max( qkw(k)-qmin, 0.03 ), 30.0)*dzk - elt = elt +qdz*zwk - vsc = vsc +qdz - k = k+1 - zwk = zw(k) - END DO - - elt = MIN( MAX(alp1*elt/vsc, 10.), 400.) - !avoid use of buoyancy flux functions which are ill-defined at the surface - !vflx = ( vt(kts)+1.0 )*flt +( vq(kts)+tv0 )*flq - vflx = fltv - vsc = ( gtr*elt*MAX( vflx, 0.0 ) )**onethird - - ! ** Strictly, el(i,j,1) is not zero. ** - el(kts) = 0.0 - zwk1 = zw(kts+1) - - DO k = kts+1,kte - zwk = zw(k) !full-sigma levels - dzk = 0.5*( dz(k)+dz(k-1) ) - cldavg = 0.5*(cldfra_bl1D(k-1)+cldfra_bl1D(k)) - - ! ** Length scale limited by the buoyancy effect ** - IF ( dtv(k) .GT. 0.0 ) THEN - !impose min value on bv - bv = MAX( SQRT( gtr*dtv(k) ), 0.001) - !elb_mf = alp2*qkw(k) / bv & - elb_mf = MAX(alp2*qkw(k), & - & alp6*edmf_a1(k-1)*edmf_w1(k-1)) / bv & - & *( 1.0 + alp3*SQRT( vsc/( bv*elt ) ) ) - elb = MIN(MAX(alp5*qkw(k), alp6*edmf_a1(k)*edmf_w1(k))/bv, zwk) - - !tau_cloud = MIN(MAX(0.5*zi/((gtr*zi*MAX(vflx,1.0e-4))**onethird),30.),150.) - wstar = 1.25*(gtr*zi*MAX(vflx,1.0e-4))**onethird - tau_cloud = MIN(MAX(ctau * wstar/grav, 30.), 150.) - !minimize influence of surface heat flux on tau far away from the PBLH. - wt=.5*TANH((zwk - (zi2+h1))/h2) + .5 - tau_cloud = tau_cloud*(1.-wt) + 50.*wt - elf = MIN(MAX(tau_cloud*SQRT(MIN(qtke(k),40.)), & - & alp6*edmf_a1(k)*edmf_w1(k)/bv), zwk) - - !IF (zwk > zi .AND. elf > 400.) THEN - ! ! COMPUTE BouLac mixing length - ! !CALL boulac_length0(k,kts,kte,zw,dz,qtke,thetaw,elBLmin0,elBLavg0) - ! !elf = alp5*elBLavg0 - ! elf = MIN(MAX(50.*SQRT(qtke(k)), 400.), zwk) - !ENDIF - - ELSE - ! use version in development for RAP/HRRR 2016 - ! JAYMES- - ! tau_cloud is an eddy turnover timescale; - ! see Teixeira and Cheinet (2004), Eq. 1, and - ! Cheinet and Teixeira (2003), Eq. 7. The - ! coefficient 0.5 is tuneable. Expression in - ! denominator is identical to vsc (a convective - ! velocity scale), except that elt is relpaced - ! by zi, and zero is replaced by 1.0e-4 to - ! prevent division by zero. - !tau_cloud = MIN(MAX(0.5*zi/((gtr*zi*MAX(vflx,1.0e-4))**onethird),50.),150.) - wstar = 1.25*(gtr*zi*MAX(vflx,1.0e-4))**onethird - tau_cloud = MIN(MAX(ctau * wstar/grav, 50.), 200.) - !minimize influence of surface heat flux on tau far away from the PBLH. - wt=.5*TANH((zwk - (zi2+h1))/h2) + .5 - !tau_cloud = tau_cloud*(1.-wt) + 50.*wt - tau_cloud = tau_cloud*(1.-wt) + MAX(100.,dzk*0.25)*wt - - elb = MIN(tau_cloud*SQRT(MIN(qtke(k),40.)), zwk) - !elf = elb - elf = elb !/(1. + (elb/800.)) !bound free-atmos mixing length to < 800 m. - elb_mf = elb - END IF - elf = elf/(1. + (elf/800.)) !bound free-atmos mixing length to < 800 m. - elb_mf = MAX(elb_mf, 0.01) !to avoid divide-by-zero below - - ! ** Length scale in the surface layer ** - IF ( rmo .GT. 0.0 ) THEN - els = karman*zwk/(1.0+cns*MIN( zwk*rmo, zmax )) - ELSE - els = karman*zwk*( 1.0 - alp4* zwk*rmo )**0.2 - END IF - - ! ** NOW BLEND THE MIXING LENGTH SCALES: - wt=.5*TANH((zwk - (zi2+h1))/h2) + .5 - - !try squared-blending - el(k) = SQRT( els**2/(1. + (els**2/elt**2) +(els**2/elb_mf**2))) - el(k) = el(k)*(1.-wt) + elf*wt - - ! include scale-awareness. For now, use simple asymptotic kz -> 12 m (should be ~dz). - el_les= MIN(els/(1. + (els/12.)), elb_mf) - el(k) = el(k)*Psig_bl + (1.-Psig_bl)*el_les - - END DO - - END SELECT - - -#ifdef HARDCODE_VERTICAL -# undef kts -# undef kte -#endif - - END SUBROUTINE mym_length - -! ================================================================== -!>\ingroup gsd_mynn_edmf -!! This subroutine was taken from the BouLac scheme in WRF-ARW and modified for -!! integration into the MYNN PBL scheme. WHILE loops were added to reduce the -!! computational expense. This subroutine computes the length scales up and down -!! and then computes the min, average of the up/down length scales, and also -!! considers the distance to the surface. -!\param dlu the distance a parcel can be lifted upwards give a finite -! amount of TKE. -!\param dld the distance a parcel can be displaced downwards given a -! finite amount of TKE. -!\param lb1 the minimum of the length up and length down -!\param lb2 the average of the length up and length down - SUBROUTINE boulac_length0(k,kts,kte,zw,dz,qtke,theta,lb1,lb2) -! -! NOTE: This subroutine was taken from the BouLac scheme in WRF-ARW -! and modified for integration into the MYNN PBL scheme. -! WHILE loops were added to reduce the computational expense. -! This subroutine computes the length scales up and down -! and then computes the min, average of the up/down -! length scales, and also considers the distance to the -! surface. -! -! dlu = the distance a parcel can be lifted upwards give a finite -! amount of TKE. -! dld = the distance a parcel can be displaced downwards given a -! finite amount of TKE. -! lb1 = the minimum of the length up and length down -! lb2 = the average of the length up and length down -!------------------------------------------------------------------- - - integer, intent(in) :: k,kts,kte - real(kind_phys), dimension(kts:kte), intent(in) :: qtke,dz,theta - real(kind_phys), intent(out) :: lb1,lb2 - real(kind_phys), dimension(kts:kte+1), intent(in) :: zw - - !LOCAL VARS - integer :: izz, found - real(kind_phys):: dlu,dld - real(kind_phys):: dzt, zup, beta, zup_inf, bbb, tl, zdo, zdo_sup, zzz - - - !---------------------------------- - ! FIND DISTANCE UPWARD - !---------------------------------- - zup=0. - dlu=zw(kte+1)-zw(k)-dz(k)*0.5 - zzz=0. - zup_inf=0. - beta=gtr !Buoyancy coefficient (g/tref) - - !print*,"FINDING Dup, k=",k," zw=",zw(k) - - if (k .lt. kte) then !cant integrate upwards from highest level - found = 0 - izz=k - DO WHILE (found .EQ. 0) - - if (izz .lt. kte) then - dzt=dz(izz) ! layer depth above - zup=zup-beta*theta(k)*dzt ! initial PE the parcel has at k - !print*," ",k,izz,theta(izz),dz(izz) - zup=zup+beta*(theta(izz+1)+theta(izz))*dzt*0.5 ! PE gained by lifting a parcel to izz+1 - zzz=zzz+dzt ! depth of layer k to izz+1 - !print*," PE=",zup," TKE=",qtke(k)," z=",zw(izz) - if (qtke(k).lt.zup .and. qtke(k).ge.zup_inf) then - bbb=(theta(izz+1)-theta(izz))/dzt - if (bbb .ne. 0.) then - !fractional distance up into the layer where TKE becomes < PE - tl=(-beta*(theta(izz)-theta(k)) + & - & sqrt( max(0.,(beta*(theta(izz)-theta(k)))**2 + & - & 2.*bbb*beta*(qtke(k)-zup_inf))))/bbb/beta - else - if (theta(izz) .ne. theta(k))then - tl=(qtke(k)-zup_inf)/(beta*(theta(izz)-theta(k))) - else - tl=0. - endif - endif - dlu=zzz-dzt+tl - !print*," FOUND Dup:",dlu," z=",zw(izz)," tl=",tl - found =1 - endif - zup_inf=zup - izz=izz+1 - ELSE - found = 1 - ENDIF - - ENDDO - - endif - - !---------------------------------- - ! FIND DISTANCE DOWN - !---------------------------------- - zdo=0. - zdo_sup=0. - dld=zw(k) - zzz=0. - - !print*,"FINDING Ddown, k=",k," zwk=",zw(k) - if (k .gt. kts) then !cant integrate downwards from lowest level - - found = 0 - izz=k - DO WHILE (found .EQ. 0) - - if (izz .gt. kts) then - dzt=dz(izz-1) - zdo=zdo+beta*theta(k)*dzt - !print*," ",k,izz,theta(izz),dz(izz-1) - zdo=zdo-beta*(theta(izz-1)+theta(izz))*dzt*0.5 - zzz=zzz+dzt - !print*," PE=",zdo," TKE=",qtke(k)," z=",zw(izz) - if (qtke(k).lt.zdo .and. qtke(k).ge.zdo_sup) then - bbb=(theta(izz)-theta(izz-1))/dzt - if (bbb .ne. 0.) then - tl=(beta*(theta(izz)-theta(k))+ & - & sqrt( max(0.,(beta*(theta(izz)-theta(k)))**2 + & - & 2.*bbb*beta*(qtke(k)-zdo_sup))))/bbb/beta - else - if (theta(izz) .ne. theta(k)) then - tl=(qtke(k)-zdo_sup)/(beta*(theta(izz)-theta(k))) - else - tl=0. - endif - endif - dld=zzz-dzt+tl - !print*," FOUND Ddown:",dld," z=",zw(izz)," tl=",tl - found = 1 - endif - zdo_sup=zdo - izz=izz-1 - ELSE - found = 1 - ENDIF - ENDDO - - endif - - !---------------------------------- - ! GET MINIMUM (OR AVERAGE) - !---------------------------------- - !The surface layer length scale can exceed z for large z/L, - !so keep maximum distance down > z. - dld = min(dld,zw(k+1))!not used in PBL anyway, only free atmos - lb1 = min(dlu,dld) !minimum - !JOE-fight floating point errors - dlu=MAX(0.1,MIN(dlu,1000.)) - dld=MAX(0.1,MIN(dld,1000.)) - lb2 = sqrt(dlu*dld) !average - biased towards smallest - !lb2 = 0.5*(dlu+dld) !average - - if (k .eq. kte) then - lb1 = 0. - lb2 = 0. - endif - !print*,"IN MYNN-BouLac",k,lb1 - !print*,"IN MYNN-BouLac",k,dld,dlu - - END SUBROUTINE boulac_length0 - -! ================================================================== -!>\ingroup gsd_mynn_edmf -!! This subroutine was taken from the BouLac scheme in WRF-ARW -!! and modified for integration into the MYNN PBL scheme. -!! WHILE loops were added to reduce the computational expense. -!! This subroutine computes the length scales up and down -!! and then computes the min, average of the up/down -!! length scales, and also considers the distance to the -!! surface. - SUBROUTINE boulac_length(kts,kte,zw,dz,qtke,theta,lb1,lb2) -! dlu = the distance a parcel can be lifted upwards give a finite -! amount of TKE. -! dld = the distance a parcel can be displaced downwards given a -! finite amount of TKE. -! lb1 = the minimum of the length up and length down -! lb2 = the average of the length up and length down -!------------------------------------------------------------------- - - integer, intent(in) :: kts,kte - real(kind_phys), dimension(kts:kte), intent(in) :: qtke,dz,theta - real(kind_phys), dimension(kts:kte), intent(out):: lb1,lb2 - real(kind_phys), dimension(kts:kte+1), intent(in) :: zw - - !LOCAL VARS - integer :: iz, izz, found - real(kind_phys), dimension(kts:kte) :: dlu,dld - real(kind_phys), parameter :: Lmax=2000. !soft limit - real(kind_phys):: dzt, zup, beta, zup_inf, bbb, tl, zdo, zdo_sup, zzz - - !print*,"IN MYNN-BouLac",kts, kte - - do iz=kts,kte - - !---------------------------------- - ! FIND DISTANCE UPWARD - !---------------------------------- - zup=0. - dlu(iz)=zw(kte+1)-zw(iz)-dz(iz)*0.5 - zzz=0. - zup_inf=0. - beta=gtr !Buoyancy coefficient (g/tref) - - !print*,"FINDING Dup, k=",iz," zw=",zw(iz) - - if (iz .lt. kte) then !cant integrate upwards from highest level - - found = 0 - izz=iz - DO WHILE (found .EQ. 0) - - if (izz .lt. kte) then - dzt=dz(izz) ! layer depth above - zup=zup-beta*theta(iz)*dzt ! initial PE the parcel has at iz - !print*," ",iz,izz,theta(izz),dz(izz) - zup=zup+beta*(theta(izz+1)+theta(izz))*dzt*0.5 ! PE gained by lifting a parcel to izz+1 - zzz=zzz+dzt ! depth of layer iz to izz+1 - !print*," PE=",zup," TKE=",qtke(iz)," z=",zw(izz) - if (qtke(iz).lt.zup .and. qtke(iz).ge.zup_inf) then - bbb=(theta(izz+1)-theta(izz))/dzt - if (bbb .ne. 0.) then - !fractional distance up into the layer where TKE becomes < PE - tl=(-beta*(theta(izz)-theta(iz)) + & - & sqrt( max(0.,(beta*(theta(izz)-theta(iz)))**2 + & - & 2.*bbb*beta*(qtke(iz)-zup_inf))))/bbb/beta - else - if (theta(izz) .ne. theta(iz))then - tl=(qtke(iz)-zup_inf)/(beta*(theta(izz)-theta(iz))) - else - tl=0. - endif - endif - dlu(iz)=zzz-dzt+tl - !print*," FOUND Dup:",dlu(iz)," z=",zw(izz)," tl=",tl - found =1 - endif - zup_inf=zup - izz=izz+1 - ELSE - found = 1 - ENDIF - - ENDDO - - endif - - !---------------------------------- - ! FIND DISTANCE DOWN - !---------------------------------- - zdo=0. - zdo_sup=0. - dld(iz)=zw(iz) - zzz=0. - - !print*,"FINDING Ddown, k=",iz," zwk=",zw(iz) - if (iz .gt. kts) then !cant integrate downwards from lowest level - - found = 0 - izz=iz - DO WHILE (found .EQ. 0) - - if (izz .gt. kts) then - dzt=dz(izz-1) - zdo=zdo+beta*theta(iz)*dzt - !print*," ",iz,izz,theta(izz),dz(izz-1) - zdo=zdo-beta*(theta(izz-1)+theta(izz))*dzt*0.5 - zzz=zzz+dzt - !print*," PE=",zdo," TKE=",qtke(iz)," z=",zw(izz) - if (qtke(iz).lt.zdo .and. qtke(iz).ge.zdo_sup) then - bbb=(theta(izz)-theta(izz-1))/dzt - if (bbb .ne. 0.) then - tl=(beta*(theta(izz)-theta(iz))+ & - & sqrt( max(0.,(beta*(theta(izz)-theta(iz)))**2 + & - & 2.*bbb*beta*(qtke(iz)-zdo_sup))))/bbb/beta - else - if (theta(izz) .ne. theta(iz)) then - tl=(qtke(iz)-zdo_sup)/(beta*(theta(izz)-theta(iz))) - else - tl=0. - endif - endif - dld(iz)=zzz-dzt+tl - !print*," FOUND Ddown:",dld(iz)," z=",zw(izz)," tl=",tl - found = 1 - endif - zdo_sup=zdo - izz=izz-1 - ELSE - found = 1 - ENDIF - ENDDO - - endif - - !---------------------------------- - ! GET MINIMUM (OR AVERAGE) - !---------------------------------- - !The surface layer length scale can exceed z for large z/L, - !so keep maximum distance down > z. - dld(iz) = min(dld(iz),zw(iz+1))!not used in PBL anyway, only free atmos - lb1(iz) = min(dlu(iz),dld(iz)) !minimum - !JOE-fight floating point errors - dlu(iz)=MAX(0.1,MIN(dlu(iz),1000.)) - dld(iz)=MAX(0.1,MIN(dld(iz),1000.)) - lb2(iz) = sqrt(dlu(iz)*dld(iz)) !average - biased towards smallest - !lb2(iz) = 0.5*(dlu(iz)+dld(iz)) !average - - !Apply soft limit (only impacts very large lb; lb=100 by 5%, lb=500 by 20%). - lb1(iz) = lb1(iz)/(1. + (lb1(iz)/Lmax)) - lb2(iz) = lb2(iz)/(1. + (lb2(iz)/Lmax)) - - if (iz .eq. kte) then - lb1(kte) = lb1(kte-1) - lb2(kte) = lb2(kte-1) - endif - !print*,"IN MYNN-BouLac",kts, kte,lb1(iz) - !print*,"IN MYNN-BouLac",iz,dld(iz),dlu(iz) - - ENDDO - - END SUBROUTINE boulac_length -! -! ================================================================== -! SUBROUTINE mym_turbulence: -! -! Input variables: see subroutine mym_initialize -! closure : closure level (2.5, 2.6, or 3.0) -! -! # ql, vt, vq, qke, tsq, qsq and cov are changed to input variables. -! -! Output variables: see subroutine mym_initialize -! dfm(nx,nz,ny) : Diffusivity coefficient for momentum, -! divided by dz (not dz*h(i,j)) (m/s) -! dfh(nx,nz,ny) : Diffusivity coefficient for heat, -! divided by dz (not dz*h(i,j)) (m/s) -! dfq(nx,nz,ny) : Diffusivity coefficient for q^2, -! divided by dz (not dz*h(i,j)) (m/s) -! tcd(nx,nz,ny) : Countergradient diffusion term for Theta_l -! (K/s) -! qcd(nx,nz,ny) : Countergradient diffusion term for Q_w -! (kg/kg s) -! pd?(nx,nz,ny) : Half of the production terms -! -! Only tcd and qcd are defined at the center of the grid boxes -! -! # DO NOT forget that tcd and qcd are added on the right-hand side -! of the equations for Theta_l and Q_w, respectively. -! -! Work arrays: see subroutine mym_initialize and level2 -! -! # dtl, dqw, dtv, gm and gh are allowed to share storage units with -! dfm, dfh, dfq, tcd and qcd, respectively, for saving memory. -! -!>\ingroup gsd_mynn_edmf -!! This subroutine calculates the vertical diffusivity coefficients and the -!! production terms for the turbulent quantities. -!>\section gen_mym_turbulence GSD mym_turbulence General Algorithm -!! Two subroutines mym_level2() and mym_length() are called within this -!!subrouine to collect variable to carry out successive calculations: -!! - mym_level2() calculates the level 2 nondimensional wind shear \f$G_M\f$ -!! and vertical temperature gradient \f$G_H\f$ as well as the level 2 stability -!! functions \f$S_h\f$ and \f$S_m\f$. -!! - mym_length() calculates the mixing lengths. -!! - The stability criteria from Helfand and Labraga (1989) are applied. -!! - The stability functions for level 2.5 or level 3.0 are calculated. -!! - If level 3.0 is used, counter-gradient terms are calculated. -!! - Production terms of TKE,\f$\theta^{'2}\f$,\f$q^{'2}\f$, and \f$\theta^{'}q^{'}\f$ -!! are calculated. -!! - Eddy diffusivity \f$K_h\f$ and eddy viscosity \f$K_m\f$ are calculated. -!! - TKE budget terms are calculated (if the namelist parameter \p tke_budget -!! is set to True) - SUBROUTINE mym_turbulence ( & - & kts,kte, & - & xland,closure, & - & dz, dx, zw, & - & u, v, thl, thetav, ql, qw, & - & qke, tsq, qsq, cov, & - & vt, vq, & - & rmo, flt, fltv, flq, & - & zi,theta, & - & sh, sm, & - & El, & - & Dfm, Dfh, Dfq, Tcd, Qcd, Pdk, Pdt, Pdq, Pdc, & - & qWT1D,qSHEAR1D,qBUOY1D,qDISS1D, & - & tke_budget, & - & Psig_bl,Psig_shcu,cldfra_bl1D, & - & bl_mynn_mixlength, & - & edmf_w1,edmf_a1, & - & TKEprodTD, & - & spp_pbl,rstoch_col ) - -!------------------------------------------------------------------- - - integer, intent(in) :: kts,kte - -#ifdef HARDCODE_VERTICAL -# define kts 1 -# define kte HARDCODE_VERTICAL -#endif - - integer, intent(in) :: bl_mynn_mixlength,tke_budget - real(kind_phys), intent(in) :: closure - real(kind_phys), dimension(kts:kte), intent(in) :: dz - real(kind_phys), dimension(kts:kte+1), intent(in) :: zw - real(kind_phys), intent(in) :: rmo,flt,fltv,flq, & - &Psig_bl,Psig_shcu,xland,dx,zi - real(kind_phys), dimension(kts:kte), intent(in) :: u,v,thl,thetav,qw, & - &ql,vt,vq,qke,tsq,qsq,cov,cldfra_bl1D,edmf_w1,edmf_a1, & - &TKEprodTD - - real(kind_phys), dimension(kts:kte), intent(out) :: dfm,dfh,dfq, & - &pdk,pdt,pdq,pdc,tcd,qcd,el - - real(kind_phys), dimension(kts:kte), intent(inout) :: & - qWT1D,qSHEAR1D,qBUOY1D,qDISS1D - real(kind_phys):: q3sq_old,dlsq1,qWTP_old,qWTP_new - real(kind_phys):: dudz,dvdz,dTdz,upwp,vpwp,Tpwp - - real(kind_phys), dimension(kts:kte) :: qkw,dtl,dqw,dtv,gm,gh,sm,sh - - integer :: k -! real(kind_phys):: cc2,cc3,e1c,e2c,e3c,e4c,e5c - real(kind_phys):: e6c,dzk,afk,abk,vtt,vqq, & - &cw25,clow,cupp,gamt,gamq,smd,gamv,elq,elh - - real(kind_phys):: cldavg - real(kind_phys), dimension(kts:kte), intent(in) :: theta - - real(kind_phys):: a2fac, duz, ri !JOE-Canuto/Kitamura mod - - real:: auh,aum,adh,adm,aeh,aem,Req,Rsl,Rsl2, & - gmelq,sm20,sh20,sm25max,sh25max,sm25min,sh25min, & - sm_pbl,sh_pbl,zi2,wt,slht,wtpr - - DOUBLE PRECISION q2sq, t2sq, r2sq, c2sq, elsq, gmel, ghel - DOUBLE PRECISION q3sq, t3sq, r3sq, c3sq, dlsq, qdiv - DOUBLE PRECISION e1, e2, e3, e4, enum, eden, wden - -! Stochastic - integer, intent(in) :: spp_pbl - real(kind_phys), dimension(kts:kte) :: rstoch_col - real(kind_phys):: Prnum, shb - real(kind_phys), parameter :: Prlimit = 5.0 - -! -! tv0 = 0.61*tref -! gtr = 9.81/tref -! -! cc2 = 1.0-c2 -! cc3 = 1.0-c3 -! e1c = 3.0*a2*b2*cc3 -! e2c = 9.0*a1*a2*cc2 -! e3c = 9.0*a2*a2*cc2*( 1.0-c5 ) -! e4c = 12.0*a1*a2*cc2 -! e5c = 6.0*a1*a1 -! - - CALL mym_level2 (kts,kte, & - & dz, & - & u, v, thl, thetav, qw, & - & ql, vt, vq, & - & dtl, dqw, dtv, gm, gh, sm, sh ) -! - CALL mym_length ( & - & kts,kte,xland, & - & dz, dx, zw, & - & rmo, flt, fltv, flq, & - & vt, vq, & - & u, v, qke, & - & dtv, & - & el, & - & zi,theta, & - & qkw,Psig_bl,cldfra_bl1D, & - & bl_mynn_mixlength, & - & edmf_w1,edmf_a1 ) -! - - DO k = kts+1,kte - dzk = 0.5 *( dz(k)+dz(k-1) ) - afk = dz(k)/( dz(k)+dz(k-1) ) - abk = 1.0 -afk - elsq = el (k)**2 - q3sq = qkw(k)**2 - q2sq = b1*elsq*( sm(k)*gm(k)+sh(k)*gh(k) ) - - sh20 = MAX(sh(k), 1e-5) - sm20 = MAX(sm(k), 1e-5) - sh(k)= MAX(sh(k), 1e-5) - - !Canuto/Kitamura mod - duz = ( u(k)-u(k-1) )**2 +( v(k)-v(k-1) )**2 - duz = duz /dzk**2 - ! ** Gradient Richardson number ** - ri = -gh(k)/MAX( duz, 1.0e-10 ) - IF (CKmod .eq. 1) THEN - a2fac = 1./(1. + MAX(ri,0.0)) - ELSE - a2fac = 1. - ENDIF - !end Canuto/Kitamura mod - - !level 2.0 Prandtl number - !Prnum = MIN(sm20/sh20, 4.0) - !The form of Zilitinkevich et al. (2006) but modified - !half-way towards Esau and Grachev (2007, Wind Eng) - !Prnum = MIN(0.76 + 3.0*MAX(ri,0.0), Prlimit) - Prnum = MIN(0.76 + 4.0*MAX(ri,0.0), Prlimit) - !Prnum = MIN(0.76 + 5.0*MAX(ri,0.0), Prlimit) -! -! Modified: Dec/22/2005, from here, (dlsq -> elsq) - gmel = gm (k)*elsq - ghel = gh (k)*elsq -! Modified: Dec/22/2005, up to here - - ! Level 2.0 debug prints - IF ( debug_code ) THEN - IF (sh(k)<0.0 .OR. sm(k)<0.0) THEN - print*,"MYNN; mym_turbulence 2.0; sh=",sh(k)," k=",k - print*," gm=",gm(k)," gh=",gh(k)," sm=",sm(k) - print*," q2sq=",q2sq," q3sq=",q3sq," q3/q2=",q3sq/q2sq - print*," qke=",qke(k)," el=",el(k)," ri=",ri - print*," PBLH=",zi," u=",u(k)," v=",v(k) - ENDIF - ENDIF - -! ** Since qkw is set to more than 0.0, q3sq > 0.0. ** - -! new stability criteria in level 2.5 (as well as level 3) - little/no impact -! ** Limitation on q, instead of L/q ** - dlsq = elsq - IF ( q3sq/dlsq .LT. -gh(k) ) q3sq = -dlsq*gh(k) - - IF ( q3sq .LT. q2sq ) THEN - !Apply Helfand & Labraga mod - qdiv = SQRT( q3sq/q2sq ) !HL89: (1-alfa) -! - !Use level 2.5 stability functions - !e1 = q3sq - e1c*ghel*a2fac - !e2 = q3sq - e2c*ghel*a2fac - !e3 = e1 + e3c*ghel*a2fac**2 - !e4 = e1 - e4c*ghel*a2fac - !eden = e2*e4 + e3*e5c*gmel - !eden = MAX( eden, 1.0d-20 ) - !sm(k) = q3sq*a1*( e3-3.0*c1*e4 )/eden - !!JOE-Canuto/Kitamura mod - !!sh(k) = q3sq*a2*( e2+3.0*c1*e5c*gmel )/eden - !sh(k) = q3sq*(a2*a2fac)*( e2+3.0*c1*e5c*gmel )/eden - !sm(k) = Prnum*sh(k) - !sm(k) = sm(k) * qdiv - - !Use level 2.0 functions as in original MYNN - sh(k) = sh(k) * qdiv - sm(k) = sm(k) * qdiv - ! !sm_pbl = sm(k) * qdiv - ! - ! !Or, use the simple Pr relationship - ! sm(k) = Prnum*sh(k) - ! - ! !or blend them: - ! zi2 = MAX(zi, 300.) - ! wt =.5*TANH((zw(k) - zi2)/200.) + .5 - ! sm(k) = sm_pbl*(1.-wt) + sm(k)*wt - - !Recalculate terms for later use - !JOE-Canuto/Kitamura mod - !e1 = q3sq - e1c*ghel * qdiv**2 - !e2 = q3sq - e2c*ghel * qdiv**2 - !e3 = e1 + e3c*ghel * qdiv**2 - !e4 = e1 - e4c*ghel * qdiv**2 - e1 = q3sq - e1c*ghel*a2fac * qdiv**2 - e2 = q3sq - e2c*ghel*a2fac * qdiv**2 - e3 = e1 + e3c*ghel*a2fac**2 * qdiv**2 - e4 = e1 - e4c*ghel*a2fac * qdiv**2 - eden = e2*e4 + e3*e5c*gmel * qdiv**2 - eden = MAX( eden, 1.0d-20 ) - !!JOE-Canuto/Kitamura mod - !!sh(k) = q3sq*a2*( e2+3.0*c1*e5c*gmel )/eden - retro 5 - !sh(k) = q3sq*(a2*a2fac)*( e2+3.0*c1*e5c*gmel )/eden - !sm(k) = Prnum*sh(k) - ELSE - !JOE-Canuto/Kitamura mod - !e1 = q3sq - e1c*ghel - !e2 = q3sq - e2c*ghel - !e3 = e1 + e3c*ghel - !e4 = e1 - e4c*ghel - e1 = q3sq - e1c*ghel*a2fac - e2 = q3sq - e2c*ghel*a2fac - e3 = e1 + e3c*ghel*a2fac**2 - e4 = e1 - e4c*ghel*a2fac - eden = e2*e4 + e3*e5c*gmel - eden = MAX( eden, 1.0d-20 ) - - qdiv = 1.0 - !Use level 2.5 stability functions - sm(k) = q3sq*a1*( e3-3.0*c1*e4 )/eden - ! sm_pbl = q3sq*a1*( e3-3.0*c1*e4 )/eden - !!JOE-Canuto/Kitamura mod - !!sh(k) = q3sq*a2*( e2+3.0*c1*e5c*gmel )/eden - sh(k) = q3sq*(a2*a2fac)*( e2+3.0*c1*e5c*gmel )/eden - ! sm(k) = Prnum*sh(k) - - ! !or blend them: - ! zi2 = MAX(zi, 300.) - ! wt = .5*TANH((zw(k) - zi2)/200.) + .5 - ! sm(k) = sm_pbl*(1.-wt) + sm(k)*wt - END IF !end Helfand & Labraga check - - !Impose broad limits on Sh and Sm: - gmelq = MAX(gmel/q3sq, 1e-8) - sm25max = 4. !MIN(sm20*3.0, SQRT(.1936/gmelq)) - sh25max = 4. !MIN(sh20*3.0, 0.76*b2) - sm25min = 0.0 !MAX(sm20*0.1, 1e-6) - sh25min = 0.0 !MAX(sh20*0.1, 1e-6) - - !JOE: Level 2.5 debug prints - ! HL88 , lev2.5 criteria from eqs. 3.17, 3.19, & 3.20 - IF ( debug_code ) THEN - IF ((sh(k)sh25max .OR. sm(k)>sm25max) ) THEN - print*,"In mym_turbulence 2.5: k=",k - print*," sm=",sm(k)," sh=",sh(k) - print*," ri=",ri," Pr=",sm(k)/MAX(sh(k),1e-8) - print*," gm=",gm(k)," gh=",gh(k) - print*," q2sq=",q2sq," q3sq=",q3sq, q3sq/q2sq - print*," qke=",qke(k)," el=",el(k) - print*," PBLH=",zi," u=",u(k)," v=",v(k) - print*," SMnum=",q3sq*a1*( e3-3.0*c1*e4)," SMdenom=",eden - print*," SHnum=",q3sq*(a2*a2fac)*( e2+3.0*c1*e5c*gmel ),& - " SHdenom=",eden - ENDIF - ENDIF - - !Enforce constraints for level 2.5 functions - IF ( sh(k) > sh25max ) sh(k) = sh25max - IF ( sh(k) < sh25min ) sh(k) = sh25min - !IF ( sm(k) > sm25max ) sm(k) = sm25max - !IF ( sm(k) < sm25min ) sm(k) = sm25min - !sm(k) = Prnum*sh(k) - - !surface layer PR - !slht = zi*0.1 - !wtpr = min( max( (slht - zw(k))/slht, 0.0), 1.0) ! 1 at z=0, 0 above sfc layer - !Prlim = 1.0*wtpr + (1.0 - wtpr)*Prlimit - !Prlim = 2.0*wtpr + (1.0 - wtpr)*Prlimit - !sm(k) = MIN(sm(k), Prlim*Sh(k)) - !Pending more testing, keep same Pr limit in sfc layer - shb = max(sh(k), 0.02) - sm(k) = MIN(sm(k), Prlimit*shb) - -! ** Level 3 : start ** - IF ( closure .GE. 3.0 ) THEN - t2sq = qdiv*b2*elsq*sh(k)*dtl(k)**2 - r2sq = qdiv*b2*elsq*sh(k)*dqw(k)**2 - c2sq = qdiv*b2*elsq*sh(k)*dtl(k)*dqw(k) - t3sq = MAX( tsq(k)*abk+tsq(k-1)*afk, 0.0 ) - r3sq = MAX( qsq(k)*abk+qsq(k-1)*afk, 0.0 ) - c3sq = cov(k)*abk+cov(k-1)*afk - -! Modified: Dec/22/2005, from here - c3sq = SIGN( MIN( ABS(c3sq), SQRT(t3sq*r3sq) ), c3sq ) -! - vtt = 1.0 +vt(k)*abk +vt(k-1)*afk - vqq = tv0 +vq(k)*abk +vq(k-1)*afk - - t2sq = vtt*t2sq +vqq*c2sq - r2sq = vtt*c2sq +vqq*r2sq - c2sq = MAX( vtt*t2sq+vqq*r2sq, 0.0d0 ) - t3sq = vtt*t3sq +vqq*c3sq - r3sq = vtt*c3sq +vqq*r3sq - c3sq = MAX( vtt*t3sq+vqq*r3sq, 0.0d0 ) -! - cw25 = e1*( e2 + 3.0*c1*e5c*gmel*qdiv**2 )/( 3.0*eden ) -! -! ** Limitation on q, instead of L/q ** - dlsq = elsq - IF ( q3sq/dlsq .LT. -gh(k) ) q3sq = -dlsq*gh(k) -! -! ** Limitation on c3sq (0.12 =< cw =< 0.76) ** - ! Use Janjic's (2001; p 13-17) methodology (eqs 4.11-414 and 5.7-5.10) - ! to calculate an exact limit for c3sq: - auh = 27.*a1*((a2*a2fac)**2)*b2*(gtr)**2 - aum = 54.*(a1**2)*(a2*a2fac)*b2*c1*(gtr) - adh = 9.*a1*((a2*a2fac)**2)*(12.*a1 + 3.*b2)*(gtr)**2 - adm = 18.*(a1**2)*(a2*a2fac)*(b2 - 3.*(a2*a2fac))*(gtr) - - aeh = (9.*a1*((a2*a2fac)**2)*b1 +9.*a1*((a2*a2fac)**2)* & - (12.*a1 + 3.*b2))*(gtr) - aem = 3.*a1*(a2*a2fac)*b1*(3.*(a2*a2fac) + 3.*b2*c1 + & - (18.*a1*c1 - b2)) + & - (18.)*(a1**2)*(a2*a2fac)*(b2 - 3.*(a2*a2fac)) - - Req = -aeh/aem - Rsl = (auh + aum*Req)/(3.*adh + 3.*adm*Req) - !For now, use default values, since tests showed little/no sensitivity - Rsl = .12 !lower limit - Rsl2= 1.0 - 2.*Rsl !upper limit - !IF (k==2)print*,"Dynamic limit RSL=",Rsl - !IF (Rsl < 0.10 .OR. Rsl > 0.18) THEN - ! print*,'--- ERROR: MYNN: Dynamic Cw '// & - ! 'limit exceeds reasonable limits' - ! print*," MYNN: Dynamic Cw limit needs attention=",Rsl - !ENDIF - - !JOE-Canuto/Kitamura mod - !e2 = q3sq - e2c*ghel * qdiv**2 - !e3 = q3sq + e3c*ghel * qdiv**2 - !e4 = q3sq - e4c*ghel * qdiv**2 - e2 = q3sq - e2c*ghel*a2fac * qdiv**2 - e3 = q3sq + e3c*ghel*a2fac**2 * qdiv**2 - e4 = q3sq - e4c*ghel*a2fac * qdiv**2 - eden = e2*e4 + e3 *e5c*gmel * qdiv**2 - - !JOE-Canuto/Kitamura mod - !wden = cc3*gtr**2 * dlsq**2/elsq * qdiv**2 & - ! & *( e2*e4c - e3c*e5c*gmel * qdiv**2 ) - wden = cc3*gtr**2 * dlsq**2/elsq * qdiv**2 & - & *( e2*e4c*a2fac - e3c*e5c*gmel*a2fac**2 * qdiv**2 ) - - IF ( wden .NE. 0.0 ) THEN - !JOE: test dynamic limits - clow = q3sq*( 0.12-cw25 )*eden/wden - cupp = q3sq*( 0.76-cw25 )*eden/wden - !clow = q3sq*( Rsl -cw25 )*eden/wden - !cupp = q3sq*( Rsl2-cw25 )*eden/wden -! - IF ( wden .GT. 0.0 ) THEN - c3sq = MIN( MAX( c3sq, c2sq+clow ), c2sq+cupp ) - ELSE - c3sq = MAX( MIN( c3sq, c2sq+clow ), c2sq+cupp ) - END IF - END IF -! - e1 = e2 + e5c*gmel * qdiv**2 - eden = MAX( eden, 1.0d-20 ) -! Modified: Dec/22/2005, up to here - - !JOE-Canuto/Kitamura mod - !e6c = 3.0*a2*cc3*gtr * dlsq/elsq - e6c = 3.0*(a2*a2fac)*cc3*gtr * dlsq/elsq - - !============================ - ! ** for Gamma_theta ** - !! enum = qdiv*e6c*( t3sq-t2sq ) - IF ( t2sq .GE. 0.0 ) THEN - enum = MAX( qdiv*e6c*( t3sq-t2sq ), 0.0d0 ) - ELSE - enum = MIN( qdiv*e6c*( t3sq-t2sq ), 0.0d0 ) - ENDIF - gamt =-e1 *enum /eden - - !============================ - ! ** for Gamma_q ** - !! enum = qdiv*e6c*( r3sq-r2sq ) - IF ( r2sq .GE. 0.0 ) THEN - enum = MAX( qdiv*e6c*( r3sq-r2sq ), 0.0d0 ) - ELSE - enum = MIN( qdiv*e6c*( r3sq-r2sq ), 0.0d0 ) - ENDIF - gamq =-e1 *enum /eden - - !============================ - ! ** for Sm' and Sh'd(Theta_V)/dz ** - !! enum = qdiv*e6c*( c3sq-c2sq ) - enum = MAX( qdiv*e6c*( c3sq-c2sq ), 0.0d0) - - !JOE-Canuto/Kitamura mod - !smd = dlsq*enum*gtr/eden * qdiv**2 * (e3c+e4c)*a1/a2 - smd = dlsq*enum*gtr/eden * qdiv**2 * (e3c*a2fac**2 + & - & e4c*a2fac)*a1/(a2*a2fac) - - gamv = e1 *enum*gtr/eden - sm(k) = sm(k) +smd - - !============================ - ! ** For elh (see below), qdiv at Level 3 is reset to 1.0. ** - qdiv = 1.0 - - ! Level 3 debug prints - IF ( debug_code ) THEN - IF (sh(k)<-0.3 .OR. sm(k)<-0.3 .OR. & - qke(k) < -0.1 .or. ABS(smd) .gt. 2.0) THEN - print*," MYNN; mym_turbulence3.0; sh=",sh(k)," k=",k - print*," gm=",gm(k)," gh=",gh(k)," sm=",sm(k) - print*," q2sq=",q2sq," q3sq=",q3sq," q3/q2=",q3sq/q2sq - print*," qke=",qke(k)," el=",el(k)," ri=",ri - print*," PBLH=",zi," u=",u(k)," v=",v(k) - ENDIF - ENDIF - -! ** Level 3 : end ** - - ELSE -! ** At Level 2.5, qdiv is not reset. ** - gamt = 0.0 - gamq = 0.0 - gamv = 0.0 - END IF -! -! Add min background stability function (diffusivity) within model levels -! with active plumes and clouds. - cldavg = 0.5*(cldfra_bl1D(k-1) + cldfra_bl1D(k)) - IF (edmf_a1(k) > 0.001 .OR. cldavg > 0.02) THEN - ! for mass-flux columns - sm(k) = MAX(sm(k), 0.03*MIN(10.*edmf_a1(k)*edmf_w1(k),1.0) ) - sh(k) = MAX(sh(k), 0.03*MIN(10.*edmf_a1(k)*edmf_w1(k),1.0) ) - ! for clouds - sm(k) = MAX(sm(k), 0.05*MIN(cldavg,1.0) ) - sh(k) = MAX(sh(k), 0.05*MIN(cldavg,1.0) ) - ENDIF -! - elq = el(k)*qkw(k) - elh = elq*qdiv - - ! Production of TKE (pdk), T-variance (pdt), - ! q-variance (pdq), and covariance (pdc) - pdk(k) = elq*( sm(k)*gm(k) & - & +sh(k)*gh(k)+gamv ) + & - & 0.5*TKEprodTD(k) ! xmchen - pdt(k) = elh*( sh(k)*dtl(k)+gamt )*dtl(k) - pdq(k) = elh*( sh(k)*dqw(k)+gamq )*dqw(k) - pdc(k) = elh*( sh(k)*dtl(k)+gamt ) & - & *dqw(k)*0.5 & - & + elh*( sh(k)*dqw(k)+gamq )*dtl(k)*0.5 - - ! Contergradient terms - tcd(k) = elq*gamt - qcd(k) = elq*gamq - - ! Eddy Diffusivity/Viscosity divided by dz - dfm(k) = elq*sm(k) / dzk - dfh(k) = elq*sh(k) / dzk -! Modified: Dec/22/2005, from here -! ** In sub.mym_predict, dfq for the TKE and scalar variance ** -! ** are set to 3.0*dfm and 1.0*dfm, respectively. (Sqfac) ** - dfq(k) = dfm(k) -! Modified: Dec/22/2005, up to here - - IF (tke_budget .eq. 1) THEN - !TKE BUDGET -! dudz = ( u(k)-u(k-1) )/dzk -! dvdz = ( v(k)-v(k-1) )/dzk -! dTdz = ( thl(k)-thl(k-1) )/dzk - -! upwp = -elq*sm(k)*dudz -! vpwp = -elq*sm(k)*dvdz -! Tpwp = -elq*sh(k)*dTdz -! Tpwp = SIGN(MAX(ABS(Tpwp),1.E-6),Tpwp) - - -!! TKE budget (Puhales, 2020, WRF 4.2.1) << EOB - - !!!Shear Term - !!!qSHEAR1D(k)=-(upwp*dudz + vpwp*dvdz) - qSHEAR1D(k) = elq*sm(k)*gm(k) !staggered - - !!!Buoyancy Term - !!!qBUOY1D(k)=grav*Tpwp/thl(k) - !qBUOY1D(k)= elq*(sh(k)*gh(k) + gamv) - !qBUOY1D(k) = elq*(sh(k)*(-dTdz*grav/thl(k)) + gamv) !! ORIGINAL CODE - - !! Buoyncy term takes the TKEprodTD(k) production now - qBUOY1D(k) = elq*(sh(k)*gh(k)+gamv)+0.5*TKEprodTD(k) ! xmchen - - !!!Dissipation Term (now it evaluated in mym_predict) - !qDISS1D(k) = (q3sq**(3./2.))/(b1*MAX(el(k),1.)) !! ORIGINAL CODE - - !! >> EOB - ENDIF - - END DO -! - - dfm(kts) = 0.0 - dfh(kts) = 0.0 - dfq(kts) = 0.0 - tcd(kts) = 0.0 - qcd(kts) = 0.0 - - tcd(kte) = 0.0 - qcd(kte) = 0.0 - -! - DO k = kts,kte-1 - dzk = dz(k) - tcd(k) = ( tcd(k+1)-tcd(k) )/( dzk ) - qcd(k) = ( qcd(k+1)-qcd(k) )/( dzk ) - END DO -! - if (spp_pbl==1) then - DO k = kts,kte - dfm(k)= dfm(k) + dfm(k)* rstoch_col(k) * 1.5 * MAX(exp(-MAX(zw(k)-8000.,0.0)/2000.),0.001) - dfh(k)= dfh(k) + dfh(k)* rstoch_col(k) * 1.5 * MAX(exp(-MAX(zw(k)-8000.,0.0)/2000.),0.001) - END DO - endif - -! RETURN -#ifdef HARDCODE_VERTICAL -# undef kts -# undef kte -#endif - - END SUBROUTINE mym_turbulence - -! ================================================================== -! SUBROUTINE mym_predict: -! -! Input variables: see subroutine mym_initialize and turbulence -! qke(nx,nz,ny) : qke at (n)th time level -! tsq, ...cov : ditto -! -! Output variables: -! qke(nx,nz,ny) : qke at (n+1)th time level -! tsq, ...cov : ditto -! -! Work arrays: -! qkw(nx,nz,ny) : q at the center of the grid boxes (m/s) -! bp (nx,nz,ny) : = 1/2*F, see below -! rp (nx,nz,ny) : = P-1/2*F*Q, see below -! -! # The equation for a turbulent quantity Q can be expressed as -! dQ/dt + Ah + Av = Dh + Dv + P - F*Q, (1) -! where A is the advection, D the diffusion, P the production, -! F*Q the dissipation and h and v denote horizontal and vertical, -! respectively. If Q is q^2, F is 2q/B_1L. -! Using the Crank-Nicholson scheme for Av, Dv and F*Q, a finite -! difference equation is written as -! Q{n+1} - Q{n} = dt *( Dh{n} - Ah{n} + P{n} ) -! + dt/2*( Dv{n} - Av{n} - F*Q{n} ) -! + dt/2*( Dv{n+1} - Av{n+1} - F*Q{n+1} ), (2) -! where n denotes the time level. -! When the advection and diffusion terms are discretized as -! dt/2*( Dv - Av ) = a(k)Q(k+1) - b(k)Q(k) + c(k)Q(k-1), (3) -! Eq.(2) can be rewritten as -! - a(k)Q(k+1) + [ 1 + b(k) + dt/2*F ]Q(k) - c(k)Q(k-1) -! = Q{n} + dt *( Dh{n} - Ah{n} + P{n} ) -! + dt/2*( Dv{n} - Av{n} - F*Q{n} ), (4) -! where Q on the left-hand side is at (n+1)th time level. -! -! In this subroutine, a(k), b(k) and c(k) are obtained from -! subprogram coefvu and are passed to subprogram tinteg via -! common. 1/2*F and P-1/2*F*Q are stored in bp and rp, -! respectively. Subprogram tinteg solves Eq.(4). -! -! Modify this subroutine according to your numerical integration -! scheme (program). -! -!------------------------------------------------------------------- -!>\ingroup gsd_mynn_edmf -!! This subroutine predicts the turbulent quantities at the next step. - SUBROUTINE mym_predict (kts,kte, & - & closure, & - & delt, & - & dz, & - & ust, flt, flq, pmz, phh, & - & el, dfq, rho, & - & pdk, pdt, pdq, pdc, & - & qke, tsq, qsq, cov, & - & s_aw,s_awqke,bl_mynn_edmf_tke, & - & qWT1D, qDISS1D,tke_budget) !! TKE budget (Puhales, 2020) - -!------------------------------------------------------------------- - integer, intent(in) :: kts,kte - -#ifdef HARDCODE_VERTICAL -# define kts 1 -# define kte HARDCODE_VERTICAL -#endif - - real(kind_phys), intent(in) :: closure - integer, intent(in) :: bl_mynn_edmf_tke,tke_budget - real(kind_phys), dimension(kts:kte), intent(in) :: dz, dfq, el, rho - real(kind_phys), dimension(kts:kte), intent(inout) :: pdk, pdt, pdq, pdc - real(kind_phys), intent(in) :: flt, flq, pmz, phh - real(kind_phys), intent(in) :: ust, delt - real(kind_phys), dimension(kts:kte), intent(inout) :: qke,tsq, qsq, cov -! WA 8/3/15 - real(kind_phys), dimension(kts:kte+1), intent(inout) :: s_awqke,s_aw - - !! TKE budget (Puhales, 2020, WRF 4.2.1) << EOB - real(kind_phys), dimension(kts:kte), intent(out) :: qWT1D, qDISS1D - real(kind_phys), dimension(kts:kte) :: tke_up,dzinv - !! >> EOB - - integer :: k - real(kind_phys), dimension(kts:kte) :: qkw, bp, rp, df3q - real(kind_phys):: vkz,pdk1,phm,pdt1,pdq1,pdc1,b1l,b2l,onoff - real(kind_phys), dimension(kts:kte) :: dtz - real(kind_phys), dimension(kts:kte) :: a,b,c,d,x - - real(kind_phys), dimension(kts:kte) :: rhoinv - real(kind_phys), dimension(kts:kte+1) :: rhoz,kqdz,kmdz - - ! REGULATE THE MOMENTUM MIXING FROM THE MASS-FLUX SCHEME (on or off) - IF (bl_mynn_edmf_tke == 0) THEN - onoff=0.0 - ELSE - onoff=1.0 - ENDIF - -! ** Strictly, vkz*h(i,j) -> karman*( 0.5*dz(1)*h(i,j)+z0 ) ** - vkz = karman*0.5*dz(kts) -! -! ** dfq for the TKE is 3.0*dfm. ** -! - DO k = kts,kte -!! qke(k) = MAX(qke(k), 0.0) - qkw(k) = SQRT( MAX( qke(k), 0.0 ) ) - df3q(k)=Sqfac*dfq(k) - dtz(k)=delt/dz(k) - END DO -! -!JOE-add conservation + stability criteria - !Prepare "constants" for diffusion equation. - !khdz = rho*Kh/dz = rho*dfh - rhoz(kts) =rho(kts) - rhoinv(kts)=1./rho(kts) - kqdz(kts) =rhoz(kts)*df3q(kts) - kmdz(kts) =rhoz(kts)*dfq(kts) - DO k=kts+1,kte - rhoz(k) =(rho(k)*dz(k-1) + rho(k-1)*dz(k))/(dz(k-1)+dz(k)) - rhoz(k) = MAX(rhoz(k),1E-4) - rhoinv(k)=1./MAX(rho(k),1E-4) - kqdz(k) = rhoz(k)*df3q(k) ! for TKE - kmdz(k) = rhoz(k)*dfq(k) ! for T'2, q'2, and T'q' - ENDDO - rhoz(kte+1)=rhoz(kte) - kqdz(kte+1)=rhoz(kte+1)*df3q(kte) - kmdz(kte+1)=rhoz(kte+1)*dfq(kte) - - !stability criteria for mf - DO k=kts+1,kte-1 - kqdz(k) = MAX(kqdz(k), 0.5* s_aw(k)) - kqdz(k) = MAX(kqdz(k), -0.5*(s_aw(k)-s_aw(k+1))) - kmdz(k) = MAX(kmdz(k), 0.5* s_aw(k)) - kmdz(k) = MAX(kmdz(k), -0.5*(s_aw(k)-s_aw(k+1))) - ENDDO - !end conservation mods - - pdk1 = 2.0*ust**3*pmz/( vkz ) - phm = 2.0/ust *phh/( vkz ) - pdt1 = phm*flt**2 - pdq1 = phm*flq**2 - pdc1 = phm*flt*flq -! -! ** pdk(1)+pdk(2) corresponds to pdk1. ** - pdk(kts) = pdk1 - pdk(kts+1) - -!! pdt(kts) = pdt1 -pdt(kts+1) -!! pdq(kts) = pdq1 -pdq(kts+1) -!! pdc(kts) = pdc1 -pdc(kts+1) - pdt(kts) = pdt(kts+1) - pdq(kts) = pdq(kts+1) - pdc(kts) = pdc(kts+1) -! -! ** Prediction of twice the turbulent kinetic energy ** -!! DO k = kts+1,kte-1 - DO k = kts,kte-1 - b1l = b1*0.5*( el(k+1)+el(k) ) - bp(k) = 2.*qkw(k) / b1l - rp(k) = pdk(k+1) + pdk(k) - END DO - -!! a(1)=0. -!! b(1)=1. -!! c(1)=-1. -!! d(1)=0. - -! Since df3q(kts)=0.0, a(1)=0.0 and b(1)=1.+dtz(k)*df3q(k+1)+bp(k)*delt. - DO k=kts,kte-1 -! a(k-kts+1)=-dtz(k)*df3q(k) -! b(k-kts+1)=1.+dtz(k)*(df3q(k)+df3q(k+1))+bp(k)*delt -! c(k-kts+1)=-dtz(k)*df3q(k+1) -! d(k-kts+1)=rp(k)*delt + qke(k) -! WA 8/3/15 add EDMF contribution -! a(k)= - dtz(k)*df3q(k) + 0.5*dtz(k)*s_aw(k)*onoff -! b(k)=1. + dtz(k)*(df3q(k)+df3q(k+1)) & -! + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))*onoff + bp(k)*delt -! c(k)= - dtz(k)*df3q(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff -! d(k)=rp(k)*delt + qke(k) + dtz(k)*(s_awqke(k)-s_awqke(k+1))*onoff -!JOE 8/22/20 improve conservation - a(k)= - dtz(k)*kqdz(k)*rhoinv(k) & - & + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*onoff - b(k)=1. + dtz(k)*(kqdz(k)+kqdz(k+1))*rhoinv(k) & - & + 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*onoff & - & + bp(k)*delt - c(k)= - dtz(k)*kqdz(k+1)*rhoinv(k) & - & - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff - d(k)=rp(k)*delt + qke(k) & - & + dtz(k)*rhoinv(k)*(s_awqke(k)-s_awqke(k+1))*onoff - ENDDO - -!! DO k=kts+1,kte-1 -!! a(k-kts+1)=-dtz(k)*df3q(k) -!! b(k-kts+1)=1.+dtz(k)*(df3q(k)+df3q(k+1)) -!! c(k-kts+1)=-dtz(k)*df3q(k+1) -!! d(k-kts+1)=rp(k)*delt + qke(k) - qke(k)*bp(k)*delt -!! ENDDO - -!! "no flux at top" -! a(kte)=-1. !0. -! b(kte)=1. -! c(kte)=0. -! d(kte)=0. -!! "prescribed value" - a(kte)=0. - b(kte)=1. - c(kte)=0. - d(kte)=qke(kte) - -! CALL tridiag(kte,a,b,c,d) - CALL tridiag2(kte,a,b,c,d,x) - - DO k=kts,kte -! qke(k)=max(d(k-kts+1), qkemin) - qke(k)=max(x(k), qkemin) - qke(k)=min(qke(k), 150.) - ENDDO - - -!! TKE budget (Puhales, 2020, WRF 4.2.1) << EOB - IF (tke_budget .eq. 1) THEN - !! TKE Vertical transport << EOBvt - tke_up=0.5*qke - dzinv=1./dz - k=kts - qWT1D(k)=dzinv(k)*( & - & (kqdz(k+1)*(tke_up(k+1)-tke_up(k))-kqdz(k)*tke_up(k)) & - & + 0.5*rhoinv(k)*(s_aw(k+1)*tke_up(k+1) & - & + (s_aw(k+1)-s_aw(k))*tke_up(k) & - & + (s_awqke(k)-s_awqke(k+1)))*onoff) !unstaggered - DO k=kts+1,kte-1 - qWT1D(k)=dzinv(k)*( & - & (kqdz(k+1)*(tke_up(k+1)-tke_up(k))-kqdz(k)*(tke_up(k)-tke_up(k-1))) & - & + 0.5*rhoinv(k)*(s_aw(k+1)*tke_up(k+1) & - & + (s_aw(k+1)-s_aw(k))*tke_up(k) & - & - s_aw(k)*tke_up(k-1) & - & + (s_awqke(k)-s_awqke(k+1)))*onoff) !unstaggered - ENDDO - k=kte - qWT1D(k)=dzinv(k)*(-kqdz(k)*(tke_up(k)-tke_up(k-1)) & - & + 0.5*rhoinv(k)*(-s_aw(k)*tke_up(k)-s_aw(k)*tke_up(k-1)+s_awqke(k))*onoff) !unstaggered - !! >> EOBvt - qDISS1D=bp*tke_up !! TKE dissipation rate !unstaggered - END IF -!! >> EOB - - IF ( closure > 2.5 ) THEN - - ! ** Prediction of the moisture variance ** - DO k = kts,kte-1 - b2l = b2*0.5*( el(k+1)+el(k) ) - bp(k) = 2.*qkw(k) / b2l - rp(k) = pdq(k+1) + pdq(k) - END DO - - !zero gradient for qsq at bottom and top - !a(1)=0. - !b(1)=1. - !c(1)=-1. - !d(1)=0. - - ! Since dfq(kts)=0.0, a(1)=0.0 and b(1)=1.+dtz(k)*dfq(k+1)+bp(k)*delt. - DO k=kts,kte-1 - a(k)= - dtz(k)*kmdz(k)*rhoinv(k) - b(k)=1. + dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) + bp(k)*delt - c(k)= - dtz(k)*kmdz(k+1)*rhoinv(k) - d(k)=rp(k)*delt + qsq(k) - ENDDO - - a(kte)=-1. !0. - b(kte)=1. - c(kte)=0. - d(kte)=0. - -! CALL tridiag(kte,a,b,c,d) - CALL tridiag2(kte,a,b,c,d,x) - - DO k=kts,kte - !qsq(k)=d(k-kts+1) - qsq(k)=MAX(x(k),1e-17) - ENDDO - ELSE - !level 2.5 - use level 2 diagnostic - DO k = kts,kte-1 - IF ( qkw(k) .LE. 0.0 ) THEN - b2l = 0.0 - ELSE - b2l = b2*0.25*( el(k+1)+el(k) )/qkw(k) - END IF - qsq(k) = b2l*( pdq(k+1)+pdq(k) ) - END DO - qsq(kte)=qsq(kte-1) - END IF -!!!!!!!!!!!!!!!!!!!!!!end level 2.6 - - IF ( closure .GE. 3.0 ) THEN -! -! ** dfq for the scalar variance is 1.0*dfm. ** -! -! ** Prediction of the temperature variance ** -!! DO k = kts+1,kte-1 - DO k = kts,kte-1 - b2l = b2*0.5*( el(k+1)+el(k) ) - bp(k) = 2.*qkw(k) / b2l - rp(k) = pdt(k+1) + pdt(k) - END DO - -!zero gradient for tsq at bottom and top - -!! a(1)=0. -!! b(1)=1. -!! c(1)=-1. -!! d(1)=0. - -! Since dfq(kts)=0.0, a(1)=0.0 and b(1)=1.+dtz(k)*dfq(k+1)+bp(k)*delt. - DO k=kts,kte-1 - !a(k-kts+1)=-dtz(k)*dfq(k) - !b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1))+bp(k)*delt - !c(k-kts+1)=-dtz(k)*dfq(k+1) - !d(k-kts+1)=rp(k)*delt + tsq(k) -!JOE 8/22/20 improve conservation - a(k)= - dtz(k)*kmdz(k)*rhoinv(k) - b(k)=1. + dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) + bp(k)*delt - c(k)= - dtz(k)*kmdz(k+1)*rhoinv(k) - d(k)=rp(k)*delt + tsq(k) - ENDDO - -!! DO k=kts+1,kte-1 -!! a(k-kts+1)=-dtz(k)*dfq(k) -!! b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1)) -!! c(k-kts+1)=-dtz(k)*dfq(k+1) -!! d(k-kts+1)=rp(k)*delt + tsq(k) - tsq(k)*bp(k)*delt -!! ENDDO - - a(kte)=-1. !0. - b(kte)=1. - c(kte)=0. - d(kte)=0. - -! CALL tridiag(kte,a,b,c,d) - CALL tridiag2(kte,a,b,c,d,x) - - DO k=kts,kte -! tsq(k)=d(k-kts+1) - tsq(k)=x(k) - ENDDO - -! ** Prediction of the temperature-moisture covariance ** -!! DO k = kts+1,kte-1 - DO k = kts,kte-1 - b2l = b2*0.5*( el(k+1)+el(k) ) - bp(k) = 2.*qkw(k) / b2l - rp(k) = pdc(k+1) + pdc(k) - END DO - -!zero gradient for tqcov at bottom and top - -!! a(1)=0. -!! b(1)=1. -!! c(1)=-1. -!! d(1)=0. - -! Since dfq(kts)=0.0, a(1)=0.0 and b(1)=1.+dtz(k)*dfq(k+1)+bp(k)*delt. - DO k=kts,kte-1 - !a(k-kts+1)=-dtz(k)*dfq(k) - !b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1))+bp(k)*delt - !c(k-kts+1)=-dtz(k)*dfq(k+1) - !d(k-kts+1)=rp(k)*delt + cov(k) -!JOE 8/22/20 improve conservation - a(k)= - dtz(k)*kmdz(k)*rhoinv(k) - b(k)=1. + dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) + bp(k)*delt - c(k)= - dtz(k)*kmdz(k+1)*rhoinv(k) - d(k)=rp(k)*delt + cov(k) - ENDDO - -!! DO k=kts+1,kte-1 -!! a(k-kts+1)=-dtz(k)*dfq(k) -!! b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1)) -!! c(k-kts+1)=-dtz(k)*dfq(k+1) -!! d(k-kts+1)=rp(k)*delt + cov(k) - cov(k)*bp(k)*delt -!! ENDDO - - a(kte)=-1. !0. - b(kte)=1. - c(kte)=0. - d(kte)=0. - -! CALL tridiag(kte,a,b,c,d) - CALL tridiag2(kte,a,b,c,d,x) - - DO k=kts,kte -! cov(k)=d(k-kts+1) - cov(k)=x(k) - ENDDO - - ELSE - - !Not level 3 - default to level 2 diagnostic - DO k = kts,kte-1 - IF ( qkw(k) .LE. 0.0 ) THEN - b2l = 0.0 - ELSE - b2l = b2*0.25*( el(k+1)+el(k) )/qkw(k) - END IF -! - tsq(k) = b2l*( pdt(k+1)+pdt(k) ) - cov(k) = b2l*( pdc(k+1)+pdc(k) ) - END DO - - tsq(kte)=tsq(kte-1) - cov(kte)=cov(kte-1) - - END IF - -#ifdef HARDCODE_VERTICAL -# undef kts -# undef kte -#endif - - END SUBROUTINE mym_predict - -! ================================================================== -! SUBROUTINE mym_condensation: -! -! Input variables: see subroutine mym_initialize and turbulence -! exner(nz) : Perturbation of the Exner function (J/kg K) -! defined on the walls of the grid boxes -! This is usually computed by integrating -! d(pi)/dz = h*g*tv/tref**2 -! from the upper boundary, where tv is the -! virtual potential temperature minus tref. -! -! Output variables: see subroutine mym_initialize -! cld(nx,nz,ny) : Cloud fraction -! -! Work arrays/variables: -! qmq : Q_w-Q_{sl}, where Q_{sl} is the saturation -! specific humidity at T=Tl -! alp(nx,nz,ny) : Functions in the condensation process -! bet(nx,nz,ny) : ditto -! sgm(nx,nz,ny) : Combined standard deviation sigma_s -! multiplied by 2/alp -! -! # qmq, alp, bet and sgm are allowed to share storage units with -! any four of other work arrays for saving memory. -! -! # Results are sensitive particularly to values of cp and r_d. -! Set these values to those adopted by you. -! -!------------------------------------------------------------------- -!>\ingroup gsd_mynn_edmf -!! This subroutine calculates the nonconvective component of the -!! subgrid cloud fraction and mixing ratio as well as the functions used to -!! calculate the buoyancy flux. Different cloud PDFs can be selected by -!! use of the namelist parameter \p bl_mynn_cloudpdf . - SUBROUTINE mym_condensation (kts,kte, & - & dx, dz, zw, xland, & - & thl, qw, qv, qc, qi, qs, & - & p,exner, & - & tsq, qsq, cov, & - & Sh, el, bl_mynn_cloudpdf, & - & qc_bl1D, qi_bl1D, & - & cldfra_bl1D, & - & PBLH1,HFX1, & - & Vt, Vq, th, sgm, rmo, & - & spp_pbl,rstoch_col ) - -!------------------------------------------------------------------- - - integer, intent(in) :: kts,kte, bl_mynn_cloudpdf - -#ifdef HARDCODE_VERTICAL -# define kts 1 -# define kte HARDCODE_VERTICAL -#endif - - real(kind_phys), intent(in) :: HFX1,rmo,xland - real(kind_phys), intent(in) :: dx,pblh1 - real(kind_phys), dimension(kts:kte), intent(in) :: dz - real(kind_phys), dimension(kts:kte+1), intent(in) :: zw - real(kind_phys), dimension(kts:kte), intent(in) :: p,exner,thl,qw, & - &qv,qc,qi,qs,tsq,qsq,cov,th - - real(kind_phys), dimension(kts:kte), intent(inout) :: vt,vq,sgm - - real(kind_phys), dimension(kts:kte) :: alp,a,bet,b,ql,q1,RH - real(kind_phys), dimension(kts:kte), intent(out) :: qc_bl1D,qi_bl1D, & - &cldfra_bl1D - DOUBLE PRECISION :: t3sq, r3sq, c3sq - - real(kind_phys):: qsl,esat,qsat,dqsl,cld0,q1k,qlk,eq1,qll, & - &q2p,pt,rac,qt,t,xl,rsl,cpm,Fng,qww,alpha,beta,bb, & - &ls,wt,wt2,qpct,cld_factor,fac_damp,liq_frac,ql_ice,ql_water, & - &qmq,qsat_tk,q1_rh,rh_hack,dzm1,zsl,maxqc - real(kind_phys), parameter :: qpct_sfc=0.025 - real(kind_phys), parameter :: qpct_pbl=0.030 - real(kind_phys), parameter :: qpct_trp=0.040 - real(kind_phys), parameter :: rhcrit =0.83 !for cloudpdf = 2 - real(kind_phys), parameter :: rhmax =1.02 !for cloudpdf = 2 - integer :: i,j,k - - real(kind_phys):: erf - - !VARIABLES FOR ALTERNATIVE SIGMA - real:: dth,dtl,dqw,dzk,els - real(kind_phys), dimension(kts:kte), intent(in) :: Sh,el - - !variables for SGS BL clouds - real(kind_phys) :: zagl,damp,PBLH2 - real(kind_phys) :: cfmax - - !JAYMES: variables for tropopause-height estimation - real(kind_phys) :: theta1, theta2, ht1, ht2 - integer :: k_tropo - -! Stochastic - integer, intent(in) :: spp_pbl - real(kind_phys), dimension(kts:kte) :: rstoch_col - real(kind_phys) :: qw_pert - -! First, obtain an estimate for the tropopause height (k), using the method employed in the -! Thompson subgrid-cloud scheme. This height will be a consideration later when determining -! the "final" subgrid-cloud properties. -! JAYMES: added 3 Nov 2016, adapted from G. Thompson - - DO k = kte-3, kts, -1 - theta1 = th(k) - theta2 = th(k+2) - ht1 = 44307.692 * (1.0 - (p(k)/101325.)**0.190) - ht2 = 44307.692 * (1.0 - (p(k+2)/101325.)**0.190) - if ( (((theta2-theta1)/(ht2-ht1)) .lt. 10./1500. ) .AND. & - & (ht1.lt.19000.) .and. (ht1.gt.4000.) ) then - goto 86 - endif - ENDDO - 86 continue - k_tropo = MAX(kts+2, k+2) - - zagl = 0. - - SELECT CASE(bl_mynn_cloudpdf) - - CASE (0) ! ORIGINAL MYNN PARTIAL-CONDENSATION SCHEME - - DO k = kts,kte-1 - t = th(k)*exner(k) - -!x if ( ct .gt. 0.0 ) then -! a = 17.27 -! b = 237.3 -!x else -!x a = 21.87 -!x b = 265.5 -!x end if -! -! ** 3.8 = 0.622*6.11 (hPa) ** - - !SATURATED VAPOR PRESSURE - esat = esat_blend(t) - !SATURATED SPECIFIC HUMIDITY - !qsl=ep_2*esat/(p(k)-ep_3*esat) - qsl=ep_2*esat/max(1.e-4,(p(k)-ep_3*esat)) - !dqw/dT: Clausius-Clapeyron - dqsl = qsl*ep_2*xlv/( r_d*t**2 ) - - alp(k) = 1.0/( 1.0+dqsl*xlvcp ) - bet(k) = dqsl*exner(k) - - !Sommeria and Deardorff (1977) scheme, as implemented - !in Nakanishi and Niino (2009), Appendix B - t3sq = MAX( tsq(k), 0.0 ) - r3sq = MAX( qsq(k), 0.0 ) - c3sq = cov(k) - c3sq = SIGN( MIN( ABS(c3sq), SQRT(t3sq*r3sq) ), c3sq ) - r3sq = r3sq +bet(k)**2*t3sq -2.0*bet(k)*c3sq - !DEFICIT/EXCESS WATER CONTENT - qmq = qw(k) -qsl - !ORIGINAL STANDARD DEVIATION - sgm(k) = SQRT( MAX( r3sq, 1.0d-10 )) - !NORMALIZED DEPARTURE FROM SATURATION - q1(k) = qmq / sgm(k) - !CLOUD FRACTION. rr2 = 1/SQRT(2) = 0.707 - cldfra_bl1D(k) = 0.5*( 1.0+erf( q1(k)*rr2 ) ) - - q1k = q1(k) - eq1 = rrp*EXP( -0.5*q1k*q1k ) - qll = MAX( cldfra_bl1D(k)*q1k + eq1, 0.0 ) - !ESTIMATED LIQUID WATER CONTENT (UNNORMALIZED) - ql(k) = alp(k)*sgm(k)*qll - !LIMIT SPECIES TO TEMPERATURE RANGES - liq_frac = min(1.0, max(0.0,(t-240.0)/29.0)) - qc_bl1D(k) = liq_frac*ql(k) - qi_bl1D(k) = (1.0 - liq_frac)*ql(k) - - !Now estimate the buoyancy flux functions - q2p = xlvcp/exner(k) - pt = thl(k) +q2p*ql(k) ! potential temp - - !qt is a THETA-V CONVERSION FOR TOTAL WATER (i.e., THETA-V = qt*THETA) - qt = 1.0 +p608*qw(k) -(1.+p608)*(qc_bl1D(k)+qi_bl1D(k))*cldfra_bl1D(k) - rac = alp(k)*( cldfra_bl1D(K)-qll*eq1 )*( q2p*qt-(1.+p608)*pt ) - - !BUOYANCY FACTORS: wherever vt and vq are used, there is a - !"+1" and "+tv0", respectively, so these are subtracted out here. - !vt is unitless and vq has units of K. - vt(k) = qt-1.0 -rac*bet(k) - vq(k) = p608*pt-tv0 +rac - - END DO - - CASE (1, -1) !ALTERNATIVE FORM (Nakanishi & Niino 2004 BLM, eq. B6, and - !Kuwano-Yoshida et al. 2010 QJRMS, eq. 7): - DO k = kts,kte-1 - t = th(k)*exner(k) - !SATURATED VAPOR PRESSURE - esat = esat_blend(t) - !SATURATED SPECIFIC HUMIDITY - !qsl=ep_2*esat/(p(k)-ep_3*esat) - qsl=ep_2*esat/max(1.e-4,(p(k)-ep_3*esat)) - !dqw/dT: Clausius-Clapeyron - dqsl = qsl*ep_2*xlv/( r_d*t**2 ) - - alp(k) = 1.0/( 1.0+dqsl*xlvcp ) - bet(k) = dqsl*exner(k) - - if (k .eq. kts) then - dzk = 0.5*dz(k) - else - dzk = dz(k) - end if - dth = 0.5*(thl(k+1)+thl(k)) - 0.5*(thl(k)+thl(MAX(k-1,kts))) - dqw = 0.5*(qw(k+1) + qw(k)) - 0.5*(qw(k) + qw(MAX(k-1,kts))) - sgm(k) = SQRT( MAX( (alp(k)**2 * MAX(el(k)**2,0.1) * & - b2 * MAX(Sh(k),0.03))/4. * & - (dqw/dzk - bet(k)*(dth/dzk ))**2 , 1.0e-10) ) - qmq = qw(k) -qsl - q1(k) = qmq / sgm(k) - cldfra_bl1D(K) = 0.5*( 1.0+erf( q1(k)*rr2 ) ) - - !now compute estimated lwc for PBL scheme's use - !qll IS THE NORMALIZED LIQUID WATER CONTENT (Sommeria and - !Deardorff (1977, eq 29a). rrp = 1/(sqrt(2*pi)) = 0.3989 - q1k = q1(k) - eq1 = rrp*EXP( -0.5*q1k*q1k ) - qll = MAX( cldfra_bl1D(K)*q1k + eq1, 0.0 ) - !ESTIMATED LIQUID WATER CONTENT (UNNORMALIZED) - ql (k) = alp(k)*sgm(k)*qll - liq_frac = min(1.0, max(0.0,(t-240.0)/29.0)) - qc_bl1D(k) = liq_frac*ql(k) - qi_bl1D(k) = (1.0 - liq_frac)*ql(k) - - !Now estimate the buoyancy flux functions - q2p = xlvcp/exner(k) - pt = thl(k) +q2p*ql(k) ! potential temp - - !qt is a THETA-V CONVERSION FOR TOTAL WATER (i.e., THETA-V = qt*THETA) - qt = 1.0 +p608*qw(k) -(1.+p608)*(qc_bl1D(k)+qi_bl1D(k))*cldfra_bl1D(k) - rac = alp(k)*( cldfra_bl1D(K)-qll*eq1 )*( q2p*qt-(1.+p608)*pt ) - - !BUOYANCY FACTORS: wherever vt and vq are used, there is a - !"+1" and "+tv0", respectively, so these are subtracted out here. - !vt is unitless and vq has units of K. - vt(k) = qt-1.0 -rac*bet(k) - vq(k) = p608*pt-tv0 +rac - - END DO - - CASE (2, -2) - - !Diagnostic statistical scheme of Chaboureau and Bechtold (2002), JAS - !but with use of higher-order moments to estimate sigma - pblh2=MAX(10._kind_phys,pblh1) - zagl = 0. - dzm1 = 0. - DO k = kts,kte-1 - zagl = zagl + 0.5*(dz(k) + dzm1) - dzm1 = dz(k) - - t = th(k)*exner(k) - xl = xl_blend(t) ! obtain latent heat - qsat_tk= qsat_blend(t, p(k)) ! saturation water vapor mixing ratio at tk and p - rh(k) = MAX(MIN(rhmax, qw(k)/MAX(1.E-10,qsat_tk)),0.001_kind_phys) - - !dqw/dT: Clausius-Clapeyron - dqsl = qsat_tk*ep_2*xlv/( r_d*t**2 ) - alp(k) = 1.0/( 1.0+dqsl*xlvcp ) - bet(k) = dqsl*exner(k) - - rsl = xl*qsat_tk / (r_v*t**2) ! slope of C-C curve at t (=abs temperature) - ! CB02, Eqn. 4 - cpm = cp + qw(k)*cpv ! CB02, sec. 2, para. 1 - a(k) = 1./(1. + xl*rsl/cpm) ! CB02 variable "a" - b(k) = a(k)*rsl ! CB02 variable "b" - - !SPP - qw_pert= qw(k) + qw(k)*0.5*rstoch_col(k)*real(spp_pbl) - - !This form of qmq (the numerator of Q1) no longer uses the a(k) factor - qmq = qw_pert - qsat_tk ! saturation deficit/excess; - - !Use the form of Eq. (6) in Chaboureau and Bechtold (2002) - !except neglect all but the first term for sig_r - r3sq = max( qsq(k), 0.0 ) - !Calculate sigma using higher-order moments: - sgm(k) = SQRT( r3sq ) - !Set constraints on sigma relative to saturation water vapor - sgm(k) = min( sgm(k), qsat_tk*0.666 ) - !sgm(k) = max( sgm(k), qsat_tk*0.035 ) - - !introduce vertical grid spacing dependence on min sgm - wt = max(500. - max(dz(k)-100.,0.0), 0.0_kind_phys)/500. !=1 for dz < 100 m, =0 for dz > 600 m - sgm(k) = sgm(k) + sgm(k)*0.2*(1.0-wt) !inflate sgm for coarse dz - - !allow min sgm to vary with dz and z. - qpct = qpct_pbl*wt + qpct_trp*(1.0-wt) - qpct = min(qpct, max(qpct_sfc, qpct_pbl*zagl/500.) ) - sgm(k) = max( sgm(k), qsat_tk*qpct ) - - q1(k) = qmq / sgm(k) ! Q1, the normalized saturation - - !Add condition for falling/settling into low-RH layers, so at least - !some cloud fraction is applied for all qc, qs, and qi. - rh_hack= rh(k) - wt2 = min(max( zagl - pblh2, 0.0 )/300., 1.0) - !ensure adequate RH & q1 when qi is at least 1e-9 (above the PBLH) - if ((qi(k)+qs(k))>1.e-9 .and. (zagl .gt. pblh2)) then - rh_hack =min(rhmax, rhcrit + wt2*0.045*(9.0 + log10(qi(k)+qs(k)))) - rh(k) =max(rh(k), rh_hack) - !add rh-based q1 - q1_rh =-3. + 3.*(rh(k)-rhcrit)/(1.-rhcrit) - q1(k) =max(q1_rh, q1(k) ) - endif - !ensure adequate rh & q1 when qc is at least 1e-6 (above the PBLH) - if (qc(k)>1.e-6 .and. (zagl .gt. pblh2)) then - rh_hack =min(rhmax, rhcrit + wt2*0.08*(6.0 + log10(qc(k)))) - rh(k) =max(rh(k), rh_hack) - !add rh-based q1 - q1_rh =-3. + 3.*(rh(k)-rhcrit)/(1.-rhcrit) - q1(k) =max(q1_rh, q1(k) ) - endif - - q1k = q1(k) ! backup Q1 for later modification - - ! Specify cloud fraction - !Original C-B cloud fraction, allows cloud fractions out to q1 = -3.5 - !cldfra_bl1D(K) = max(0., min(1., 0.5+0.36*atan(1.55*q1(k)))) ! Eq. 7 in CB02 - !Waynes LES fit - over-diffuse, when limits removed from vt & vq & fng - !cldfra_bl1D(K) = max(0., min(1., 0.5+0.36*atan(1.2*(q1(k)+0.4)))) - !Best compromise: Improves marine stratus without adding much cold bias. - cldfra_bl1D(k) = max(0., min(1., 0.5+0.36*atan(1.8*(q1(k)+0.2)))) - - ! Specify hydrometeors - ! JAYMES- this option added 8 May 2015 - ! The cloud water formulations are taken from CB02, Eq. 8. - maxqc = max(qw(k) - qsat_tk, 0.0) - if (q1k < 0.) then !unsaturated - ql_water = sgm(k)*exp(1.2*q1k-1.) - ql_ice = sgm(k)*exp(1.2*q1k-1.) - elseif (q1k > 2.) then !supersaturated - ql_water = min(sgm(k)*q1k, maxqc) - ql_ice = sgm(k)*q1k - else !slightly saturated (0 > q1 < 2) - ql_water = min(sgm(k)*(exp(-1.) + 0.66*q1k + 0.086*q1k**2), maxqc) - ql_ice = sgm(k)*(exp(-1.) + 0.66*q1k + 0.086*q1k**2) - endif - - !In saturated grid cells, use average of SGS and resolved values - !if ( qc(k) > 1.e-6 ) ql_water = 0.5 * ( ql_water + qc(k) ) - !ql_ice is actually the total frozen condensate (snow+ice), - !if ( (qi(k)+qs(k)) > 1.e-9 ) ql_ice = 0.5 * ( ql_ice + (qi(k)+qs(k)) ) - - if (cldfra_bl1D(k) < 0.001) then - ql_ice = 0.0 - ql_water = 0.0 - cldfra_bl1D(k) = 0.0 - endif - - liq_frac = MIN(1.0, MAX(0.0, (t-tice)/(tliq-tice))) - qc_bl1D(k) = liq_frac*ql_water ! apply liq_frac to ql_water and ql_ice - qi_bl1D(k) = (1.0-liq_frac)*ql_ice - - !Above tropopause: eliminate subgrid clouds from CB scheme. Note that this was - !"k_tropo - 1" as of 20 Feb 2023. Changed to allow more high-level clouds. - if (k .ge. k_tropo) then - cldfra_bl1D(K) = 0. - qc_bl1D(k) = 0. - qi_bl1D(k) = 0. - endif - - !Buoyancy-flux-related calculations follow... - !limiting Q1 to avoid too much diffusion in cloud layers - !q1k=max(Q1(k),-2.0) - if ((xland-1.5).GE.0) then ! water - q1k=max(Q1(k),-2.5) - else ! land - q1k=max(Q1(k),-2.0) - endif - ! "Fng" represents the non-Gaussian transport factor - ! (non-dimensional) from Bechtold et al. 1995 - ! (hereafter BCMT95), section 3(c). Their suggested - ! forms for Fng (from their Eq. 20) are: - !IF (q1k < -2.) THEN - ! Fng = 2.-q1k - !ELSE IF (q1k > 0.) THEN - ! Fng = 1. - !ELSE - ! Fng = 1.-1.5*q1k - !ENDIF - ! Use the form of "Fng" from Bechtold and Siebesma (1998, JAS) - if (q1k .ge. 1.0) then - Fng = 1.0 - elseif (q1k .ge. -1.7 .and. q1k .lt. 1.0) then - Fng = exp(-0.4*(q1k-1.0)) - elseif (q1k .ge. -2.5 .and. q1k .lt. -1.7) then - Fng = 3.0 + exp(-3.8*(q1k+1.7)) - else - Fng = min(23.9 + exp(-1.6*(q1k+2.5)), 60._kind_phys) - endif - - cfmax = min(cldfra_bl1D(k), 0.6_kind_phys) - !Further limit the cf going into vt & vq near the surface - zsl = min(max(25., 0.1*pblh2), 100.) - wt = min(zagl/zsl, 1.0) !=0 at z=0 m, =1 above ekman layer - cfmax = cfmax*wt - - bb = b(k)*t/th(k) ! bb is "b" in BCMT95. Their "b" differs from - ! "b" in CB02 (i.e., b(k) above) by a factor - ! of T/theta. Strictly, b(k) above is formulated in - ! terms of sat. mixing ratio, but bb in BCMT95 is - ! cast in terms of sat. specific humidity. The - ! conversion is neglected here. - qww = 1.+0.61*qw(k) - alpha = 0.61*th(k) - beta = (th(k)/t)*(xl/cp) - 1.61*th(k) - vt(k) = qww - cfmax*beta*bb*Fng - 1. - vq(k) = alpha + cfmax*beta*a(k)*Fng - tv0 - ! vt and vq correspond to beta-theta and beta-q, respectively, - ! in NN09, Eq. B8. They also correspond to the bracketed - ! expressions in BCMT95, Eq. 15, since (s*ql/sigma^2) = cldfra*Fng - ! The "-1" and "-tv0" terms are included for consistency with - ! the legacy vt and vq formulations (above). - - ! dampen amplification factor where need be - fac_damp = min(zagl * 0.0025, 1.0) - !cld_factor = 1.0 + fac_damp*MAX(0.0, ( RH(k) - 0.75 ) / 0.26 )**1.9 !HRRRv4 - !cld_factor = 1.0 + fac_damp*min((max(0.0, ( RH(k) - 0.92 )) / 0.25 )**2, 0.3) - cld_factor = 1.0 + fac_damp*min((max(0.0, ( RH(k) - 0.92 )) / 0.145)**2, 0.37) - cldfra_bl1D(K) = min( 1., cld_factor*cldfra_bl1D(K) ) - enddo - - END SELECT !end cloudPDF option - - !For testing purposes only, option for isolating on the mass-flux clouds. - IF (bl_mynn_cloudpdf .LT. 0) THEN - DO k = kts,kte-1 - cldfra_bl1D(k) = 0.0 - qc_bl1D(k) = 0.0 - qi_bl1D(k) = 0.0 - END DO - ENDIF -! - ql(kte) = ql(kte-1) - vt(kte) = vt(kte-1) - vq(kte) = vq(kte-1) - qc_bl1D(kte)=0. - qi_bl1D(kte)=0. - cldfra_bl1D(kte)=0. - RETURN - -#ifdef HARDCODE_VERTICAL -# undef kts -# undef kte -#endif - - END SUBROUTINE mym_condensation - -! ================================================================== -!>\ingroup gsd_mynn_edmf -!! This subroutine solves for tendencies of U, V, \f$\theta\f$, qv, -!! qc, and qi - SUBROUTINE mynn_tendencies(kts,kte,i, & - &delt,dz,rho, & - &u,v,th,tk,qv,qc,qi,qs,qnc,qni, & - &psfc,p,exner, & - &thl,sqv,sqc,sqi,sqs,sqw, & - &qnwfa,qnifa,qnbca,ozone, & - &ust,flt,flq,flqv,flqc,wspd, & - &uoce,voce, & - &tsq,qsq,cov, & - &tcd,qcd, & - &dfm,dfh,dfq, & - &Du,Dv,Dth,Dqv,Dqc,Dqi,Dqs,Dqnc,Dqni, & - &Dqnwfa,Dqnifa,Dqnbca,Dozone, & - &diss_heat, & - &s_aw,s_awthl,s_awqt,s_awqv,s_awqc, & - &s_awu,s_awv, & - &s_awqnc,s_awqni, & - &s_awqnwfa,s_awqnifa,s_awqnbca, & - &sd_aw,sd_awthl,sd_awqt,sd_awqv, & - &sd_awqc,sd_awu,sd_awv, & - &sub_thl,sub_sqv, & - &sub_u,sub_v, & - &det_thl,det_sqv,det_sqc, & - &det_u,det_v, & - &FLAG_QC,FLAG_QI,FLAG_QNC,FLAG_QNI, & - &FLAG_QS, & - &FLAG_QNWFA,FLAG_QNIFA,FLAG_QNBCA, & - &FLAG_OZONE, & - &cldfra_bl1d, & - &bl_mynn_cloudmix, & - &bl_mynn_mixqt, & - &bl_mynn_edmf, & - &bl_mynn_edmf_mom, & - &bl_mynn_mixscalars ) - -!------------------------------------------------------------------- - integer, intent(in) :: kts,kte,i - -#ifdef HARDCODE_VERTICAL -# define kts 1 -# define kte HARDCODE_VERTICAL -#endif - - integer, intent(in) :: bl_mynn_cloudmix,bl_mynn_mixqt, & - bl_mynn_edmf,bl_mynn_edmf_mom, & - bl_mynn_mixscalars - logical, intent(in) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QS, & - &FLAG_QNC,FLAG_QNWFA,FLAG_QNIFA,FLAG_QNBCA,FLAG_OZONE - -! thl - liquid water potential temperature -! qw - total water -! dfm,dfh,dfq - diffusivities i.e., dfh(k) = elq*sh(k) / dzk -! flt - surface flux of thl -! flq - surface flux of qw - -! mass-flux plumes - real(kind_phys), dimension(kts:kte+1), intent(in) :: s_aw, & - &s_awthl,s_awqt,s_awqnc,s_awqni,s_awqv,s_awqc,s_awu,s_awv, & - &s_awqnwfa,s_awqnifa,s_awqnbca, & - &sd_aw,sd_awthl,sd_awqt,sd_awqv,sd_awqc,sd_awu,sd_awv -! tendencies from mass-flux environmental subsidence and detrainment - real(kind_phys), dimension(kts:kte), intent(in) :: sub_thl,sub_sqv, & - &sub_u,sub_v,det_thl,det_sqv,det_sqc,det_u,det_v - real(kind_phys), dimension(kts:kte), intent(in) :: u,v,th,tk,qv,qc,qi,& - &qs,qni,qnc,rho,p,exner,dfq,dz,tsq,qsq,cov,tcd,qcd, & - &cldfra_bl1d,diss_heat - real(kind_phys), dimension(kts:kte), intent(inout) :: thl,sqw,sqv,sqc,& - &sqi,sqs,qnwfa,qnifa,qnbca,ozone,dfm,dfh - real(kind_phys), dimension(kts:kte), intent(inout) :: du,dv,dth,dqv, & - &dqc,dqi,dqs,dqni,dqnc,dqnwfa,dqnifa,dqnbca,dozone - real(kind_phys), intent(in) :: flt,flq,flqv,flqc,uoce,voce - real(kind_phys), intent(in) :: ust,delt,psfc,wspd - !debugging - real(kind_phys):: wsp,wsp2,tk2,th2 - logical :: problem - integer :: kproblem - -! real(kind_phys), intent(in) :: gradu_top,gradv_top,gradth_top,gradqv_top - -!local vars - - real(kind_phys), dimension(kts:kte) :: dtz,dfhc,dfmc,delp - real(kind_phys), dimension(kts:kte) :: sqv2,sqc2,sqi2,sqs2,sqw2, & - &qni2,qnc2,qnwfa2,qnifa2,qnbca2,ozone2 - real(kind_phys), dimension(kts:kte) :: zfac,plumeKh,rhoinv - real(kind_phys), dimension(kts:kte) :: a,b,c,d,x - real(kind_phys), dimension(kts:kte+1) :: rhoz, & !rho on model interface - &khdz,kmdz - real(kind_phys):: rhs,gfluxm,gfluxp,dztop,maxdfh,mindfh,maxcf,maxKh,zw - real(kind_phys):: t,esat,qsl,onoff,kh,km,dzk,rhosfc - real(kind_phys):: ustdrag,ustdiff,qvflux - real(kind_phys):: th_new,portion_qc,portion_qi,condensate,qsat - integer :: k,kk - - !Activate nonlocal mixing from the mass-flux scheme for - !number concentrations and aerosols (0.0 = no; 1.0 = yes) - real(kind_phys), parameter :: nonloc = 1.0 - - dztop=.5*(dz(kte)+dz(kte-1)) - - ! REGULATE THE MOMENTUM MIXING FROM THE MASS-FLUX SCHEME (on or off) - ! Note that s_awu and s_awv already come in as 0.0 if bl_mynn_edmf_mom == 0, so - ! we only need to zero-out the MF term - IF (bl_mynn_edmf_mom == 0) THEN - onoff=0.0 - ELSE - onoff=1.0 - ENDIF - - !Prepare "constants" for diffusion equation. - !khdz = rho*Kh/dz = rho*dfh - rhosfc = psfc/(R_d*(tk(kts)+p608*qv(kts))) - dtz(kts) =delt/dz(kts) - rhoz(kts) =rho(kts) - rhoinv(kts)=1./rho(kts) - khdz(kts) =rhoz(kts)*dfh(kts) - kmdz(kts) =rhoz(kts)*dfm(kts) - delp(kts) = psfc - (p(kts+1)*dz(kts) + p(kts)*dz(kts+1))/(dz(kts)+dz(kts+1)) - DO k=kts+1,kte - dtz(k) =delt/dz(k) - rhoz(k) =(rho(k)*dz(k-1) + rho(k-1)*dz(k))/(dz(k-1)+dz(k)) - rhoz(k) = MAX(rhoz(k),1E-4) - rhoinv(k)=1./MAX(rho(k),1E-4) - dzk = 0.5 *( dz(k)+dz(k-1) ) - khdz(k) = rhoz(k)*dfh(k) - kmdz(k) = rhoz(k)*dfm(k) - ENDDO - DO k=kts+1,kte-1 - delp(k) = (p(k)*dz(k-1) + p(k-1)*dz(k))/(dz(k)+dz(k-1)) - & - (p(k+1)*dz(k) + p(k)*dz(k+1))/(dz(k)+dz(k+1)) - ENDDO - delp(kte) =delp(kte-1) - rhoz(kte+1)=rhoz(kte) - khdz(kte+1)=rhoz(kte+1)*dfh(kte) - kmdz(kte+1)=rhoz(kte+1)*dfm(kte) - - !stability criteria for mf - DO k=kts+1,kte-1 - khdz(k) = MAX(khdz(k), 0.5*s_aw(k)) - khdz(k) = MAX(khdz(k), -0.5*(s_aw(k)-s_aw(k+1))) - kmdz(k) = MAX(kmdz(k), 0.5*s_aw(k)) - kmdz(k) = MAX(kmdz(k), -0.5*(s_aw(k)-s_aw(k+1))) - ENDDO - - ustdrag = MIN(ust*ust,0.99)/wspd ! limit at ~ 20 m/s - ustdiff = MIN(ust*ust,0.01)/wspd ! limit at ~ 2 m/s - dth(kts:kte) = 0.0 ! must initialize for moisture_check routine - -!!============================================ -!! u -!!============================================ - - k=kts - -!rho-weighted (drag in b-vector): - a(k)= -dtz(k)*kmdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(kmdz(k+1)+rhosfc*ust**2/wspd)*rhoinv(k) & - & - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff & - & - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff - c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) & - & - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff & - & - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff - d(k)=u(k) + dtz(k)*uoce*ust**2/wspd & - & - dtz(k)*rhoinv(k)*s_awu(k+1)*onoff & - & + dtz(k)*rhoinv(k)*sd_awu(k+1)*onoff & - & + sub_u(k)*delt + det_u(k)*delt - - do k=kts+1,kte-1 - a(k)= -dtz(k)*kmdz(k)*rhoinv(k) & - & + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*onoff & - & + 0.5*dtz(k)*rhoinv(k)*sd_aw(k)*onoff - b(k)=1.+ dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) & - & + 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*onoff & - & + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1))*onoff - c(k)= - dtz(k)*kmdz(k+1)*rhoinv(k) & - & - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff & - & - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff - d(k)=u(k) + dtz(k)*rhoinv(k)*(s_awu(k)-s_awu(k+1))*onoff & - & - dtz(k)*rhoinv(k)*(sd_awu(k)-sd_awu(k+1))*onoff & - & + sub_u(k)*delt + det_u(k)*delt - enddo - -!! no flux at the top -! a(kte)=-1. -! b(kte)=1. -! c(kte)=0. -! d(kte)=0. - -!! specified gradient at the top -! a(kte)=-1. -! b(kte)=1. -! c(kte)=0. -! d(kte)=gradu_top*dztop - -!! prescribed value - a(kte)=0 - b(kte)=1. - c(kte)=0. - d(kte)=u(kte) - -! CALL tridiag(kte,a,b,c,d) - CALL tridiag2(kte,a,b,c,d,x) -! CALL tridiag3(kte,a,b,c,d,x) - - DO k=kts,kte -! du(k)=(d(k-kts+1)-u(k))/delt - du(k)=(x(k)-u(k))/delt - ENDDO - -!!============================================ -!! v -!!============================================ - - k=kts - -!rho-weighted (drag in b-vector): - a(k)= -dtz(k)*kmdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(kmdz(k+1) + rhosfc*ust**2/wspd)*rhoinv(k) & - & - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff & - & - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff - c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) & - & - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff & - & - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff - d(k)=v(k) + dtz(k)*voce*ust**2/wspd & - & - dtz(k)*rhoinv(k)*s_awv(k+1)*onoff & - & + dtz(k)*rhoinv(k)*sd_awv(k+1)*onoff & - & + sub_v(k)*delt + det_v(k)*delt - - do k=kts+1,kte-1 - a(k)= -dtz(k)*kmdz(k)*rhoinv(k) & - & + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*onoff & - & + 0.5*dtz(k)*rhoinv(k)*sd_aw(k)*onoff - b(k)=1.+dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) & - & + 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*onoff & - & + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1))*onoff - c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) & - & - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff & - & - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff - d(k)=v(k) + dtz(k)*rhoinv(k)*(s_awv(k)-s_awv(k+1))*onoff & - & - dtz(k)*rhoinv(k)*(sd_awv(k)-sd_awv(k+1))*onoff & - & + sub_v(k)*delt + det_v(k)*delt - enddo - -!! no flux at the top -! a(kte)=-1. -! b(kte)=1. -! c(kte)=0. -! d(kte)=0. - -!! specified gradient at the top -! a(kte)=-1. -! b(kte)=1. -! c(kte)=0. -! d(kte)=gradv_top*dztop - -!! prescribed value - a(kte)=0 - b(kte)=1. - c(kte)=0. - d(kte)=v(kte) - -! CALL tridiag(kte,a,b,c,d) - CALL tridiag2(kte,a,b,c,d,x) -! CALL tridiag3(kte,a,b,c,d,x) - - DO k=kts,kte -! dv(k)=(d(k-kts+1)-v(k))/delt - dv(k)=(x(k)-v(k))/delt - ENDDO - -!!============================================ -!! thl tendency -!!============================================ - k=kts - -! a(k)=0. -! b(k)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) -! c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) -! d(k)=thl(k) + dtz(k)*flt + tcd(k)*delt & -! & -dtz(k)*s_awthl(kts+1) + diss_heat(k)*delt + & -! & sub_thl(k)*delt + det_thl(k)*delt -! -! DO k=kts+1,kte-1 -! a(k)= -dtz(k)*dfh(k) + 0.5*dtz(k)*s_aw(k) -! b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1)) -! c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) -! d(k)=thl(k) + tcd(k)*delt + dtz(k)*(s_awthl(k)-s_awthl(k+1)) & -! & + diss_heat(k)*delt + & -! & sub_thl(k)*delt + det_thl(k)*delt -! ENDDO - -!rho-weighted: rhosfc*X*rhoinv(k) - a(k)= -dtz(k)*khdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) - d(k)=thl(k) + dtz(k)*rhosfc*flt*rhoinv(k) + tcd(k)*delt & - & - dtz(k)*rhoinv(k)*s_awthl(k+1) -dtz(k)*rhoinv(k)*sd_awthl(k+1) + & - & diss_heat(k)*delt + sub_thl(k)*delt + det_thl(k)*delt - - DO k=kts+1,kte-1 - a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k) + 0.5*dtz(k)*rhoinv(k)*sd_aw(k) - b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + & - & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1)) + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1)) - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) - d(k)=thl(k) + tcd(k)*delt + & - & dtz(k)*rhoinv(k)*(s_awthl(k)-s_awthl(k+1)) + dtz(k)*rhoinv(k)*(sd_awthl(k)-sd_awthl(k+1)) + & - & diss_heat(k)*delt + & - & sub_thl(k)*delt + det_thl(k)*delt - ENDDO - -!! no flux at the top -! a(kte)=-1. -! b(kte)=1. -! c(kte)=0. -! d(kte)=0. - -!! specified gradient at the top -!assume gradthl_top=gradth_top -! a(kte)=-1. -! b(kte)=1. -! c(kte)=0. -! d(kte)=gradth_top*dztop - -!! prescribed value - a(kte)=0. - b(kte)=1. - c(kte)=0. - d(kte)=thl(kte) - -! CALL tridiag(kte,a,b,c,d) - CALL tridiag2(kte,a,b,c,d,x) -! CALL tridiag3(kte,a,b,c,d,x) - - DO k=kts,kte - !thl(k)=d(k-kts+1) - thl(k)=x(k) - ENDDO - -IF (bl_mynn_mixqt > 0) THEN - !============================================ - ! MIX total water (sqw = sqc + sqv + sqi) - ! NOTE: no total water tendency is output; instead, we must calculate - ! the saturation specific humidity and then - ! subtract out the moisture excess (sqc & sqi) - !============================================ - - k=kts - -! a(k)=0. -! b(k)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) -! c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) -! !rhs= qcd(k) !+ (gfluxp - gfluxm)/dz(k)& -! d(k)=sqw(k) + dtz(k)*flq + qcd(k)*delt - dtz(k)*s_awqt(k+1) -! -! DO k=kts+1,kte-1 -! a(k)= -dtz(k)*dfh(k) + 0.5*dtz(k)*s_aw(k) -! b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1)) -! c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) -! d(k)=sqw(k) + qcd(k)*delt + dtz(k)*(s_awqt(k)-s_awqt(k+1)) -! ENDDO - -!rho-weighted: - a(k)= -dtz(k)*khdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) - d(k)=sqw(k) + dtz(k)*rhosfc*flq*rhoinv(k) + qcd(k)*delt - dtz(k)*rhoinv(k)*s_awqt(k+1) - dtz(k)*rhoinv(k)*sd_awqt(k+1) - - DO k=kts+1,kte-1 - a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k) + 0.5*dtz(k)*rhoinv(k)*sd_aw(k) - b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + & - & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1)) + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1)) - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) - d(k)=sqw(k) + qcd(k)*delt + dtz(k)*rhoinv(k)*(s_awqt(k)-s_awqt(k+1)) + dtz(k)*rhoinv(k)*(sd_awqt(k)-sd_awqt(k+1)) - ENDDO - -!! no flux at the top -! a(kte)=-1. -! b(kte)=1. -! c(kte)=0. -! d(kte)=0. -!! specified gradient at the top -!assume gradqw_top=gradqv_top -! a(kte)=-1. -! b(kte)=1. -! c(kte)=0. -! d(kte)=gradqv_top*dztop -!! prescribed value - a(kte)=0. - b(kte)=1. - c(kte)=0. - d(kte)=sqw(kte) - -! CALL tridiag(kte,a,b,c,d) - CALL tridiag2(kte,a,b,c,d,sqw2) -! CALL tridiag3(kte,a,b,c,d,sqw2) - -! DO k=kts,kte -! sqw2(k)=d(k-kts+1) -! ENDDO -ELSE - sqw2=sqw -ENDIF - -IF (bl_mynn_mixqt == 0) THEN -!============================================ -! cloud water ( sqc ). If mixing total water (bl_mynn_mixqt > 0), -! then sqc will be backed out of saturation check (below). -!============================================ - IF (bl_mynn_cloudmix > 0 .AND. FLAG_QC) THEN - - k=kts - -! a(k)=0. -! b(k)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) -! c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) -! d(k)=sqc(k) + dtz(k)*flqc + qcd(k)*delt - & -! dtz(k)*s_awqc(k+1) + det_sqc(k)*delt -! -! DO k=kts+1,kte-1 -! a(k)= -dtz(k)*dfh(k) + 0.5*dtz(k)*s_aw(k) -! b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1)) -! c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) -! d(k)=sqc(k) + qcd(k)*delt + dtz(k)*(s_awqc(k)-s_awqc(k+1)) + & -! det_sqc(k)*delt -! ENDDO - -!rho-weighted: - a(k)= -dtz(k)*khdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) - d(k)=sqc(k) + dtz(k)*rhosfc*flqc*rhoinv(k) + qcd(k)*delt & - & - dtz(k)*rhoinv(k)*s_awqc(k+1) - dtz(k)*rhoinv(k)*sd_awqc(k+1) + & - & det_sqc(k)*delt - - DO k=kts+1,kte-1 - a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k) + 0.5*dtz(k)*rhoinv(k)*sd_aw(k) - b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + & - & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1)) + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1)) - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) - d(k)=sqc(k) + qcd(k)*delt + dtz(k)*rhoinv(k)*(s_awqc(k)-s_awqc(k+1)) + dtz(k)*rhoinv(k)*(sd_awqc(k)-sd_awqc(k+1)) + & - & det_sqc(k)*delt - ENDDO - -! prescribed value - a(kte)=0. - b(kte)=1. - c(kte)=0. - d(kte)=sqc(kte) - -! CALL tridiag(kte,a,b,c,d) - CALL tridiag2(kte,a,b,c,d,sqc2) -! CALL tridiag3(kte,a,b,c,d,sqc2) - -! DO k=kts,kte -! sqc2(k)=d(k-kts+1) -! ENDDO - ELSE - !If not mixing clouds, set "updated" array equal to original array - sqc2=sqc - ENDIF -ENDIF - -IF (bl_mynn_mixqt == 0) THEN - !============================================ - ! MIX WATER VAPOR ONLY ( sqv ). If mixing total water (bl_mynn_mixqt > 0), - ! then sqv will be backed out of saturation check (below). - !============================================ - - k=kts - -! a(k)=0. -! b(k)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) -! c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) -! d(k)=sqv(k) + dtz(k)*flqv + qcd(k)*delt - dtz(k)*s_awqv(k+1) + & -! & sub_sqv(k)*delt + det_sqv(k)*delt -! -! DO k=kts+1,kte-1 -! a(k)= -dtz(k)*dfh(k) + 0.5*dtz(k)*s_aw(k) -! b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1)) -! c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) -! d(k)=sqv(k) + qcd(k)*delt + dtz(k)*(s_awqv(k)-s_awqv(k+1)) + & -! & sub_sqv(k)*delt + det_sqv(k)*delt -! ENDDO - - !limit unreasonably large negative fluxes: - qvflux = flqv - if (qvflux < 0.0) then - !do not allow specified surface flux to reduce qv below 1e-8 kg/kg - qvflux = max(qvflux, (min(0.9*sqv(kts) - 1e-8, 0.0)/dtz(kts))) - endif - -!rho-weighted: rhosfc*X*rhoinv(k) - a(k)= -dtz(k)*khdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) - d(k)=sqv(k) + dtz(k)*rhosfc*qvflux*rhoinv(k) + qcd(k)*delt & - & - dtz(k)*rhoinv(k)*s_awqv(k+1) - dtz(k)*rhoinv(k)*sd_awqv(k+1) + & - & sub_sqv(k)*delt + det_sqv(k)*delt - - DO k=kts+1,kte-1 - a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k) + 0.5*dtz(k)*rhoinv(k)*sd_aw(k) - b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + & - & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1)) + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1)) - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) - d(k)=sqv(k) + qcd(k)*delt + dtz(k)*rhoinv(k)*(s_awqv(k)-s_awqv(k+1)) + dtz(k)*rhoinv(k)*(sd_awqv(k)-sd_awqv(k+1)) + & - & sub_sqv(k)*delt + det_sqv(k)*delt - ENDDO - -! no flux at the top -! a(kte)=-1. -! b(kte)=1. -! c(kte)=0. -! d(kte)=0. - -! specified gradient at the top -! assume gradqw_top=gradqv_top -! a(kte)=-1. -! b(kte)=1. -! c(kte)=0. -! d(kte)=gradqv_top*dztop - -! prescribed value - a(kte)=0. - b(kte)=1. - c(kte)=0. - d(kte)=sqv(kte) - -! CALL tridiag(kte,a,b,c,d) - CALL tridiag2(kte,a,b,c,d,sqv2) -! CALL tridiag3(kte,a,b,c,d,sqv2) - -! DO k=kts,kte -! sqv2(k)=d(k-kts+1) -! ENDDO -ELSE - sqv2=sqv -ENDIF - -!============================================ -! MIX CLOUD ICE ( sqi ) -!============================================ -IF (bl_mynn_cloudmix > 0 .AND. FLAG_QI) THEN - - k=kts -!rho-weighted: - a(k)= -dtz(k)*khdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - d(k)=sqi(k) - - DO k=kts+1,kte-1 - a(k)= -dtz(k)*khdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - d(k)=sqi(k) - ENDDO - -!! no flux at the top -! a(kte)=-1. -! b(kte)=1. -! c(kte)=0. -! d(kte)=0. - -!! specified gradient at the top -!assume gradqw_top=gradqv_top -! a(kte)=-1. -! b(kte)=1. -! c(kte)=0. -! d(kte)=gradqv_top*dztop - -!! prescribed value - a(kte)=0. - b(kte)=1. - c(kte)=0. - d(kte)=sqi(kte) - -! CALL tridiag(kte,a,b,c,d) - CALL tridiag2(kte,a,b,c,d,sqi2) -! CALL tridiag3(kte,a,b,c,d,sqi2) - -! DO k=kts,kte -! sqi2(k)=d(k-kts+1) -! ENDDO -ELSE - sqi2=sqi -ENDIF - -!============================================ -! MIX SNOW ( sqs ) -!============================================ -!hard-code to not mix snow -IF (bl_mynn_cloudmix > 0 .AND. .false.) THEN - - k=kts -!rho-weighted: - a(k)= -dtz(k)*khdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - d(k)=sqs(k) - - DO k=kts+1,kte-1 - a(k)= -dtz(k)*khdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - d(k)=sqs(k) - ENDDO - -!! prescribed value - a(kte)=0. - b(kte)=1. - c(kte)=0. - d(kte)=sqs(kte) - -! CALL tridiag(kte,a,b,c,d) - CALL tridiag2(kte,a,b,c,d,sqs2) -! CALL tridiag3(kte,a,b,c,d,sqs2) - -! DO k=kts,kte -! sqs2(k)=d(k-kts+1) -! ENDDO -ELSE - sqs2=sqs -ENDIF - -!!============================================ -!! cloud ice number concentration (qni) -!!============================================ -IF (bl_mynn_cloudmix > 0 .AND. FLAG_QNI .AND. & - bl_mynn_mixscalars > 0) THEN - - k=kts - - a(k)= -dtz(k)*khdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc - d(k)=qni(k) - dtz(k)*rhoinv(k)*s_awqni(k+1)*nonloc - - DO k=kts+1,kte-1 - a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*nonloc - b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + & - & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*nonloc - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc - d(k)=qni(k) + dtz(k)*rhoinv(k)*(s_awqni(k)-s_awqni(k+1))*nonloc - ENDDO - -!! prescribed value - a(kte)=0. - b(kte)=1. - c(kte)=0. - d(kte)=qni(kte) - -! CALL tridiag(kte,a,b,c,d) - CALL tridiag2(kte,a,b,c,d,x) -! CALL tridiag3(kte,a,b,c,d,x) - - DO k=kts,kte - !qni2(k)=d(k-kts+1) - qni2(k)=x(k) - ENDDO - -ELSE - qni2=qni -ENDIF - -!!============================================ -!! cloud water number concentration (qnc) -!! include non-local transport -!!============================================ - IF (bl_mynn_cloudmix > 0 .AND. FLAG_QNC .AND. & - bl_mynn_mixscalars > 0) THEN - - k=kts - - a(k)= -dtz(k)*khdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc - d(k)=qnc(k) - dtz(k)*rhoinv(k)*s_awqnc(k+1)*nonloc - - DO k=kts+1,kte-1 - a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*nonloc - b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + & - & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*nonloc - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc - d(k)=qnc(k) + dtz(k)*rhoinv(k)*(s_awqnc(k)-s_awqnc(k+1))*nonloc - ENDDO - -!! prescribed value - a(kte)=0. - b(kte)=1. - c(kte)=0. - d(kte)=qnc(kte) - -! CALL tridiag(kte,a,b,c,d) - CALL tridiag2(kte,a,b,c,d,x) -! CALL tridiag3(kte,a,b,c,d,x) - - DO k=kts,kte - !qnc2(k)=d(k-kts+1) - qnc2(k)=x(k) - ENDDO - -ELSE - qnc2=qnc -ENDIF - -!============================================ -! Water-friendly aerosols ( qnwfa ). -!============================================ -IF (bl_mynn_cloudmix > 0 .AND. FLAG_QNWFA .AND. & - bl_mynn_mixscalars > 0) THEN - - k=kts - - a(k)= -dtz(k)*khdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))*rhoinv(k) - & - & 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc - d(k)=qnwfa(k) - dtz(k)*rhoinv(k)*s_awqnwfa(k+1)*nonloc - - DO k=kts+1,kte-1 - a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*nonloc - b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))*rhoinv(k) + & - & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*nonloc - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc - d(k)=qnwfa(k) + dtz(k)*rhoinv(k)*(s_awqnwfa(k)-s_awqnwfa(k+1))*nonloc - ENDDO - -! prescribed value - a(kte)=0. - b(kte)=1. - c(kte)=0. - d(kte)=qnwfa(kte) - -! CALL tridiag(kte,a,b,c,d) - CALL tridiag2(kte,a,b,c,d,x) -! CALL tridiag3(kte,a,b,c,d,x) - - DO k=kts,kte - !qnwfa2(k)=d(k) - qnwfa2(k)=x(k) - ENDDO - -ELSE - !If not mixing aerosols, set "updated" array equal to original array - qnwfa2=qnwfa -ENDIF - -!============================================ -! Ice-friendly aerosols ( qnifa ). -!============================================ -IF (bl_mynn_cloudmix > 0 .AND. FLAG_QNIFA .AND. & - bl_mynn_mixscalars > 0) THEN - - k=kts - - a(k)= -dtz(k)*khdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))*rhoinv(k) - & - & 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc - d(k)=qnifa(k) - dtz(k)*rhoinv(k)*s_awqnifa(k+1)*nonloc - - DO k=kts+1,kte-1 - a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*nonloc - b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))*rhoinv(k) + & - & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*nonloc - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc - d(k)=qnifa(k) + dtz(k)*rhoinv(k)*(s_awqnifa(k)-s_awqnifa(k+1))*nonloc - ENDDO - -! prescribed value - a(kte)=0. - b(kte)=1. - c(kte)=0. - d(kte)=qnifa(kte) - -! CALL tridiag(kte,a,b,c,d) - CALL tridiag2(kte,a,b,c,d,x) -! CALL tridiag3(kte,a,b,c,d,x) - - DO k=kts,kte - !qnifa2(k)=d(k-kts+1) - qnifa2(k)=x(k) - ENDDO - -ELSE - !If not mixing aerosols, set "updated" array equal to original array - qnifa2=qnifa -ENDIF - -!============================================ -! Black-carbon aerosols ( qnbca ). -!============================================ -IF (bl_mynn_cloudmix > 0 .AND. FLAG_QNBCA .AND. & - bl_mynn_mixscalars > 0) THEN - - k=kts - - a(k)= -dtz(k)*khdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))*rhoinv(k) - & - & 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc - d(k)=qnbca(k) - dtz(k)*rhoinv(k)*s_awqnbca(k+1)*nonloc - - DO k=kts+1,kte-1 - a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*nonloc - b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))*rhoinv(k) + & - & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*nonloc - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc - d(k)=qnbca(k) + dtz(k)*rhoinv(k)*(s_awqnbca(k)-s_awqnbca(k+1))*nonloc - ENDDO - -! prescribed value - a(kte)=0. - b(kte)=1. - c(kte)=0. - d(kte)=qnbca(kte) - -! CALL tridiag(kte,a,b,c,d) - CALL tridiag2(kte,a,b,c,d,x) -! CALL tridiag3(kte,a,b,c,d,x) - - DO k=kts,kte - !qnbca2(k)=d(k-kts+1) - qnbca2(k)=x(k) - ENDDO - -ELSE - !If not mixing aerosols, set "updated" array equal to original array - qnbca2=qnbca -ENDIF - -!============================================ -! Ozone - local mixing only -!============================================ -IF (FLAG_OZONE) THEN - k=kts - -!rho-weighted: - a(k)= -dtz(k)*khdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - d(k)=ozone(k) - - DO k=kts+1,kte-1 - a(k)= -dtz(k)*khdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - d(k)=ozone(k) - ENDDO - -! prescribed value - a(kte)=0. - b(kte)=1. - c(kte)=0. - d(kte)=ozone(kte) - -! CALL tridiag(kte,a,b,c,d) - CALL tridiag2(kte,a,b,c,d,x) -! CALL tridiag3(kte,a,b,c,d,x) - - DO k=kts,kte - !ozone2(k)=d(k-kts+1) - dozone(k)=(x(k)-ozone(k))/delt - ENDDO -ELSE - dozone(:)=0.0 -ENDIF - -!!============================================ -!! Compute tendencies and convert to mixing ratios for WRF. -!! Note that the momentum tendencies are calculated above. -!!============================================ - - IF (bl_mynn_mixqt > 0) THEN - DO k=kts,kte - !compute updated theta using updated thl and old condensate - th_new = thl(k) + xlvcp/exner(k)*sqc(k) & - & + xlscp/exner(k)*sqi(k) - - t = th_new*exner(k) - qsat = qsat_blend(t,p(k)) - !SATURATED VAPOR PRESSURE - !esat=esat_blend(t) - !SATURATED SPECIFIC HUMIDITY - !qsl=ep_2*esat/(p(k)-ep_3*esat) - !qsl=ep_2*esat/max(1.e-4,(p(k)-ep_3*esat)) - - IF (sqc(k) > 0.0 .or. sqi(k) > 0.0) THEN !initially saturated - sqv2(k) = MIN(sqw2(k),qsat) - portion_qc = sqc(k)/(sqc(k) + sqi(k)) - portion_qi = sqi(k)/(sqc(k) + sqi(k)) - condensate = MAX(sqw2(k) - qsat, 0.0) - sqc2(k) = condensate*portion_qc - sqi2(k) = condensate*portion_qi - ELSE ! initially unsaturated ----- - sqv2(k) = sqw2(k) ! let microphys decide what to do - sqi2(k) = 0.0 ! if sqw2 > qsat - sqc2(k) = 0.0 - ENDIF - ENDDO - ENDIF - - - !===================== - ! WATER VAPOR TENDENCY - !===================== - DO k=kts,kte - Dqv(k)=(sqv2(k) - sqv(k))/delt - !if (sqv2(k) < 0.0)print*,"neg qv:",sqv2(k),k - ENDDO - - IF (bl_mynn_cloudmix > 0) THEN - !===================== - ! CLOUD WATER TENDENCY - !===================== - !print*,"FLAG_QC:",FLAG_QC - IF (FLAG_QC) THEN - DO k=kts,kte - Dqc(k)=(sqc2(k) - sqc(k))/delt - !if (sqc2(k) < 0.0)print*,"neg qc:",sqc2(k),k - ENDDO - ELSE - DO k=kts,kte - Dqc(k) = 0. - ENDDO - ENDIF - - !=================== - ! CLOUD WATER NUM CONC TENDENCY - !=================== - IF (FLAG_QNC .AND. bl_mynn_mixscalars > 0) THEN - DO k=kts,kte - Dqnc(k) = (qnc2(k)-qnc(k))/delt - !IF(Dqnc(k)*delt + qnc(k) < 0.)Dqnc(k)=-qnc(k)/delt - ENDDO - ELSE - DO k=kts,kte - Dqnc(k) = 0. - ENDDO - ENDIF - - !=================== - ! CLOUD ICE TENDENCY - !=================== - IF (FLAG_QI) THEN - DO k=kts,kte - Dqi(k)=(sqi2(k) - sqi(k))/delt - !if (sqi2(k) < 0.0)print*,"neg qi:",sqi2(k),k - ENDDO - ELSE - DO k=kts,kte - Dqi(k) = 0. - ENDDO - ENDIF - - !=================== - ! CLOUD SNOW TENDENCY - !=================== - IF (.false.) THEN !disabled - DO k=kts,kte - Dqs(k)=(sqs2(k) - sqs(k))/delt - ENDDO - ELSE - DO k=kts,kte - Dqs(k) = 0. - ENDDO - ENDIF - - !=================== - ! CLOUD ICE NUM CONC TENDENCY - !=================== - IF (FLAG_QNI .AND. bl_mynn_mixscalars > 0) THEN - DO k=kts,kte - Dqni(k)=(qni2(k)-qni(k))/delt - !IF(Dqni(k)*delt + qni(k) < 0.)Dqni(k)=-qni(k)/delt - ENDDO - ELSE - DO k=kts,kte - Dqni(k)=0. - ENDDO - ENDIF - ELSE !-MIX CLOUD SPECIES? - !CLOUDS ARE NOT NIXED (when bl_mynn_cloudmix == 0) - DO k=kts,kte - Dqc(k) =0. - Dqnc(k)=0. - Dqi(k) =0. - Dqni(k)=0. - Dqs(k) =0. - ENDDO - ENDIF - - !ensure non-negative moist species - CALL moisture_check(kte, delt, delp, exner, & - sqv2, sqc2, sqi2, sqs2, thl, & - dqv, dqc, dqi, dqs, dth ) - - !===================== - ! OZONE TENDENCY CHECK - !===================== - DO k=kts,kte - IF(Dozone(k)*delt + ozone(k) < 0.) THEN - Dozone(k)=-ozone(k)*0.99/delt - ENDIF - ENDDO - - !=================== - ! THETA TENDENCY - !=================== - IF (FLAG_QI) THEN - DO k=kts,kte - Dth(k)=(thl(k) + xlvcp/exner(k)*sqc2(k) & - & + xlscp/exner(k)*(sqi2(k)) & !+sqs(k)) & - & - th(k))/delt - !Use form from Tripoli and Cotton (1981) with their - !suggested min temperature to improve accuracy: - !Dth(k)=(thl(k)*(1.+ xlvcp/MAX(tk(k),TKmin)*sqc(k) & - ! & + xlscp/MAX(tk(k),TKmin)*sqi(k)) & - ! & - th(k))/delt - ENDDO - ELSE - DO k=kts,kte - Dth(k)=(thl(k)+xlvcp/exner(k)*sqc2(k) - th(k))/delt - !Use form from Tripoli and Cotton (1981) with their - !suggested min temperature to improve accuracy. - !Dth(k)=(thl(k)*(1.+ xlvcp/MAX(tk(k),TKmin)*sqc(k)) & - !& - th(k))/delt - ENDDO - ENDIF - - !=================== - ! AEROSOL TENDENCIES - !=================== - IF (FLAG_QNWFA .AND. FLAG_QNIFA .AND. & - bl_mynn_mixscalars > 0) THEN - DO k=kts,kte - !===================== - ! WATER-friendly aerosols - !===================== - Dqnwfa(k)=(qnwfa2(k) - qnwfa(k))/delt - !===================== - ! Ice-friendly aerosols - !===================== - Dqnifa(k)=(qnifa2(k) - qnifa(k))/delt - ENDDO - ELSE - DO k=kts,kte - Dqnwfa(k)=0. - Dqnifa(k)=0. - ENDDO - ENDIF - - !======================== - ! BLACK-CARBON TENDENCIES - !======================== - IF (FLAG_QNBCA .AND. bl_mynn_mixscalars > 0) THEN - DO k=kts,kte - Dqnbca(k)=(qnbca2(k) - qnbca(k))/delt - ENDDO - ELSE - DO k=kts,kte - Dqnbca(k)=0. - ENDDO - ENDIF - - !ensure non-negative moist species - !note: if called down here, dth needs to be updated, but - ! if called before the theta-tendency calculation, do not compute dth - !CALL moisture_check(kte, delt, delp, exner, & - ! sqv, sqc, sqi, thl, & - ! dqv, dqc, dqi, dth ) - - if (debug_code) then - problem = .false. - do k=kts,kte - wsp = sqrt(u(k)**2 + v(k)**2) - wsp2 = sqrt((u(k)+du(k)*delt)**2 + (v(k)+du(k)*delt)**2) - th2 = th(k) + Dth(k)*delt - tk2 = th2*exner(k) - if (wsp2 > 200. .or. tk2 > 360. .or. tk2 < 160.) then - problem = .true. - print*,"Outgoing problem at: i=",i," k=",k - print*," incoming wsp=",wsp," outgoing wsp=",wsp2 - print*," incoming T=",th(k)*exner(k),"outgoing T:",tk2 - print*," du=",du(k)*delt," dv=",dv(k)*delt," dth=",dth(k)*delt - print*," km=",kmdz(k)*dz(k)," kh=",khdz(k)*dz(k) - print*," u*=",ust," wspd=",wspd,"rhosfc=",rhosfc - print*," LH=",flq*rhosfc*1004.," HFX=",flt*rhosfc*1004. - print*," drag term=",ust**2/wspd*dtz(k)*rhosfc/rho(kts) - kproblem = k - endif - enddo - if (problem) then - print*,"==thl:",thl(max(kproblem-3,1):min(kproblem+3,kte)) - print*,"===qv:",sqv2(max(kproblem-3,1):min(kproblem+3,kte)) - print*,"===qc:",sqc2(max(kproblem-3,1):min(kproblem+3,kte)) - print*,"===qi:",sqi2(max(kproblem-3,1):min(kproblem+3,kte)) - print*,"====u:",u(max(kproblem-3,1):min(kproblem+3,kte)) - print*,"====v:",v(max(kproblem-3,1):min(kproblem+3,kte)) - endif - endif - -#ifdef HARDCODE_VERTICAL -# undef kts -# undef kte -#endif - - END SUBROUTINE mynn_tendencies - -! ================================================================== - SUBROUTINE moisture_check(kte, delt, dp, exner, & - qv, qc, qi, qs, th, & - dqv, dqc, dqi, dqs, dth ) - - ! This subroutine was adopted from the CAM-UW ShCu scheme and - ! adapted for use here. - ! - ! If qc < qcmin, qi < qimin, or qv < qvmin happens in any layer, - ! force them to be larger than minimum value by (1) condensating - ! water vapor into liquid or ice, and (2) by transporting water vapor - ! from the very lower layer. - ! - ! We then update the final state variables and tendencies associated - ! with this correction. If any condensation happens, update theta too. - ! Note that (qv,qc,qi,th) are the final state variables after - ! applying corresponding input tendencies and corrective tendencies. - - implicit none - integer, intent(in) :: kte - real(kind_phys), intent(in) :: delt - real(kind_phys), dimension(kte), intent(in) :: dp, exner - real(kind_phys), dimension(kte), intent(inout) :: qv, qc, qi, qs, th - real(kind_phys), dimension(kte), intent(inout) :: dqv, dqc, dqi, dqs, dth - integer k - real(kind_phys):: dqc2, dqi2, dqs2, dqv2, sum, aa, dum - real(kind_phys), parameter :: qvmin = 1e-20, & - qcmin = 0.0, & - qimin = 0.0 - - do k = kte, 1, -1 ! From the top to the surface - dqc2 = max(0.0, qcmin-qc(k)) !qc deficit (>=0) - dqi2 = max(0.0, qimin-qi(k)) !qi deficit (>=0) - dqs2 = max(0.0, qimin-qs(k)) !qs deficit (>=0) - - !fix tendencies - dqc(k) = dqc(k) + dqc2/delt - dqi(k) = dqi(k) + dqi2/delt - dqs(k) = dqs(k) + dqs2/delt - dqv(k) = dqv(k) - (dqc2+dqi2+dqs2)/delt - dth(k) = dth(k) + xlvcp/exner(k)*(dqc2/delt) + & - xlscp/exner(k)*((dqi2+dqs2)/delt) - !update species - qc(k) = qc(k) + dqc2 - qi(k) = qi(k) + dqi2 - qs(k) = qs(k) + dqs2 - qv(k) = qv(k) - dqc2 - dqi2 - dqs2 - th(k) = th(k) + xlvcp/exner(k)*dqc2 + & - xlscp/exner(k)*(dqi2+dqs2) - - !then fix qv - dqv2 = max(0.0, qvmin-qv(k)) !qv deficit (>=0) - dqv(k) = dqv(k) + dqv2/delt - qv(k) = qv(k) + dqv2 - if( k .ne. 1 ) then - qv(k-1) = qv(k-1) - dqv2*dp(k)/dp(k-1) - dqv(k-1) = dqv(k-1) - dqv2*dp(k)/dp(k-1)/delt - endif - qv(k) = max(qv(k),qvmin) - qc(k) = max(qc(k),qcmin) - qi(k) = max(qi(k),qimin) - qs(k) = max(qs(k),qimin) - end do - ! Extra moisture used to satisfy 'qv(1)>=qvmin' is proportionally - ! extracted from all the layers that has 'qv > 2*qvmin'. This fully - ! preserves column moisture. - if( dqv2 .gt. 1.e-20 ) then - sum = 0.0 - do k = 1, kte - if( qv(k) .gt. 2.0*qvmin ) sum = sum + qv(k)*dp(k) - enddo - aa = dqv2*dp(1)/max(1.e-20,sum) - if( aa .lt. 0.5 ) then - do k = 1, kte - if( qv(k) .gt. 2.0*qvmin ) then - dum = aa*qv(k) - qv(k) = qv(k) - dum - dqv(k) = dqv(k) - dum/delt - endif - enddo - else - ! For testing purposes only (not yet found in any output): - ! write(*,*) 'Full moisture conservation is impossible' - endif - endif - - return - - END SUBROUTINE moisture_check - -! ================================================================== - - SUBROUTINE mynn_mix_chem(kts,kte,i, & - delt,dz,pblh, & - nchem, kdvel, ndvel, & - chem1, vd1, & - rho, & - flt, tcd, qcd, & - dfh, & - s_aw, s_awchem, & - emis_ant_no, frp, rrfs_sd, & - enh_mix, smoke_dbg ) - -!------------------------------------------------------------------- - integer, intent(in) :: kts,kte,i - real(kind_phys), dimension(kts:kte), intent(in) :: dfh,dz,tcd,qcd - real(kind_phys), dimension(kts:kte), intent(inout) :: rho - real(kind_phys), intent(in) :: flt - real(kind_phys), intent(in) :: delt,pblh - integer, intent(in) :: nchem, kdvel, ndvel - real(kind_phys), dimension( kts:kte+1), intent(in) :: s_aw - real(kind_phys), dimension( kts:kte, nchem ), intent(inout) :: chem1 - real(kind_phys), dimension( kts:kte+1,nchem), intent(in) :: s_awchem - real(kind_phys), dimension( ndvel ), intent(in) :: vd1 - real(kind_phys), intent(in) :: emis_ant_no,frp - logical, intent(in) :: rrfs_sd,enh_mix,smoke_dbg -!local vars - - real(kind_phys), dimension(kts:kte) :: dtz - real(kind_phys), dimension(kts:kte) :: a,b,c,d,x - real(kind_phys):: rhs,dztop - real(kind_phys):: t,dzk - real(kind_phys):: hght - real(kind_phys):: khdz_old, khdz_back - integer :: k,kk,kmaxfire ! JLS 12/21/21 - integer :: ic ! Chemical array loop index - - integer, SAVE :: icall - - real(kind_phys), dimension(kts:kte) :: rhoinv - real(kind_phys), dimension(kts:kte+1) :: rhoz,khdz - real(kind_phys), parameter :: NO_threshold = 10.0 ! For anthropogenic sources - real(kind_phys), parameter :: frp_threshold = 10.0 ! RAR 02/11/22: I increased the frp threshold to enhance mixing over big fires - real(kind_phys), parameter :: pblh_threshold = 100.0 - - dztop=.5*(dz(kte)+dz(kte-1)) - - DO k=kts,kte - dtz(k)=delt/dz(k) - ENDDO - - !Prepare "constants" for diffusion equation. - !khdz = rho*Kh/dz = rho*dfh - rhoz(kts) =rho(kts) - rhoinv(kts)=1./rho(kts) - khdz(kts) =rhoz(kts)*dfh(kts) - - DO k=kts+1,kte - rhoz(k) =(rho(k)*dz(k-1) + rho(k-1)*dz(k))/(dz(k-1)+dz(k)) - rhoz(k) = MAX(rhoz(k),1E-4) - rhoinv(k)=1./MAX(rho(k),1E-4) - dzk = 0.5 *( dz(k)+dz(k-1) ) - khdz(k) = rhoz(k)*dfh(k) - ENDDO - rhoz(kte+1)=rhoz(kte) - khdz(kte+1)=rhoz(kte+1)*dfh(kte) - - !stability criteria for mf - DO k=kts+1,kte-1 - khdz(k) = MAX(khdz(k), 0.5*s_aw(k)) - khdz(k) = MAX(khdz(k), -0.5*(s_aw(k)-s_aw(k+1))) - ENDDO - - !Enhanced mixing over fires - IF ( rrfs_sd .and. enh_mix ) THEN - DO k=kts+1,kte-1 - khdz_old = khdz(k) - khdz_back = pblh * 0.15 / dz(k) - !Modify based on anthropogenic emissions of NO and FRP - IF ( pblh < pblh_threshold ) THEN - IF ( emis_ant_no > NO_threshold ) THEN - khdz(k) = MAX(1.1*khdz(k),sqrt((emis_ant_no / NO_threshold)) / dz(k) * rhoz(k)) ! JLS 12/21/21 -! khdz(k) = MAX(khdz(k),khdz_back) - ENDIF - IF ( frp > frp_threshold ) THEN - kmaxfire = ceiling(log(frp)) - khdz(k) = MAX(1.1*khdz(k), (1. - k/(kmaxfire*2.)) * ((log(frp))**2.- 2.*log(frp)) / dz(k)*rhoz(k)) ! JLS 12/21/21 -! khdz(k) = MAX(khdz(k),khdz_back) - ENDIF - ENDIF - ENDDO - ENDIF - - !============================================ - ! Patterned after mixing of water vapor in mynn_tendencies. - !============================================ - - DO ic = 1,nchem - k=kts - - a(k)= -dtz(k)*khdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - d(k)=chem1(k,ic) & !dtz(k)*flt !neglecting surface sources - & - dtz(k)*vd1(ic)*chem1(k,ic) & - & - dtz(k)*rhoinv(k)*s_awchem(k+1,ic) - - DO k=kts+1,kte-1 - a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k) - b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + & - & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1)) - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - d(k)=chem1(k,ic) + dtz(k)*rhoinv(k)*(s_awchem(k,ic)-s_awchem(k+1,ic)) - ENDDO - - ! prescribed value at top - a(kte)=0. - b(kte)=1. - c(kte)=0. - d(kte)=chem1(kte,ic) - - CALL tridiag3(kte,a,b,c,d,x) - - DO k=kts,kte - chem1(k,ic)=x(k) - ENDDO - ENDDO - - END SUBROUTINE mynn_mix_chem - -! ================================================================== -!>\ingroup gsd_mynn_edmf - SUBROUTINE retrieve_exchange_coeffs(kts,kte,& - &dfm,dfh,dz,K_m,K_h) - -!------------------------------------------------------------------- - - integer , intent(in) :: kts,kte - - real(kind_phys), dimension(KtS:KtE), intent(in) :: dz,dfm,dfh - - real(kind_phys), dimension(KtS:KtE), intent(out) :: K_m, K_h - - - integer :: k - real(kind_phys):: dzk - - K_m(kts)=0. - K_h(kts)=0. - - DO k=kts+1,kte - dzk = 0.5 *( dz(k)+dz(k-1) ) - K_m(k)=dfm(k)*dzk - K_h(k)=dfh(k)*dzk - ENDDO - - END SUBROUTINE retrieve_exchange_coeffs - -! ================================================================== -!>\ingroup gsd_mynn_edmf - SUBROUTINE tridiag(n,a,b,c,d) - -!! to solve system of linear eqs on tridiagonal matrix n times n -!! after Peaceman and Rachford, 1955 -!! a,b,c,d - are vectors of order n -!! a,b,c - are coefficients on the LHS -!! d - is initially RHS on the output becomes a solution vector - -!------------------------------------------------------------------- - - integer, intent(in):: n - real(kind_phys), dimension(n), intent(in) :: a,b - real(kind_phys), dimension(n), intent(inout) :: c,d - - integer :: i - real(kind_phys):: p - real(kind_phys), dimension(n) :: q - - c(n)=0. - q(1)=-c(1)/b(1) - d(1)=d(1)/b(1) - - DO i=2,n - p=1./(b(i)+a(i)*q(i-1)) - q(i)=-c(i)*p - d(i)=(d(i)-a(i)*d(i-1))*p - ENDDO - - DO i=n-1,1,-1 - d(i)=d(i)+q(i)*d(i+1) - ENDDO - - END SUBROUTINE tridiag - -! ================================================================== -!>\ingroup gsd_mynn_edmf - subroutine tridiag2(n,a,b,c,d,x) - implicit none -! a - sub-diagonal (means it is the diagonal below the main diagonal) -! b - the main diagonal -! c - sup-diagonal (means it is the diagonal above the main diagonal) -! d - right part -! x - the answer -! n - number of unknowns (levels) - - integer,intent(in) :: n - real(kind_phys), dimension(n), intent(in) :: a,b,c,d - real(kind_phys), dimension(n), intent(out):: x - real(kind_phys), dimension(n) :: cp,dp - real(kind_phys):: m - integer :: i - - ! initialize c-prime and d-prime - cp(1) = c(1)/b(1) - dp(1) = d(1)/b(1) - ! solve for vectors c-prime and d-prime - do i = 2,n - m = b(i)-cp(i-1)*a(i) - cp(i) = c(i)/m - dp(i) = (d(i)-dp(i-1)*a(i))/m - enddo - ! initialize x - x(n) = dp(n) - ! solve for x from the vectors c-prime and d-prime - do i = n-1, 1, -1 - x(i) = dp(i)-cp(i)*x(i+1) - end do - - end subroutine tridiag2 -! ================================================================== -!>\ingroup gsd_mynn_edmf - subroutine tridiag3(kte,a,b,c,d,x) - -!ccccccccccccccccccccccccccccccc -! Aim: Inversion and resolution of a tridiagonal matrix -! A X = D -! Input: -! a(*) lower diagonal (Ai,i-1) -! b(*) principal diagonal (Ai,i) -! c(*) upper diagonal (Ai,i+1) -! d -! Output -! x results -!ccccccccccccccccccccccccccccccc - - implicit none - integer,intent(in) :: kte - integer, parameter :: kts=1 - real(kind_phys), dimension(kte) :: a,b,c,d - real(kind_phys), dimension(kte), intent(out) :: x - integer :: in - -! integer kms,kme,kts,kte,in -! real(kind_phys)a(kms:kme,3),c(kms:kme),x(kms:kme) - - do in=kte-1,kts,-1 - d(in)=d(in)-c(in)*d(in+1)/b(in+1) - b(in)=b(in)-c(in)*a(in+1)/b(in+1) - enddo - - do in=kts+1,kte - d(in)=d(in)-a(in)*d(in-1)/b(in-1) - enddo - - do in=kts,kte - x(in)=d(in)/b(in) - enddo - - return - end subroutine tridiag3 - -! ================================================================== -!>\ingroup gsd_mynn_edmf -!! This subroutine calculates hybrid diagnotic boundary-layer height (PBLH). -!! -!! NOTES ON THE PBLH FORMULATION: The 1.5-theta-increase method defines -!!PBL heights as the level at. -!!which the potential temperature first exceeds the minimum potential. -!!temperature within the boundary layer by 1.5 K. When applied to. -!!observed temperatures, this method has been shown to produce PBL- -!!height estimates that are unbiased relative to profiler-based. -!!estimates (Nielsen-Gammon et al. 2008 \cite Nielsen_Gammon_2008). -!! However, their study did not -!!include LLJs. Banta and Pichugina (2008) \cite Pichugina_2008 show that a TKE-based. -!!threshold is a good estimate of the PBL height in LLJs. Therefore, -!!a hybrid definition is implemented that uses both methods, weighting -!!the TKE-method more during stable conditions (PBLH < 400 m). -!!A variable tke threshold (TKEeps) is used since no hard-wired -!!value could be found to work best in all conditions. -!>\section gen_get_pblh GSD get_pblh General Algorithm -!> @{ - SUBROUTINE GET_PBLH(KTS,KTE,zi,thetav1D,qke1D,zw1D,dz1D,landsea,kzi) - - !--------------------------------------------------------------- - ! NOTES ON THE PBLH FORMULATION - ! - !The 1.5-theta-increase method defines PBL heights as the level at - !which the potential temperature first exceeds the minimum potential - !temperature within the boundary layer by 1.5 K. When applied to - !observed temperatures, this method has been shown to produce PBL- - !height estimates that are unbiased relative to profiler-based - !estimates (Nielsen-Gammon et al. 2008). However, their study did not - !include LLJs. Banta and Pichugina (2008) show that a TKE-based - !threshold is a good estimate of the PBL height in LLJs. Therefore, - !a hybrid definition is implemented that uses both methods, weighting - !the TKE-method more during stable conditions (PBLH < 400 m). - !A variable tke threshold (TKEeps) is used since no hard-wired - !value could be found to work best in all conditions. - !--------------------------------------------------------------- - - integer,intent(in) :: KTS,KTE - -#ifdef HARDCODE_VERTICAL -# define kts 1 -# define kte HARDCODE_VERTICAL -#endif - - real(kind_phys), intent(out) :: zi - real(kind_phys), intent(in) :: landsea - real(kind_phys), dimension(kts:kte), intent(in) :: thetav1D, qke1D, dz1D - real(kind_phys), dimension(kts:kte+1), intent(in) :: zw1D - !LOCAL VARS - real(kind_phys):: PBLH_TKE,qtke,qtkem1,wt,maxqke,TKEeps,minthv - real(kind_phys):: delt_thv !delta theta-v; dependent on land/sea point - real(kind_phys), parameter :: sbl_lim = 200. !upper limit of stable BL height (m). - real(kind_phys), parameter :: sbl_damp = 400. !transition length for blending (m). - integer :: I,J,K,kthv,ktke,kzi - - !Initialize KPBL (kzi) - kzi = 2 - - !> - FIND MIN THETAV IN THE LOWEST 200 M AGL - k = kts+1 - kthv = 1 - minthv = 9.E9 - DO WHILE (zw1D(k) .LE. 200.) - !DO k=kts+1,kte-1 - IF (minthv > thetav1D(k)) then - minthv = thetav1D(k) - kthv = k - ENDIF - k = k+1 - !IF (zw1D(k) .GT. sbl_lim) exit - ENDDO - - !> - FIND THETAV-BASED PBLH (BEST FOR DAYTIME). - zi=0. - k = kthv+1 - IF((landsea-1.5).GE.0)THEN - ! WATER - delt_thv = 1.0 - ELSE - ! LAND - delt_thv = 1.25 - ENDIF - - zi=0. - k = kthv+1 -! DO WHILE (zi .EQ. 0.) - DO k=kts+1,kte-1 - IF (thetav1D(k) .GE. (minthv + delt_thv))THEN - zi = zw1D(k) - dz1D(k-1)* & - & MIN((thetav1D(k)-(minthv + delt_thv))/ & - & MAX(thetav1D(k)-thetav1D(k-1),1E-6),1.0) - ENDIF - !k = k+1 - IF (k .EQ. kte-1) zi = zw1D(kts+1) !EXIT SAFEGUARD - IF (zi .NE. 0.0) exit - ENDDO - !print*,"IN GET_PBLH:",thsfc,zi - - !> - FOR STABLE BOUNDARY LAYERS, USE TKE METHOD TO COMPLEMENT THE - !! THETAV-BASED DEFINITION (WHEN THE THETA-V BASED PBLH IS BELOW ~0.5 KM). - !!THE TANH WEIGHTING FUNCTION WILL MAKE THE TKE-BASED DEFINITION NEGLIGIBLE - !!WHEN THE THETA-V-BASED DEFINITION IS ABOVE ~1 KM. - ktke = 1 - maxqke = MAX(Qke1D(kts),0.) - !Use 5% of tke max (Kosovic and Curry, 2000; JAS) - !TKEeps = maxtke/20. = maxqke/40. - TKEeps = maxqke/40. - TKEeps = MAX(TKEeps,0.02) !0.025) - PBLH_TKE=0. - - k = ktke+1 -! DO WHILE (PBLH_TKE .EQ. 0.) - DO k=kts+1,kte-1 - !QKE CAN BE NEGATIVE (IF CKmod == 0)... MAKE TKE NON-NEGATIVE. - qtke =MAX(Qke1D(k)/2.,0.) ! maximum TKE - qtkem1=MAX(Qke1D(k-1)/2.,0.) - IF (qtke .LE. TKEeps) THEN - PBLH_TKE = zw1D(k) - dz1D(k-1)* & - & MIN((TKEeps-qtke)/MAX(qtkem1-qtke, 1E-6), 1.0) - !IN CASE OF NEAR ZERO TKE, SET PBLH = LOWEST LEVEL. - PBLH_TKE = MAX(PBLH_TKE,zw1D(kts+1)) - !print *,"PBLH_TKE:",i,PBLH_TKE, Qke1D(k)/2., zw1D(kts+1) - ENDIF - !k = k+1 - IF (k .EQ. kte-1) PBLH_TKE = zw1D(kts+1) !EXIT SAFEGUARD - IF (PBLH_TKE .NE. 0.) exit - ENDDO - - !> - With TKE advection turned on, the TKE-based PBLH can be very large - !! in grid points with convective precipitation (> 8 km!), - !! so an artificial limit is imposed to not let PBLH_TKE exceed the - !!theta_v-based PBL height +/- 350 m. - !!This has no impact on 98-99% of the domain, but is the simplest patch - !!that adequately addresses these extremely large PBLHs. - PBLH_TKE = MIN(PBLH_TKE,zi+350.) - PBLH_TKE = MAX(PBLH_TKE,MAX(zi-350.,10.)) - - wt=.5*TANH((zi - sbl_lim)/sbl_damp) + .5 - IF (maxqke <= 0.05) THEN - !Cold pool situation - default to theta_v-based def - ELSE - !BLEND THE TWO PBLH TYPES HERE: - zi=PBLH_TKE*(1.-wt) + zi*wt - ENDIF - - !Compute KPBL (kzi) - DO k=kts+1,kte-1 - IF ( zw1D(k) >= zi) THEN - kzi = k-1 - exit - ENDIF - ENDDO - -#ifdef HARDCODE_VERTICAL -# undef kts -# undef kte -#endif - - END SUBROUTINE GET_PBLH -!> @} - -! ================================================================== -!>\ingroup gsd_mynn_edmf -!! This subroutine is the Dynamic Multi-Plume (DMP) Mass-Flux Scheme. -!! -!! dmp_mf() calculates the nonlocal turbulent transport from the dynamic -!! multiplume mass-flux scheme as well as the shallow-cumulus component of -!! the subgrid clouds. Note that this mass-flux scheme is called when the -!! namelist paramter \p bl_mynn_edmf is set to 1 (recommended). -!! -!! Much thanks to Kay Suslj of NASA-JPL for contributing the original version -!! of this mass-flux scheme. Considerable changes have been made from it's -!! original form. Some additions include: -!! -# scale-aware tapering as dx -> 0 -!! -# transport of TKE (extra namelist option) -!! -# Chaboureau-Bechtold cloud fraction & coupling to radiation (when icloud_bl > 0) -!! -# some extra limits for numerical stability -!! -!! This scheme remains under development, so consider it experimental code. -!! - SUBROUTINE DMP_mf( & - & kts,kte,dt,zw,dz,p,rho, & - & momentum_opt, & - & tke_opt, & - & scalar_opt, & - & u,v,w,th,thl,thv,tk, & - & qt,qv,qc,qke, & - & qnc,qni,qnwfa,qnifa,qnbca, & - & exner,vt,vq,sgm, & - & ust,flt,fltv,flq,flqv, & - & pblh,kpbl,dx,landsea,ts, & - ! outputs - updraft properties - & edmf_a,edmf_w, & - & edmf_qt,edmf_thl, & - & edmf_ent,edmf_qc, & - ! outputs - variables needed for solver - & s_aw,s_awthl,s_awqt, & - & s_awqv,s_awqc, & - & s_awu,s_awv,s_awqke, & - & s_awqnc,s_awqni, & - & s_awqnwfa,s_awqnifa, & - & s_awqnbca, & - & sub_thl,sub_sqv, & - & sub_u,sub_v, & - & det_thl,det_sqv,det_sqc, & - & det_u,det_v, & - ! chem/smoke - & nchem,chem1,s_awchem, & - & mix_chem, & - ! in/outputs - subgrid scale clouds - & qc_bl1d,cldfra_bl1d, & - & qc_bl1D_old,cldfra_bl1D_old, & - ! inputs - flags for moist arrays - & F_QC,F_QI, & - & F_QNC,F_QNI, & - & F_QNWFA,F_QNIFA,F_QNBCA, & - & Psig_shcu, & - ! output info - & maxwidth,ktop,maxmf,ztop, & - ! inputs for stochastic perturbations - & spp_pbl,rstoch_col ) - - ! inputs: - integer, intent(in) :: KTS,KTE,KPBL,momentum_opt,tke_opt,scalar_opt - -#ifdef HARDCODE_VERTICAL -# define kts 1 -# define kte HARDCODE_VERTICAL -#endif - -! Stochastic - integer, intent(in) :: spp_pbl - real(kind_phys), dimension(kts:kte) :: rstoch_col - - real(kind_phys),dimension(kts:kte), intent(in) :: & - &U,V,W,TH,THL,TK,QT,QV,QC, & - &exner,dz,THV,P,rho,qke,qnc,qni,qnwfa,qnifa,qnbca - real(kind_phys),dimension(kts:kte+1), intent(in) :: zw !height at full-sigma - real(kind_phys), intent(in) :: flt,fltv,flq,flqv,Psig_shcu, & - &landsea,ts,dx,dt,ust,pblh - logical, optional :: F_QC,F_QI,F_QNC,F_QNI,F_QNWFA,F_QNIFA,F_QNBCA - - ! outputs - updraft properties - real(kind_phys),dimension(kts:kte), intent(out) :: edmf_a,edmf_w, & - & edmf_qt,edmf_thl,edmf_ent,edmf_qc - !add one local edmf variable: - real(kind_phys),dimension(kts:kte) :: edmf_th - ! output - integer, intent(out) :: ktop - real(kind_phys), intent(out) :: maxmf,ztop,maxwidth - ! outputs - variables needed for solver - real(kind_phys),dimension(kts:kte+1) :: s_aw, & !sum ai*rho*wis_awphi - &s_awthl,s_awqt,s_awqv,s_awqc,s_awqnc,s_awqni, & - &s_awqnwfa,s_awqnifa,s_awqnbca,s_awu,s_awv, & - &s_awqke,s_aw2 - - real(kind_phys),dimension(kts:kte), intent(inout) :: & - &qc_bl1d,cldfra_bl1d,qc_bl1d_old,cldfra_bl1d_old - - integer, parameter :: nup=8, debug_mf=0 - real(kind_phys) :: nup2 - - !------------- local variables ------------------- - ! updraft properties defined on interfaces (k=1 is the top of the - ! first model layer - real(kind_phys),dimension(kts:kte+1,1:NUP) :: & - &UPW,UPTHL,UPQT,UPQC,UPQV, & - &UPA,UPU,UPV,UPTHV,UPQKE,UPQNC, & - &UPQNI,UPQNWFA,UPQNIFA,UPQNBCA - ! entrainment variables - real(kind_phys),dimension(kts:kte,1:NUP) :: ENT,ENTf - integer,dimension(kts:kte,1:NUP) :: ENTi - ! internal variables - integer :: K,I,k50 - real(kind_phys):: fltv2,wstar,qstar,thstar,sigmaW,sigmaQT, & - &sigmaTH,z0,pwmin,pwmax,wmin,wmax,wlv,Psig_w,maxw,maxqc,wpbl - real(kind_phys):: B,QTn,THLn,THVn,QCn,Un,Vn,QKEn,QNCn,QNIn, & - & QNWFAn,QNIFAn,QNBCAn, & - & Wn2,Wn,EntEXP,EntEXM,EntW,BCOEFF,THVkm1,THVk,Pk,rho_int - - ! w parameters - real(kind_phys), parameter :: & - &Wa=2./3., & - &Wb=0.002, & - &Wc=1.5 - - ! Lateral entrainment parameters ( L0=100 and ENT0=0.1) were taken from - ! Suselj et al (2013, jas). Note that Suselj et al (2014,waf) use L0=200 and ENT0=0.2. - real(kind_phys),parameter :: & - & L0=100., & - & ENT0=0.1 - - ! Parameters/variables for regulating plumes: - real(kind_phys), parameter :: Atot = 0.10 ! Maximum total fractional area of all updrafts - real(kind_phys), parameter :: lmax = 1000.! diameter of largest plume (absolute maximum, can be smaller) - real(kind_phys), parameter :: lmin = 300. ! diameter of smallest plume (absolute minimum, can be larger) - real(kind_phys), parameter :: dlmin = 0. ! delta increase in the diameter of smallest plume (large fltv) - real(kind_phys) :: minwidth ! actual width of smallest plume - real(kind_phys) :: dl ! variable increment of plume size - real(kind_phys), parameter :: dcut = 1.2 ! max diameter of plume to parameterize relative to dx (km) - real(kind_phys):: d != -2.3 to -1.7 ;=-1.9 in Neggers paper; power law exponent for number density (N=Cl^d). - ! Note that changing d to -2.0 makes each size plume equally contribute to the total coverage of all plumes. - ! Note that changing d to -1.7 doubles the area coverage of the largest plumes relative to the smallest plumes. - real(kind_phys):: cn,c,l,n,an2,hux,wspd_pbl,cloud_base,width_flx - - ! chem/smoke - integer, intent(in) :: nchem - real(kind_phys),dimension(:, :) :: chem1 - real(kind_phys),dimension(kts:kte+1, nchem) :: s_awchem - real(kind_phys),dimension(nchem) :: chemn - real(kind_phys),dimension(kts:kte+1,1:NUP, nchem) :: UPCHEM - integer :: ic - real(kind_phys),dimension(kts:kte+1, nchem) :: edmf_chem - logical, intent(in) :: mix_chem - - !JOE: add declaration of ERF - real(kind_phys):: ERF - - logical :: superadiabatic - - ! VARIABLES FOR CHABOUREAU-BECHTOLD CLOUD FRACTION - real(kind_phys),dimension(kts:kte), intent(inout) :: vt, vq, sgm - real(kind_phys):: sigq,xl,rsl,cpm,a,qmq,mf_cf,Aup,Q1,diffqt,qsat_tk,& - Fng,qww,alpha,beta,bb,f,pt,t,q2p,b9,satvp,rhgrid, & - Ac_mf,Ac_strat,qc_mf - real(kind_phys), parameter :: cf_thresh = 0.5 ! only overwrite stratus CF less than this value - - ! Variables for plume interpolation/saturation check - real(kind_phys),dimension(kts:kte) :: exneri,dzi,rhoz - real(kind_phys):: THp, QTp, QCp, QCs, esat, qsl - real(kind_phys):: csigma,acfac,ac_wsp - - !plume overshoot - integer :: overshoot - real(kind_phys):: bvf, Frz, dzp - - !Flux limiter: not let mass-flux of heat between k=1&2 exceed (fluxportion)*(surface heat flux). - !This limiter makes adjustments to the entire column. - real(kind_phys):: adjustment, flx1, flt2 - real(kind_phys), parameter :: fluxportion=0.75 ! set liberally, so has minimal impact. Note that - ! 0.5 starts to have a noticeable impact - ! over land (decrease maxMF by 10-20%), but no impact over water. - - !Subsidence - real(kind_phys),dimension(kts:kte) :: sub_thl,sub_sqv,sub_u,sub_v, & !tendencies due to subsidence - det_thl,det_sqv,det_sqc,det_u,det_v, & !tendencied due to detrainment - envm_a,envm_w,envm_thl,envm_sqv,envm_sqc, & - envm_u,envm_v !environmental variables defined at middle of layer - real(kind_phys),dimension(kts:kte+1) :: envi_a,envi_w !environmental variables defined at model interface - real(kind_phys):: temp,sublim,qc_ent,qv_ent,qt_ent,thl_ent,detrate, & - detrateUV,oow,exc_fac,aratio,detturb,qc_grid,qc_sgs, & - qc_plume,exc_heat,exc_moist,tk_int,tvs - real(kind_phys), parameter :: Cdet = 1./45. - real(kind_phys), parameter :: dzpmax = 300. !limit dz used in detrainment - can be excessing in thick layers - !parameter "Csub" determines the propotion of upward vertical velocity that contributes to - !environmenatal subsidence. Some portion is expected to be compensated by downdrafts instead of - !gentle environmental subsidence. 1.0 assumes all upward vertical velocity in the mass-flux scheme - !is compensated by "gentle" environmental subsidence. - real(kind_phys), parameter :: Csub=0.25 - - !Factor for the pressure gradient effects on momentum transport - real(kind_phys), parameter :: pgfac = 0.00 ! Zhang and Wu showed 0.4 is more appropriate for lower troposphere - real(kind_phys):: Uk,Ukm1,Vk,Vkm1,dxsa - -! check the inputs -! print *,'dt',dt -! print *,'dz',dz -! print *,'u',u -! print *,'v',v -! print *,'thl',thl -! print *,'qt',qt -! print *,'ust',ust -! print *,'flt',flt -! print *,'flq',flq -! print *,'pblh',pblh - -! Initialize individual updraft properties - UPW=0. - UPTHL=0. - UPTHV=0. - UPQT=0. - UPA=0. - UPU=0. - UPV=0. - UPQC=0. - UPQV=0. - UPQKE=0. - UPQNC=0. - UPQNI=0. - UPQNWFA=0. - UPQNIFA=0. - UPQNBCA=0. - if ( mix_chem ) then - UPCHEM(kts:kte+1,1:NUP,1:nchem)=0.0 - endif - - ENT=0.001 -! Initialize mean updraft properties - edmf_a =0. - edmf_w =0. - edmf_qt =0. - edmf_thl=0. - edmf_ent=0. - edmf_qc =0. - if ( mix_chem ) then - edmf_chem(kts:kte+1,1:nchem) = 0.0 - endif - -! Initialize the variables needed for implicit solver - s_aw=0. - s_awthl=0. - s_awqt=0. - s_awqv=0. - s_awqc=0. - s_awu=0. - s_awv=0. - s_awqke=0. - s_awqnc=0. - s_awqni=0. - s_awqnwfa=0. - s_awqnifa=0. - s_awqnbca=0. - if ( mix_chem ) then - s_awchem(kts:kte+1,1:nchem) = 0.0 - endif - -! Initialize explicit tendencies for subsidence & detrainment - sub_thl = 0. - sub_sqv = 0. - sub_u = 0. - sub_v = 0. - det_thl = 0. - det_sqv = 0. - det_sqc = 0. - det_u = 0. - det_v = 0. - nup2 = nup !start with nup, but set to zero if activation criteria fails - - ! Taper off MF scheme when significant resolved-scale motions - ! are present This function needs to be asymetric... - maxw = 0.0 - cloud_base = 9000.0 - do k=1,kte-1 - if (zw(k) > pblh + 500.) exit - - wpbl = w(k) - if (w(k) < 0.)wpbl = 2.*w(k) - maxw = max(maxw,abs(wpbl)) - - !Find highest k-level below 50m AGL - if (ZW(k)<=50.)k50=k - - !Search for cloud base - qc_sgs = max(qc(k), qc_bl1d(k)) - if (qc_sgs> 1E-5 .and. (cldfra_bl1d(k) .ge. 0.5) .and. cloud_base == 9000.0) then - cloud_base = 0.5*(ZW(k)+ZW(k+1)) - endif - enddo - - !do nothing for small w (< 1 m/s), but linearly taper off for w > 1.0 m/s - maxw = max(0.,maxw - 1.0) - Psig_w = max(0.0, 1.0 - maxw) - Psig_w = min(Psig_w, Psig_shcu) - - !Completely shut off MF scheme for strong resolved-scale vertical velocities. - fltv2 = fltv - if(Psig_w == 0.0 .and. fltv > 0.0) fltv2 = -1.*fltv - - ! If surface buoyancy is positive we do integration, otherwise no. - ! Also, ensure that it is at least slightly superadiabatic up through 50 m - superadiabatic = .false. - if ((landsea-1.5).ge.0) then - hux = -0.001 ! WATER ! dT/dz must be < - 0.1 K per 100 m. - else - hux = -0.005 ! LAND ! dT/dz must be < - 0.5 K per 100 m. - endif - tvs = ts*(1.0+p608*qv(kts)) - do k=1,max(1,k50-1) !use "-1" because k50 used interface heights (zw). - if (k == 1) then - if ((thv(k)-tvs)/(0.5*dz(k)) < hux) then - superadiabatic = .true. - else - superadiabatic = .false. - exit - endif - else - if ((thv(k)-thv(k-1))/(0.5*(dz(k)+dz(k-1))) < hux) then - superadiabatic = .true. - else - superadiabatic = .false. - exit - endif - endif - enddo - - ! Determine the numer of updrafts/plumes in the grid column: - ! Some of these criteria may be a little redundant but useful for bullet-proofing. - ! (1) largest plume = 1.2 * dx. - ! (2) Apply a scale-break, assuming no plumes with diameter larger than 1.1*PBLH can exist. - ! (3) max plume size beneath clouds deck approx = 0.5 * cloud_base. - ! (4) add wspd-dependent limit, when plume model breaks down. (hurricanes) - ! (5) limit to reduce max plume sizes in weakly forced conditions. This is only - ! meant to "soften" the activation of the mass-flux scheme. - ! Criteria (1) - maxwidth = min(dx*dcut, lmax) - !Criteria (2) - maxwidth = min(maxwidth, 1.1_kind_phys*PBLH) - ! Criteria (3) - if ((landsea-1.5) .lt. 0) then !land - maxwidth = MIN(maxwidth, 0.5_kind_phys*cloud_base) - else !water - maxwidth = MIN(maxwidth, 0.9_kind_phys*cloud_base) - endif - ! Criteria (4) - wspd_pbl=SQRT(MAX(u(kts)**2 + v(kts)**2, 0.01_kind_phys)) - !Note: area fraction (acfac) is modified below - ! Criteria (5) - only a function of flt (not fltv) - if ((landsea-1.5).LT.0) then !land - width_flx = MAX(MIN(1000.*(0.6*tanh((fltv - 0.040)/0.04) + .5),1000._kind_phys), 0._kind_phys) - else !water - width_flx = MAX(MIN(1000.*(0.6*tanh((fltv - 0.007)/0.02) + .5),1000._kind_phys), 0._kind_phys) - endif - maxwidth = MIN(maxwidth, width_flx) - minwidth = lmin - !allow min plume size to increase in large flux conditions (eddy diffusivity should be - !large enough to handle the representation of small plumes). - if (maxwidth .ge. (lmax - 1.0) .and. fltv .gt. 0.2)minwidth = lmin + dlmin*min((fltv-0.2)/0.3, 1._kind_phys) - - if (maxwidth .le. minwidth) then ! deactivate MF component - nup2 = 0 - maxwidth = 0.0 - endif - - ! Initialize values for 2d output fields: - ktop = 0 - ztop = 0.0 - maxmf= 0.0 - -!Begin plume processing if passes criteria -if ( fltv2 > 0.002 .AND. (maxwidth > minwidth) .AND. superadiabatic) then - - ! Find coef C for number size density N - cn = 0. - d =-1.9 !set d to value suggested by Neggers 2015 (JAMES). - dl = (maxwidth - minwidth)/real(nup-1,kind=kind_phys) - do i=1,NUP - ! diameter of plume - l = minwidth + dl*real(i-1) - cn = cn + l**d * (l*l)/(dx*dx) * dl ! sum fractional area of each plume - enddo - C = Atot/cn !Normalize C according to the defined total fraction (Atot) - - ! Make updraft area (UPA) a function of the buoyancy flux - acfac = .5*tanh((fltv2 - 0.02)/0.05) + .5 - - !add a windspeed-dependent adjustment to acfac that tapers off - !the mass-flux scheme linearly above sfc wind speeds of 10 m/s. - !Note: this effect may be better represented by an increase in - !entrainment rate for high wind consitions (more ambient turbulence). - if (wspd_pbl .le. 10.) then - ac_wsp = 1.0 - else - ac_wsp = 1.0 - min((wspd_pbl - 10.0)/15., 1.0) - endif - acfac = acfac * ac_wsp - - ! Find the portion of the total fraction (Atot) of each plume size: - An2 = 0. - do i=1,NUP - ! diameter of plume - l = minwidth + dl*real(i-1) - N = C*l**d ! number density of plume n - UPA(1,i) = N*l*l/(dx*dx) * dl ! fractional area of plume n - - UPA(1,i) = UPA(1,i)*acfac - An2 = An2 + UPA(1,i) ! total fractional area of all plumes - !print*," plume size=",l,"; area=",UPA(1,I),"; total=",An2 - end do - - ! set initial conditions for updrafts - z0=50. - pwmin=0.1 ! was 0.5 - pwmax=0.4 ! was 3.0 - - wstar=max(1.E-2,(gtr*fltv2*pblh)**(onethird)) - qstar=max(flq,1.0E-5)/wstar - thstar=flt/wstar - - if ((landsea-1.5) .ge. 0) then - csigma = 1.34 ! WATER - else - csigma = 1.34 ! LAND - endif - - if (env_subs) then - exc_fac = 0.0 - else - if ((landsea-1.5).GE.0) then - !water: increase factor to compensate for decreased pwmin/pwmax - exc_fac = 0.58*4.0 - else - !land: no need to increase factor - already sufficiently large superadiabatic layers - exc_fac = 0.58 - endif - endif - !decrease excess for large wind speeds - exc_fac = exc_fac * ac_wsp - - !Note: sigmaW is typically about 0.5*wstar - sigmaW =csigma*wstar*(z0/pblh)**(onethird)*(1 - 0.8*z0/pblh) - sigmaQT=csigma*qstar*(z0/pblh)**(onethird) - sigmaTH=csigma*thstar*(z0/pblh)**(onethird) - - !Note: Given the pwmin & pwmax set above, these max/mins are - ! rarely exceeded. - wmin=MIN(sigmaW*pwmin,0.1) - wmax=MIN(sigmaW*pwmax,0.5) - - !SPECIFY SURFACE UPDRAFT PROPERTIES AT MODEL INTERFACE BETWEEN K = 1 & 2 - do i=1,NUP - wlv=wmin+(wmax-wmin)/NUP2*(i-1) - - !SURFACE UPDRAFT VERTICAL VELOCITY - UPW(1,I)=wmin + real(i)/real(NUP)*(wmax-wmin) - UPU(1,I)=(U(KTS)*DZ(KTS+1)+U(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) - UPV(1,I)=(V(KTS)*DZ(KTS+1)+V(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) - UPQC(1,I)=0.0 - !UPQC(1,I)=(QC(KTS)*DZ(KTS+1)+QC(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) - - exc_heat = exc_fac*UPW(1,I)*sigmaTH/sigmaW - UPTHV(1,I)=(THV(KTS)*DZ(KTS+1)+THV(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) & - & + exc_heat - UPTHL(1,I)=(THL(KTS)*DZ(KTS+1)+THL(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) & - & + exc_heat - - !calculate exc_moist by use of surface fluxes - exc_moist=exc_fac*UPW(1,I)*sigmaQT/sigmaW - UPQT(1,I)=(QT(KTS)*DZ(KTS+1)+QT(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1))& - & +exc_moist - - UPQKE(1,I)=(QKE(KTS)*DZ(KTS+1)+QKE(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) - UPQNC(1,I)=(QNC(KTS)*DZ(KTS+1)+QNC(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) - UPQNI(1,I)=(QNI(KTS)*DZ(KTS+1)+QNI(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) - UPQNWFA(1,I)=(QNWFA(KTS)*DZ(KTS+1)+QNWFA(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) - UPQNIFA(1,I)=(QNIFA(KTS)*DZ(KTS+1)+QNIFA(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) - UPQNBCA(1,I)=(QNBCA(KTS)*DZ(KTS+1)+QNBCA(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) - enddo - - if ( mix_chem ) then - do i=1,NUP - do ic = 1,nchem - UPCHEM(1,i,ic)=(chem1(KTS,ic)*DZ(KTS+1)+chem1(KTS+1,ic)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) - enddo - enddo - endif - - !Initialize environmental variables which can be modified by detrainment - envm_thl(kts:kte)=THL(kts:kte) - envm_sqv(kts:kte)=QV(kts:kte) - envm_sqc(kts:kte)=QC(kts:kte) - envm_u(kts:kte)=U(kts:kte) - envm_v(kts:kte)=V(kts:kte) - do k=kts,kte-1 - rhoz(k) = (rho(k)*dz(k+1)+rho(k+1)*dz(k))/(dz(k+1)+dz(k)) - enddo - rhoz(kte) = rho(kte) - - !dxsa is scale-adaptive factor governing the pressure-gradient term of the momentum transport - dxsa = 1. - MIN(MAX((12000.0-dx)/(12000.0-3000.0), 0.), 1.) - - ! do integration updraft - do i=1,NUP - QCn = 0. - overshoot = 0 - l = minwidth + dl*real(i-1) ! diameter of plume - do k=kts+1,kte-1 - !Entrainment from Tian and Kuang (2016) - !ENT(k,i) = 0.35/(MIN(MAX(UPW(K-1,I),0.75),1.9)*l) - wmin = 0.3 + l*0.0005 !* MAX(pblh-ZW(k+1), 0.0)/pblh - ENT(k,i) = 0.33/(MIN(MAX(UPW(K-1,I),wmin),0.9)*l) - - !Entrainment from Negggers (2015, JAMES) - !ENT(k,i) = 0.02*l**-0.35 - 0.0009 - !ENT(k,i) = 0.04*l**-0.50 - 0.0009 !more plume diversity - !ENT(k,i) = 0.04*l**-0.495 - 0.0009 !"neg1+" - - !Minimum background entrainment - ENT(k,i) = max(ENT(k,i),0.0003) - !ENT(k,i) = max(ENT(k,i),0.05/ZW(k)) !not needed for Tian and Kuang - - !increase entrainment for plumes extending very high. - IF(ZW(k) >= MIN(pblh+1500., 4000.))THEN - ENT(k,i)=ENT(k,i) + (ZW(k)-MIN(pblh+1500.,4000.))*5.0E-6 - ENDIF - - !SPP - ENT(k,i) = ENT(k,i) * (1.0 - rstoch_col(k)) - - ENT(k,i) = min(ENT(k,i),0.9/(ZW(k+1)-ZW(k))) - - ! Define environment U & V at the model interface levels - Uk =(U(k)*DZ(k+1)+U(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) - Ukm1=(U(k-1)*DZ(k)+U(k)*DZ(k-1))/(DZ(k-1)+DZ(k)) - Vk =(V(k)*DZ(k+1)+V(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) - Vkm1=(V(k-1)*DZ(k)+V(k)*DZ(k-1))/(DZ(k-1)+DZ(k)) - - ! Linear entrainment: - EntExp= ENT(K,I)*(ZW(k+1)-ZW(k)) - EntExm= EntExp*0.3333 !reduce entrainment for momentum - QTn =UPQT(k-1,I) *(1.-EntExp) + QT(k)*EntExp - THLn=UPTHL(k-1,I)*(1.-EntExp) + THL(k)*EntExp - Un =UPU(k-1,I) *(1.-EntExm) + U(k)*EntExm + dxsa*pgfac*(Uk - Ukm1) - Vn =UPV(k-1,I) *(1.-EntExm) + V(k)*EntExm + dxsa*pgfac*(Vk - Vkm1) - QKEn=UPQKE(k-1,I)*(1.-EntExp) + QKE(k)*EntExp - QNCn=UPQNC(k-1,I)*(1.-EntExp) + QNC(k)*EntExp - QNIn=UPQNI(k-1,I)*(1.-EntExp) + QNI(k)*EntExp - QNWFAn=UPQNWFA(k-1,I)*(1.-EntExp) + QNWFA(k)*EntExp - QNIFAn=UPQNIFA(k-1,I)*(1.-EntExp) + QNIFA(k)*EntExp - QNBCAn=UPQNBCA(k-1,I)*(1.-EntExp) + QNBCA(k)*EntExp - - !capture the updated qc, qt & thl modified by entranment alone, - !since they will be modified later if condensation occurs. - qc_ent = QCn - qt_ent = QTn - thl_ent = THLn - - ! Exponential Entrainment: - !EntExp= exp(-ENT(K,I)*(ZW(k)-ZW(k-1))) - !QTn =QT(K) *(1-EntExp)+UPQT(K-1,I)*EntExp - !THLn=THL(K)*(1-EntExp)+UPTHL(K-1,I)*EntExp - !Un =U(K) *(1-EntExp)+UPU(K-1,I)*EntExp - !Vn =V(K) *(1-EntExp)+UPV(K-1,I)*EntExp - !QKEn=QKE(k)*(1-EntExp)+UPQKE(K-1,I)*EntExp - - if ( mix_chem ) then - do ic = 1,nchem - ! Exponential Entrainment: - !chemn(ic) = chem(k,ic)*(1-EntExp)+UPCHEM(K-1,I,ic)*EntExp - ! Linear entrainment: - chemn(ic)=UPCHEM(k-1,i,ic)*(1.-EntExp) + chem1(k,ic)*EntExp - enddo - endif - - ! Define pressure at model interface - Pk =(P(k)*DZ(k+1)+P(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) - ! Compute plume properties thvn and qcn - call condensation_edmf(QTn,THLn,Pk,ZW(k+1),THVn,QCn) - - ! Define environment THV at the model interface levels - THVk =(THV(k)*DZ(k+1)+THV(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) - THVkm1=(THV(k-1)*DZ(k)+THV(k)*DZ(k-1))/(DZ(k-1)+DZ(k)) - -! B=g*(0.5*(THVn+UPTHV(k-1,I))/THV(k-1) - 1.0) - B=grav*(THVn/THVk - 1.0) - IF(B>0.)THEN - BCOEFF = 0.15 !w typically stays < 2.5, so doesnt hit the limits nearly as much - ELSE - BCOEFF = 0.2 !0.33 - ENDIF - - ! Original StEM with exponential entrainment - !EntW=exp(-2.*(Wb+Wc*ENT(K,I))*(ZW(k)-ZW(k-1))) - !Wn2=UPW(K-1,I)**2*EntW + (1.-EntW)*0.5*Wa*B/(Wb+Wc*ENT(K,I)) - ! Original StEM with linear entrainment - !Wn2=UPW(K-1,I)**2*(1.-EntExp) + EntExp*0.5*Wa*B/(Wb+Wc*ENT(K,I)) - !Wn2=MAX(Wn2,0.0) - !WA: TEMF form -! IF (B>0.0 .AND. UPW(K-1,I) < 0.2 ) THEN - IF (UPW(K-1,I) < 0.2 ) THEN - Wn = UPW(K-1,I) + (-2. * ENT(K,I) * UPW(K-1,I) + BCOEFF*B / MAX(UPW(K-1,I),0.2)) * MIN(ZW(k)-ZW(k-1), 250.) - ELSE - Wn = UPW(K-1,I) + (-2. * ENT(K,I) * UPW(K-1,I) + BCOEFF*B / UPW(K-1,I)) * MIN(ZW(k)-ZW(k-1), 250.) - ENDIF - !Do not allow a parcel to accelerate more than 1.25 m/s over 200 m. - !Add max increase of 2.0 m/s for coarse vertical resolution. - IF(Wn > UPW(K-1,I) + MIN(1.25*(ZW(k)-ZW(k-1))/200., 2.0) ) THEN - Wn = UPW(K-1,I) + MIN(1.25*(ZW(k)-ZW(k-1))/200., 2.0) - ENDIF - !Add symmetrical max decrease in w - IF(Wn < UPW(K-1,I) - MIN(1.25*(ZW(k)-ZW(k-1))/200., 2.0) ) THEN - Wn = UPW(K-1,I) - MIN(1.25*(ZW(k)-ZW(k-1))/200., 2.0) - ENDIF - Wn = MIN(MAX(Wn,0.0), 3.0) - - !Check to make sure that the plume made it up at least one level. - !if it failed, then set nup2=0 and exit the mass-flux portion. - IF (k==kts+1 .AND. Wn == 0.) THEN - NUP2=0 - exit - ENDIF - - IF (debug_mf == 1) THEN - IF (Wn .GE. 3.0) THEN - ! surface values - print *," **** SUSPICIOUSLY LARGE W:" - print *,' QCn:',QCn,' ENT=',ENT(k,i),' Nup2=',Nup2 - print *,'pblh:',pblh,' Wn:',Wn,' UPW(k-1)=',UPW(K-1,I) - print *,'K=',k,' B=',B,' dz=',ZW(k)-ZW(k-1) - ENDIF - ENDIF - - !Allow strongly forced plumes to overshoot if KE is sufficient - IF (Wn <= 0.0 .AND. overshoot == 0) THEN - overshoot = 1 - IF ( THVk-THVkm1 .GT. 0.0 ) THEN - bvf = SQRT( gtr*(THVk-THVkm1)/dz(k) ) - !vertical Froude number - Frz = UPW(K-1,I)/(bvf*dz(k)) - !IF ( Frz >= 0.5 ) Wn = MIN(Frz,1.0)*UPW(K-1,I) - dzp = dz(k)*MAX(MIN(Frz,1.0),0.0) ! portion of highest layer the plume penetrates - ENDIF - ELSE - dzp = dz(k) - ENDIF - - !minimize the plume penetratration in stratocu-topped PBL - !IF (fltv2 < 0.06) THEN - ! IF(ZW(k+1) >= pblh-200. .AND. qc(k) > 1e-5 .AND. I > 4) Wn=0. - !ENDIF - - !Modify environment variables (representative of the model layer - envm*) - !following the updraft dynamical detrainment of Asai and Kasahara (1967, JAS). - !Reminder: w is limited to be non-negative (above) - aratio = MIN(UPA(K-1,I)/(1.-UPA(K-1,I)), 0.5) !limit should never get hit - detturb = 0.00008 - oow = -0.060/MAX(1.0,(0.5*(Wn+UPW(K-1,I)))) !coef for dynamical detrainment rate - detrate = MIN(MAX(oow*(Wn-UPW(K-1,I))/dz(k), detturb), .0002) ! dynamical detrainment rate (m^-1) - detrateUV= MIN(MAX(oow*(Wn-UPW(K-1,I))/dz(k), detturb), .0001) ! dynamical detrainment rate (m^-1) - envm_thl(k)=envm_thl(k) + (0.5*(thl_ent + UPTHL(K-1,I)) - thl(k))*detrate*aratio*MIN(dzp,dzpmax) - qv_ent = 0.5*(MAX(qt_ent-qc_ent,0.) + MAX(UPQT(K-1,I)-UPQC(K-1,I),0.)) - envm_sqv(k)=envm_sqv(k) + (qv_ent-QV(K))*detrate*aratio*MIN(dzp,dzpmax) - IF (UPQC(K-1,I) > 1E-8) THEN - IF (QC(K) > 1E-6) THEN - qc_grid = QC(K) - ELSE - qc_grid = cldfra_bl1d(k)*qc_bl1d(K) - ENDIF - envm_sqc(k)=envm_sqc(k) + MAX(UPA(K-1,I)*0.5*(QCn + UPQC(K-1,I)) - qc_grid, 0.0)*detrate*aratio*MIN(dzp,dzpmax) - ENDIF - envm_u(k) =envm_u(k) + (0.5*(Un + UPU(K-1,I)) - U(K))*detrateUV*aratio*MIN(dzp,dzpmax) - envm_v(k) =envm_v(k) + (0.5*(Vn + UPV(K-1,I)) - V(K))*detrateUV*aratio*MIN(dzp,dzpmax) - - IF (Wn > 0.) THEN - !Update plume variables at current k index - UPW(K,I)=Wn !sqrt(Wn2) - UPTHV(K,I)=THVn - UPTHL(K,I)=THLn - UPQT(K,I)=QTn - UPQC(K,I)=QCn - UPU(K,I)=Un - UPV(K,I)=Vn - UPQKE(K,I)=QKEn - UPQNC(K,I)=QNCn - UPQNI(K,I)=QNIn - UPQNWFA(K,I)=QNWFAn - UPQNIFA(K,I)=QNIFAn - UPQNBCA(K,I)=QNBCAn - UPA(K,I)=UPA(K-1,I) - IF ( mix_chem ) THEN - do ic = 1,nchem - UPCHEM(k,I,ic) = chemn(ic) - enddo - ENDIF - ktop = MAX(ktop,k) - ELSE - exit !exit k-loop - END IF - ENDDO - - IF (debug_mf == 1) THEN - IF (MAXVAL(UPW(:,I)) > 10.0 .OR. MINVAL(UPA(:,I)) < 0.0 .OR. & - MAXVAL(UPA(:,I)) > Atot .OR. NUP2 > 10) THEN - ! surface values - print *,'flq:',flq,' fltv:',fltv2,' Nup2=',Nup2 - print *,'pblh:',pblh,' wstar:',wstar,' ktop=',ktop - print *,'sigmaW=',sigmaW,' sigmaTH=',sigmaTH,' sigmaQT=',sigmaQT - ! means - print *,'u:',u - print *,'v:',v - print *,'thl:',thl - print *,'UPA:',UPA(:,I) - print *,'UPW:',UPW(:,I) - print *,'UPTHL:',UPTHL(:,I) - print *,'UPQT:',UPQT(:,I) - print *,'ENT:',ENT(:,I) - ENDIF - ENDIF - ENDDO -ELSE - !At least one of the conditions was not met for activating the MF scheme. - NUP2=0. -END IF !end criteria check for mass-flux scheme - -ktop=MIN(ktop,KTE-1) -IF (ktop == 0) THEN - ztop = 0.0 -ELSE - ztop=zw(ktop) -ENDIF - -IF (nup2 > 0) THEN - !Calculate the fluxes for each variable - !All s_aw* variable are == 0 at k=1 - DO i=1,NUP - DO k=KTS,KTE-1 - s_aw(k+1) = s_aw(k+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*Psig_w - s_awthl(k+1)= s_awthl(k+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPTHL(K,i)*Psig_w - s_awqt(k+1) = s_awqt(k+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPQT(K,i)*Psig_w - !to conform to grid mean properties, move qc to qv in grid mean - !saturated layers, so total water fluxes are preserved but - !negative qc fluxes in unsaturated layers is reduced. -! if (qc(k) > 1e-12 .or. qc(k+1) > 1e-12) then - qc_plume = UPQC(K,i) -! else -! qc_plume = 0.0 -! endif - s_awqc(k+1) = s_awqc(k+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*qc_plume*Psig_w - s_awqv(k+1) = s_awqt(k+1) - s_awqc(k+1) - ENDDO - ENDDO - !momentum - if (momentum_opt > 0) then - do i=1,nup - do k=kts,kte-1 - s_awu(k+1) = s_awu(k+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPU(K,i)*Psig_w - s_awv(k+1) = s_awv(k+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPV(K,i)*Psig_w - enddo - enddo - endif - !tke - if (tke_opt > 0) then - do i=1,nup - do k=kts,kte-1 - s_awqke(k+1)= s_awqke(k+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPQKE(K,i)*Psig_w - enddo - enddo - endif - !chem - if ( mix_chem ) then - do k=kts,kte - do i=1,nup - do ic = 1,nchem - s_awchem(k+1,ic) = s_awchem(k+1,ic) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPCHEM(K,i,ic)*Psig_w - enddo - enddo - enddo - endif - - if (scalar_opt > 0) then - do k=kts,kte - do I=1,nup - s_awqnc(k+1) = s_awqnc(K+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPQNC(K,i)*Psig_w - s_awqni(k+1) = s_awqni(K+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPQNI(K,i)*Psig_w - s_awqnwfa(k+1)= s_awqnwfa(K+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPQNWFA(K,i)*Psig_w - s_awqnifa(k+1)= s_awqnifa(K+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPQNIFA(K,i)*Psig_w - s_awqnbca(k+1)= s_awqnbca(K+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPQNBCA(K,i)*Psig_w - enddo - enddo - endif - - !Flux limiter: Check ratio of heat flux at top of first model layer - !and at the surface. Make sure estimated flux out of the top of the - !layer is < fluxportion*surface_heat_flux - IF (s_aw(kts+1) /= 0.) THEN - dzi(kts) = 0.5*(DZ(kts)+DZ(kts+1)) !dz centered at model interface - flx1 = MAX(s_aw(kts+1)*(TH(kts)-TH(kts+1))/dzi(kts),1.0e-5) - ELSE - flx1 = 0.0 - !print*,"ERROR: s_aw(kts+1) == 0, NUP=",NUP," NUP2=",NUP2,& - ! " superadiabatic=",superadiabatic," KTOP=",KTOP - ENDIF - adjustment=1.0 - flt2=max(flt,0.0) !need because activation is now based on fltv, not flt - !Print*,"Flux limiter in MYNN-EDMF, adjustment=",fluxportion*flt/dz(kts)/flx1 - !Print*,"flt/dz=",flt/dz(kts)," flx1=",flx1," s_aw(kts+1)=",s_aw(kts+1) - IF (flx1 > fluxportion*flt2/dz(kts) .AND. flx1>0.0) THEN - adjustment= fluxportion*flt2/dz(kts)/flx1 - s_aw = s_aw*adjustment - s_awthl = s_awthl*adjustment - s_awqt = s_awqt*adjustment - s_awqc = s_awqc*adjustment - s_awqv = s_awqv*adjustment - s_awqnc = s_awqnc*adjustment - s_awqni = s_awqni*adjustment - s_awqnwfa = s_awqnwfa*adjustment - s_awqnifa = s_awqnifa*adjustment - s_awqnbca = s_awqnbca*adjustment - IF (momentum_opt > 0) THEN - s_awu = s_awu*adjustment - s_awv = s_awv*adjustment - ENDIF - IF (tke_opt > 0) THEN - s_awqke= s_awqke*adjustment - ENDIF - IF ( mix_chem ) THEN - s_awchem = s_awchem*adjustment - ENDIF - UPA = UPA*adjustment - ENDIF - !Print*,"adjustment=",adjustment," fluxportion=",fluxportion," flt=",flt - - !Calculate mean updraft properties for output: - !all edmf_* variables at k=1 correspond to the interface at top of first model layer - do k=kts,kte-1 - do I=1,nup - edmf_a(K) =edmf_a(K) +UPA(K,i) - edmf_w(K) =edmf_w(K) +UPA(K,i)*UPW(K,i) - edmf_qt(K) =edmf_qt(K) +UPA(K,i)*UPQT(K,i) - edmf_thl(K)=edmf_thl(K)+UPA(K,i)*UPTHL(K,i) - edmf_ent(K)=edmf_ent(K)+UPA(K,i)*ENT(K,i) - edmf_qc(K) =edmf_qc(K) +UPA(K,i)*UPQC(K,i) - enddo - enddo - do k=kts,kte-1 - !Note that only edmf_a is multiplied by Psig_w. This takes care of the - !scale-awareness of the subsidence below: - if (edmf_a(k)>0.) then - edmf_w(k)=edmf_w(k)/edmf_a(k) - edmf_qt(k)=edmf_qt(k)/edmf_a(k) - edmf_thl(k)=edmf_thl(k)/edmf_a(k) - edmf_ent(k)=edmf_ent(k)/edmf_a(k) - edmf_qc(k)=edmf_qc(k)/edmf_a(k) - edmf_a(k)=edmf_a(k)*Psig_w - !FIND MAXIMUM MASS-FLUX IN THE COLUMN: - if(edmf_a(k)*edmf_w(k) > maxmf) maxmf = edmf_a(k)*edmf_w(k) - endif - enddo ! end k - - !smoke/chem - if ( mix_chem ) then - do k=kts,kte-1 - do I=1,nup - do ic = 1,nchem - edmf_chem(k,ic) = edmf_chem(k,ic) + rhoz(k)*UPA(K,I)*UPCHEM(k,i,ic) - enddo - enddo - enddo - do k=kts,kte-1 - if (edmf_a(k)>0.) then - do ic = 1,nchem - edmf_chem(k,ic) = edmf_chem(k,ic)/edmf_a(k) - enddo - endif - enddo ! end k - endif - - !Calculate the effects environmental subsidence. - !All envi_*variables are valid at the interfaces, like the edmf_* variables - IF (env_subs) THEN - DO k=kts+1,kte-1 - !First, smooth the profiles of w & a, since sharp vertical gradients - !in plume variables are not likely extended to env variables - !Note1: w is treated as negative further below - !Note2: both w & a will be transformed into env variables further below - envi_w(k) = onethird*(edmf_w(k-1)+edmf_w(k)+edmf_w(k+1)) - envi_a(k) = onethird*(edmf_a(k-1)+edmf_a(k)+edmf_a(k+1))*adjustment - ENDDO - !define env variables at k=1 (top of first model layer) - envi_w(kts) = edmf_w(kts) - envi_a(kts) = edmf_a(kts) - !define env variables at k=kte - envi_w(kte) = 0.0 - envi_a(kte) = edmf_a(kte) - !define env variables at k=kte+1 - envi_w(kte+1) = 0.0 - envi_a(kte+1) = edmf_a(kte) - !Add limiter for very long time steps (i.e. dt > 300 s) - !Note that this is not a robust check - only for violations in - ! the first model level. - IF (envi_w(kts) > 0.9*DZ(kts)/dt) THEN - sublim = 0.9*DZ(kts)/dt/envi_w(kts) - ELSE - sublim = 1.0 - ENDIF - !Transform w & a into env variables - DO k=kts,kte - temp=envi_a(k) - envi_a(k)=1.0-temp - envi_w(k)=csub*sublim*envi_w(k)*temp/(1.-temp) - ENDDO - !calculate tendencies from subsidence and detrainment valid at the middle of - !each model layer. The lowest model layer uses an assumes w=0 at the surface. - dzi(kts) = 0.5*(dz(kts)+dz(kts+1)) - sub_thl(kts)= 0.5*envi_w(kts)*envi_a(kts)* & - (rho(kts+1)*thl(kts+1)-rho(kts)*thl(kts))/dzi(kts)/rhoz(k) - sub_sqv(kts)= 0.5*envi_w(kts)*envi_a(kts)* & - (rho(kts+1)*qv(kts+1)-rho(kts)*qv(kts))/dzi(kts)/rhoz(k) - DO k=kts+1,kte-1 - dzi(k) = 0.5*(dz(k)+dz(k+1)) - sub_thl(k)= 0.5*(envi_w(k)+envi_w(k-1))*0.5*(envi_a(k)+envi_a(k-1)) * & - (rho(k+1)*thl(k+1)-rho(k)*thl(k))/dzi(k)/rhoz(k) - sub_sqv(k)= 0.5*(envi_w(k)+envi_w(k-1))*0.5*(envi_a(k)+envi_a(k-1)) * & - (rho(k+1)*qv(k+1)-rho(k)*qv(k))/dzi(k)/rhoz(k) - ENDDO - - DO k=KTS,KTE-1 - det_thl(k)=Cdet*(envm_thl(k)-thl(k))*envi_a(k)*Psig_w - det_sqv(k)=Cdet*(envm_sqv(k)-qv(k))*envi_a(k)*Psig_w - det_sqc(k)=Cdet*(envm_sqc(k)-qc(k))*envi_a(k)*Psig_w - ENDDO - - IF (momentum_opt > 0) THEN - sub_u(kts)=0.5*envi_w(kts)*envi_a(kts)* & - (rho(kts+1)*u(kts+1)-rho(kts)*u(kts))/dzi(kts)/rhoz(k) - sub_v(kts)=0.5*envi_w(kts)*envi_a(kts)* & - (rho(kts+1)*v(kts+1)-rho(kts)*v(kts))/dzi(kts)/rhoz(k) - DO k=kts+1,kte-1 - sub_u(k)=0.5*(envi_w(k)+envi_w(k-1))*0.5*(envi_a(k)+envi_a(k-1)) * & - (rho(k+1)*u(k+1)-rho(k)*u(k))/dzi(k)/rhoz(k) - sub_v(k)=0.5*(envi_w(k)+envi_w(k-1))*0.5*(envi_a(k)+envi_a(k-1)) * & - (rho(k+1)*v(k+1)-rho(k)*v(k))/dzi(k)/rhoz(k) - ENDDO - - DO k=KTS,KTE-1 - det_u(k) = Cdet*(envm_u(k)-u(k))*envi_a(k)*Psig_w - det_v(k) = Cdet*(envm_v(k)-v(k))*envi_a(k)*Psig_w - ENDDO - ENDIF - ENDIF !end subsidence/env detranment - - !First, compute exner, plume theta, and dz centered at interface - !Here, k=1 is the top of the first model layer. These values do not - !need to be defined at k=kte (unused level). - DO K=KTS,KTE-1 - exneri(k) = (exner(k)*dz(k+1)+exner(k+1)*dz(k))/(dz(k+1)+dz(k)) - edmf_th(k)= edmf_thl(k) + xlvcp/exneri(k)*edmf_qc(K) - dzi(k) = 0.5*(dz(k)+dz(k+1)) - ENDDO - -!JOE: ADD CLDFRA_bl1d, qc_bl1d. Note that they have already been defined in -! mym_condensation. Here, a shallow-cu component is added, but no cumulus -! clouds can be added at k=1 (start loop at k=2). - do k=kts+1,kte-2 - if (k > KTOP) exit - if(0.5*(edmf_qc(k)+edmf_qc(k-1))>0.0 .and. (cldfra_bl1d(k) < cf_thresh))THEN - !interpolate plume quantities to mass levels - Aup = (edmf_a(k)*dzi(k-1)+edmf_a(k-1)*dzi(k))/(dzi(k-1)+dzi(k)) - THp = (edmf_th(k)*dzi(k-1)+edmf_th(k-1)*dzi(k))/(dzi(k-1)+dzi(k)) - QTp = (edmf_qt(k)*dzi(k-1)+edmf_qt(k-1)*dzi(k))/(dzi(k-1)+dzi(k)) - !convert TH to T -! t = THp*exner(k) - !SATURATED VAPOR PRESSURE - esat = esat_blend(tk(k)) - !SATURATED SPECIFIC HUMIDITY - qsl=ep_2*esat/max(1.e-7,(p(k)-ep_3*esat)) - - !condensed liquid in the plume on mass levels - if (edmf_qc(k)>0.0 .and. edmf_qc(k-1)>0.0) then - QCp = (edmf_qc(k)*dzi(k-1)+edmf_qc(k-1)*dzi(k))/(dzi(k-1)+dzi(k)) - else - QCp = max(edmf_qc(k),edmf_qc(k-1)) - endif - - !COMPUTE CLDFRA & QC_BL FROM MASS-FLUX SCHEME and recompute vt & vq - xl = xl_blend(tk(k)) ! obtain blended heat capacity - qsat_tk = qsat_blend(tk(k),p(k)) ! get saturation water vapor mixing ratio - ! at t and p - rsl = xl*qsat_tk / (r_v*tk(k)**2) ! slope of C-C curve at t (abs temp) - ! CB02, Eqn. 4 - cpm = cp + qt(k)*cpv ! CB02, sec. 2, para. 1 - a = 1./(1. + xl*rsl/cpm) ! CB02 variable "a" - b9 = a*rsl ! CB02 variable "b" - - q2p = xlvcp/exner(k) - pt = thl(k) +q2p*QCp*Aup ! potential temp (env + plume) - bb = b9*tk(k)/pt ! bb is "b9" in BCMT95. Their "b9" differs from - ! "b9" in CB02 by a factor - ! of T/theta. Strictly, b9 above is formulated in - ! terms of sat. mixing ratio, but bb in BCMT95 is - ! cast in terms of sat. specific humidity. The - ! conversion is neglected here. - qww = 1.+0.61*qt(k) - alpha = 0.61*pt - beta = pt*xl/(tk(k)*cp) - 1.61*pt - !Buoyancy flux terms have been moved to the end of this section... - - !Now calculate convective component of the cloud fraction: - if (a > 0.0) then - f = MIN(1.0/a, 4.0) ! f is vertical profile scaling function (CB2005) - else - f = 1.0 - endif - - !CB form: - !sigq = 3.5E-3 * Aup * 0.5*(edmf_w(k)+edmf_w(k-1)) * f ! convective component of sigma (CB2005) - !sigq = SQRT(sigq**2 + sgm(k)**2) ! combined conv + stratus components - !Per S.DeRoode 2009? - !sigq = 5. * Aup * (QTp - qt(k)) - sigq = 10. * Aup * (QTp - qt(k)) - !constrain sigq wrt saturation: - sigq = max(sigq, qsat_tk*0.02 ) - sigq = min(sigq, qsat_tk*0.25 ) - - qmq = a * (qt(k) - qsat_tk) ! saturation deficit/excess; - Q1 = qmq/sigq ! the numerator of Q1 - - if ((landsea-1.5).GE.0) then ! WATER - !modified form from LES - !mf_cf = min(max(0.5 + 0.36 * atan(1.20*(Q1+0.2)),0.01),0.6) - !Original CB - mf_cf = min(max(0.5 + 0.36 * atan(1.55*Q1),0.01),0.6) - mf_cf = max(mf_cf, 1.2 * Aup) - mf_cf = min(mf_cf, 5.0 * Aup) - else ! LAND - !LES form - !mf_cf = min(max(0.5 + 0.36 * atan(1.20*(Q1+0.4)),0.01),0.6) - !Original CB - mf_cf = min(max(0.5 + 0.36 * atan(1.55*Q1),0.01),0.6) - mf_cf = max(mf_cf, 1.8 * Aup) - mf_cf = min(mf_cf, 5.0 * Aup) - endif - - !IF ( debug_code ) THEN - ! print*,"In MYNN, StEM edmf" - ! print*," CB: env qt=",qt(k)," qsat=",qsat_tk - ! print*," k=",k," satdef=",QTp - qsat_tk," sgm=",sgm(k) - ! print*," CB: sigq=",sigq," qmq=",qmq," tk=",tk(k) - ! print*," CB: mf_cf=",mf_cf," cldfra_bl=",cldfra_bl1d(k)," edmf_a=",edmf_a(k) - !ENDIF - - ! Update cloud fractions and specific humidities in grid cells - ! where the mass-flux scheme is active. The specific humidities - ! are converted to grid means (not in-cloud quantities). - if ((landsea-1.5).GE.0) then ! water - if (QCp * Aup > 5e-5) then - qc_bl1d(k) = 1.86 * (QCp * Aup) - 2.2e-5 - else - qc_bl1d(k) = 1.18 * (QCp * Aup) - endif - cldfra_bl1d(k) = mf_cf - Ac_mf = mf_cf - else ! land - if (QCp * Aup > 5e-5) then - qc_bl1d(k) = 1.86 * (QCp * Aup) - 2.2e-5 - else - qc_bl1d(k) = 1.18 * (QCp * Aup) - endif - cldfra_bl1d(k) = mf_cf - Ac_mf = mf_cf - endif - - !Now recalculate the terms for the buoyancy flux for mass-flux clouds: - !See mym_condensation for details on these formulations. - !Use Bechtold and Siebesma (1998) piecewise estimation of Fng with - !limits ,since they really should be recalculated after all the other changes...: - !Only overwrite vt & vq in non-stratus condition - !if ((landsea-1.5).GE.0) then ! WATER - Q1=max(Q1,-2.25) - !else - ! Q1=max(Q1,-2.0) - !endif - - if (Q1 .ge. 1.0) then - Fng = 1.0 - elseif (Q1 .ge. -1.7 .and. Q1 .lt. 1.0) then - Fng = EXP(-0.4*(Q1-1.0)) - elseif (Q1 .ge. -2.5 .and. Q1 .lt. -1.7) then - Fng = 3.0 + EXP(-3.8*(Q1+1.7)) - else - Fng = min(23.9 + EXP(-1.6*(Q1+2.5)), 60.) - endif - - !link the buoyancy flux function to active clouds only (c*Aup): - vt(k) = qww - (1.5*Aup)*beta*bb*Fng - 1. - vq(k) = alpha + (1.5*Aup)*beta*a*Fng - tv0 - endif !check for (qc in plume) .and. (cldfra_bl < threshold) - enddo !k-loop - -ENDIF !end nup2 > 0 - -!modify output (negative: dry plume, positive: moist plume) -if (ktop > 0) then - maxqc = maxval(edmf_qc(1:ktop)) - if ( maxqc < 1.E-8) maxmf = -1.0*maxmf -endif - -! -! debugging -! -if (edmf_w(1) > 4.0) then -! surface values - print *,'flq:',flq,' fltv:',fltv2 - print *,'pblh:',pblh,' wstar:',wstar - print *,'sigmaW=',sigmaW,' sigmaTH=',sigmaTH,' sigmaQT=',sigmaQT -! means -! print *,'u:',u -! print *,'v:',v -! print *,'thl:',thl -! print *,'thv:',thv -! print *,'qt:',qt -! print *,'p:',p - -! updrafts -! DO I=1,NUP2 -! print *,'up:A',i -! print *,UPA(:,i) -! print *,'up:W',i -! print*,UPW(:,i) -! print *,'up:thv',i -! print *,UPTHV(:,i) -! print *,'up:thl',i -! print *,UPTHL(:,i) -! print *,'up:qt',i -! print *,UPQT(:,i) -! print *,'up:tQC',i -! print *,UPQC(:,i) -! print *,'up:ent',i -! print *,ENT(:,i) -! ENDDO - -! mean updrafts - print *,' edmf_a',edmf_a(1:14) - print *,' edmf_w',edmf_w(1:14) - print *,' edmf_qt:',edmf_qt(1:14) - print *,' edmf_thl:',edmf_thl(1:14) - -ENDIF !END Debugging - - -#ifdef HARDCODE_VERTICAL -# undef kts -# undef kte -#endif - -END SUBROUTINE DMP_MF -!================================================================= -!>\ingroup gsd_mynn_edmf -!! This subroutine -subroutine condensation_edmf(QT,THL,P,zagl,THV,QC) -! -! zero or one condensation for edmf: calculates THV and QC -! -real(kind_phys),intent(in) :: QT,THL,P,zagl -real(kind_phys),intent(out) :: THV -real(kind_phys),intent(inout):: QC - -integer :: niter,i -real(kind_phys):: diff,exn,t,th,qs,qcold - -! constants used from module_model_constants.F -! p1000mb -! rcp ... Rd/cp -! xlv ... latent heat for water (2.5e6) -! cp -! rvord .. r_v/r_d (1.6) - -! number of iterations - niter=50 -! minimum difference (usually converges in < 8 iterations with diff = 2e-5) - diff=1.e-6 - - EXN=(P/p1000mb)**rcp - !QC=0. !better first guess QC is incoming from lower level, do not set to zero - do i=1,NITER - T=EXN*THL + xlvcp*QC - QS=qsat_blend(T,P) - QCOLD=QC - QC=0.5*QC + 0.5*MAX((QT-QS),0.) - if (abs(QC-QCOLD) 0.0) THEN -! PRINT*,"EDMF SAT, p:",p," iterations:",i -! PRINT*," T=",T," THL=",THL," THV=",THV -! PRINT*," QS=",QS," QT=",QT," QC=",QC,"ratio=",qc/qs -! ENDIF - - !THIS BASICALLY GIVE THE SAME RESULT AS THE PREVIOUS LINE - !TH = THL + xlv/cp/EXN*QC - !THV= TH*(1. + p608*QT) - - !print *,'t,p,qt,qs,qc' - !print *,t,p,qt,qs,qc - - -end subroutine condensation_edmf - -!=============================================================== - -subroutine condensation_edmf_r(QT,THL,P,zagl,THV,QC) -! -! zero or one condensation for edmf: calculates THL and QC -! similar to condensation_edmf but with different inputs -! -real(kind_phys),intent(in) :: QT,THV,P,zagl -real(kind_phys),intent(out) :: THL, QC - -integer :: niter,i -real(kind_phys):: diff,exn,t,th,qs,qcold - -! number of iterations - niter=50 -! minimum difference - diff=2.e-5 - - EXN=(P/p1000mb)**rcp - ! assume first that th = thv - T = THV*EXN - !QS = qsat_blend(T,P) - !QC = QS - QT - - QC=0. - - do i=1,NITER - QCOLD = QC - T = EXN*THV/(1.+QT*(rvovrd-1.)-rvovrd*QC) - QS=qsat_blend(T,P) - QC= MAX((QT-QS),0.) - if (abs(QC-QCOLD)0) then -! Wn2=DOWNW(K+1,I)**2*EntW - Wa*B/Beta_dm * (1. - EntW) -! else -! Wn2=DOWNW(K+1,I)**2 - 2.*Wa*B*dz(k) -! end if - - mindownw = MIN(DOWNW(K+1,I),-0.2) - Wn = DOWNW(K+1,I) + (-2.*ENT(K,I)*DOWNW(K+1,I) - & - BCOEFF*B/mindownw)*MIN(dz(k), 250.) - - !Do not allow a parcel to accelerate more than 1.25 m/s over 200 m. - !Add max acceleration of -2.0 m/s for coarse vertical resolution. - IF (Wn < DOWNW(K+1,I) - MIN(1.25*dz(k)/200., -2.0))THEN - Wn = DOWNW(K+1,I) - MIN(1.25*dz(k)/200., -2.0) - ENDIF - !Add symmetrical max decrease in velocity (less negative) - IF (Wn > DOWNW(K+1,I) + MIN(1.25*dz(k)/200., 2.0))THEN - Wn = DOWNW(K+1,I) + MIN(1.25*dz(k)/200., 2.0) - ENDIF - Wn = MAX(MIN(Wn,0.0), -3.0) - - !print *, " k =", k, " z =", ZW(k) - !print *, " entw =",ENT(K,I), " Bouy =", B - !print *, " downthv =", THVn, " thvk =", thvk - !print *, " downthl =", THLn, " thl =", thl(k) - !print *, " downqt =", QTn , " qt =", qt(k) - !print *, " downw+1 =",DOWNW(K+1,I), " Wn2 =", Wn - - IF (Wn .lt. 0.) THEN !terminate when velocity is too small - DOWNW(K,I) = Wn !-sqrt(Wn2) - DOWNTHV(K,I)= THVn - DOWNTHL(K,I)= THLn - DOWNQT(K,I) = QTn - DOWNQC(K,I) = QCn - DOWNU(K,I) = Un - DOWNV(K,I) = Vn - DOWNA(K,I) = DOWNA(K+1,I) - ELSE - !plumes must go at least 2 levels - if (DD_initK(I) - K .lt. 2) then - DOWNW(:,I) = 0.0 - DOWNTHV(:,I)= 0.0 - DOWNTHL(:,I)= 0.0 - DOWNQT(:,I) = 0.0 - DOWNQC(:,I) = 0.0 - DOWNU(:,I) = 0.0 - DOWNV(:,I) = 0.0 - endif - exit - ENDIF - ENDDO - ENDDO - endif ! end cloud flag - - DOWNW(1,:) = 0. !make sure downdraft does not go to the surface - DOWNA(1,:) = 0. - - ! Combine both moist and dry plume, write as one averaged plume - ! Even though downdraft starts at different height, average all up to qlTop - DO k=qlTop,KTS,-1 - DO I=1,NDOWN - edmf_a_dd(K) =edmf_a_dd(K) +DOWNA(K-1,I) - edmf_w_dd(K) =edmf_w_dd(K) +DOWNA(K-1,I)*DOWNW(K-1,I) - edmf_qt_dd(K) =edmf_qt_dd(K) +DOWNA(K-1,I)*DOWNQT(K-1,I) - edmf_thl_dd(K)=edmf_thl_dd(K)+DOWNA(K-1,I)*DOWNTHL(K-1,I) - edmf_ent_dd(K)=edmf_ent_dd(K)+DOWNA(K-1,I)*ENT(K-1,I) - edmf_qc_dd(K) =edmf_qc_dd(K) +DOWNA(K-1,I)*DOWNQC(K-1,I) - ENDDO - - IF (edmf_a_dd(k) >0.) THEN - edmf_w_dd(k) =edmf_w_dd(k) /edmf_a_dd(k) - edmf_qt_dd(k) =edmf_qt_dd(k) /edmf_a_dd(k) - edmf_thl_dd(k)=edmf_thl_dd(k)/edmf_a_dd(k) - edmf_ent_dd(k)=edmf_ent_dd(k)/edmf_a_dd(k) - edmf_qc_dd(k) =edmf_qc_dd(k) /edmf_a_dd(k) - ENDIF - ENDDO - - ! - ! computing variables needed for solver - ! - - DO k=KTS,qlTop - rho_int = (rho(k)*DZ(k+1)+rho(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) - DO I=1,NDOWN - sd_aw(k) =sd_aw(k) +rho_int*DOWNA(k,i)*DOWNW(k,i) - sd_awthl(k)=sd_awthl(k)+rho_int*DOWNA(k,i)*DOWNW(k,i)*DOWNTHL(k,i) - sd_awqt(k) =sd_awqt(k) +rho_int*DOWNA(k,i)*DOWNW(k,i)*DOWNQT(k,i) - sd_awqc(k) =sd_awqc(k) +rho_int*DOWNA(k,i)*DOWNW(k,i)*DOWNQC(k,i) - sd_awu(k) =sd_awu(k) +rho_int*DOWNA(k,i)*DOWNW(k,i)*DOWNU(k,i) - sd_awv(k) =sd_awv(k) +rho_int*DOWNA(k,i)*DOWNW(k,i)*DOWNV(k,i) - ENDDO - sd_awqv(k) = sd_awqt(k) - sd_awqc(k) - ENDDO - -END SUBROUTINE DDMF_JPL -!=============================================================== - - -SUBROUTINE SCALE_AWARE(dx,PBL1,Psig_bl,Psig_shcu) - - !--------------------------------------------------------------- - ! NOTES ON SCALE-AWARE FORMULATION - ! - !JOE: add scale-aware factor (Psig) here, taken from Honnert et al. (2011, - ! JAS) and/or from Hyeyum Hailey Shin and Song-You Hong (2013, JAS) - ! - ! Psig_bl tapers local mixing - ! Psig_shcu tapers nonlocal mixing - - real(kind_phys), intent(in) :: dx,pbl1 - real(kind_phys), intent(out) :: Psig_bl,Psig_shcu - real(kind_phys) :: dxdh - - Psig_bl=1.0 - Psig_shcu=1.0 - dxdh=MAX(2.5*dx,10.)/MIN(PBL1,3000.) - ! Honnert et al. 2011, TKE in PBL *** original form used until 201605 - !Psig_bl= ((dxdh**2) + 0.07*(dxdh**0.667))/((dxdh**2) + & - ! (3./21.)*(dxdh**0.67) + (3./42.)) - ! Honnert et al. 2011, TKE in entrainment layer - !Psig_bl= ((dxdh**2) + (4./21.)*(dxdh**0.667))/((dxdh**2) + & - ! (3./20.)*(dxdh**0.67) + (7./21.)) - ! New form to preseve parameterized mixing - only down 5% at dx = 750 m - Psig_bl= ((dxdh**2) + 0.106*(dxdh**0.667))/((dxdh**2) +0.066*(dxdh**0.667) + 0.071) - - !assume a 500 m cloud depth for shallow-cu clods - dxdh=MAX(2.5*dx,10.)/MIN(PBL1+500.,3500.) - ! Honnert et al. 2011, TKE in entrainment layer *** original form used until 201605 - !Psig_shcu= ((dxdh**2) + (4./21.)*(dxdh**0.667))/((dxdh**2) + & - ! (3./20.)*(dxdh**0.67) + (7./21.)) - - ! Honnert et al. 2011, TKE in cumulus - !Psig(i)= ((dxdh**2) + 1.67*(dxdh**1.4))/((dxdh**2) +1.66*(dxdh**1.4) + - !0.2) - - ! Honnert et al. 2011, w'q' in PBL - !Psig(i)= 0.5 + 0.5*((dxdh**2) + 0.03*(dxdh**1.4) - - !(4./13.))/((dxdh**2) + 0.03*(dxdh**1.4) + (4./13.)) - ! Honnert et al. 2011, w'q' in cumulus - !Psig(i)= ((dxdh**2) - 0.07*(dxdh**1.4))/((dxdh**2) -0.07*(dxdh**1.4) + - !0.02) - - ! Honnert et al. 2011, q'q' in PBL - !Psig(i)= 0.5 + 0.5*((dxdh**2) + 0.25*(dxdh**0.667) -0.73)/((dxdh**2) - !-0.03*(dxdh**0.667) + 0.73) - ! Honnert et al. 2011, q'q' in cumulus - !Psig(i)= ((dxdh**2) - 0.34*(dxdh**1.4))/((dxdh**2) - 0.35*(dxdh**1.4) - !+ 0.37) - - ! Hyeyum Hailey Shin and Song-You Hong 2013, TKE in PBL (same as Honnert's above) - !Psig_shcu= ((dxdh**2) + 0.070*(dxdh**0.667))/((dxdh**2) - !+0.142*(dxdh**0.667) + 0.071) - ! Hyeyum Hailey Shin and Song-You Hong 2013, TKE in entrainment zone *** switch to this form 201605 - Psig_shcu= ((dxdh**2) + 0.145*(dxdh**0.667))/((dxdh**2) +0.172*(dxdh**0.667) + 0.170) - - ! Hyeyum Hailey Shin and Song-You Hong 2013, w'theta' in PBL - !Psig(i)= 0.5 + 0.5*((dxdh**2) -0.098)/((dxdh**2) + 0.106) - ! Hyeyum Hailey Shin and Song-You Hong 2013, w'theta' in entrainment zone - !Psig(i)= 0.5 + 0.5*((dxdh**2) - 0.112*(dxdh**0.25) -0.071)/((dxdh**2) - !+ 0.054*(dxdh**0.25) + 0.10) - - !print*,"in scale_aware; dx, dxdh, Psig(i)=",dx,dxdh,Psig(i) - !If(Psig_bl(i) < 0.0 .OR. Psig(i) > 1.)print*,"dx, dxdh, Psig(i)=",dx,dxdh,Psig_bl(i) - If(Psig_bl > 1.0) Psig_bl=1.0 - If(Psig_bl < 0.0) Psig_bl=0.0 - - If(Psig_shcu > 1.0) Psig_shcu=1.0 - If(Psig_shcu < 0.0) Psig_shcu=0.0 - - END SUBROUTINE SCALE_AWARE - -! ===================================================================== -!>\ingroup gsd_mynn_edmf -!! \author JAYMES- added 22 Apr 2015 -!! This function calculates saturation vapor pressure. Separate ice and liquid functions -!! are used (identical to those in module_mp_thompson.F, v3.6). Then, the -!! final returned value is a temperature-dependant "blend". Because the final -!! value is "phase-aware", this formulation may be preferred for use throughout -!! the module (replacing "svp"). - FUNCTION esat_blend(t) - - IMPLICIT NONE - - real(kind_phys), intent(in):: t - real(kind_phys):: esat_blend,XC,ESL,ESI,chi - !liquid - real(kind_phys), parameter:: J0= .611583699E03 - real(kind_phys), parameter:: J1= .444606896E02 - real(kind_phys), parameter:: J2= .143177157E01 - real(kind_phys), parameter:: J3= .264224321E-1 - real(kind_phys), parameter:: J4= .299291081E-3 - real(kind_phys), parameter:: J5= .203154182E-5 - real(kind_phys), parameter:: J6= .702620698E-8 - real(kind_phys), parameter:: J7= .379534310E-11 - real(kind_phys), parameter:: J8=-.321582393E-13 - !ice - real(kind_phys), parameter:: K0= .609868993E03 - real(kind_phys), parameter:: K1= .499320233E02 - real(kind_phys), parameter:: K2= .184672631E01 - real(kind_phys), parameter:: K3= .402737184E-1 - real(kind_phys), parameter:: K4= .565392987E-3 - real(kind_phys), parameter:: K5= .521693933E-5 - real(kind_phys), parameter:: K6= .307839583E-7 - real(kind_phys), parameter:: K7= .105785160E-9 - real(kind_phys), parameter:: K8= .161444444E-12 - - XC=MAX(-80.,t - t0c) !note t0c = 273.15, tice is set in module mynn_common to 240 - -! For 240 < t < 268.16 K, the vapor pressures are "blended" as a function of temperature, -! using the approach similar to Chaboureau and Bechtold (2002), JAS, p. 2363. The resulting -! values are returned from the function. - IF (t .GE. (t0c-6.)) THEN - esat_blend = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8))))))) - ELSE IF (t .LE. tice) THEN - esat_blend = K0+XC*(K1+XC*(K2+XC*(K3+XC*(K4+XC*(K5+XC*(K6+XC*(K7+XC*K8))))))) - ELSE - ESL = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8))))))) - ESI = K0+XC*(K1+XC*(K2+XC*(K3+XC*(K4+XC*(K5+XC*(K6+XC*(K7+XC*K8))))))) - chi = ((t0c-6.) - t)/((t0c-6.) - tice) - esat_blend = (1.-chi)*ESL + chi*ESI - END IF - - END FUNCTION esat_blend - -! ==================================================================== - -!>\ingroup gsd_mynn_edmf -!! This function extends function "esat" and returns a "blended" -!! saturation mixing ratio. Tice currently set to 240 K, t0c = 273.15 K. -!!\author JAYMES - FUNCTION qsat_blend(t, P) - - IMPLICIT NONE - - real(kind_phys), intent(in):: t, P - real(kind_phys):: qsat_blend,XC,ESL,ESI,RSLF,RSIF,chi - !liquid - real(kind_phys), parameter:: J0= .611583699E03 - real(kind_phys), parameter:: J1= .444606896E02 - real(kind_phys), parameter:: J2= .143177157E01 - real(kind_phys), parameter:: J3= .264224321E-1 - real(kind_phys), parameter:: J4= .299291081E-3 - real(kind_phys), parameter:: J5= .203154182E-5 - real(kind_phys), parameter:: J6= .702620698E-8 - real(kind_phys), parameter:: J7= .379534310E-11 - real(kind_phys), parameter:: J8=-.321582393E-13 - !ice - real(kind_phys), parameter:: K0= .609868993E03 - real(kind_phys), parameter:: K1= .499320233E02 - real(kind_phys), parameter:: K2= .184672631E01 - real(kind_phys), parameter:: K3= .402737184E-1 - real(kind_phys), parameter:: K4= .565392987E-3 - real(kind_phys), parameter:: K5= .521693933E-5 - real(kind_phys), parameter:: K6= .307839583E-7 - real(kind_phys), parameter:: K7= .105785160E-9 - real(kind_phys), parameter:: K8= .161444444E-12 - - XC=MAX(-80.,t - t0c) - - IF (t .GE. (t0c-6.)) THEN - ESL = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8))))))) - ESL = min(ESL, P*0.15) ! Even with P=1050mb and T=55C, the sat. vap. pres only contributes to ~15% of total pres. - qsat_blend = 0.622*ESL/max(P-ESL, 1e-5) - ELSE IF (t .LE. tice) THEN - ESI = K0+XC*(K1+XC*(K2+XC*(K3+XC*(K4+XC*(K5+XC*(K6+XC*(K7+XC*K8))))))) - ESI = min(ESI, P*0.15) - qsat_blend = 0.622*ESI/max(P-ESI, 1e-5) - ELSE - ESL = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8))))))) - ESL = min(ESL, P*0.15) - ESI = K0+XC*(K1+XC*(K2+XC*(K3+XC*(K4+XC*(K5+XC*(K6+XC*(K7+XC*K8))))))) - ESI = min(ESI, P*0.15) - RSLF = 0.622*ESL/max(P-ESL, 1e-5) - RSIF = 0.622*ESI/max(P-ESI, 1e-5) -! chi = (268.16-t)/(268.16-240.) - chi = ((t0c-6.) - t)/((t0c-6.) - tice) - qsat_blend = (1.-chi)*RSLF + chi*RSIF - END IF - - END FUNCTION qsat_blend - -! =================================================================== - -!>\ingroup gsd_mynn_edmf -!! This function interpolates the latent heats of vaporization and sublimation into -!! a single, temperature-dependent, "blended" value, following -!! Chaboureau and Bechtold (2002) \cite Chaboureau_2002, Appendix. -!!\author JAYMES - FUNCTION xl_blend(t) - - IMPLICIT NONE - - real(kind_phys), intent(in):: t - real(kind_phys):: xl_blend,xlvt,xlst,chi - !note: t0c = 273.15, tice is set in mynn_common - - IF (t .GE. t0c) THEN - xl_blend = xlv + (cpv-cliq)*(t-t0c) !vaporization/condensation - ELSE IF (t .LE. tice) THEN - xl_blend = xls + (cpv-cice)*(t-t0c) !sublimation/deposition - ELSE - xlvt = xlv + (cpv-cliq)*(t-t0c) !vaporization/condensation - xlst = xls + (cpv-cice)*(t-t0c) !sublimation/deposition -! chi = (273.16-t)/(273.16-240.) - chi = (t0c - t)/(t0c - tice) - xl_blend = (1.-chi)*xlvt + chi*xlst !blended - END IF - - END FUNCTION xl_blend - -! =================================================================== - - FUNCTION phim(zet) - ! New stability function parameters for momentum (Puhales, 2020, WRF 4.2.1) - ! The forms in unstable conditions (z/L < 0) use Grachev et al. (2000), which are a blend of - ! the classical (Kansas) forms (i.e., Paulson 1970, Dyer and Hicks 1970), valid for weakly - ! unstable conditions (-1 < z/L < 0). The stability functions for stable conditions use an - ! updated form taken from Cheng and Brutsaert (2005), which extends the validity into very - ! stable conditions [z/L ~ O(10)]. - IMPLICIT NONE - - real(kind_phys), intent(in):: zet - real(kind_phys):: dummy_0,dummy_1,dummy_11,dummy_2,dummy_22,dummy_3,dummy_33,dummy_4,dummy_44,dummy_psi - real(kind_phys), parameter :: am_st=6.1, bm_st=2.5, rbm_st=1./bm_st - real(kind_phys), parameter :: ah_st=5.3, bh_st=1.1, rbh_st=1./bh_st - real(kind_phys), parameter :: am_unst=10., ah_unst=34. - real(kind_phys):: phi_m,phim - - if ( zet >= 0.0 ) then - dummy_0=1+zet**bm_st - dummy_1=zet+dummy_0**(rbm_st) - dummy_11=1+dummy_0**(rbm_st-1)*zet**(bm_st-1) - dummy_2=(-am_st/dummy_1)*dummy_11 - phi_m = 1-zet*dummy_2 - else - dummy_0 = (1.0-cphm_unst*zet)**0.25 - phi_m = 1./dummy_0 - dummy_psi = 2.*log(0.5*(1.+dummy_0))+log(0.5*(1.+dummy_0**2))-2.*atan(dummy_0)+1.570796 - - dummy_0=(1.-am_unst*zet) ! parentesis arg - dummy_1=dummy_0**0.333333 ! y - dummy_11=-0.33333*am_unst*dummy_0**(-0.6666667) ! dy/dzet - dummy_2 = 0.33333*(dummy_1**2.+dummy_1+1.) ! f - dummy_22 = 0.3333*dummy_11*(2.*dummy_1+1.) ! df/dzet - dummy_3 = 0.57735*(2.*dummy_1+1.) ! g - dummy_33 = 1.1547*dummy_11 ! dg/dzet - dummy_4 = 1.5*log(dummy_2)-1.73205*atan(dummy_3)+1.813799364 !psic - dummy_44 = (1.5/dummy_2)*dummy_22-1.73205*dummy_33/(1.+dummy_3**2)! dpsic/dzet - - dummy_0 = zet**2 - dummy_1 = 1./(1.+dummy_0) ! denon - dummy_11 = 2.*zet ! denon/dzet - dummy_2 = ((1-phi_m)/zet+dummy_11*dummy_4+dummy_0*dummy_44)*dummy_1 - dummy_22 = -dummy_11*(dummy_psi+dummy_0*dummy_4)*dummy_1**2 - - phi_m = 1.-zet*(dummy_2+dummy_22) - end if - - !phim = phi_m - zet - phim = phi_m - - END FUNCTION phim -! =================================================================== - - FUNCTION phih(zet) - ! New stability function parameters for heat (Puhales, 2020, WRF 4.2.1) - ! The forms in unstable conditions (z/L < 0) use Grachev et al. (2000), which are a blend of - ! the classical (Kansas) forms (i.e., Paulson 1970, Dyer and Hicks 1970), valid for weakly - ! unstable conditions (-1 < z/L < 0). The stability functions for stable conditions use an - ! updated form taken from Cheng and Brutsaert (2005), which extends the validity into very - ! stable conditions [z/L ~ O(10)]. - IMPLICIT NONE - - real(kind_phys), intent(in):: zet - real(kind_phys):: dummy_0,dummy_1,dummy_11,dummy_2,dummy_22,dummy_3,dummy_33,dummy_4,dummy_44,dummy_psi - real(kind_phys), parameter :: am_st=6.1, bm_st=2.5, rbm_st=1./bm_st - real(kind_phys), parameter :: ah_st=5.3, bh_st=1.1, rbh_st=1./bh_st - real(kind_phys), parameter :: am_unst=10., ah_unst=34. - real(kind_phys):: phh,phih - - if ( zet >= 0.0 ) then - dummy_0=1+zet**bh_st - dummy_1=zet+dummy_0**(rbh_st) - dummy_11=1+dummy_0**(rbh_st-1)*zet**(bh_st-1) - dummy_2=(-ah_st/dummy_1)*dummy_11 - phih = 1-zet*dummy_2 - else - dummy_0 = (1.0-cphh_unst*zet)**0.5 - phh = 1./dummy_0 - dummy_psi = 2.*log(0.5*(1.+dummy_0)) - - dummy_0=(1.-ah_unst*zet) ! parentesis arg - dummy_1=dummy_0**0.333333 ! y - dummy_11=-0.33333*ah_unst*dummy_0**(-0.6666667) ! dy/dzet - dummy_2 = 0.33333*(dummy_1**2.+dummy_1+1.) ! f - dummy_22 = 0.3333*dummy_11*(2.*dummy_1+1.) ! df/dzet - dummy_3 = 0.57735*(2.*dummy_1+1.) ! g - dummy_33 = 1.1547*dummy_11 ! dg/dzet - dummy_4 = 1.5*log(dummy_2)-1.73205*atan(dummy_3)+1.813799364 !psic - dummy_44 = (1.5/dummy_2)*dummy_22-1.73205*dummy_33/(1.+dummy_3**2)! dpsic/dzet - - dummy_0 = zet**2 - dummy_1 = 1./(1.+dummy_0) ! denon - dummy_11 = 2.*zet ! ddenon/dzet - dummy_2 = ((1-phh)/zet+dummy_11*dummy_4+dummy_0*dummy_44)*dummy_1 - dummy_22 = -dummy_11*(dummy_psi+dummy_0*dummy_4)*dummy_1**2 - - phih = 1.-zet*(dummy_2+dummy_22) - end if - -END FUNCTION phih -! ================================================================== - SUBROUTINE topdown_cloudrad(kts,kte, & - &dz1,zw,fltv,xland,kpbl,PBLH, & - &sqc,sqi,sqw,thl,th1,ex1,p1,rho1,thetav, & - &cldfra_bl1D,rthraten, & - &maxKHtopdown,KHtopdown,TKEprodTD ) - - !input - integer, intent(in) :: kte,kts - real(kind_phys), dimension(kts:kte), intent(in) :: dz1,sqc,sqi,sqw,& - thl,th1,ex1,p1,rho1,thetav,cldfra_bl1D - real(kind_phys), dimension(kts:kte), intent(in) :: rthraten - real(kind_phys), dimension(kts:kte+1), intent(in) :: zw - real(kind_phys), intent(in) :: pblh,fltv - real(kind_phys), intent(in) :: xland - integer , intent(in) :: kpbl - !output - real(kind_phys), intent(out) :: maxKHtopdown - real(kind_phys), dimension(kts:kte), intent(out) :: KHtopdown,TKEprodTD - !local - real(kind_phys), dimension(kts:kte) :: zfac,wscalek2,zfacent - real(kind_phys) :: bfx0,wm3,bfxpbl,dthvx,tmp1 - real(kind_phys) :: temps,templ,zl1,wstar3_2 - real(kind_phys) :: ent_eff,radsum,radflux,we,rcldb,rvls,minrad,zminrad - real(kind_phys), parameter :: pfac =2.0, zfmin = 0.01, phifac=8.0 - integer :: k,kk,kminrad - logical :: cloudflg - - cloudflg=.false. - minrad=100. - kminrad=kpbl - zminrad=PBLH - KHtopdown(kts:kte)=0.0 - TKEprodTD(kts:kte)=0.0 - maxKHtopdown=0.0 - - !CHECK FOR STRATOCUMULUS-TOPPED BOUNDARY LAYERS - DO kk = MAX(1,kpbl-2),kpbl+3 - if (sqc(kk).gt. 1.e-6 .OR. sqi(kk).gt. 1.e-6 .OR. & - cldfra_bl1D(kk).gt.0.5) then - cloudflg=.true. - endif - if (rthraten(kk) < minrad)then - minrad=rthraten(kk) - kminrad=kk - zminrad=zw(kk) + 0.5*dz1(kk) - endif - ENDDO - - IF (MAX(kminrad,kpbl) < 2)cloudflg = .false. - IF (cloudflg) THEN - zl1 = dz1(kts) - k = MAX(kpbl-1, kminrad-1) - !Best estimate of height of TKE source (top of downdrafts): - !zminrad = 0.5*pblh(i) + 0.5*zminrad - - templ=thl(k)*ex1(k) - !rvls is ws at full level - rvls=100.*6.112*EXP(17.67*(templ-273.16)/(templ-29.65))*(ep_2/p1(k+1)) - temps=templ + (sqw(k)-rvls)/(cp/xlv + ep_2*xlv*rvls/(r_d*templ**2)) - rvls=100.*6.112*EXP(17.67*(temps-273.15)/(temps-29.65))*(ep_2/p1(k+1)) - rcldb=max(sqw(k)-rvls,0.) - - !entrainment efficiency - dthvx = (thl(k+2) + th1(k+2)*p608*sqw(k+2)) & - - (thl(k) + th1(k) *p608*sqw(k)) - dthvx = max(dthvx,0.1) - tmp1 = xlvcp * rcldb/(ex1(k)*dthvx) - !Originally from Nichols and Turton (1986), where a2 = 60, but lowered - !here to 8, as in Grenier and Bretherton (2001). - ent_eff = 0.2 + 0.2*8.*tmp1 - - radsum=0. - DO kk = MAX(1,kpbl-3),kpbl+3 - radflux=rthraten(kk)*ex1(kk) !converts theta/s to temp/s - radflux=radflux*cp/grav*(p1(kk)-p1(kk+1)) ! converts temp/s to W/m^2 - if (radflux < 0.0 ) radsum=abs(radflux)+radsum - ENDDO - - !More strict limits over land to reduce stable-layer mixouts - if ((xland-1.5).GE.0)THEN ! WATER - radsum=MIN(radsum,90.0) - bfx0 = max(radsum/rho1(k)/cp,0.) - else ! LAND - radsum=MIN(0.25*radsum,30.0)!practically turn off over land - bfx0 = max(radsum/rho1(k)/cp - max(fltv,0.0),0.) - endif - - !entrainment from PBL top thermals - wm3 = grav/thetav(k)*bfx0*MIN(pblh,1500.) ! this is wstar3(i) - bfxpbl = - ent_eff * bfx0 - dthvx = max(thetav(k+1)-thetav(k),0.1) - we = max(bfxpbl/dthvx,-sqrt(wm3**twothirds)) - - DO kk = kts,kpbl+3 - !Analytic vertical profile - zfac(kk) = min(max((1.-(zw(kk+1)-zl1)/(zminrad-zl1)),zfmin),1.) - zfacent(kk) = 10.*MAX((zminrad-zw(kk+1))/zminrad,0.0)*(1.-zfac(kk))**3 - - !Calculate an eddy diffusivity profile (not used at the moment) - wscalek2(kk) = (phifac*karman*wm3*(zfac(kk)))**onethird - !Modify shape of Kh to be similar to Lock et al (2000): use pfac = 3.0 - KHtopdown(kk) = wscalek2(kk)*karman*(zminrad-zw(kk+1))*(1.-zfac(kk))**3 !pfac - KHtopdown(kk) = MAX(KHtopdown(kk),0.0) - - !Calculate TKE production = 2(g/TH)(w'TH'), where w'TH' = A(TH/g)wstar^3/PBLH, - !A = ent_eff, and wstar is associated with the radiative cooling at top of PBL. - !An analytic profile controls the magnitude of this TKE prod in the vertical. - TKEprodTD(kk)=2.*ent_eff*wm3/MAX(pblh,100.)*zfacent(kk) - TKEprodTD(kk)= MAX(TKEprodTD(kk),0.0) - ENDDO - ENDIF !end cloud check - maxKHtopdown=MAXVAL(KHtopdown(:)) - - END SUBROUTINE topdown_cloudrad -! ================================================================== -! =================================================================== -! =================================================================== - -END MODULE module_bl_mynn diff --git a/phys/module_bl_mynn_common.F b/phys/module_bl_mynn_common.F deleted file mode 100644 index 7d4057b27a..0000000000 --- a/phys/module_bl_mynn_common.F +++ /dev/null @@ -1,101 +0,0 @@ -!==================================================================== - - module module_bl_mynn_common - -!------------------------------------------ -!Define Model-specific constants/parameters. -!This module will be used at the initialization stage -!where all model-specific constants are read and saved into -!memory. This module is then used again in the MYNN-EDMF. All -!MYNN-specific constants are declared globally in the main -!module (module_bl_mynn) further below: -!------------------------------------------ -! -! The following 5-6 lines are the only lines in this file that are not -! universal for all dycores... Any ideas how to universalize it? -! For MPAS: -! use mpas_kind_types,only: kind_phys => RKIND -! For CCPP: - use ccpp_kind_types, only : kind_phys -! For WRF -! use module_gfs_machine, only : kind_phys - -!WRF CONSTANTS - use module_model_constants, only: & - & karman, g, p1000mb, & - & cp, r_d, r_v, rcp, xlv, xlf, xls, & - & svp1, svp2, svp3, p608, ep_2, rvovrd, & - & cpv, cliq, cice, svpt0 - - implicit none - save -! save :: cp, cpv, cice, cliq, p608, karman, rcp, & !taken directly from module_model_constants -! r_d, r_v, xls, xlv, xlf, rvovrd, ep_2, & !taken directly from module_model_constants -! p1000mb, svp1, svp2, svp3, & !taken directly from module_model_constants -! grav, t0c, & !renamed from module_model_constants -! zero, half, one, two, onethird, & !set here -! twothirds, tref, tkmin, tice, & !set here -! ep_3, gtr, rk, tv0, tv1, xlscp, xlvcp, & !derived here -! g_inv !derived here - -! To be specified from dycore -! real:: cp != 7.*r_d/2. (J/kg/K) -! real:: cpv != 4.*r_v (J/kg/K) Spec heat H2O gas -! real:: cice != 2106. (J/kg/K) Spec heat H2O ice -! real:: cliq != 4190. (J/kg/K) Spec heat H2O liq -! real:: p608 != R_v/R_d-1. -! real:: ep_2 != R_d/R_v -!! real:: grav != accel due to gravity -! real:: karman != von Karman constant -!! real:: t0c != temperature of water at freezing, 273.15 K -! real:: rcp != r_d/cp -! real:: r_d != 287. (J/kg/K) gas const dry air -! real:: r_v != 461.6 (J/kg/K) gas const water -! real:: xlf != 0.35E6 (J/kg) fusion at 0 C -! real:: xlv != 2.50E6 (J/kg) vaporization at 0 C -! real:: xls != 2.85E6 (J/kg) sublimation -! real:: rvovrd != r_v/r_d != 1.608 - -! Specified locally -! Define single & double precision - integer, parameter :: sp = selected_real_kind(6, 37) - integer, parameter :: dp = selected_real_kind(15, 307) -! integer, parameter :: kind_phys = sp - real(kind_phys),parameter:: zero = 0.0 - real(kind_phys),parameter:: half = 0.5 - real(kind_phys),parameter:: one = 1.0 - real(kind_phys),parameter:: two = 2.0 - real(kind_phys),parameter:: onethird = 1./3. - real(kind_phys),parameter:: twothirds = 2./3. - real(kind_phys),parameter:: tref = 300.0 ! reference temperature (K) - real(kind_phys),parameter:: TKmin = 253.0 ! for total water conversion, Tripoli and Cotton (1981) -! real(kind_phys),parameter:: p1000mb=100000.0 -! real(kind_phys),parameter:: svp1 = 0.6112 !(kPa) -! real(kind_phys),parameter:: svp2 = 17.67 !(dimensionless) -! real(kind_phys),parameter:: svp3 = 29.65 !(K) - real(kind_phys),parameter:: tice = 240.0 !-33 (C), temp at saturation w.r.t. ice - real(kind_phys),parameter:: grav = g - real(kind_phys),parameter:: t0c = svpt0 != 273.15 - -! To be derived in the init routine - real(kind_phys),parameter:: ep_3 = 1.-ep_2 != 0.378 - real(kind_phys),parameter:: gtr = grav/tref - real(kind_phys),parameter:: rk = cp/r_d - real(kind_phys),parameter:: tv0 = p608*tref - real(kind_phys),parameter:: tv1 = (1.+p608)*tref - real(kind_phys),parameter:: xlscp = (xlv+xlf)/cp - real(kind_phys),parameter:: xlvcp = xlv/cp - real(kind_phys),parameter:: g_inv = 1./grav - -! grav = g -! t0c = svpt0 != 273.15 -! ep_3 = 1.-ep_2 != 0.378 -! gtr = grav/tref -! rk = cp/r_d -! tv0 = p608*tref -! tv1 = (1.+p608)*tref -! xlscp = (xlv+xlf)/cp -! xlvcp = xlv/cp -! g_inv = 1./grav - - end module module_bl_mynn_common diff --git a/phys/module_bl_mynn_wrapper.F b/phys/module_bl_mynn_wrapper.F deleted file mode 100644 index 72ce6dbaaa..0000000000 --- a/phys/module_bl_mynn_wrapper.F +++ /dev/null @@ -1,812 +0,0 @@ -!> \file module_bl_mynn_wrapper.F90 -!! This serves as the interface between the WRF PBL driver and the MYNN -!! eddy-diffusivity mass-flux scheme in module_bl_mynn.F. - -!>\ingroup gsd_mynn_edmf -!> The following references best describe the code within -!! Olson et al. (2019, NOAA Technical Memorandum) -!! Nakanishi and Niino (2009) \cite NAKANISHI_2009 - MODULE module_bl_mynn_wrapper - - use module_bl_mynn_common - - contains - -!> \section arg_table_mynnedmf_wrapper_init Argument Table -!! \htmlinclude mynnedmf_wrapper_init.html -!! - subroutine mynnedmf_wrapper_init ( & - & RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN,RQCBLTEN,& - & RQIBLTEN,QKE, & - & restart,allowed_to_read, & - & P_QC,P_QI,PARAM_FIRST_SCALAR, & - & IDS,IDE,JDS,JDE,KDS,KDE, & - & IMS,IME,JMS,JME,KMS,KME, & - & ITS,ITE,JTS,JTE,KTS,KTE ) - - implicit none - - LOGICAL,INTENT(IN) :: ALLOWED_TO_READ,RESTART - - INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE, & - & IMS,IME,JMS,JME,KMS,KME, & - & ITS,ITE,JTS,JTE,KTS,KTE - - - REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: & - &RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN, & - &RQCBLTEN,RQIBLTEN,QKE - - INTEGER, intent(in) :: P_QC,P_QI,PARAM_FIRST_SCALAR - - INTEGER :: I,J,K,ITF,JTF,KTF - - JTF=MIN0(JTE,JDE-1) - KTF=MIN0(KTE,KDE-1) - ITF=MIN0(ITE,IDE-1) - - IF (.NOT.RESTART) THEN - DO J=JTS,JTF - DO K=KTS,KTF - DO I=ITS,ITF - RUBLTEN(i,k,j)=0. - RVBLTEN(i,k,j)=0. - RTHBLTEN(i,k,j)=0. - RQVBLTEN(i,k,j)=0. - if( p_qc >= param_first_scalar ) RQCBLTEN(i,k,j)=0. - if( p_qi >= param_first_scalar ) RQIBLTEN(i,k,j)=0. - ENDDO - ENDDO - ENDDO - ENDIF - - end subroutine mynnedmf_wrapper_init - - subroutine mynnedmf_wrapper_finalize () - end subroutine mynnedmf_wrapper_finalize - -! \brief This scheme (1) performs pre-mynnedmf work, (2) runs the mynnedmf, and (3) performs post-mynnedmf work -!> \section arg_table_mynnedmf_wrapper_run Argument Table -!! \htmlinclude mynnedmf_wrapper_run.html -!! -SUBROUTINE mynnedmf_wrapper_run( & - & initflag,restart,cycling, & - & delt,dz,dxc,znt, & - & u,v,w,th, & - & qv,qc,qi,qs,qnc,qni,qnwfa,qnifa,qnbca, & -! & ozone, & - & p,exner,rho,t3d, & - & xland,ts,qsfc,ps, & - & ust,ch,hfx,qfx,rmol,wspd, & - & uoce,voce, & - & qke,qke_adv,sh3d,sm3d, & -!--- chem/smoke -#if (WRF_CHEM == 1) - & mix_chem,chem3d,vd3d,nchem,kdvel, & - & ndvel,num_vert_mix, & -! & frp_mean,emis_ant_no,enh_mix, & !to be included soon -#endif -!--- end chem/smoke - & Tsq,Qsq,Cov, & - & rublten,rvblten,rthblten, & - & rqvblten,rqcblten,rqiblten,rqsblten, & - & rqncblten,rqniblten, & - & rqnwfablten,rqnifablten,rqnbcablten, & -! & ro3blten, & - & exch_h,exch_m,pblh,kpbl,el_pbl, & - & dqke,qwt,qshear,qbuoy,qdiss, & - & qc_bl,qi_bl,cldfra_bl, & - & edmf_a,edmf_w,edmf_qt, & - & edmf_thl,edmf_ent,edmf_qc, & - & sub_thl3d,sub_sqv3d, & - & det_thl3d,det_sqv3d, & - & maxwidth,maxMF,ztop_plume,ktop_plume, & - & rthraten, & - & tke_budget, bl_mynn_tkeadvect, & - & bl_mynn_cloudpdf, bl_mynn_mixlength, & - & icloud_bl, bl_mynn_edmf, & - & bl_mynn_edmf_mom, bl_mynn_edmf_tke, & - & bl_mynn_cloudmix, bl_mynn_mixqt, & - & bl_mynn_output, bl_mynn_closure, & - & bl_mynn_mixscalars, & - & spp_pbl,pattern_spp_pbl, & - & flag_qc,flag_qi,flag_qs, & - & flag_qnc,flag_qni, & - & flag_qnwfa,flag_qnifa,flag_qnbca, & - & ids,ide,jds,jde,kds,kde, & - & ims,ime,jms,jme,kms,kme, & - & its,ite,jts,jte,kts,kte ) - - use module_bl_mynn, only: mynn_bl_driver - -!------------------------------------------------------------------- - implicit none -!------------------------------------------------------------------- - - !smoke/chem: disclaimer: all smoke-related variables are still - !considered under development in CCPP. Until that work is - !completed, these flags/arrays must be kept hard-coded as is. -#if (WRF_CHEM == 1) - logical, intent(in) :: mix_chem - integer, intent(in) :: nchem, ndvel, kdvel, num_vert_mix - logical, parameter :: & - & rrfs_sd =.false., & - & smoke_dbg =.false., & - & enh_mix =.false. -#else - logical, parameter :: & - & mix_chem =.false., & - & enh_mix =.false., & - & rrfs_sd =.false., & - & smoke_dbg =.false. - integer, parameter :: nchem=2, ndvel=2, kdvel=1, & - num_vert_mix = 1 -#endif - -! NAMELIST OPTIONS (INPUT): - logical, intent(in) :: & - & bl_mynn_tkeadvect, & - & cycling - integer, intent(in) :: & - & bl_mynn_cloudpdf, & - & bl_mynn_mixlength, & - & icloud_bl, & - & bl_mynn_edmf, & - & bl_mynn_edmf_mom, & - & bl_mynn_edmf_tke, & - & bl_mynn_cloudmix, & - & bl_mynn_mixqt, & - & bl_mynn_output, & - & bl_mynn_mixscalars, & - & spp_pbl, & - & tke_budget - real(kind_phys), intent(in) :: & - & bl_mynn_closure - - logical, intent(in) :: & - & FLAG_QI, FLAG_QNI, FLAG_QC, FLAG_QNC, & - & FLAG_QS, FLAG_QNWFA, FLAG_QNIFA, FLAG_QNBCA - logical, parameter :: FLAG_OZONE = .false. - -!MYNN-1D - REAL(kind_phys), intent(in) :: delt, dxc - LOGICAL, intent(in) :: restart - INTEGER :: i, j, k, itf, jtf, ktf, n - INTEGER, intent(in) :: initflag, & - & IDS,IDE,JDS,JDE,KDS,KDE, & - & IMS,IME,JMS,JME,KMS,KME, & - & ITS,ITE,JTS,JTE,KTS,KTE - -!MYNN-3D - real(kind_phys), dimension(ims:ime,kms:kme,jms:jme), intent(in) :: & - & u,v,w,t3d,th,rho,exner,p,dz - real(kind_phys), dimension(ims:ime,kms:kme,jms:jme), intent(inout) :: & - & rublten,rvblten,rthblten, & - & rqvblten,rqcblten,rqiblten,rqsblten, & - & rqncblten,rqniblten, & - & rqnwfablten,rqnifablten,rqnbcablten !,ro3blten - real(kind_phys), dimension(ims:ime,kms:kme,jms:jme), intent(inout) :: & - & qke, qke_adv, el_pbl, sh3d, sm3d - real(kind_phys), dimension(ims:ime,kms:kme,jms:jme), intent(inout) :: & - & Tsq, Qsq, Cov, exch_h, exch_m - real(kind_phys), dimension(ims:ime,kms:kme,jms:jme), intent(in) :: rthraten - -!optional 3D arrays - real(kind_phys), dimension(ims:ime,kms:kme,jms:jme), optional, intent(in) :: & - & pattern_spp_pbl - real(kind_phys), dimension(ims:ime,kms:kme,jms:jme), optional, intent(inout) :: & - & qc_bl, qi_bl, cldfra_bl - real(kind_phys), dimension(ims:ime,kms:kme,jms:jme), optional, intent(inout) :: & - & edmf_a,edmf_w,edmf_qt, & - & edmf_thl,edmf_ent,edmf_qc, & - & sub_thl3d,sub_sqv3d,det_thl3d,det_sqv3d - real(kind_phys), dimension(ims:ime,kms:kme,jms:jme), optional, intent(inout) :: & - & dqke,qWT,qSHEAR,qBUOY,qDISS - real(kind_phys), dimension(ims:ime,kms:kme,jms:jme), optional, intent(inout) :: & - & qv,qc,qi,qs,qnc,qni,qnwfa,qnifa,qnbca!,o3 - -!optional 2D arrays for passing into module_bl_myn.F - real(kind_phys), allocatable, dimension(:,:) :: & - & qc_bl2d, qi_bl2d, cldfra_bl2d, pattern_spp_pbl2d - real(kind_phys), allocatable, dimension(:,:) :: & - & edmf_a2d,edmf_w2d,edmf_qt2d, & - & edmf_thl2d,edmf_ent2d,edmf_qc2d, & - & sub_thl2d,sub_sqv2d,det_thl2d,det_sqv2d - real(kind_phys), allocatable, dimension(:,:) :: & - & dqke2d,qWT2d,qSHEAR2d,qBUOY2d,qDISS2d - real(kind_phys), allocatable, dimension(:,:) :: & - & qc2d,qi2d,qs2d,qnc2d,qni2d,qnwfa2d,qnifa2d,qnbca2d!,o32d - -!smoke/chem arrays - no if-defs in module_bl_mynn.F, so must define arrays -#if (WRF_CHEM == 1) - real(kind_phys), dimension(ims:ime,kms:kme,jms:jme,nchem), intent(in) :: chem3d - real(kind_phys), dimension(ims:ime,kdvel,jms:jme, ndvel), intent(in) :: vd3d - real(kind_phys), dimension(ims:ime,kms:kme,nchem) :: chem - real(kind_phys), dimension(ims:ime,ndvel) :: vd - real(kind_phys), dimension(ims:ime) :: frp_mean, emis_ant_no -#else - real(kind_phys), dimension(ims:ime,kms:kme,nchem) :: chem - real(kind_phys), dimension(ims:ime,ndvel) :: vd - real(kind_phys), dimension(ims:ime) :: frp_mean, emis_ant_no -#endif - -!MYNN-2D - real(kind_phys), dimension(ims:ime,jms:jme), intent(in) :: & - & xland,ts,qsfc,ps,ch - real(kind_phys), dimension(ims:ime,jms:jme), intent(inout) :: & - & znt,pblh,maxwidth,maxmf,ztop_plume,rmol,hfx,qfx,ust,wspd, & - & uoce,voce - integer, dimension(ims:ime,jms:jme), intent(inout) :: & - & kpbl,ktop_plume - -!Local - real(kind_phys), dimension(ims:ime,kms:kme) :: delp,sqv,sqc,sqi,sqs,ikzero - real(kind_phys), dimension(ims:ime) :: dx - logical, parameter :: debug = .false. - real(kind_phys), dimension(ims:ime,kms:kme,jms:jme) :: ozone,rO3blten - - !write(0,*)"==============================================" - !write(0,*)"in mynn wrapper..." - !write(0,*)"initflag=",initflag - !write(0,*)"restart =",restart - - jtf=MIN0(JTE,JDE-1) - ktf=MIN0(KTE,KDE-1) - itf=MIN0(ITE,IDE-1) - - !For now, initialized bogus array - ozone=0.0 - rO3blten=0.0 - ikzero=0.0 - - !Allocate any arrays being used - if (icloud_bl > 0) then - allocate(qc_bl2d(ims:ime,kms:kme)) - allocate(qi_bl2d(ims:ime,kms:kme)) - allocate(cldfra_bl2d(ims:ime,kms:kme)) - qc_bl2d=0.0 - qi_bl2d=0.0 - cldfra_bl2d=0.0 - endif - if (spp_pbl > 0) then - allocate(pattern_spp_pbl2d(ims:ime,kms:kme)) - endif - if (bl_mynn_output > 0) then - allocate(edmf_a2d(ims:ime,kms:kme)) - allocate(edmf_w2d(ims:ime,kms:kme)) - allocate(edmf_qt2d(ims:ime,kms:kme)) - allocate(edmf_thl2d(ims:ime,kms:kme)) - allocate(edmf_ent2d(ims:ime,kms:kme)) - allocate(edmf_qc2d(ims:ime,kms:kme)) - allocate(sub_thl2d(ims:ime,kms:kme)) - allocate(sub_sqv2d(ims:ime,kms:kme)) - allocate(det_thl2d(ims:ime,kms:kme)) - allocate(det_sqv2d(ims:ime,kms:kme)) - endif - if (tke_budget .eq. 1) then - allocate(dqke2d(ims:ime,kms:kme)) - allocate(qWT2d(ims:ime,kms:kme)) - allocate(qSHEAR2d(ims:ime,kms:kme)) - allocate(qBUOY2d(ims:ime,kms:kme)) - allocate(qDISS2d(ims:ime,kms:kme)) - dqke2d =0.0 - qWT2d =0.0 - qSHEAR2d=0.0 - qBUOY2d =0.0 - qDISS2d =0.0 - endif - if (flag_qc) then - allocate(qc2d(ims:ime,kms:kme)) - qc2d=0.0 - endif - if (flag_qi) then - allocate(qi2d(ims:ime,kms:kme)) - qi2d=0.0 - endif - if (flag_qs) then - allocate(qs2d(ims:ime,kms:kme)) - qs2d=0.0 - endif - if (flag_qnc) then - allocate(qnc2d(ims:ime,kms:kme)) - qnc2d=0.0 - endif - if (flag_qni) then - allocate(qni2d(ims:ime,kms:kme)) - qni2d=0.0 - endif - if (flag_qnwfa) then - allocate(qnwfa2d(ims:ime,kms:kme)) - qnwfa2d=0.0 - endif - if (flag_qnifa) then - allocate(qnifa2d(ims:ime,kms:kme)) - qnifa2d=0.0 - endif - if (flag_qnbca) then - allocate(qnbca2d(ims:ime,kms:kme)) - qnbca2d=0.0 - endif - !--------------------------------- - !Begin looping in the j-direction - !--------------------------------- - do j = jts,jtf - - !need sgs cloud info input for diagnostic-decay - if (icloud_bl > 0) then - do k=kts,ktf - do i=its,itf - qc_bl2d(i,k) = qc_bl(i,k,j) - qi_bl2d(i,k) = qi_bl(i,k,j) - cldfra_bl2d(i,k) = cldfra_bl(i,k,j) - enddo - enddo - endif - - !spp input - if (spp_pbl > 0) then - do k=kts,ktf - do i=its,itf - pattern_spp_pbl2d(i,k) = pattern_spp_pbl(i,k,j) - enddo - enddo - endif - - !intialize moist species - if (flag_qc) then - do k=kts,ktf - do i=its,itf - qc2d(i,k) = qc(i,k,j) - enddo - enddo - endif - if (flag_qi) then - do k=kts,ktf - do i=its,itf - qi2d(i,k) = qi(i,k,j) - enddo - enddo - endif - if (flag_qs) then - do k=kts,ktf - do i=its,itf - qs2d(i,k) = qs(i,k,j) - enddo - enddo - endif - if (flag_qnc) then - do k=kts,ktf - do i=its,itf - qnc2d(i,k) = qnc(i,k,j) - enddo - enddo - endif - if (flag_qni) then - do k=kts,ktf - do i=its,itf - qni2d(i,k) = qni(i,k,j) - enddo - enddo - endif - if (flag_qnwfa) then - do k=kts,ktf - do i=its,itf - qnwfa2d(i,k) = qnwfa(i,k,j) - enddo - enddo - endif - if (flag_qnifa) then - do k=kts,ktf - do i=its,itf - qnifa2d(i,k) = qnifa(i,k,j) - enddo - enddo - endif - if (flag_qnbca) then - do k=kts,ktf - do i=its,itf - qnbca2d(i,k) = qnbca(i,k,j) - enddo - enddo - endif - -#if (WRF_CHEM == 1) - if (mix_chem) then - do n=1,nchem - do k=kts,ktf - do i=its,itf - chem(i,k,n)=chem3d(i,k,j,n) - enddo - enddo - enddo - - !set kdvel =1 - do n=1,ndvel - do i=its,itf - vd(i,n) =vd3d(i,1,j,n) - enddo - enddo - endif - frp_mean = 0.0 - emis_ant_no = 0.0 -#else - chem = 0.0 - vd = 0.0 - frp_mean = 0.0 - emis_ant_no = 0.0 -#endif - - ! Check incoming moist species to ensure non-negative values - ! First, create pressure differences (delp) across model layers - do i=its,itf - dx(i)=dxc - enddo - -! do i=its,itf -! call moisture_check2(kte, delt, & -! delp(i,:), exner(i,:,j), & -! qv(i,:,j), qc(i,:,j), & -! qi(i,:,j), t3d(i,:,j) ) -! enddo - - !In WRF, mixing ratio is incoming. Convert to specific humidity: - do k=kts,ktf - do i=its,itf - sqv(i,k)=qv(i,k,j)/(1.0 + qv(i,k,j)) - sqc(i,k)=qc2d(i,k)/(1.0 + qv(i,k,j)) - enddo - enddo - if (flag_qi) then - do k=kts,ktf - do i=its,itf - sqi(i,k)=qi2d(i,k)/(1.0 + qv(i,k,j)) - enddo - enddo - else - sqi(:,:)=0.0 - endif - if (flag_qs) then - do k=kts,ktf - do i=its,itf - sqs(i,k)=qs2d(i,k)/(1.0 + qv(i,k,j)) - enddo - enddo - else - sqs(:,:)=0.0 - endif - - if (debug) then - print* - write(0,*)"===CALLING mynn_bl_driver; input:" - print*,"tke_budget=",tke_budget - print*,"bl_mynn_tkeadvect=",bl_mynn_tkeadvect - print*,"bl_mynn_cloudpdf=",bl_mynn_cloudpdf - print*,"bl_mynn_mixlength=",bl_mynn_mixlength - print*,"bl_mynn_edmf=",bl_mynn_edmf - print*,"bl_mynn_edmf_mom=",bl_mynn_edmf_mom - print*,"bl_mynn_edmf_tke=",bl_mynn_edmf_tke - print*,"bl_mynn_cloudmix=",bl_mynn_cloudmix - print*,"bl_mynn_mixqt=",bl_mynn_mixqt - print*,"icloud_bl=",icloud_bl - print*,"T:",t3d(its,1,j),t3d(its,2,j),t3d(its,kte,j) - print*,"TH:",th(its,1,j),th(its,2,j),th(its,kte,j) - print*,"rho:",rho(its,1,j),rho(its,2,j),rho(its,kte,j) - print*,"exner:",exner(its,1,j),exner(its,2,j),exner(its,kte,j) - print*,"p:",p(its,1,j),p(its,2,j),p(its,kte,j) - print*,"dz:",dz(its,1,j),dz(its,2,j),dz(its,kte,j) - print*,"u:",u(its,1,j),u(its,2,j),u(its,kte,j) - print*,"v:",v(its,1,j),v(its,2,j),v(its,kte,j) - print*,"sqv:",sqv(its,1),sqv(its,2),sqv(its,kte) - print*,"sqc:",sqc(its,1),sqc(its,2),sqc(its,kte) - print*,"sqi:",sqi(its,1),sqi(its,2),sqi(its,kte) - print*,"rmol:",rmol(its,j)," ust:",ust(its,j) - print*,"dx=",dx(its),"initflag=",initflag - print*,"Thetasurf:",ts(its,j) - print*,"HFX:",hfx(its,j)," qfx",qfx(its,j) - print*,"qsfc:",qsfc(its,j)," ps:",ps(its,j) - print*,"wspd:",wspd(its,j) - print*,"znt:",znt(its,j)," delt=",delt - print*,"ite=",ite," kte=",kte - print*,"PBLH=",pblh(its,j)," KPBL=",KPBL(its,j)," xland=",xland(its,j) - print*," ch=",ch(its,j) - print*,"qke:",qke(its,1,j),qke(its,2,j),qke(its,kte,j) - print*,"el_pbl:",el_pbl(its,1,j),el_pbl(its,2,j),el_pbl(its,kte,j) - print*,"Sh3d:",Sh3d(its,1,j),sh3d(its,2,j),sh3d(its,kte,j) - print*,"max cf_bl:",maxval(cldfra_bl(its,:,j)) - endif - -!print*,"In mynn wrapper, calling mynn_bl_driver" - CALL mynn_bl_driver( & - & initflag=initflag,restart=restart,cycling=cycling, & - & delt=delt,dz=dz(:,:,j),dx=dx,znt=znt(:,j), & - & u=u(:,:,j),v=v(:,:,j),w=w(:,:,j), & - & th=th(:,:,j),sqv3D=sqv,sqc3D=sqc, & - & sqi3D=sqi,sqs3D=sqs,qnc=qnc2d,qni=qni2d, & - & qnwfa=qnwfa2d,qnifa=qnifa2d,qnbca=qnbca2d, & - & ozone=ozone(:,:,j), & - & p=p(:,:,j),exner=exner(:,:,j),rho=rho(:,:,j), & - & T3D=t3d(:,:,j),xland=xland(:,j), & - & ts=ts(:,j),qsfc=qsfc(:,j),ps=ps(:,j), & - & ust=ust(:,j),ch=ch(:,j),hfx=hfx(:,j),qfx=qfx(:,j), & - & rmol=rmol(:,j),wspd=wspd(:,j), & - & uoce=uoce(:,j),voce=voce(:,j), & !input - & qke=QKE(:,:,j),qke_adv=qke_adv(:,:,j), & !output - & sh3d=Sh3d(:,:,j),sm3d=Sm3d(:,:,j), & !output - & nchem=nchem,kdvel=kdvel,ndvel=ndvel, & !chem/smoke - & Chem3d=chem,Vdep=vd, & - & FRP=frp_mean,EMIS_ANT_NO=emis_ant_no, & - & mix_chem=mix_chem,enh_mix=enh_mix, & - & rrfs_sd=rrfs_sd,smoke_dbg=smoke_dbg, & !end chem/smoke - & tsq=tsq(:,:,j),qsq=qsq(:,:,j),cov=cov(:,:,j), & !output - & RUBLTEN=RUBLTEN(:,:,j),RVBLTEN=RVBLTEN(:,:,j), & !output - & RTHBLTEN=RTHBLTEN(:,:,j),RQVBLTEN=RQVBLTEN(:,:,j), & !output - & RQCBLTEN=rqcblten(:,:,j),RQIBLTEN=rqiblten(:,:,j), & !output - & RQNCBLTEN=rqncblten(:,:,j),RQNIBLTEN=rqniblten(:,:,j), & !output - & RQSBLTEN=ikzero, & !there is no RQSBLTEN, so use dummy arary - & RQNWFABLTEN=RQNWFABLTEN(:,:,j), & !output - & RQNIFABLTEN=RQNIFABLTEN(:,:,j), & !output - & RQNBCABLTEN=RQNBCABLTEN(:,:,j), & !output - & dozone=rO3blten(:,:,j), & !output - & EXCH_H=exch_h(:,:,j),EXCH_M=exch_m(:,:,j), & !output - & pblh=pblh(:,j),KPBL=KPBL(:,j), & !output - & el_pbl=el_pbl(:,:,j), & !output - & dqke=dqke2d,qWT=qWT2d,qSHEAR=qSHEAR2d, & !output - & qBUOY=qBUOY2d,qDISS=qDISS2d, & !output - & qc_bl=qc_bl2d,qi_bl=qi_bl2d,cldfra_bl=cldfra_bl2d, & !output - & bl_mynn_tkeadvect=bl_mynn_tkeadvect, & !input parameter - & tke_budget=tke_budget, & !input parameter - & bl_mynn_cloudpdf=bl_mynn_cloudpdf, & !input parameter - & bl_mynn_mixlength=bl_mynn_mixlength, & !input parameter - & icloud_bl=icloud_bl, & !input parameter - & closure=bl_mynn_closure,bl_mynn_edmf=bl_mynn_edmf, & !input parameter - & bl_mynn_edmf_mom=bl_mynn_edmf_mom, & !input parameter - & bl_mynn_edmf_tke=bl_mynn_edmf_tke, & !input parameter - & bl_mynn_mixscalars=bl_mynn_mixscalars, & !input parameter - & bl_mynn_output=bl_mynn_output, & !input parameter - & bl_mynn_cloudmix=bl_mynn_cloudmix, & !input parameter - & bl_mynn_mixqt=bl_mynn_mixqt, & !input parameter - & edmf_a=edmf_a2d,edmf_w=edmf_w2d, & !output - & edmf_qt=edmf_qt2d,edmf_thl=edmf_thl2d, & !output - & edmf_ent=edmf_ent2d,edmf_qc=edmf_qc2d, & !output - & sub_thl3D=sub_thl2d,sub_sqv3D=sub_sqv2d, & !output - & det_thl3D=det_thl2d,det_sqv3D=det_sqv2d, & !output - & maxwidth=maxwidth(:,j),maxMF=maxMF(:,j), & !output - & ztop_plume=ztop_plume(:,j),ktop_plume=ktop_plume(:,j), & !output - & spp_pbl=spp_pbl,pattern_spp_pbl=pattern_spp_pbl2d, & !input - & RTHRATEN=rthraten(:,:,j), & !input - & FLAG_QI=flag_qi,FLAG_QNI=flag_qni,FLAG_QS=flag_qs, & !input - & FLAG_QC=flag_qc,FLAG_QNC=flag_qnc, & !input - & FLAG_QNWFA=FLAG_QNWFA,FLAG_QNIFA=FLAG_QNIFA, & !input - & FLAG_QNBCA=FLAG_QNBCA,FLAG_OZONE=flag_ozone, & !input - & IDS=ids,IDE=ide,JDS=jds,JDE=jde,KDS=kds,KDE=kde, & !input - & IMS=ims,IME=ime,JMS=jms,JME=jme,KMS=kms,KME=kme, & !input - & ITS=its,ITE=itf,JTS=jts,JTE=jtf,KTS=kts,KTE=kte) !input -!print*,"In mynn wrapper, after bl_mynn_driver" - - !- Convert spec hum to mixing ratio: - do k=kts,ktf - do i=its,itf - RQVBLTEN(i,k,j) = RQVBLTEN(i,k,j)/(1.0 - sqv(i,k)) - RQCBLTEN(i,k,j) = RQCBLTEN(i,k,j)/(1.0 - sqv(i,k)) - RQIBLTEN(i,k,j) = RQIBLTEN(i,k,j)/(1.0 - sqv(i,k)) - enddo - enddo - if (.false.) then !as of now, there is no RQSBLTEN in WRF - do k=kts,ktf - do i=its,itf - RQSBLTEN(i,k,j) = RQSBLTEN(i,k,j)/(1.0 - sqv(i,k)) - enddo - enddo - endif - - !- Collect 3D ouput: - if (icloud_bl > 0) then - do k=kts,ktf - do i=its,itf - qc_bl(i,k,j) = qc_bl2d(i,k)/(1.0 - sqv(i,k)) - qi_bl(i,k,j) = qi_bl2d(i,k)/(1.0 - sqv(i,k)) - cldfra_bl(i,k,j) = cldfra_bl2d(i,k) - enddo - enddo - endif - - if (tke_budget .eq. 1) then - do k=kts,ktf - do i=its,itf - dqke(i,k,j) = dqke2d(i,k) - qwt(i,k,j) = qwt2d(i,k) - qshear(i,k,j) = qshear2d(i,k) - qbuoy(i,k,j) = qbuoy2d(i,k) - qdiss(i,k,j) = qdiss2d(i,k) - enddo - enddo - endif - - if (bl_mynn_output > 0) then - do k=kts,ktf - do i=its,itf - edmf_a(i,k,j) = edmf_a2d(i,k) - edmf_w(i,k,j) = edmf_w2d(i,k) - edmf_qt(i,k,j) = edmf_qt2d(i,k) - edmf_thl(i,k,j) = edmf_thl2d(i,k) - edmf_ent(i,k,j) = edmf_ent2d(i,k) - edmf_qc(i,k,j) = edmf_qc2d(i,k) - sub_thl3d(i,k,j) = sub_thl2d(i,k) - sub_sqv3d(i,k,j) = sub_sqv2d(i,k) - det_thl3d(i,k,j) = det_thl2d(i,k) - det_sqv3d(i,k,j) = det_sqv2d(i,k) - enddo - enddo - endif - - if (debug) then - print* - print*,"===Finished with mynn_bl_driver; output:" - print*,"T:",t3d(its,1,j),t3d(its,2,j),t3d(its,kte,j) - print*,"TH:",th(its,1,j),th(its,2,j),th(its,kte,j) - print*,"rho:",rho(its,1,j),rho(its,2,j),rho(its,kte,j) - print*,"exner:",exner(its,1,j),exner(its,2,j),exner(its,kte,j) - print*,"p:",p(its,1,j),p(its,2,j),p(its,kte,j) - print*,"dz:",dz(its,1,j),dz(its,2,j),dz(its,kte,j) - print*,"u:",u(its,1,j),u(its,2,j),u(its,kte,j) - print*,"v:",v(its,1,j),v(its,2,j),v(its,kte,j) - print*,"sqv:",sqv(its,1),sqv(its,2),sqv(its,kte) - print*,"sqc:",sqc(its,1),sqc(its,2),sqc(its,kte) - print*,"sqi:",sqi(its,1),sqi(its,2),sqi(its,kte) - print*,"rmol:",rmol(its,j)," ust:",ust(its,j) - print*,"dx(its,j)=",dx(its),"initflag=",initflag - print*,"Thetasurf:",ts(its,j) - print*,"HFX:",hfx(its,j)," qfx",qfx(its,j) - print*,"qsfc:",qsfc(its,j)," ps:",ps(its,j) - print*,"wspd:",wspd(its,j) - print*,"znt:",znt(its,j)," delt=",delt - print*,"im=",ite," kte=",kte - print*,"PBLH=",pblh(its,j)," KPBL=",KPBL(its,j)," xland=",xland(its,j) - print*,"ch=",ch(its,j) - print*,"qke:",qke(its,1,j),qke(its,2,j),qke(its,kte,j) - print*,"el_pbl:",el_pbl(its,1,j),el_pbl(its,2,j),el_pbl(its,kte,j) - print*,"Sh3d:",Sh3d(its,1,j),sh3d(its,2,j),sh3d(its,kte,j) - print*,"exch_h:",exch_h(its,1,j),exch_h(its,2,j),exch_h(its,kte,j) - print*,"exch_m:",exch_m(its,1,j),exch_m(its,2,j),exch_m(its,kte,j) - print*,"max cf_bl:",maxval(cldfra_bl(its,:,j)) - print*,"max qc_bl:",maxval(qc_bl(its,:,j)) - print*,"dtdt:",rthblten(its,1,j),rthblten(its,2,j),rthblten(its,kte,j) - print*,"dudt:",rublten(its,1,j),rublten(its,2,j),rublten(its,kte,j) - print*,"dvdt:",rvblten(its,1,j),rvblten(its,2,j),rvblten(its,kte,j) - print*,"dqdt:",rqvblten(its,1,j),rqvblten(its,2,j),rqvblten(its,kte,j) - print*,"ztop_plume:",ztop_plume(its,j)," maxmf:",maxmf(its,j) - print* - endif - - enddo !end j-loop - - !Deallocate all temporary interface arrays - if (bl_mynn_output > 0) then - deallocate(edmf_a2d) - deallocate(edmf_w2d) - deallocate(edmf_qt2d) - deallocate(edmf_thl2d) - deallocate(edmf_ent2d) - deallocate(edmf_qc2d) - deallocate(sub_thl2d) - deallocate(sub_sqv2d) - deallocate(det_thl2d) - deallocate(det_sqv2d) - endif - if (tke_budget .eq. 1) then - deallocate(dqke2d) - deallocate(qwt2d) - deallocate(qshear2d) - deallocate(qbuoy2d) - deallocate(qdiss2d) - endif - if (icloud_bl > 0) then - deallocate(qc_bl2d) - deallocate(qi_bl2d) - deallocate(cldfra_bl2d) - endif - if (flag_qc) deallocate(qc2d) - if (flag_qi) deallocate(qi2d) - if (flag_qs) deallocate(qs2d) - if (flag_qnc) deallocate(qnc2d) - if (flag_qni) deallocate(qni2d) - if (flag_qnwfa)deallocate(qnwfa2d) - if (flag_qnifa)deallocate(qnifa2d) - if (flag_qnbca)deallocate(qnbca2d) - if (spp_pbl > 0) then - deallocate(pattern_spp_pbl2d) - endif - -!print*,"In mynn wrapper, at end" - - CONTAINS - -! ================================================================== - SUBROUTINE moisture_check2(kte, delt, dp, exner, & - qv, qc, qi, th ) - ! - ! If qc < qcmin, qi < qimin, or qv < qvmin happens in any layer, - ! force them to be larger than minimum value by (1) condensating - ! water vapor into liquid or ice, and (2) by transporting water vapor - ! from the very lower layer. - ! - ! We then update the final state variables and tendencies associated - ! with this correction. If any condensation happens, update theta/temperature too. - ! Note that (qv,qc,qi,th) are the final state variables after - ! applying corresponding input tendencies and corrective tendencies. - - implicit none - integer, intent(in) :: kte - real, intent(in) :: delt - real, dimension(kte), intent(in) :: dp - real, dimension(kte), intent(in) :: exner - real, dimension(kte), intent(inout) :: qv, qc, qi, th - integer k - real :: dqc2, dqi2, dqv2, sum, aa, dum - real, parameter :: qvmin1= 1e-8, & !min at k=1 - qvmin = 1e-20, & !min above k=1 - qcmin = 0.0, & - qimin = 0.0 - - do k = kte, 1, -1 ! From the top to the surface - dqc2 = max(0.0, qcmin-qc(k)) !qc deficit (>=0) - dqi2 = max(0.0, qimin-qi(k)) !qi deficit (>=0) - - !update species - qc(k) = qc(k) + dqc2 - qi(k) = qi(k) + dqi2 - qv(k) = qv(k) - dqc2 - dqi2 - !for theta - !th(k) = th(k) + xlvcp/exner(k)*dqc2 + & - ! xlscp/exner(k)*dqi2 - !for temperature - th(k) = th(k) + xlvcp*dqc2 + & - xlscp*dqi2 - - !then fix qv if lending qv made it negative - if (k .eq. 1) then - dqv2 = max(0.0, qvmin1-qv(k)) !qv deficit (>=0) - qv(k) = qv(k) + dqv2 - qv(k) = max(qv(k),qvmin1) - dqv2 = 0.0 - else - dqv2 = max(0.0, qvmin-qv(k)) !qv deficit (>=0) - qv(k) = qv(k) + dqv2 - qv(k-1)= qv(k-1) - dqv2*dp(k)/dp(k-1) - qv(k) = max(qv(k),qvmin) - endif - qc(k) = max(qc(k),qcmin) - qi(k) = max(qi(k),qimin) - end do - - ! Extra moisture used to satisfy 'qv(1)>=qvmin' is proportionally - ! extracted from all the layers that has 'qv > 2*qvmin'. This fully - ! preserves column moisture. - if( dqv2 .gt. 1.e-20 ) then - sum = 0.0 - do k = 1, kte - if( qv(k) .gt. 2.0*qvmin ) sum = sum + qv(k)*dp(k) - enddo - aa = dqv2*dp(1)/max(1.e-20,sum) - if( aa .lt. 0.5 ) then - do k = 1, kte - if( qv(k) .gt. 2.0*qvmin ) then - dum = aa*qv(k) - qv(k) = qv(k) - dum - endif - enddo - else - ! For testing purposes only (not yet found in any output): - ! write(*,*) 'Full moisture conservation is impossible' - endif - endif - - return - - END SUBROUTINE moisture_check2 - - END SUBROUTINE mynnedmf_wrapper_run - -!###================================================================= - -END MODULE module_bl_mynn_wrapper diff --git a/phys/module_bl_ysu.F b/phys/module_bl_ysu.F index 403532e094..fd071f5d7a 100644 --- a/phys/module_bl_ysu.F +++ b/phys/module_bl_ysu.F @@ -353,27 +353,34 @@ subroutine ysu(u3d,v3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d, & present(b_v_bep) .and. present(b_t_bep) .and. present(b_q_bep) .and. & present(b_e_bep) .and. present(dlg_bep) .and. present(dl_u_bep) .and. & present(sf_bep) .and. present(vl_bep) .and. present(frc_urb2d)) then - do k = kts, kte - do i = its,ite - a_u_hv(i,k) = a_u_bep(i,k,j) - a_v_hv(i,k) = a_v_bep(i,k,j) - a_t_hv(i,k) = a_t_bep(i,k,j) - a_q_hv(i,k) = a_q_bep(i,k,j) - a_e_hv(i,k) = a_e_bep(i,k,j) - b_u_hv(i,k) = b_u_bep(i,k,j) - b_v_hv(i,k) = b_v_bep(i,k,j) - b_t_hv(i,k) = b_t_bep(i,k,j) - b_q_hv(i,k) = b_q_bep(i,k,j) - b_e_hv(i,k) = b_e_bep(i,k,j) - dlg_hv(i,k) = dlg_bep(i,k,j) - dl_u_hv(i,k) = dl_u_bep(i,k,j) - vlk_hv(i,k) = vl_bep(i,k,j) - sfk_hv(i,k) = sf_bep(i,k,j) + + ! following v4.5 logic to fix access violation + if(flag_bep) then + + do k = kts, kte + do i = its,ite + a_u_hv(i,k) = a_u_bep(i,k,j) + a_v_hv(i,k) = a_v_bep(i,k,j) + a_t_hv(i,k) = a_t_bep(i,k,j) + a_q_hv(i,k) = a_q_bep(i,k,j) + a_e_hv(i,k) = a_e_bep(i,k,j) + b_u_hv(i,k) = b_u_bep(i,k,j) + b_v_hv(i,k) = b_v_bep(i,k,j) + b_t_hv(i,k) = b_t_bep(i,k,j) + b_q_hv(i,k) = b_q_bep(i,k,j) + b_e_hv(i,k) = b_e_bep(i,k,j) + dlg_hv(i,k) = dlg_bep(i,k,j) + dl_u_hv(i,k) = dl_u_bep(i,k,j) + vlk_hv(i,k) = vl_bep(i,k,j) + sfk_hv(i,k) = sf_bep(i,k,j) + enddo enddo - enddo - do i = its, ite - frcurb_hv(i) = frc_urb2d(i,j) - enddo + do i = its, ite + frcurb_hv(i) = frc_urb2d(i,j) + enddo + + endif + endif do i = its, ite diff --git a/phys/module_diag_misc.F b/phys/module_diag_misc.F index 04ca35f82f..54ba69e42d 100644 --- a/phys/module_diag_misc.F +++ b/phys/module_diag_misc.F @@ -288,7 +288,11 @@ SUBROUTINE diagnostic_output_calc( & !----------------------------------------------------------------- ! Handle accumulations with buckets to prevent round-off truncation in long runs ! This is done every 360 minutes assuming time step fits exactly into 360 minutes - IF(bucket_mm .gt. 0. .AND. MOD(NINT(XTIME),360) .EQ. 0)THEN + +!!!~~ CURR_SECS2 is elapsed seconds since restart. It is preferred to +!!!~~ XTIME here because XTIME goes imprecise at 2^24, just under 32 years. + + IF(bucket_mm .gt. 0. .AND. MOD(NINT(CURR_SECS2),3600) .EQ. 0)THEN ! SET START AND END POINTS FOR TILES ! !$OMP PARALLEL DO & ! !$OMP PRIVATE ( ij ) diff --git a/phys/module_fdda_psufddagd.F b/phys/module_fdda_psufddagd.F index 6a64a62ae2..fc773ab3d2 100644 --- a/phys/module_fdda_psufddagd.F +++ b/phys/module_fdda_psufddagd.F @@ -9,7 +9,17 @@ ! surfance reanalsys !Reference: Alapaty et al., 2008: Development of the flux-adjusting surface ! data assimilation system for mesoscale models. JAMC, 47, 2331-2350 - +! +! Changed logic for determining next nudging time to rely on minutes elapsed +! since restart (CURR_MINS2) rather than on minutes since initialization +! (XTIME). The REAL variable, XTIME, will become imprecise after 1 X 2^24 +! minutes (just under 32 years of continuous simulation). Cannot remove all +! reliance on XTIME because actual end time is in absolute minutes. Using XTIME +! results in spectral nudging analyses ingested at the wrong times, beginning +! 23 years and 3.5 months into a continous simulation. Purposefully not +! modifying the ramping function because pragmatically we will not get +! very large XTIME values in any situation where the off-ramp for nudging would +! be used. (Tanya Spero, U.S. Environmental Protection Agency -- June 2024) ! ! MODULE module_fdda_psufddagd @@ -18,7 +28,7 @@ MODULE module_fdda_psufddagd ! !------------------------------------------------------------------- ! - SUBROUTINE fddagd(itimestep,dx,dt,xtime, & + SUBROUTINE fddagd(itimestep,dx,dt,xtime, curr_mins2, & id,analysis_interval, end_fdda_hour, & if_no_pbl_nudging_uv, if_no_pbl_nudging_t, if_no_pbl_nudging_q, & if_zfac_uv, k_zfac_uv, if_zfac_t, k_zfac_t, if_zfac_q, k_zfac_q, & @@ -101,7 +111,7 @@ SUBROUTINE fddagd(itimestep,dx,dt,xtime, & INTEGER, INTENT(IN) :: if_ramping INTEGER , INTENT(IN) :: id - REAL, INTENT(IN) :: DT, dx, xtime, dtramp_min + REAL, INTENT(IN) :: DT, dx, xtime, dtramp_min, curr_mins2 INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -243,10 +253,10 @@ SUBROUTINE fddagd(itimestep,dx,dt,xtime, & ENDIF IF( analysis_interval <= 0 )CALL wrf_error_fatal('In grid FDDA, gfdda_interval_m must be > 0') - xtime_old = FLOOR(xtime/analysis_interval) * analysis_interval * 1.0 + xtime_old = FLOOR(curr_mins2/analysis_interval) * analysis_interval * 1.0 xtime_new = xtime_old + analysis_interval IF( int4 == 1 ) THEN - coef = (xtime-xtime_old)/(xtime_new-xtime_old) + coef = (curr_mins2-xtime_old)/(xtime_new-xtime_old) ELSE coef = 1.0 ! Nudging toward a target value (*_ndg_new values) ENDIF @@ -255,7 +265,7 @@ SUBROUTINE fddagd(itimestep,dx,dt,xtime, & CALL get_wrf_debug_level( dbg_level ) - IF( xtime-xtime_old < 0.5*dt/60.0 ) THEN + IF( curr_mins2-xtime_old < 0.5*dt/60.0 ) THEN IF( xtime < end_fdda_hour*60.0 ) THEN WRITE(message,'(a,i1,a,f10.3,a)') & @@ -578,7 +588,7 @@ SUBROUTINE fddagd(itimestep,dx,dt,xtime, & ! Surface Analysis Nudging ! IF( grid_sfdda >= 1 ) THEN - CALL SFDDAGD(itimestep,dx,dt,xtime, id, & + CALL SFDDAGD(itimestep,dx,dt,xtime, curr_mins2, id, & analysis_interval_sfc, end_fdda_hour_sfc, guv_sfc, gt_sfc, gq_sfc, & rinblw, & u3d,v3d,th3d,t3d, & @@ -680,7 +690,7 @@ SUBROUTINE fddagd(itimestep,dx,dt,xtime, & END SUBROUTINE fddagd !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - SUBROUTINE sfddagd(itimestep,dx,dt,xtime, & + SUBROUTINE sfddagd(itimestep,dx,dt,xtime, curr_mins2, & id, analysis_interval_sfc, end_fdda_hour_sfc, & guv_sfc, gt_sfc, gq_sfc, rinblw, & u3d,v3d,th3d,t3d, & @@ -758,7 +768,7 @@ SUBROUTINE sfddagd(itimestep,dx,dt,xtime, & INTEGER, INTENT(IN) :: itimestep, analysis_interval_sfc, end_fdda_hour_sfc INTEGER , INTENT(IN) :: id - REAL, INTENT(IN) :: dx,DT, xtime + REAL, INTENT(IN) :: dx,DT, xtime, curr_mins2 INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -862,10 +872,10 @@ SUBROUTINE sfddagd(itimestep,dx,dt,xtime, & int4 = 1 ! 1: temporal ionterpolation. else: target nudging toward *_ndg_new values IF( analysis_interval_sfc <= 0 )CALL wrf_error_fatal('In grid sfc FDDA, sgfdda_interval_m must be > 0') - xtime_old_sfc = FLOOR(xtime/analysis_interval_sfc) * analysis_interval_sfc * 1.0 + xtime_old_sfc = FLOOR(curr_mins2/analysis_interval_sfc) * analysis_interval_sfc * 1.0 xtime_new_sfc = xtime_old_sfc + analysis_interval_sfc IF( int4 == 1 ) THEN - coef = (xtime-xtime_old_sfc)/(xtime_new_sfc-xtime_old_sfc) ! Temporal interpolation + coef = (curr_mins2-xtime_old_sfc)/(xtime_new_sfc-xtime_old_sfc) ! Temporal interpolation ELSE coef = 1.0 ! Nudging toward a target value (*_ndg_new values) ENDIF @@ -874,7 +884,7 @@ SUBROUTINE sfddagd(itimestep,dx,dt,xtime, & CALL get_wrf_debug_level( dbg_level ) - IF( xtime-xtime_old_sfc < 0.5*dt/60.0 ) THEN + IF( curr_mins2-xtime_old_sfc < 0.5*dt/60.0 ) THEN IF( xtime < end_fdda_hour_sfc*60.0 ) THEN WRITE(message,'(a,i1,a,f10.3,a)') & diff --git a/phys/module_fdda_spnudging.F b/phys/module_fdda_spnudging.F index d48b3d0fd9..facebb8453 100644 --- a/phys/module_fdda_spnudging.F +++ b/phys/module_fdda_spnudging.F @@ -5,6 +5,17 @@ ! Added capability to spectrally nudge water vapor mixing ratio, and added ! user-definable lid for nudging potential temperature and water vapor mixing ! ratio. (Tanya Spero, U.S. Environmental Protection Agency -- October 2017) +! +! Changed logic for determining next nudging time to rely on minutes elapsed +! since restart (CURR_MINS2) rather than on minutes since initialization +! (XTIME). The REAL variable, XTIME, will become imprecise after 1 X 2^24 +! minutes (just under 32 years of continuous simulation). Cannot remove all +! reliance on XTIME because actual end time is in absolute minutes. Using XTIME +! results in spectral nudging analyses ingested at the wrong times, beginning +! 23 years and 3.5 months into a continous simulation. Purposefully not +! modifying the ramping function because pragmatically we will not get +! very large XTIME values in any situation where the off-ramp for nudging would +! be used. (Tanya Spero, U.S. Environmental Protection Agency -- June 2024) MODULE module_fdda_spnudging @@ -17,7 +28,8 @@ MODULE module_fdda_spnudging ! !------------------------------------------------------------------- ! - SUBROUTINE spectral_nudging(grid,itimestep,dt,xtime,id,analysis_interval, end_fdda_hour, & + SUBROUTINE spectral_nudging(grid,itimestep,dt,xtime,curr_mins2, & + id,analysis_interval, end_fdda_hour, & if_no_pbl_nudging_uv, if_no_pbl_nudging_t, if_no_pbl_nudging_ph,if_no_pbl_nudging_q,& if_zfac_uv, k_zfac_uv, dk_zfac_uv, & if_zfac_t, k_zfac_t, dk_zfac_t, & @@ -95,7 +107,7 @@ SUBROUTINE spectral_nudging(grid,itimestep,dt,xtime,id,analysis_interval, end_fd INTEGER, INTENT(IN) :: xwavenum,ywavenum INTEGER , INTENT(IN) :: id - REAL, INTENT(IN) :: DT, xtime, dtramp_min + REAL, INTENT(IN) :: DT, xtime, dtramp_min, curr_mins2 INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -202,15 +214,15 @@ SUBROUTINE spectral_nudging(grid,itimestep,dt,xtime,id,analysis_interval, end_fd ! IF( if_ramping == 1 .AND. dtramp_min > 0.0 ) & ! actual_end_fdda_min = end_fdda_hour*60.0 + ABS(dtramp_min) - xtime_old = FLOOR(xtime/analysis_interval) * analysis_interval * 1.0 + xtime_old = FLOOR(curr_mins2/analysis_interval) * analysis_interval * 1.0 xtime_new = xtime_old + analysis_interval - coef = (xtime-xtime_old)/(xtime_new-xtime_old) + coef = (curr_mins2-xtime_old)/(xtime_new-xtime_old) IF ( wrf_dm_on_monitor()) THEN CALL get_wrf_debug_level( dbg_level ) - IF( xtime-xtime_old < 0.5*dt/60.0 ) THEN + IF( curr_mins2-xtime_old < 0.5*dt/60.0 ) THEN IF( xtime < end_fdda_hour*60.0 ) THEN WRITE(wrf_err_message,FMT='(a,i2.2,a,f15.3,a)') & @@ -549,7 +561,7 @@ SUBROUTINE spectral_nudging(grid,itimestep,dt,xtime,id,analysis_interval, end_fd tfac = 1.0 ELSEIF( xtime >= actual_end_fdda_min-ABS(dtramp_min) .AND. xtime <= actual_end_fdda_min )THEN tfac = ( actual_end_fdda_min - xtime ) / ABS(dtramp_min) - IF( dtramp_min > 0.0 ) coef = (xtime-xtime_old+analysis_interval)/analysis_interval + IF( dtramp_min > 0.0 ) coef = (curr_mins2-xtime_old+analysis_interval)/analysis_interval ELSE tfac = 0.0 ENDIF diff --git a/phys/module_fddagd_driver.F b/phys/module_fddagd_driver.F index dd9b8b38e9..ba5fcdfda4 100644 --- a/phys/module_fddagd_driver.F +++ b/phys/module_fddagd_driver.F @@ -6,7 +6,7 @@ MODULE module_fddagd_driver !------------------------------------------------------------------ SUBROUTINE fddagd_driver(itimestep,dt,xtime, & - id, & + curr_mins2, id, & RUNDGDTEN,RVNDGDTEN,RTHNDGDTEN, & RPHNDGDTEN,RQVNDGDTEN,RMUNDGDTEN, & SDA_HFX, SDA_QFX, & !fasdas @@ -143,7 +143,7 @@ SUBROUTINE fddagd_driver(itimestep,dt,xtime, & INTEGER, INTENT(IN ) :: itimestep,STEPFG ! - REAL, INTENT(IN ) :: DT,DX,XTIME + REAL, INTENT(IN ) :: DT,DX,XTIME, curr_mins2 ! @@ -521,7 +521,7 @@ SUBROUTINE fddagd_driver(itimestep,dt,xtime, & ENDIF CALL FDDAGD(itimestep,dx,dt,xtime, & - id, & + curr_mins2, id, & config_flags%auxinput10_interval_m, & config_flags%auxinput10_end_h, & config_flags%if_no_pbl_nudging_uv, & @@ -570,7 +570,7 @@ SUBROUTINE fddagd_driver(itimestep,dt,xtime, & CASE (SPNUDGING) CALL wrf_debug(100,'in SPECTRAL NUDGING scheme') CALL SPECTRAL_NUDGING(grid,itimestep,dt,xtime, & - id, & + curr_mins2, id, & config_flags%auxinput10_interval_m, & config_flags%auxinput10_end_h, & config_flags%if_no_pbl_nudging_uv, & diff --git a/phys/module_microphysics_driver.F b/phys/module_microphysics_driver.F index 53514d346e..94004191cb 100644 --- a/phys/module_microphysics_driver.F +++ b/phys/module_microphysics_driver.F @@ -16,7 +16,7 @@ SUBROUTINE microphysics_driver( & ,chem_opt, progn & ,cldfra, cldfra_old, exch_h, nsource & ,qlsink, precr, preci, precs, precg & - ,xland,snowh,itimestep & + ,xland,snowh,xice,itimestep & ,f_ice_phy,f_rain_phy,f_rimef_phy & ,lowlyr,sr, id & ,ids,ide, jds,jde, kds,kde & @@ -111,6 +111,7 @@ SUBROUTINE microphysics_driver( & #endif ,qnwfa2d, qnifa2d, qnbca2d & ! for water/ice-friendly/black carbon aerosols ,qnocbb2d, qnbcbb2d & ! for biomass burning aerosols + ,ssat,ssati & ,refl_10cm & ! HM, 9/22/09, add for refl ,vmi3d & ! for P3 ,di3d & ! for P3 @@ -161,15 +162,16 @@ SUBROUTINE microphysics_driver( & ,perts_qsnow, perts_ni & ,pert_thom_qv,pert_thom_qc,pert_thom_qi & ,pert_thom_qs,pert_thom_ni & + ,cloudnc & ) ! Framework USE module_state_description, ONLY : & KESSLERSCHEME, LINSCHEME, SBU_YLINSCHEME, WSM3SCHEME, WSM5SCHEME & - ,WSM6SCHEME, ETAMPNEW, FER_MP_HIRES, THOMPSON, THOMPSONAERO, THOMPSONGH, FAST_KHAIN_LYNN_SHPUND, MORR_TWO_MOMENT & + ,WSM6SCHEME, ETAMPNEW, FER_MP_HIRES, THOMPSON, THOMPSONAERO, RCON_MP_SCHEME, THOMPSONGH, FAST_KHAIN_LYNN_SHPUND, MORR_TWO_MOMENT & ,GSFCGCESCHEME, WDM5SCHEME, WDM6SCHEME, NSSL_2MOM, MADWRF_MP & ,FER_MP_HIRES_ADVECT & - ,WSM7SCHEME, WDM7SCHEME & + ,WSM7SCHEME, WDM7SCHEME, UDMSCHEME & ,NUWRF4ICESCHEME & ,MILBRANDT2MOM , CAMMGMPSCHEME,FULL_KHAIN_LYNN, P3_1CATEGORY, P3_1CATEGORY_NC, P3_2CATEGORY, P3_1CAT_3MOM & ,MORR_TM_AERO, JENSEN_ISHMAEL, SPRINKLER, NTU !,MILBRANDT3MOM @@ -220,6 +222,7 @@ SUBROUTINE microphysics_driver( & USE module_mp_wsm7 USE module_mp_etanew USE module_mp_fer_hires + USE module_mp_rcon USE module_mp_thompson USE module_mp_full_sbm #if ( BUILD_SBM_FAST == 1 ) @@ -237,6 +240,7 @@ SUBROUTINE microphysics_driver( & USE module_mp_wdm5 USE module_mp_wdm6 USE module_mp_wdm7 + USE module_mp_udm USE module_mp_milbrandt2mom # if (EM_CORE == 1) USE module_mp_cammgmp_driver, ONLY: CAMMGMP ! CAM5's microphysics driver @@ -596,6 +600,7 @@ SUBROUTINE microphysics_driver( & REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN) :: XLAND REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN), OPTIONAL :: SNOWH + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN) :: XICE REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(OUT) :: SR @@ -606,7 +611,7 @@ SUBROUTINE microphysics_driver( & ! ! Optional ! - REAL, OPTIONAL, DIMENSION( ims:ime , kms:kme, jms:jme ) , INTENT(OUT) :: refl_10cm + REAL, OPTIONAL, DIMENSION( ims:ime , kms:kme, jms:jme ) , INTENT(OUT) :: refl_10cm,ssat,ssati REAL, OPTIONAL, DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: & ! for ntu3m qdcn_curr,qtcn_curr,qccn_curr,qrcn_curr,qnin_curr, & ! for ntu3m fi_curr,fs_curr,vi_curr,vs_curr,vg_curr,ai_curr, & ! for ntu3m @@ -684,6 +689,7 @@ SUBROUTINE microphysics_driver( & ,GRAUPELNCV & ,HAILNC & ,HAILNCV & + ,CLOUDNC & ,hail_maxk1, hail_max2d #if ( WRF_CHEM == 1) @@ -724,7 +730,7 @@ SUBROUTINE microphysics_driver( & ,f_qvoli,f_qaoli & ! for Jensen ISHMAEL ,f_qvoli2,f_qaoli2 & ! for Jensen ISHMAEL ,f_qi3,f_qni3,f_qvoli3,f_qaoli3 & ! for Jensen ISHMAEL - ,f_qnwfa, f_qnifa, f_qnbca ! Added by G. Thompson + ,f_qnwfa, f_qnifa, f_qnbca ! Added by G. Thompson LOGICAL, OPTIONAL, INTENT(IN) :: diagflag @@ -1025,6 +1031,90 @@ SUBROUTINE microphysics_driver( & CALL wrf_error_fatal ( 'arguments not present for calling mkessler' ) ENDIF #endif +! +! + CASE (RCON_MP_SCHEME) + + CALL wrf_debug ( 100 , 'microphysics_driver: calling RCON' ) + IF ( PRESENT( QV_CURR ) .AND. PRESENT ( QC_CURR ) .AND. & + PRESENT( QR_CURR ) .AND. PRESENT ( QI_CURR ) .AND. & + PRESENT( QS_CURR ) .AND. PRESENT ( QG_CURR ) .AND. & + PRESENT( QNR_CURR) .AND. PRESENT ( QNI_CURR) .AND. & + PRESENT( QNC_CURR) .AND. PRESENT ( QNWFA_CURR) .AND. & + PRESENT( QNIFA_CURR).AND.PRESENT ( QNWFA2D) .AND. & + PRESENT( QNIFA2D) .AND. & + PRESENT( SNOWNC) .AND. PRESENT ( SNOWNCV) .AND. & + PRESENT( GRAUPELNC).AND. PRESENT ( GRAUPELNCV) .AND. & + PRESENT( RAINNC ) .AND. PRESENT ( RAINNCV ) ) THEN +#if ( WRF_CHEM == 1 ) + qv_b4mp(its:ite,kts:kte,jts:jte) = qv_curr(its:ite,kts:kte,jts:jte) + qc_b4mp(its:ite,kts:kte,jts:jte) = qc_curr(its:ite,kts:kte,jts:jte) + qi_b4mp(its:ite,kts:kte,jts:jte) = qi_curr(its:ite,kts:kte,jts:jte) + qs_b4mp(its:ite,kts:kte,jts:jte) = qs_curr(its:ite,kts:kte,jts:jte) +#endif + CALL mp_rcon_driver( & + QV=qv_curr, & + QC=qc_curr, & + QR=qr_curr, & + QI=qi_curr, & + QS=qs_curr, & + QG=qg_curr, & + NI=qni_curr, & + NR=qnr_curr, & + NC=qnc_curr, & + NWFA=qnwfa_curr, & + NIFA=qnifa_curr, & + NBCA=qnbca_curr, & + NWFA2D=qnwfa2d, & + NIFA2D=qnifa2d, & + NBCA2D=qnbca2d, & + aer_init_opt=config_flags%aer_init_opt, & + wif_input_opt=config_flags%wif_input_opt, & + TH=th, & + PII=pi_phy, & + P=p, & + W=w, & + DZ=dz8w, & + DT_IN=dt, & + ITIMESTEP=itimestep, & + RAINNC=RAINNC, & + RAINNCV=RAINNCV, & + CLOUDNC=CLOUDNC, & + SNOWNC=SNOWNC, & + SNOWNCV=SNOWNCV, & + GRAUPELNC=GRAUPELNC, & + GRAUPELNCV=GRAUPELNCV, & + SR=SR, & +#if ( WRF_CHEM == 1 ) + WETSCAV_ON=config_flags%wetscav_onoff == 1, & + RAINPROD=rainprod, & + EVAPPROD=evapprod, & +#endif + REFL_10CM=refl_10cm, & + diagflag=diagflag, & + ke_diag = ke_diag, & + do_radar_ref=do_radar_ref, & + re_cloud=re_cloud, & + re_ice=re_ice, & + re_snow=re_snow, & + has_reqc=has_reqc, & + has_reqi=has_reqi, & + has_reqs=has_reqs, & + IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde, & + IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme, & + ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte) + + + IF (config_flags%aer_fire_emit_opt.gt.0) then + CALL wrf_debug ( 200 , ' call fire_emis_simple_plumerise' ) + CALL fire_emis_simple_plumerise (config_flags%wif_fire_inj, config_flags%aer_fire_emit_opt & + ,z_at_mass, pblh, qnwfa_curr, qnbca_curr & + ,qnocbb2d, qnbcbb2d, dt, ids, ide, jds, jde, kds, kde & + ,ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts, kte ) + ENDIF + ELSE + CALL wrf_error_fatal ( 'arguments not present for calling rcon' ) + ENDIF ! CASE (THOMPSONAERO) if (pert_thom .and. multi_perturb == 1) then @@ -1988,6 +2078,9 @@ SUBROUTINE microphysics_driver( & GRPLNCV = GRAUPELNCV, & SR=SR, & dbz = refl_10cm, & + ssat3d = ssat, & + ssati = ssati, & + nssl_ssat_output = config_flags%nssl_ssat_output, & #if ( WRF_CHEM == 1 ) WETSCAV_ON = config_flags%wetscav_onoff == 1, & EVAPPROD=evapprod,RAINPROD=rainprod, & @@ -2566,6 +2659,58 @@ SUBROUTINE microphysics_driver( & CALL wrf_error_fatal ( 'arguments not present for calling wdm7') ENDIF + CASE (UDMSCHEME) + CALL wrf_debug ( 100 , 'microphysics_driver: calling udm' ) + IF ( PRESENT( QV_CURR ) .AND. PRESENT ( QC_CURR ) .AND. & + PRESENT( QR_CURR ) .AND. PRESENT ( QI_CURR ) .AND. & + PRESENT( QS_CURR ) .AND. PRESENT ( QG_CURR ) .AND. & + PRESENT( QH_CURR ) .AND. & + PRESENT( QNN_CURR ) .AND. PRESENT ( QNC_CURR ) .AND. & + PRESENT( QNR_CURR ).AND. & + PRESENT( RAINNC ) .AND. PRESENT ( RAINNCV ) ) THEN + CALL udm( & + TH=th & + ,Q=qv_curr & + ,QC=qc_curr & + ,QR=qr_curr & + ,QI=qi_curr & + ,QS=qs_curr & + ,QG=qg_curr & + ,QH=qh_curr & + ,NN=qnn_curr & + ,NC=qnc_curr & + ,NR=qnr_curr & + ,DEN=rho,PII=pi_phy,P=p,DELZ=dz8w & + ,DELT=dt,G=g,CPD=cp,CPV=cpv,CCN0=ccn_conc & ! RAS + ,RD=r_d,RV=r_v,T0C=svpt0 & + ,EP1=ep_1, EP2=ep_2, QMIN=epsilon & + ,XLS=xls, XLV0=xlv, XLF0=xlf & + ,DEN0=rhoair0, DENR=rhowater & + ,CLIQ=cliq,CICE=cice,PSAT=psat & + ,xland=xland, xice=xice & ! land mask, 1: land, 2: water + ,RAIN=rainnc ,RAINNCV=rainncv & + ,SNOW=snownc ,SNOWNCV=snowncv & + ,SR=sr & + ,REFL_10CM=refl_10cm & ! added for radar reflectivity + ,diagflag=diagflag & ! added for radar reflectivity + ,do_radar_ref=do_radar_ref & ! added for radar reflectivity + ,GRAUPEL=graupelnc ,GRAUPELNCV=graupelncv & + ,HAIL=hailnc ,HAILNCV=hailncv & + ,ITIMESTEP=itimestep & + ,has_reqc=has_reqc & ! for radiation + + ,has_reqi=has_reqi & + ,has_reqs=has_reqs & + ,re_cloud=re_cloud & + ,re_ice=re_ice & + ,re_snow=re_snow & ! for radiation - + ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & + ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & + ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & + ) + ELSE + CALL wrf_error_fatal ( 'arguments not present for calling udm') + ENDIF + CASE (ETAMPNEW) !-- Operational 4-km High-Resolution Window (HRW) version CALL wrf_debug ( 100 , 'microphysics_driver: calling etampnew') diff --git a/phys/module_mp_nssl_2mom.F b/phys/module_mp_nssl_2mom.F index d89baf3571..562564f528 100644 --- a/phys/module_mp_nssl_2mom.F +++ b/phys/module_mp_nssl_2mom.F @@ -1,6 +1,6 @@ !WRF:MODEL_LAYER:PHYSICS -! prepocessed on "Aug 14 2023" at "16:15:23" +! prepocessed on "Mar 11 2025" at "09:41:58" @@ -71,6 +71,19 @@ ! ! !--------------------------------------------------------------------- +! Feb. 2025 +! - More accurate saturation mixing ratio calculation (iqvsopt=1) +! - Changed default droplet renucleation to irenuc=5, which allows extra nucleation at high supersaturation +! - Default explicit rain breakup for 3-moment (irainbreak=2) +! - Imposed reflectivity conservation in graupel->hail conversion (ihlcnh=3) and Bigg +! freezing (both 2- and 3-moment) +! - Option (nsplinter=1001) for ice crystal production by drop freezing/shattering (Sullivan et al. 2018) +! - Option (incwet = 1) to treat wet growth only for D > Dwet rather than all or nothing; results in +! slightly greater hail production due to maintaining dry growth at D < Dwet +! - Improved logic for sedimentation +! - Separated flushing of small masses into its own subroutine (smallvalues) +! - Some syntax fixes for issues with old versions of gfortran +!--------------------------------------------------------------------- ! Apr. 2023 (WRF-4.6) ! - Update to 3-moment for rain, graupel, and hail ! - Change default graupel/hail fall speeds to icdx/icdxhl=6 (Milbrandt & Morrison 2013) @@ -177,6 +190,7 @@ MODULE module_mp_nssl_2mom public nssl_2mom_driver public nssl_2mom_init + private gamma_sp,gamxinf,GAML02, GAML02d300, GAML02d500, fqvs, fqis private gamma_dp, gamxinfdp, gamma_dpr private delbk, delabk @@ -265,6 +279,7 @@ MODULE module_mp_nssl_2mom integer, private :: itfall = 0 integer, private :: iscfall = 1 integer, private :: irfall = -1 + integer, private :: iifall = 0 integer, private :: isfall = 2 ! default limit with method II (more restrictive) logical, private :: do_accurate_sedimentation = .false. ! if true, recalculate fall speeds on sub time steps; (more expensive) ! if false, reuse fall speeds on multiple steps (can have a noticeable speedup) @@ -338,8 +353,9 @@ MODULE module_mp_nssl_2mom ! (first nucleation is done with a KW sat. adj. step) integer, private :: issfilt = 0 ! flag to turn on filtering of supersaturation field integer, private :: icnuclimit = 0 ! limit droplet nucleation based on Konwar et al. (2012) and Chandrakar et al. (2016) - integer, private :: irenuc = 2 ! =1 to always allow renucleation of droplets within the cloud (do no use, obsolete) + integer, private :: irenuc = 5 ! =1 to always allow renucleation of droplets within the cloud (do no use, obsolete) ! =2 renucleation following Twomey/Cohard&Pinty + ! =5 Similar to 7 but can produce extra activated nuclei from the 'smaller' CCN at higher SS ! =7 New renucleation that requires prediction of the number of activated nuclei ! i.e., not only at cloud base integer, private :: irenuc3d = 0 ! =1 to include horizontal gradient in renucleation of droplets within the cloud @@ -400,6 +416,8 @@ MODULE module_mp_nssl_2mom integer, private :: ierw = 1 ! for single-moment rain (LFO/Z) integer, private :: iehr0c = 0 ! 0 -> no collection for T > 0C; 1 -> turn on collection/shedding for T > 0C integer, private :: iehlr0c = 0 ! 0 -> no collection for T > 0C; 1 -> turn on collection/shedding for T > 0C + real , private :: eiw0 = 0.5 ! constant or max assumed ice-crystal-droplet collection efficiency + real , private :: esw0 = 0.5 ! constant or max assumed snow-droplet collection efficiency real , private :: ehw0 = 0.9 ! 0.5 ! constant or max assumed graupel-droplet collection efficiency real , private :: erw0 = 1.0 ! constant assumed rain-droplet collection efficiency real , private :: ehlw0 = 0.9 ! 0.75 ! constant or max assumed hail-droplet collection efficiency @@ -512,6 +530,8 @@ MODULE module_mp_nssl_2mom real :: sheddiamlg = 10.0e-03 ! diameter of hail to use fwmlarge real :: sheddiam0 = 20.0e-03 ! diameter of hail at which all water is shed + real :: fwmhtmptem = -15. ! temperature at which fwmhtmp fully switches to liquid water only being on large particles + integer :: ifwmhtmptemopt = 1 ! option to use fwmhtmptem (1) or dwet (2) for max liquid at T < 0. integer :: ifwmhopt = 2 ! option for calculating maximum liquid fraction when fwmh and/or fwmhl is set to -1 ! 1 = maximum based on size of maximum mass diameter ! 2 = integrate over spectrum for maximum liquid (experimental) @@ -549,6 +569,8 @@ MODULE module_mp_nssl_2mom real , private :: dwtempmin = 242. ! lowest temperature to allow wet growth conversion to hail real , private :: dwehwmin = 0. ! Minimum ehw to use to find wet growth diameter (if > ehw0, then wet growth diam becomes smaller) real , private :: dg0thresh = 0.15 ! graupel wet growth diameter above which we say do not bother + real , private :: wetgrthtoffset = -1. ! maximum temperature (Celcius) for wet growth (shedding) + real , private :: hailcnvtoffset = -2. ! maximum temperature (Celcius) for hail conversion integer :: ifddenfac = 0 ! = 1 to use density threshold to count FD as GR when converting to HL real :: fddenthresh = 500. ! if ifddenfac > 0, then hail from FD with lower density are considered to come from graupel integer :: icvhl2h = 0 ! allow conversion of hail back to graupel when hail density gets close to minimum allowed @@ -567,8 +589,18 @@ MODULE module_mp_nssl_2mom ! = 1 use mean diameter for breakup ! = 2 use maximum mass diameter for breakup ! = 3 use mass-weighted diameter for breakup - integer :: iraintailbreak = 0 ! 1 = on - real :: draintail = 8.e-3 ! starting size for rain breakup + integer :: irainbreak = -1 ! -1 : auto sets off for 2-moment and on (=2) for 3-moment + ! 0 = off + ! 1 = on (no diameter dependence) (recommend using option 2) + ! 2 = (recommended) as for 1, but apply factor of 1-ec0 to turn off a smaller diameter (ec0 is rain self-coll factor) + ! 10 = as for 1, but sets ec0=1 for rain self-collection (i.e., no passive breakup); set higher rainbreakfac for this option + ! 11 = breakup for DSD tail only; uses draintail etc. + integer :: ibincracr = 0 + real :: rainbreakfac = 1.0e6 ! 1.e6 for irainbreak=2 (reduce double counting); 2.0e6 for lower hand fit for irainbreak=10; 2.542e6 for 'best' fit + real :: draintail = 10.e-3 ! starting size for rain breakup (irainbreak = 11) + real :: drsmall = 1.e-3 ! size of small drops from breakup (irainbreak = 11) + real :: qrbrthresh1 = 0.1e-3 ! lower threshold rain content (kg/m^3) for large drop breakup (irainbreak=11) + real :: qrbrthresh2 = 1.0e-3 ! upper threshold rain content (kg/m^3) for large drop breakup (irainbreak=11) integer, private :: dmrauto = 0 ! = -1 no limiter on crcnw ! = 0 limit crcnw when qr > 1.2*L (Cohard-Pinty 2002) @@ -634,7 +666,7 @@ MODULE module_mp_nssl_2mom real, private :: alphasmlr0 = 14.0 ! shape parameter for drops formed from melting/shedding snow real, private :: delta_alphamlr = 0.5 ! offset from alphamax at which melting does not further collapse the shape parameter - integer :: iqvsopt = 0 ! =0 use old default for tabqvs; =1 use Bolton formulation (Rogers and Yau) + integer, private :: iqvsopt = 1 ! =0 use old default for tabqvs with e/p approx; =1 use Bolton formulation (Rogers and Yau) with e/(p-e) integer :: imaxsupopt = 4 ! how to treat saturation adjustment in two-moment droplets ! 1 = add droplets with same mean mass as current droplets @@ -662,6 +694,8 @@ MODULE module_mp_nssl_2mom integer, private :: lccn = 9 ! 0 or 9, other indices adjusted accordingly integer, private :: lccnuf = 0 integer, private :: lccna = 0 + integer, private :: lccnaco = 0 + integer, private :: lccnanu = 0 integer, private :: lcina = 0 integer, private :: lcin = 0 integer, private :: lnc = 9 @@ -791,6 +825,9 @@ MODULE module_mp_nssl_2mom real, private :: delqxw = 1.0e-10! 1.0e-12 ! real :: tindmn = 233, tindmx = 298.0 ! min and max temperatures where inductive charging is allowed + integer, private :: imorrgdnglimit = 0 ! flag to impose limit on graupel slope parameter + real, private :: morrdnglimit = 2000.E-6 + ! ! gamma function lookup table ! @@ -834,6 +871,7 @@ MODULE module_mp_nssl_2mom integer lvol(lc:lqmx) integer lz(lc:lqmx) integer lliq(li:lqmx) + integer linfall(lc:lqmx) integer denscale(lc:lqmx) ! flag for density scaling (mixing ratio conversion) integer ido(lc:lqmx) @@ -888,11 +926,11 @@ MODULE module_mp_nssl_2mom real xvfmn, xvfmx ! min, max frozen drop volumes real xvgmn, xvgmx ! min, max graupel volumes real xvhmn, xvhmn0, xvhmx, xvhmx0 ! min, max hail volumes - real xvhlmn, xvhlmx ! min, max lg hail volumes + real xvhlmn, xvhlmx, xvhlmx0 ! min, max lg hail volumes - real, parameter :: dhlmn = 0.3e-3, dhlmx = 40.e-3 + real, parameter :: dhlmn = 0.3e-3 real, parameter :: dhmn0 = 0.3e-3 - real, private :: dhmn = dhmn0, dhmx = -1. + real, private :: dhmn = dhmn0, dhmx = -1., dhlmx = -1. ! 40.e-3 real, parameter :: cwradn = 2.0e-6, xcradmn = cwradn ! minimum radius real, parameter :: cwradx = 60.e-6, xcradmx = cwradx ! maximum radius @@ -915,7 +953,7 @@ MODULE module_mp_nssl_2mom parameter( xvfmn=0.523599*(0.1e-3)**3, xvfmx=0.523599*(10.e-3)**3 ) ! mks xvfmx = (pi/6)*(10mm)**3 parameter( xvgmn=0.523599*(0.1e-3)**3, xvgmx=0.523599*(10.e-3)**3 ) ! mks xvfmx = (pi/6)*(10mm)**3 parameter( xvhmn0=0.523599*(0.3e-3)**3, xvhmx0=0.523599*(20.e-3)**3 ) ! mks xvfmx = (pi/6)*(20mm)**3 - parameter( xvhlmn=0.523599*(dhlmn)**3, xvhlmx=0.523599*(dhlmx)**3 ) ! mks xvfmx = (pi/6)*(40mm)**3 + parameter( xvhlmn=0.523599*(dhlmn)**3, xvhlmx0=0.523599*(40.e-3)**3 ) ! mks xvfmx = (pi/6)*(40mm)**3 ! ! electrical permitivity of air C / (N m**2) - check the units @@ -941,6 +979,7 @@ MODULE module_mp_nssl_2mom real, parameter :: cbwbolton = 29.65 ! constants for Bolton formulation real, parameter :: cawbolton = 17.67 + real, parameter :: esbolton = 6.112e2 real, parameter :: tfrh = 233.15 real, parameter :: tfr = 273.15 @@ -992,14 +1031,50 @@ MODULE module_mp_nssl_2mom logical, parameter :: do_satadj_for_wrfchem = .true. - integer, parameter :: ac_opt = 0 ! option flag for alternate aerosol (for NUWRF only) + integer, private :: lcn_nu = 0 ! 27 ! need to check no conflict with other variables + integer, private :: lcn_ac = 0 ! 28 + integer, private :: lcn_co = 0 ! 29 + integer, private :: lcinp = 0 ! 30 + integer, private :: ac_opt = 0 ! option flag for: (1 and 2 currently for NUWRF only) + ! 0 : normal NSSL CCN physics + ! 1 : accumulation mode CN following Fridland et al. (2012, 2017), + ! where CCN number is sum of unactivated CCN and droplet concentrations + ! 2 : As for 1 but have three modes (but does not partition activated CCN) + ! 11: As for 1 but track activated CCN as a separate category (CN category advects only) + ! 22: As for 11 but 3 modes, each with its own activation tracer + real, private :: ac_wthresh = 10.0 ! for W < ac_wthresh, use max of sswater and diagnosed SS; otherwise use sswater logical, private :: nuaccoinp = .false. +! T.Iguchi Y2021 Update +! logical :: ac_only = .true. ! flag for considering ac_mode of CN only, or all nu,ac,co modes (still under construction) + + logical, private :: arg_para = .true. ! flag for Abdul-Razzak_and_Ghan parameterization works similarly to flag_qndrop, and neglects irenuc, ccna(mgs), and cnuc(mgs) + real, private :: nu_pmr = 7.5 * 1.e-3 * 1.e-6 ! aerosol radius (meter); these parameter values follow Cheng et al. (2007QJ) + real, private :: nu_pgw = 0.53 ! Unlike original Abdul-Razzak_and_Ghan, this value is used without log (Cheng et al. 2007QJ) + real, private :: nu_kappa = 0.07 ! ammonium sulfate as CCN (Petters and Kreidenweis, 2007ACP) + real, private :: ac_pmr = 3.8 * 1.e-2 * 1.e-6 ! aerosol radius (meter) + real, private :: ac_pgw = 0.69 + real, private :: ac_kappa = 0.61 ! ammonium sulfate as CCN (Petters and Kreidenweis, 2007ACP) + real, private :: co_pmr = 0.51 * 1.e-6 ! aerosol radius (meter) + real, private :: co_pgw = 0.77 + real, private :: co_kappa = 0.61 ! ammonium sulfate as CCN (Petters and Kreidenweis, 2007ACP) + + real, parameter :: cn_minlimit = 1.e3 ! 1.e3 m-3 = 0.001 cm-3 + + logical :: dm15_para = .false. ! flag for DeMott et al. (2015) parameterization for heterogenous freezing, regardless of "ibfc" + + ! Note to users: Many of these options are for development and not guaranteed to perform well. ! Some may not be functional depending on the version of the code. ! Some may be useful for ensemble physics diversity. Feel free to contact Ted Mansell if you have questions ! in that regard. NAMELIST /nssl_mp_params/ & +! nuwrf 3-mode params + ac_opt,arg_para, & + ac_kappa, ac_pmr, ac_pgw, & + nu_kappa, nu_pmr, nu_pgw, & + co_kappa, co_pmr, co_pgw, & +! --- ndebug, ncdebug,& iusewetgraupel, & iusewethail, & @@ -1007,16 +1082,17 @@ MODULE module_mp_nssl_2mom idbzci, & vtmaxsed, & itfall,iscfall, & - infall,irfall,isfall, & + infall,irfall,isfall,iifall, & rssflg, & sssflg, & hssflg, & hlssflg, & + irainbreak, rainbreakfac, & irimdenopt,rimdenvwgt, & rimc1, rimc2, rimc3, rimc4, & idiagnosecnu, & icnuclimit, & - irenuc, & + irenuc, ccn, & restoreccn, ccntimeconst, cck, & decayufccn, ufccntimeconst, & switchccn, old_cccn, & @@ -1078,6 +1154,7 @@ MODULE module_mp_nssl_2mom ehimax, & ehsmax, & ecollmx, & + eiw0, esw0, & ehw0, ehlw0, & ehr0, ehlr0, & erw0, & @@ -1087,7 +1164,7 @@ MODULE module_mp_nssl_2mom iqcinit, & ssmxinit, & xvdmx, & - dhmn, dhmx, & + dhmn, dhmx, dhlmx, & fwms,fwmh,fwmhl, & ifwmhopt, & ihxw2rain, & @@ -1103,7 +1180,8 @@ MODULE module_mp_nssl_2mom rescale_low_alphah, & rescale_low_alphahl, & rescale_high_alpha, & - ihlcnh, hldia1,iusedw, dwehwmin, dwmin, dwmax, dwtempmin, dg0thresh, & + ihlcnh, hldia1,iusedw, dwehwmin, dwmin, dwmax, dwtempmin, dg0thresh, incwet, & + wetgrthtoffset, hailcnvtoffset, & icvhl2h, hldnmn,hdnmn, & hlcnhdia, hlcnhqmin, & isedonly, & @@ -1159,6 +1237,8 @@ REAL FUNCTION fqis(t) END FUNCTION fqis +!==========================================================================================! + @@ -1167,6 +1247,7 @@ END FUNCTION fqis ! ##################################################################### SUBROUTINE nssl_2mom_init( & & ims,ime, jms,jme, kms,kme, nssl_params, ipctmp, mixphase,ihvol,idoniconlytmp, & + & namelist_filename, & & nssl_graupelfallfac, & & nssl_hailfallfac, & & nssl_ehw0, & @@ -1181,6 +1262,7 @@ SUBROUTINE nssl_2mom_init( & & nssl_alphahl, & & nssl_alphar, & & nssl_density_on, nssl_hail_on, nssl_ccn_on, nssl_icecrystals_on, ccn_is_ccna, & + & nssl_ccn_opt, & & infileunit, & & myrank, mpiroot & ) @@ -1199,14 +1281,19 @@ SUBROUTINE nssl_2mom_init( & & nssl_alphahl, & & nssl_alphar integer, intent(in), optional :: & - & nssl_icdx, & + & nssl_icdx, & & nssl_icdxhl, myrank, mpiroot, & - & nssl_ufccn - logical, intent(in), optional :: nssl_density_on, nssl_hail_on, nssl_ccn_on, nssl_icecrystals_on + & nssl_ufccn, & + & nssl_ccn_opt + logical, intent(in), optional :: nssl_density_on, nssl_ccn_on, nssl_hail_on, nssl_icecrystals_on integer, intent(inout), optional :: ccn_is_ccna integer, intent(in),optional :: infileunit + integer,parameter::strsize=512 + character(len=strsize), intent(in), optional :: namelist_filename + character(len=strsize) :: namelist_inputfile + integer, intent(in), optional :: ims,ime, jms,jme, kms,kme real, intent(in), dimension(20), optional :: nssl_params @@ -1223,7 +1310,7 @@ SUBROUTINE nssl_2mom_init( & integer :: hail_on = -1, density_on = -1, icecrystals_on = 1 integer :: ccn_on = -1 - double precision :: arg + double precision :: arg,cwch real :: temq integer :: igam integer :: i,il,j,l @@ -1294,7 +1381,7 @@ SUBROUTINE nssl_2mom_init( & ! hack to switch CCN field to CCNA (activated ccn) ! invertccn = .true. turn_on_ccna = .true. - irenuc = 7 + irenuc = 5 ENDIF ccnuf = Abs( nssl_params(14) ) IF ( present(nssl_ufccn) ) iufccn = nssl_ufccn @@ -1332,31 +1419,45 @@ SUBROUTINE nssl_2mom_init( & ipconc = ipctmp - IF ( ipconc < 5 ) THEN - ihlcnh = 0 - ENDIF IF ( ihlcnh <= 0 ) THEN - IF ( ipconc == 5 ) THEN + IF ( ipconc < 5 ) THEN + ihlcnh = 0 + ELSEIF ( ipconc == 5 ) THEN ihlcnh = 3 ELSEIF ( ipconc >= 6 ) THEN ihlcnh = 3 ENDIF ENDIF - + ! turn on active rain breakup by default for 3-moment rain since it has no implicit breakup from sedimentation + ! Check this after namelist read so that user can set irainbreak=0 to turn off + IF ( irainbreak == -1 ) THEN + IF ( ipconc >= 6 ) THEN + irainbreak = 2 + ELSE + irainbreak = 0 + ENDIF + ENDIF + + + namelist_inputfile = 'namelist.input' ! default for WRF/cm1 + IF ( present( namelist_filename ) ) THEN + namelist_inputfile = namelist_filename + ELSE + ENDIF IF ( .true. ) THEN ! set to true to enable internal namelist read - open(15,file='namelist.input',status='old',form='formatted',action='read') + open(15,file=namelist_inputfile,status='old',form='formatted',action='read') rewind(15) read(15,NML=nssl_mp_params,iostat=istat) close(15) IF ( istat /= 0 ) THEN #ifdef WRF_ELEC IF ( wrf_dm_on_monitor() ) THEN - write(0,*) 'NSSL_2MOM_INIT: PROBLEM WITH NSSL_MP_PARAMS namelist: not found or bad token' + write(0,*) 'NSSL_2MOM_INIT: NSSL_MP_PARAMS namelist: not found or bad token' ENDIF #else ! write(0,*) 'NSSL_2MOM_INIT: PROBLEM WITH NSSL_MP_PARAMS namelist: not found or bad token' @@ -1371,7 +1472,6 @@ SUBROUTINE nssl_2mom_init( & ENDIF - IF ( iufccn > 0 ) THEN ! make sure to use option that uses UF ccn irenuc = 7 IF ( ccnuf <= 0.0 ) decayufccn = .true. ! assume surface emission and need decay @@ -1384,6 +1484,9 @@ SUBROUTINE nssl_2mom_init( & IF ( present( nssl_ccn_on ) ) THEN IF ( nssl_ccn_on ) THEN ccn_on = 1 + IF ( present( nssl_ccn_opt ) ) THEN + IF ( nssl_ccn_opt > 10 ) ac_opt = 22 + ENDIF ELSE ccn_on = 0 irenuc = 2 @@ -1394,7 +1497,7 @@ SUBROUTINE nssl_2mom_init( & turn_on_ccna = .true. IF ( present( nssl_ccn_on ) ) THEN IF ( .not. nssl_ccn_on ) THEN - write(0,*) 'NSSL_MP Error: Must have nssl_ccn_on=1 for irenuc >= 5!' + write(0,*) 'NSSL_MP Error: Must have nssl_ccn_on=1/true for irenuc >= 5!' STOP ENDIF ENDIF @@ -1470,13 +1573,14 @@ SUBROUTINE nssl_2mom_init( & dtabqvs(l) = ((-caw*(-273.15 + temq))/(temq - cbw)**2 + & & caw/(temq - cbw))*tabqvs(l) ELSE - tabqvs(l) = exp(caw*(temq-273.15)/(temq-cbw)) + tabqvs(l) = exp(cawbolton*(temq-273.15)/(temq-cbwbolton)) dtabqvs(l) = ((-cawbolton*(-273.15 + temq))/(temq - cbwbolton)**2 + & & cawbolton/(temq - cbwbolton))*tabqvs(l) ENDIF tabqis(l) = exp(cai*(temq-273.15)/(temq-cbi)) dtabqis(l) = ((-cai*(-273.15 + temq))/(temq - cbi)**2 + & & cai/(temq - cbi))*tabqis(l) + end do bx(lr) = 0.85 @@ -1528,8 +1632,8 @@ SUBROUTINE nssl_2mom_init( & gmoi(igam) = gamma_dp(arg) end do - ! build lookup table to compute the number and mass fractions of rain drops - ! (imurain=1) greater than a given diameter. Used for qiacr and ciacr + ! build lookup table to compute the number and mass fractions of particles + ! (mu=1) greater than a given diameter. Used for qiacr and ciacr ! Uses incomplete gamma functions ! The terms with bxh or bxhl will be off if the actual bxh or bxhl is different from the base value (icdx=6 option) @@ -1617,6 +1721,8 @@ SUBROUTINE nssl_2mom_init( & lccn = 0 lccnuf = 0 lccna = 0 + lccnaco = 0 + lccnanu = 0 lnc = 0 lnr = 0 lni = 0 @@ -1640,9 +1746,15 @@ SUBROUTINE nssl_2mom_init( & IF ( ipconc == 0 ) THEN IF ( hail_on == 1 ) THEN ! turn on graupel density for 1-moment scheme - lvh = 9 - ltmp = 9 - denscale(lvh) = 1 + IF ( density_on >= 1 ) THEN ! turn on graupel density for 1-moment scheme + lvh = 9 + ltmp = 9 + denscale(lvh) = 1 + ELSE + ltmp = lhab + lvh = 0 + lvhl = 0 + ENDIF ELSE ! no hail, 'LFO' scheme ltmp = lhab lhl = 0 @@ -1780,7 +1892,8 @@ SUBROUTINE nssl_2mom_init( & !debug write(0,*) 'Setting lcin to ',lcin ENDIF na = ltmp - + + ln(:) = 0 ln(lc) = lnc ln(lr) = lnr ln(li) = lni @@ -1788,6 +1901,7 @@ SUBROUTINE nssl_2mom_init( & ln(lh) = lnh IF ( lhl .gt. 1 ) ln(lhl) = lnhl + ipc(:) = 0 ipc(lc) = 2 ipc(lr) = 3 ipc(li) = 1 @@ -1990,9 +2104,19 @@ SUBROUTINE nssl_2mom_init( & ido(lh) = idohw IF ( lhl .gt. 1 ) ido(lhl) = idohl + linfall(:) = infall + linfall(lc) = 0 IF ( irfall .lt. 0 ) irfall = infall IF ( isfall .lt. 0 ) isfall = infall + IF ( iifall .lt. 0 ) iifall = infall IF ( lzr > 0 ) irfall = 0 + IF ( lzs > 0 ) isfall = 0 + IF ( lzh > 0 ) linfall(lh) = 0 + IF ( lzhl > 0 .and. lhl > 0 ) linfall(lhl) = 0 + IF ( lzr > 0 .and. lf > 0 ) linfall(lf) = 0 + linfall(lr) = irfall + linfall(ls) = isfall + linfall(li) = iifall qccn = ccn/rho00 qccnuf = ccnuf/rho00 @@ -2023,6 +2147,19 @@ SUBROUTINE nssl_2mom_init( & ELSE xvhmx = 0.523599*(dhmx)**3 ENDIF + + IF ( dhlmx <= 0.0 ) THEN + xvhlmx = xvhlmx0 + ELSE + xvhlmx = 0.523599*(dhlmx)**3 + ENDIF + + IF ( ipconc == 5 .and. imorrgdnglimit >= 1 ) THEN + ! convert morrdnglimit to xvhmx equivalent + cwch = ((3. + alphah)*(2. + alphah)*(1.0 + alphah))**(-1./3.) + xvhmx = pi/6.0*(morrdnglimit/cwch)**3 + dhmx = morrdnglimit/cwch + ENDIF IF ( qhdpvdn < 0. ) qhdpvdn = xdnmn(lh) IF ( qhacidn < 0. ) qhacidn = xdnmn(lh) @@ -2224,7 +2361,9 @@ END SUBROUTINE nssl_2mom_init SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw, chl, & cn, vhw, vhl, cna, cni, f_cn, f_cna, f_cina, & f_qc, f_qr, f_qi, f_qs, f_qh, f_qhl, & - cnuf, f_cnuf, & + cn_nu, cn_co, cinp, f_cnnu, f_cnco, f_cinp, & + cna_co, cna_nu, f_cnaco, f_cnanu, & + cnuf, f_cnuf, cn_ac, f_cnac, & zrw, zhw, zhl, f_zrw, f_zhw, f_zhl, f_vhw, f_vhl, & qsw, qhw, qhlw, & tt, th, pii, p, w, dn, dz, dtp, itimestep, & @@ -2246,8 +2385,9 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw rscghis_2d,rscghis_2dp,rscghis_2dn, & scr,scw,sci,scs,sch,schl,sctot, & elec_physics, & - induc,elecz,scion,sciona, & + induc,elecz,scion,sciona,f_scion,f_sciona, & noninduc,noninducp,noninducn, & + ssat3d,ssati,nssl_ssat_output, & pcc2, pre2, depsubr, & mnucf2, melr2, ctr2, & rim1_2, rim2_2,rim3_2, & @@ -2261,6 +2401,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! re_liquid, re_graupel, re_hail, re_icesnow, & ! vtcloud, vtrain, vtsnow, vtgraupel, vthail, & ipelectmp, & + isedonly_in, & diagflag,ke_diag, & nssl_progn, & ! wrf-chem ! 20130903 acd_mb_washout start @@ -2294,7 +2435,11 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw qi,qhl,ccw,crw,cci,csw,chw,chl,vhw,vhl integer, optional, intent(in) :: is_theta_or_temp logical, optional, intent(in) :: f_zrw, f_zhw, f_zhl, f_vhw, f_vhl ! not used yet + integer, optional, intent(in) :: nssl_ssat_output real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: dbz, vzf, cn, cna, cni, cnuf + real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: cn_nu, cn_ac, cn_co, cinp, cna_co, cna_nu + logical, optional, intent(in) :: f_cnnu, f_cnac, f_cnco, f_cinp, f_cnaco, f_cnanu + real, dimension(ims:ime, jms:jme), optional, intent(inout):: compdbz real, dimension(ims:ime, jms:jme), optional, intent(inout):: rscghis_2d, & ! 2D accumulation arrays for vertically-integrated charging rate rscghis_2dp, & ! 2D accumulation arrays for vertically-integrated charging rate (positive only) @@ -2306,11 +2451,12 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: & induc,noninduc,noninducp,noninducn ! charging rates: inductive, noninductive (all, positive, negative to graupel) real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(in) :: elecz ! elecsave = Ez - real, dimension(ims:ime, kms:kme, jms:jme,2),optional, intent(inout) :: scion + real, dimension(ims:ime, kms:kme, jms:jme, 2),optional, intent(inout) :: scion real, dimension(ims:ime, kms:kme, jms:jme), intent(in):: p,w,dz,dn real, dimension(ims:ime, kms:kme, jms:jme), intent(in):: pii real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: & + ssat3d, ssati, & pcc2, pre2, depsubr, & mnucf2, melr2, ctr2, & rim1_2, rim2_2,rim3_2, & @@ -2345,13 +2491,14 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw real, dimension(ims:ime, jms:jme), intent(out), optional :: & rainncw2, rainnci2 ! liquid rain, ice, accumulation rates real, optional, intent(in) :: dx,dy - real, intent(in):: dtp - integer, intent(in):: itimestep !, ccntype + real, intent(in) :: dtp + integer, intent(in) :: itimestep !, ccntype integer, intent(in), optional :: ntmul, ntcnt logical, optional, intent(in) :: lastloop logical, optional, intent(in) :: diagflag, f_cna, f_cn, f_cina, f_cnuf logical, optional, intent(in) :: f_qc, f_qr, f_qi, f_qs, f_qh, f_qhl - integer, optional, intent(in) :: ipelectmp, ke_diag + logical, optional, intent(in) :: f_scion,f_sciona + integer, optional, intent(in) :: ipelectmp, ke_diag, isedonly_in LOGICAL, INTENT(IN), OPTIONAL :: nssl_progn ! flags for wrf-chem @@ -2423,16 +2570,18 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw double precision :: wvol5,wvol10 real :: tmp,dv,dv1,tmpchg real :: rdt + real :: temp1, c1 double precision :: dt1,dt2 double precision :: timesed,timesed1,timesed2,timesed3, timegs, timenucond, timedbz,zmaxsed double precision :: timevtcalc,timesetvt - logical :: f_cnatmp, f_cinatmp + logical :: f_cnatmp, f_cinatmp, f_cnacotmp, f_cnanutmp logical :: has_wetscav integer :: kediagloc integer :: iunit + integer :: isedonly_local real :: ycent, y, emissrate, emissrate0, emissrate1, z, fac, factot real :: fach(kts:kte) @@ -2520,6 +2669,13 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ELSE ipelec = 0 ENDIF + + IF ( present( isedonly_in ) ) THEN + isedonly_local = isedonly_in + ELSE + isedonly_local = 0 + ENDIF + ! IF ( present( dbz ) ) THEN ! DO jy = jts,jte ! DO kz = kts,kte @@ -2643,10 +2799,9 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw infdo = 0 ENDIF - IF ( infall .ge. 3 .or. ipconc .ge. 6 ) THEN + IF ( Any(linfall(:) .ge. 3 ) .or. ipconc .ge. 6 ) THEN infdo = 2 ENDIF - IF ( present( HAILNCV ) .and. lhl < 1 ) THEN ! for WRF 3.1 compatibility HAILNCV(its:ite,jts:jte) = 0. @@ -2689,7 +2844,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! write(0,*) 'N2M: load an, jy,lccn = ',jy,lccn,qccn - IF ( present( pcc2 ) .and. makediag ) THEN + IF ( ( present( pcc2 ) .or. present( axtra ) ) .and. makediag ) THEN axtra2d(its:ite,1,kts:kte,:) = 0.0 ENDIF @@ -2749,7 +2904,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( lccna > 1 ) THEN IF ( present( cna ) .and. f_cnatmp ) THEN - an(ix,1,kz,lccna) = cna(ix,kz,jy) + an(ix,1,kz,lccna) = Max(0.0, cna(ix,kz,jy) ) ENDIF ENDIF @@ -2774,7 +2929,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw an(ix,1,kz,lnh) = chw(ix,kz,jy) IF ( lhl > 1 ) an(ix,1,kz,lnhl) = chl(ix,kz,jy) ENDIF - IF ( lvh > 0 ) an(ix,1,kz,lvh) = vhw(ix,kz,jy) + IF ( lvh > 0 .and. present( vhw ) ) an(ix,1,kz,lvh) = vhw(ix,kz,jy) IF ( lvhl > 0 .and. present( vhl ) ) an(ix,1,kz,lvhl) = vhl(ix,kz,jy) IF ( ipconc >= 6 ) THEN @@ -2835,7 +2990,11 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! ! saturation mixing ratio ! - t8s = t00(ix,1,kz)*tabqvs(ltemq) !saturation mixing ratio wrt water + IF ( iqvsopt == 0 ) THEN + t8s = t00(ix,1,kz)*tabqvs(ltemq) !saturation mixing ratio wrt water + ELSE + t8s = rdorv*esbolton*tabqvs(ltemq)/(pn(ix,1,kz) - esbolton*tabqvs(ltemq)) + ENDIF t9s = t00(ix,1,kz)*tabqis(ltemq) !saturation mixing ratio wrt ice ! @@ -2952,12 +3111,10 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! IF ( .true. ) THEN -! #ifndef CM1 ! for real cases when hydrometeor mixing ratios have been initialized without concentrations IF ( itimestep == 1 .and. ipconc > 0 .and. loopcnt == 1 ) THEN call calcnfromq(nx,ny,nz,an,na,nor,nor,dn1) ENDIF -! #endif IF ( present(cu_used) .and. & ( present( qrcuten ) .or. present( qscuten ) .or. & @@ -2977,24 +3134,13 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw call calcnfromcuten(nx,ny,nz,ancuten,an,na,nor,nor,dn1) - DO kz = kts,kte - DO ix = its,ite - - - IF ( ipconc >= 6 ) THEN -! IF ( lzr > 0 ) an(ix,1,kz,lzr) = an(ix,1,kz,lzr) + ancuten(ix,1,kz,lzr) - ENDIF - - ENDDO - ENDDO - ENDIF !} ENDIF !} - - + IF ( isedonly_local == 0 ) THEN + call sediment1d(dtp,nx,ny,nz,an,na,nor,nor,xfall,dn1,dz2d,dz2dinv, & & t0,t7,infdo,jy,its,jts & & ,timesed1,timesed2,timesed3,zmaxsed,timesetvt) @@ -3015,11 +3161,11 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw & xfall(ix,1,lh)*1000./xdn0(lr) ) ENDIF IF ( present ( rainncw2 ) ) THEN ! rain only - rainncw2(ix,jy) = rainncw2(ix,jy) + dtp*dn1(ix,1,1)*xfall(ix,1,lr) + rainncw2(ix,jy) = rainncw2(ix,jy) + dtp*dn1(ix,1,1)*xfall(ix,1,lr) ENDIF IF ( present ( rainnci2 ) ) THEN ! ice only IF ( lhl > 1 ) THEN - rainnci2(ix,jy) =rainnci2(ix,jy) + dtp*dn1(ix,1,1)*(xfall(ix,1,ls)*1000./xdn0(lr) + & + rainnci2(ix,jy) = rainnci2(ix,jy) + dtp*dn1(ix,1,1)*(xfall(ix,1,ls)*1000./xdn0(lr) + & & xfall(ix,1,lh)*1000./xdn0(lr) + xfall(ix,1,lhl)*1000./xdn0(lr) ) ELSE rainnci2(ix,jy) = rainnci2(ix,jy) + dtp*dn1(ix,1,1)*(xfall(ix,1,ls)*1000./xdn0(lr) + & @@ -3040,11 +3186,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw SNOWNC(ix,jy) = SNOWNC(ix,jy) + SNOWNCV(ix,jy) ENDIF IF ( lhl > 1 ) THEN -!#ifdef CM1 -! IF ( .true. ) THEN -!#else IF ( present( HAILNC ) ) THEN -!#endif HAILNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,lhl)*1000./xdn0(lr) IF ( loopcnt == loopmax ) HAILNC(ix,jy) = HAILNC(ix,jy) + HAILNCV(ix,jy) ! ELSEIF ( present( GRPLNCV ) ) THEN ! if no separate hail accum, then add to graupel @@ -3063,6 +3205,8 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDIF ENDDO + ENDIF ! isedonly_local + ! ENDIF ! .false. IF ( isedonly /= 1 ) THEN @@ -3110,6 +3254,14 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw & ,axtra2d, makediag & & ,ssat,t00,t77,flag_qndrop) +! Clean up tiny values of mixing ratio and final checks on max/min sizes + CALL smallvalues & + & (nx,ny,nz,na,jy & + & ,nor,nor,dtp,nx & + & ,t0 & + & ,an,dn1,wn & + & ,t77,flag_qndrop) + ENDIF @@ -3128,6 +3280,40 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDDO ENDIF + IF ( ( present( ssat3d ) .and. present( nssl_ssat_output ) ) .and. makediag ) THEN + DO kz = kts,kte + DO ix = its,ite + + ! updated temperature and qv + temp1 = t0(ix,1,kz) ! an(ix,1,kz,lt)*t77(ix,1,kz) + ltemq = Int( (temp1-163.15)/fqsat+1.5 ) + ltemq = Min( nqsat, Max(1,ltemq) ) + + IF ( present( ssat3d ) .and. nssl_ssat_output >= 1 ) THEN + +! c1 = t00(ix,1,kz)*tabqvs(ltemq) + IF ( iqvsopt == 0 ) THEN + c1 = (380.0/pn(ix,1,kz))*tabqvs(ltemq) + ELSEIF ( iqvsopt == 1 ) THEN + c1 = rdorv*esbolton*tabqvs(ltemq)/(pn(ix,1,kz) - esbolton*tabqvs(ltemq)) + ENDIF + + IF ( c1 > 0. ) THEN + ssat3d(ix,kz,jy) = 100.*(an(ix,1,kz,lv)/c1 - 1.0) ! from "new" values + ENDIF + + ENDIF + + IF ( present( ssati ) .and. nssl_ssat_output >= 2 ) THEN + t9s = (380.0/pn(ix,1,kz))*tabqis(ltemq) !saturation mixing ratio wrt ice + ssati(ix,kz,jy) = 100.*(an(ix,1,kz,lv)/t9s - 1.0) ! Min(t8s,max(an(ix,1,kz,lv),0.0))/t9s ! qv/qvi + ENDIF + + ENDDO + ENDDO + ENDIF + + ! compute diagnostic S-band reflectivity if needed IF ( present( dbz ) .and. makediag .and. lastlooptmp ) THEN @@ -3332,7 +3518,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw - IF ( lvh > 0 ) vhw(ix,kz,jy) = an(ix,1,kz,lvh) + IF ( lvh > 0 .and. present( vhw ) ) vhw(ix,kz,jy) = an(ix,1,kz,lvh) IF ( lvhl > 0 .and. present( vhl ) ) vhl(ix,kz,jy) = an(ix,1,kz,lvhl) #if ( WRF_CHEM == 1 ) @@ -3391,17 +3577,15 @@ REAL FUNCTION GAMMA_SP(xx) real xx integer j -! Double precision ser,stp,tmp,x,y,cof(6) - - real*8 ser,stp,tmp,x,y,cof(6) + double precision :: ser,stp,tmp,x,y,cof(6) SAVE cof,stp - DATA cof,stp/76.18009172947146d+0, & + DATA cof /76.18009172947146d+0, & & -86.50532032941677d0, & & 24.01409824083091d0, & & -1.231739572450155d0, & & 0.1208650973866179d-2,& - & -0.5395239384953d-5, & - & 2.5066282746310005d0/ + & -0.5395239384953d-5/ + DATA stp/2.5066282746310005d0/ IF ( xx <= 0.0 ) THEN write(0,*) 'Argument to gamma must be > 0!! xx = ',xx @@ -3774,20 +3958,18 @@ END function BETA DOUBLE PRECISION FUNCTION GAMMA_DP(xx) implicit none - double precision xx + double precision :: xx integer j -! Double precision ser,stp,tmp,x,y,cof(6) - - real*8 ser,stp,tmp,x,y,cof(6) + double precision ser,stp,tmp,x,y,cof(6) SAVE cof,stp - DATA cof,stp/76.18009172947146d+0, & + DATA cof /76.18009172947146d+0, & & -86.50532032941677d0, & & 24.01409824083091d0, & & -1.231739572450155d0, & & 0.1208650973866179d-2,& - & -0.5395239384953d-5, & - & 2.5066282746310005d0/ + & -0.5395239384953d-5/ + DATA stp/2.5066282746310005d0/ x = xx y = x @@ -3821,6 +4003,19 @@ SUBROUTINE GAMMADP(X,GA) integer :: k,m1,m double precision :: G(26) + + DATA G/1.0D0,0.5772156649015329D0, & + & -0.6558780715202538D0, -0.420026350340952D-1, & + & 0.1665386113822915D0,-.421977345555443D-1, & + & -.96219715278770D-2, .72189432466630D-2, & + & -.11651675918591D-2, -.2152416741149D-3, & + & .1280502823882D-3, -.201348547807D-4, & + & -.12504934821D-5, .11330272320D-5, & + & -.2056338417D-6, .61160950D-8, & + & .50020075D-8, -.11812746D-8, & + & .1043427D-9, .77823D-11, & + & -.36968D-11, .51D-12, & + & -.206D-13, -.54D-14, .14D-14, .1D-15/ IF (X.EQ.INT(X)) THEN IF (X.GT.0.0D0) THEN @@ -3844,18 +4039,6 @@ SUBROUTINE GAMMADP(X,GA) ELSE Z=X ENDIF - DATA G/1.0D0,0.5772156649015329D0, & - & -0.6558780715202538D0, -0.420026350340952D-1, & - & 0.1665386113822915D0,-.421977345555443D-1, & - & -.96219715278770D-2, .72189432466630D-2, & - & -.11651675918591D-2, -.2152416741149D-3, & - & .1280502823882D-3, -.201348547807D-4, & - & -.12504934821D-5, .11330272320D-5, & - & -.2056338417D-6, .61160950D-8, & - & .50020075D-8, -.11812746D-8, & - & .1043427D-9, .77823D-11, & - & -.36968D-11, .51D-12, & - & -.206D-13, -.54D-14, .14D-14, .1D-15/ GR=G(26) DO K=25,1,-1 GR=GR*Z+G(K) @@ -4063,7 +4246,7 @@ subroutine hailmaxd(dtp,nx,ny,nz,an,na,nor,norz,alpha2d,dn, & integer :: plo, phi integer :: ialp, i, j - logical :: debug_mpi = .TRUE. + logical :: debug_mpi = .false. ! ################################################################### @@ -4268,7 +4451,6 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ! real gz(-nor+ng1:nz+nor),z1d(-nor+ng1:nz+nor,4) real dtp real xfall(nx,ny,na) ! array for stuff landing on the ground -! real xfall0(nx,ny) ! dummy array integer infdo integer jslab ! which line of xfall to use @@ -4276,14 +4458,6 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & real tmp, vtmax, dtptmp, dtfrac real, parameter :: dz = 200. -! real :: xvt(nz+1,nx,3,lc:lhab) ! (nx,nz,2,lc:lhab) ! 1=mass-weighted, 2=number-weighted -! real :: tmpn(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) -! real :: tmpn2(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) -! real :: z(-nor+ng1:nx+nor,-norz+ng1:nz+norz,lr:lhab) -! real :: db1(nx,nz+1),dtz1(nz+1,nx,0:1),dz2dinv(nz+1,nx),db1inv(nx,nz+1) - -! real :: rhovtzx(nz,nx) - real, allocatable :: db1(:,:), dtz1(:,:,:),dz2dinv(:,:),db1inv(:,:) ! db1(nx,nz+1),dtz1(nz+1,nx,0:1),dz2dinv(nz+1,nx),db1inv(nx,nz+1) real, allocatable :: rhovtzx(:,:) real, allocatable :: xfall0(:,:), xvt(:,:,:,:),tmpn(:,:,:),tmpn2(:,:,:),z(:,:,:) @@ -4294,33 +4468,6 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & integer :: ngs ! = 512 integer :: ngscnt,mgs,ipconc0 -! real :: qx(ngs,lv:lhab) -! real :: qxw(ngs,ls:lhab) -! real :: cx(ngs,lc:lhab) -! real :: xv(ngs,lc:lhab) -! real :: vtxbar(ngs,lc:lhab,3) -! real :: xmas(ngs,lc:lhab) -! real :: xdn(ngs,lc:lhab) -! real :: xdia(ngs,lc:lhab,3) -! real :: vx(ngs,li:lhab) -! real :: alpha(ngs,lc:lhab) -! real :: zx(ngs,lr:lhab) -! logical :: hasmass(nx,lc+1:lhab) -! -! integer igs(ngs),kgs(ngs) -! -! real rho0(ngs),temcg(ngs) -! -! real temg(ngs) -! -! real rhovt(ngs) -! -! real cwnc(ngs),cinc(ngs) -! real fadvisc(ngs),cwdia(ngs),cipmas(ngs) -! -! real cimasn,cimasx,cnina(ngs),cimas(ngs) -! -! real cnostmp(ngs) real, allocatable :: qx(:,:) real, allocatable :: qxw(:,:) @@ -4359,8 +4506,6 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & integer :: ixe, jye, kze integer :: plo, phi - logical :: debug_mpi = .TRUE. - ! ################################################################### @@ -4558,12 +4703,9 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ENDIF ! (n .ge. 2) - IF ( il >= lr .and. ( infall .eq. 3 .or. infall .eq. 4 ) .and. ln(il) > 0 ) THEN - IF ( (il .eq. lr .and. irfall .eq. infall .and. lzr < 1) .or. & - (il .ge. lh .and. lz(il) .lt. 1 ) .or. (il == ls .and. isfall == infall ) ) THEN + IF ( il >= lr .and. ( linfall(il) .eq. 3 .or. linfall(il) .eq. 4 ) .and. ln(il) > 0 ) THEN call calczgr1d(nx,ny,nz,nor,na,an,ixe,kze, & & z,db1,jgs,ipconc, dnu(il), il, ln(il), qxmin(il), xvmn(il), xvmx(il), lvol(il), xdn0(il), ix ) - ENDIF ENDIF if (ndebug .gt. 0 ) write(0,*) 'dbg = 1b' @@ -4600,34 +4742,25 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & IF ( ipconc .gt. 0 ) THEN !{ IF ( ipconc .ge. ipc(il) ) THEN - IF ( ( infall .ge. 2 .or. (infall .eq. 0 .and. il .lt. lh) ) .and. lz(il) .lt. 1) THEN !{ + IF ( ( linfall(il) .ge. 2 ) .and. lz(il) .lt. 1) THEN !{ ! ! load number conc. into tmpn to do fallout by mass-weighted mean fall speed ! to put a lower bound on number conc. ! - IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. ( (il == ls .and. isfall .eq. infall ) & - & .or. il .eq. lh .or. il .eq. lhl .or. il == lf .or. & - & ( il .eq. lr .and. irfall .eq. infall) ) ) THEN - - ! set up for method I+II + IF ( linfall(il) == 3 .or. linfall(il) == 4 ) THEN + ! set up for method I or I+II DO kz = kzb,kze -! DO ix = ixb,ixe tmpn2(ix,jy,kz) = z(ix,kz,il) -! ENDDO ENDDO DO kz = kzb,kze -! DO ix = ixb,ixe tmpn(ix,jy,kz) = an(ix,jy,kz,ln(il)) -! ENDDO ENDDO ELSE ! set up for method II only DO kz = kzb,kze -! DO ix = ixb,ixe tmpn(ix,jy,kz) = an(ix,jy,kz,ln(il)) -! ENDDO ENDDO ENDIF @@ -4638,17 +4771,14 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & if (ndebug .gt. 0 ) write(0,*) 'dbg = 3f' in = 2 - IF ( infall .eq. 1 ) in = 1 + IF ( linfall(il) .eq. 1 ) in = 1 call fallout1d(nx,ny,nz,nor,na,dtptmp,dtfrac,jgs,xvt(1,1,in,il), & & an,db1,ln(il),0,xfall,dtz1,ix) - IF ( lz(il) .lt. 1 ) THEN ! if not 3-moment, run one of the correction schemes - IF ( (infall .ge. 2 .or. infall .eq. 3) .and. .not. (infall .eq. 0 .and. il .ge. lh) & - & .and. ( il .eq. lr .or. (il .ge. li .and. il .le. lhab) )) THEN -! : .or. il .eq. lhl )) THEN - + IF ( lz(il) .lt. 1 ) THEN ! { if not 3-moment, run one of the correction schemes + IF ( linfall(il) >= 2 ) THEN xfall0(:,jgs) = 0.0 IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. & @@ -4663,42 +4793,37 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & & tmpn,db1,1,0,xfall0,dtz1,ix) ENDIF - IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. ( (il .eq. lr .and. irfall .eq. infall) & - & .or. il .ge. lh .or. (il == ls .and. isfall .eq. infall ) ) ) THEN -! "Method I" - dbz correction - + IF ( linfall(il) == 3 .or. linfall(il) == 4 ) THEN + ! "Method I" - dbz correction + ! Uses input tmpn2 (temp. Z-moment) to determine if new N and q values in an(:,:,:,ln(il)) + ! cause an increase in reflectivity moment. If so, either use N from mass-wgt Vt (tmpn) to replace + ! new N (infall=3; I) or use smaller N from tmpn or calculated from q and temporary Z (infall=4; I+II) + ! Uses 'z' array to check if new reflectivity is greater than pre-sedimentation reflectivity call calcnfromz1d(nx,ny,nz,nor,na,an,tmpn2,ixe,kze, & & z,db1,jgs,ipconc, dnu(il), il, ln(il), qxmin(il), xvmn(il), xvmx(il),tmpn, & & lvol(il), xdn0(il), infall, ix) - ELSEIF ( infall .eq. 5 .and. il .ge. lh .or. ( il == lr .and. irfall == 5 ) ) THEN + ELSEIF ( linfall(il) .eq. 5 .and. il .ge. lh .or. ( il == lr .and. irfall == 5 ) ) THEN DO kz = kzb,kze -! DO ix = ixb,ixe an(ix,jgs,kz,ln(il)) = Max( an(ix,jgs,kz,ln(il)), 0.5* ( an(ix,jgs,kz,ln(il)) + tmpn(ix,jy,kz) )) - -! ENDDO ENDDO ELSEIF ( .not. (il .eq. lr .and. irfall .eq. 0) .and. .not. (il .eq. ls .and. isfall .eq. 0) ) THEN ! "Method II" M-wgt N-fallout correction DO kz = kzb,kze -! DO ix = ixb,ixe - an(ix,jgs,kz,ln(il)) = Max( an(ix,jgs,kz,ln(il)), tmpn(ix,jy,kz) ) - -! ENDDO ENDDO - ENDIF - ENDIF ! lz(il) .lt. 1 + ENDIF !} + ENDIF - ENDIF - ENDIF + ENDIF !} lz(il) .lt. 1 + ENDIF ! ipconc > ipc - ENDIF !} + ENDIF !} (ipconc > 0) ENDDO ! n=1,ndfall @@ -4784,8 +4909,6 @@ subroutine fallout1d(nx,ny,nz,nor,na,dtp,dtfrac,jgs,vt, & integer :: ixb, jyb, kzb integer :: ixe, jye, kze - logical :: debug_mpi = .TRUE. - ! ################################################################### jy = 1 @@ -5205,7 +5328,7 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & integer ix,jy,kz double precision vr,q,nrx,nrx2,rd,g1h,g1hl,g1r,g1s,zx,z,znew,zt,zxt,n1,laminv1 double precision :: zr, zs, zh, dninv - real, parameter :: xn0s = 3.0e6, xn0r = 8.0e6, xn0h = 2.0e5, xn0hl = 4.0e4 + real, parameter :: xn0s = 3.0e8, xn0r = 8.0e6, xn0h = 2.0e5, xn0hl = 4.0e4 real, parameter :: xdnr = 1000., xdns = 100. ,xdnh = 700.0, xdnhl = 900.0 real, parameter :: zhlfac = 1./(pi*xdnhl*xn0hl) real, parameter :: zhfac = 1./(pi*xdnh*xn0h) @@ -5813,6 +5936,9 @@ SUBROUTINE calc_eff_radius & double precision :: numh, numhl,denomh,denomhl logical :: flag_t4, flag_t5, flag_t6 + + real, parameter :: qmin = 1.e-8 + real, parameter :: volmin = 1.e-30 ! ------------------------------------------------------------------------------- @@ -5927,7 +6053,7 @@ SUBROUTINE calc_eff_radius & ENDIF IF ( present( t4 ) .and.( ( present(qrw) .and. present(crw) ) .or. flag_t4 ) ) THEN - IF ( qx(mgs,lr) > Max(1.e-8,qxmin(lr)) .and. cx(mgs,lr) > cxmin ) THEN + IF ( qx(mgs,lr) > Max(qmin,qxmin(lr)) .and. cx(mgs,lr) > cxmin ) THEN IF ( imurain == 1 ) THEN ! gamma-diameter ! Lambda for rain lam_r = factor_r *((xdn0(lr)*cx(mgs,lr))/(qx(mgs,lr)*rho0(mgs)))**(1./3.) @@ -5946,11 +6072,11 @@ SUBROUTINE calc_eff_radius & IF ( lhl < 1 .or. flag_t6 ) THEN ! graupel only - IF ( qx(mgs,lh) > Max(1.e-8,qxmin(lh)) ) THEN + IF ( qx(mgs,lh) > Max(qmin,qxmin(lh)) ) THEN ! Lambda for graupel hwdn = xdn0(lh) IF ( lvh > 1 ) THEN ! variable density - IF ( an(ix,jy,kz,lvh) > 1.e-30 ) THEN + IF ( an(ix,jy,kz,lvh) > volmin ) THEN hwdn = rho0(mgs)*qx(mgs,lh)/an(ix,jy,kz,lvh) ENDIF ENDIF @@ -5961,11 +6087,11 @@ SUBROUTINE calc_eff_radius & ELSE ! have hail, too, but do not have t6 array - IF ( qx(mgs,lh) > Max(1.e-8,qxmin(lh)) .and. qx(mgs,lhl) < Max(1.e-8,qxmin(lhl)) ) THEN + IF ( qx(mgs,lh) > Max(qmin,qxmin(lh)) .and. qx(mgs,lhl) < Max(qmin,qxmin(lhl)) ) THEN ! Lambda for graupel hwdn = xdn0(lh) IF ( lvh > 1 ) THEN ! variable density - IF ( an(ix,jy,kz,lvh) > 1.e-30 ) THEN + IF ( an(ix,jy,kz,lvh) > volmin ) THEN hwdn = rho0(mgs)*qx(mgs,lh)/an(ix,jy,kz,lvh) ENDIF ENDIF @@ -5973,11 +6099,11 @@ SUBROUTINE calc_eff_radius & lam_h = factor_h *((hwdn*cx(mgs,lh))/(qx(mgs,lh)*rho0(mgs)))**(1./3.) t5(ix,jy,kz) = 0.5*(alphah+3.)/lam_h - ELSEIF ( qx(mgs,lh) < Max(1.e-8,qxmin(lh)) .and. qx(mgs,lhl) > Max(1.e-8,qxmin(lhl)) ) THEN + ELSEIF ( qx(mgs,lh) < Max(qmin,qxmin(lh)) .and. qx(mgs,lhl) > Max(qmin,qxmin(lhl)) ) THEN ! Lambda for hail hldn = xdn0(lhl) IF ( lvhl > 1 ) THEN ! variable density - IF ( an(ix,jy,kz,lvhl) > 1.e-30 ) THEN + IF ( an(ix,jy,kz,lvhl) > volmin ) THEN hldn = rho0(mgs)*qx(mgs,lhl)/an(ix,jy,kz,lvhl) ENDIF ENDIF @@ -5985,19 +6111,19 @@ SUBROUTINE calc_eff_radius & lam_hl = factor_hl *((hldn*cx(mgs,lhl))/(qx(mgs,lhl)*rho0(mgs)))**(1./3.) t5(ix,jy,kz) = 0.5*(alphahl+3.)/lam_hl - ELSEIF ( qx(mgs,lh) > Max(1.e-8,qxmin(lh)) .and. qx(mgs,lhl) > Max(1.e-8,qxmin(lhl)) ) THEN + ELSEIF ( qx(mgs,lh) > Max(qmin,qxmin(lh)) .and. qx(mgs,lhl) > Max(qmin,qxmin(lhl)) ) THEN ! r_eff graupel and hail combined hldn = xdn0(lhl) IF ( lvhl > 1 ) THEN ! variable density - IF ( an(ix,jy,kz,lvhl) > 1.e-30 ) THEN + IF ( an(ix,jy,kz,lvhl) > volmin ) THEN hldn = rho0(mgs)*qx(mgs,lhl)/an(ix,jy,kz,lvhl) ENDIF ENDIF hwdn = xdn0(lh) IF ( lvh > 1 ) THEN ! variable density - IF ( an(ix,jy,kz,lvh) > 1.e-30 ) THEN + IF ( an(ix,jy,kz,lvh) > volmin ) THEN hwdn = rho0(mgs)*qx(mgs,lh)/an(ix,jy,kz,lvh) ENDIF ENDIF @@ -6022,11 +6148,11 @@ SUBROUTINE calc_eff_radius & IF ( present(t6) .and. flag_t6 .and. lhl > 1 ) THEN - IF ( qx(mgs,lhl) > Max(1.e-8,qxmin(lhl)) ) THEN + IF ( qx(mgs,lhl) > Max(qmin,qxmin(lhl)) ) THEN ! Lambda for hail hldn = xdn0(lhl) IF ( lvhl > 1 ) THEN ! variable density - IF ( an(ix,jy,kz,lvhl) > 1.e-30 ) THEN + IF ( an(ix,jy,kz,lvhl) > volmin ) THEN hldn = rho0(mgs)*qx(mgs,lhl)/an(ix,jy,kz,lvhl) ENDIF ENDIF @@ -6083,7 +6209,7 @@ SUBROUTINE QVEXCESS(ngs,mgs,qwvp0,qv0,qcw1,pres,thetap0,theta0, & integer itertd integer ltemq - real gamss + real gamss, tmp real theta(ngs), qvap(ngs), pqs(ngs), qcw(ngs), qwv(ngs) real qcwtmp(ngs), qss(ngs), qvs(ngs), qwvp(ngs) real dqcw(ngs), dqwv(ngs), dqvcnd(ngs) @@ -6124,7 +6250,13 @@ SUBROUTINE QVEXCESS(ngs,mgs,qwvp0,qv0,qcw1,pres,thetap0,theta0, & ltemq = (temg(mgs)-163.15)/fqsat+1.5 ltemq = Min( nqsat, Max(1,ltemq) ) - qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + IF ( iqvsopt == 0 ) THEN + pqs(mgs) = (380.0)/(pres(mgs)) + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + ELSEIF ( iqvsopt == 1 ) THEN + qvs(mgs) = rdorv*esbolton*tabqvs(ltemq)/(pres(mgs) - esbolton*tabqvs(ltemq)) + ENDIF + qss(mgs) = (0.01*ss1 + 1.0)*qvs(mgs) ! ! iterate adjustment @@ -6184,7 +6316,11 @@ SUBROUTINE QVEXCESS(ngs,mgs,qwvp0,qv0,qcw1,pres,thetap0,theta0, & ! tqvcon = temg(mgs)-cbw ltemq = (temg(mgs)-163.15)/fqsat+1.5 ltemq = Min( nqsat, Max(1,ltemq) ) - qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + IF ( iqvsopt == 0 ) THEN + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + ELSEIF ( iqvsopt == 1 ) THEN + qvs(mgs) = rdorv*esbolton*tabqvs(ltemq)/(pres(mgs) - esbolton*tabqvs(ltemq)) + ENDIF qcw(mgs) = max( 0.0, qcw(mgs) ) qwv(mgs) = max( 0.0, qvap(mgs)) qss(mgs) = (0.01*ss1 + 1.0)*qvs(mgs) @@ -6210,9 +6346,9 @@ END SUBROUTINE QVEXCESS ! SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & & xmas,vtxbar,xdn,xvmn0,xvmx0,xv,cdx,cdxgs, & - & ipconc1,ndebug1,ngs,nz,kgs,fadvisc, & + & ipconc1,ndebug1,ngs,nz,igs,kgs,fadvisc, & & cwmasn,cwmasx,cwradn,cnina,cimna,cimxa, & - & itype1a,itype2a,temcg,infdo,alpha,ildo,axx,bxx) + & itype1a,itype2a,temcg,infdo,alpha,axx,bxx,ildo) ! & itype1a,itype2a,temcg,infdo,alpha,ildo,axh,bxh,axhl,bxhl) @@ -6241,7 +6377,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & real cwc1, cimna, cimxa real cnina(ngs) - integer kgs(ngs) + integer igs(ngs),kgs(ngs) real fadvisc(ngs) real fsw @@ -7475,8 +7611,8 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & & (aax*(xdia(mgs,il,1) )**bbx * & & x)/y ! & Gamma(7.0 + alpha(mgs,il) + bbx)/Gamma(7. + alpha(mgs,il)) - IF ( .not. (vtxbar(mgs,il,1) > -1. .and. vtxbar(mgs,il,1) < 200. ) .or. & - .not. (vtxbar(mgs,il,3) > -1. .and. vtxbar(mgs,il,3) < 200. ) ) THEN + IF ( .not. (vtxbar(mgs,il,1) > -1. .and. vtxbar(mgs,il,1) < 250. ) .or. & + .not. (vtxbar(mgs,il,3) > -1. .and. vtxbar(mgs,il,3) < 250. ) ) THEN write(0,*) 'Setvtz: problem with vtxbar1/3: ',il,vtxbar(mgs,il,1),vtxbar(mgs,il,3),aax,bbx,x,y write(0,*) 'q, number, diam1,3(mm) = ', qx(mgs,il),cx(mgs,il),1000.*xdia(mgs,il,1),1000.*xdia(mgs,il,3) ! call commasmpi_abort() @@ -7712,7 +7848,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & logical ldoliq - real chw, qr, z, rd, alp, z1, g1, vr, nrx, tmp + real chw, qr, z, rd, alp, z1, g1, vr, nrx, tmp, tmpc, tmpz real vtmax real xvbarmax @@ -7735,7 +7871,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & logical :: debug_mpi = .false. - if (ndebugzf .gt. 0 ) write(0,*) "ZIEGFALL: ENTERED SUBROUTINE" + if (ndebugzf .gt. 0 ) write(0,*) "ZIEGFALL1D: ENTERED SUBROUTINE" ! ##################################################################### ! BEGIN EXECUTABLE @@ -7804,13 +7940,12 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & ngscnt = 0 - do kz = nzmpb,nz + do kz = 1,nz do ix = ixcol,ixcol flag = .false. - DO il = l1,l2 - flag = flag .or. ( an(ix,jy,kz,il) .gt. qxmin(il) ) + flag = flag .or. ( an(ix,jy,kz,il) > 0.0 ) ENDDO if ( flag ) then @@ -7819,7 +7954,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & ngscnt = ngscnt + 1 igs(ngscnt) = ix kgs(ngscnt) = kz - if ( ngscnt .eq. ngs ) goto 1100 + if ( ngscnt .eq. nz ) goto 1100 end if end do !!ix nxmpb = 1 @@ -7845,11 +7980,11 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & temg(mgs) = t0(igs(mgs),jy,kgs(mgs)) temcg(mgs) = temg(mgs) - tfr - + ! end do ! -! only need fadvisc for +! only need fadvisc for droplets IF ( lc .gt. 1 .and. (ildo == 0 .or. ildo == lc ) ) then do mgs = 1,ngscnt fadvisc(mgs) = advisc0*(416.16/(temg(mgs)+120.0))* & @@ -7898,58 +8033,52 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & cx(mgs,li) = Max(an(igs(mgs),jy,kgs(mgs),lni), 0.0) end do end if + if ( ipconc .ge. 2 .and. lc .gt. 1 .and. (ildo == 0 .or. ildo == lc ) ) then do mgs = 1,ngscnt cx(mgs,lc) = Max(an(igs(mgs),jy,kgs(mgs),lnc), 0.0) -! cx(mgs,lc) = Min( ccwmx, cx(mgs,lc) ) end do end if + if ( ipconc .ge. 3 .and. lr .gt. 1 .and. (ildo == 0 .or. ildo == lr ) ) then do mgs = 1,ngscnt cx(mgs,lr) = Max(an(igs(mgs),jy,kgs(mgs),lnr), 0.0) -! IF ( qx(mgs,lr) .le. qxmin(lr) ) THEN -! ELSE -! cx(mgs,lr) = Max( 0.0, cx(mgs,lr) ) -! ENDIF end do end if + if ( ipconc .ge. 4 .and. ls .gt. 1 .and. (ildo == 0 .or. ildo == ls ) ) then do mgs = 1,ngscnt cx(mgs,ls) = Max(an(igs(mgs),jy,kgs(mgs),lns), 0.0) -! IF ( qx(mgs,ls) .le. qxmin(ls) ) THEN -! ELSE -! cx(mgs,ls) = Max( 0.0, cx(mgs,ls) ) -! ENDIF end do end if if ( ipconc .ge. 5 .and. lh .gt. 1 .and. (ildo == 0 .or. ildo == lh ) ) then do mgs = 1,ngscnt - cx(mgs,lh) = Max(an(igs(mgs),jy,kgs(mgs),lnh), 0.0) -! IF ( qx(mgs,lh) .le. qxmin(lh) ) THEN -! ELSE -! cx(mgs,lh) = Max( 0.0, cx(mgs,lh) ) -! ENDIF - end do ENDIF if ( ipconc .ge. 5 .and. lhl .gt. 1 .and. (ildo == 0 .or. ildo == lhl ) ) then do mgs = 1,ngscnt - cx(mgs,lhl) = Max(an(igs(mgs),jy,kgs(mgs),lnhl), 0.0) -! IF ( qx(mgs,lhl) .le. qxmin(lhl) ) THEN -! cx(mgs,lhl) = 0.0 -! ELSEIF ( cx(mgs,lhl) .eq. 0.0 .and. qx(mgs,lhl) .lt. 3.0*qxmin(lhl) ) THEN -! qx(mgs,lhl) = 0.0 -! ELSE -! cx(mgs,lhl) = Max( 0.0, cx(mgs,lhl) ) -! ENDIF - end do end if - + + ! Vaporize tiny values + DO il = l1,l2 + IF ( lz(il) < 1 .and. ln(il) > 1 ) THEN + do mgs = 1,ngscnt + IF ( cx(mgs,il) <= cxmin .or. qx(mgs,il) < qxmin(il) ) THEN + cx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + ENDIF + end do + ENDIF + ENDDO + do mgs = 1,ngscnt xdn(mgs,lc) = xdn0(lc) xdn(mgs,lr) = xdn0(lr) @@ -8377,7 +8506,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & ! check for artificial breakup (graupel/hail larger than allowed max size) - IF ( imaxdiaopt == 1 ) THEN + IF ( imaxdiaopt == 1 .or. il /= lr ) THEN xvbarmax = xvmx(il) ELSEIF ( imaxdiaopt == 2 ) THEN ! test against maximum mass diameter xvbarmax = xvmx(il) /((3. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il)))) @@ -8393,7 +8522,16 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & IF ( tmp < cx(mgs,il) ) THEN ! breakup g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2) - zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) ) + ! check if incoming zx is consistent + ! Z from incoming cx, qx, and alpha + tmpz = g1/(pi/6.*xdn(mgs,il))**2 * ((rho0(mgs)*qx(mgs,il))**2)/tmp + IF ( tmpz > zx(mgs,il) ) THEN + ! find cx that gives zx + tmpc = g1/(pi/6.*xdn(mgs,il))**2 * ((rho0(mgs)*qx(mgs,il))**2)/zx(mgs,il) + cx(mgs,il) = Max(cx(mgs,il), tmpc) + ENDIF + zx(mgs,il) = g1/(pi/6.*xdn(mgs,il))**2 * ((rho0(mgs)*qx(mgs,il))**2)/cx(mgs,il) +! zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) ) an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) chw = cx(mgs,il) @@ -8467,9 +8605,9 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & call setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & & xmas,vtxbar,xdn,xvmn,xvmx,xv,cdx,cdxgs, & - & ipconc,ndebugzf,ngs,nz,kgs,fadvisc, & + & ipconc,ndebugzf,ngs,nz,igs,kgs,fadvisc, & & cwmasn,cwmasx,cwradn,cnina,cimn,cimx, & - & itype1,itype2,temcg,infdo,alpha,ildo,axx,bxx) + & itype1,itype2,temcg,infdo,alpha,axx,bxx,ildo) ! & itype1,itype2,temcg,infdo,alpha,ildo,axh,bxh,axhl,bxhl) @@ -8673,12 +8811,12 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & real dtmp (nx,nz) real tmp - real*8 dtmps, dtmpr, dtmph, dtmphl, g1, zx, ze, x + double precision :: dtmps, dtmpr, dtmph, dtmphl, g1, zx, ze, x integer i,j,k,ix,jy,kz,ihcnt - real*8 xcnoh, xcnos, dadh, dads, zhdryc, zsdryc, zhwetc,zswetc - real*8 dadr + double precision :: xcnoh, xcnos, dadh, dads, zhdryc, zsdryc, zhwetc,zswetc + double precision :: dadr real dbzmax,dbzmin parameter ( dbzmin = 0 ) @@ -9700,7 +9838,7 @@ SUBROUTINE NUCOND & ! - real ccnc(ngs), ccna(ngs), cnuc(ngs), cwnccn(ngs) + real ccnc(ngs), ccna(ngs), cnuc(ngs), cwnccn(ngs), ccnaco(ngs), ccnanu(ngs) real :: ccnc_nu(ngs), ccnc_ac(ngs), ccnc_co(ngs) real ccncuf(ngs) real sscb ! 'cloud base' SS threshold @@ -9724,7 +9862,7 @@ SUBROUTINE NUCOND & real volb, t2s real, parameter :: aa1 = 9.44e15, aa2 = 5.78e3 ! a1 in Ziegler - real ec0, ex1, ft, rhoinv(ngs) + real rhoinv(ngs) real chw, g1, rd1 @@ -9750,6 +9888,7 @@ SUBROUTINE NUCOND & real dcrit real cn(ngs), cnuf(ngs) real :: ccwmax + integer ltemq @@ -9828,16 +9967,35 @@ SUBROUTINE NUCOND & integer, parameter :: iunit = 0 - real :: frac, hwdn, tmpg + real :: frac, hwdn, tmpg, xdia1, xdia3, cwch,xvol real :: cvm,cpm,rmm real, parameter :: cpv = 1885.0 ! specific heat of water vapor at constant pressure - + real, parameter :: Mair = 0.0284 ! MOLECULAR WEIGHT OF 'AIR' (KG/MOL) + + integer :: kstag integer :: count +! Addtion T.Iguchi Y2021 Update + real, parameter :: mwwater = 0.01801528 ! Molecular weight of water (kg/mol) + real, parameter :: rhowater = 997.0 ! Density of liquid water (kg/m3) + real, parameter :: gasconst = 8.3144598 ! Gas constant (m2 kg s-2 K-1 mol-1) + real :: sswater ! unit change supersaturation from percentage to n/a + real :: sigvl, aact + + real :: alpha_ar, gamma_ar, G_ar, evs, zeta, smax + real :: f_ac, g_ac, eta_ac + real :: f_nu, g_nu, eta_nu + real :: f_co, g_co, eta_co + + real :: sm_nu, sm_ac, sm_co, ss_ac, ss_nu, ss_co + real :: uu_nu, uu_ac, uu_co + + real :: cn_ac, cn_co, cn_nu + ! ------------------------------------------------------------------------------- itile = nxi jtile = ny @@ -9877,7 +10035,12 @@ SUBROUTINE NUCOND & ltemq = Int( (temp1-163.15)/fqsat+1.5 ) ltemq = Min( nqsat, Max(1,ltemq) ) - c1 = t00(ix,jy,kz)*tabqvs(ltemq) +! c1 = t00(ix,jy,kz)*tabqvs(ltemq) + IF ( iqvsopt == 0 ) THEN + c1 = t00(ix,jy,kz)*tabqvs(ltemq) + ELSEIF ( iqvsopt == 1 ) THEN + c1 = rdorv*esbolton*tabqvs(ltemq)/(pn(ix,jy,kz) + pb(kz) - esbolton*tabqvs(ltemq)) + ENDIF IF ( c1 > 0. ) THEN ssfilt(ix,jy,kz) = 100.*(an(ix,jy,kz,lv)/c1 - 1.0) ! from "new" values @@ -9919,6 +10082,7 @@ SUBROUTINE NUCOND & do kz = kzb,kze do ix = nxmpb,nxi + pres(1) = pn(ix,jy,kz) + pb(kz) pqs(1) = 380.0/(pn(ix,jy,kz) + pb(kz)) theta(1) = an(ix,jy,kz,lt) temg(1) = t0(ix,jy,kz) @@ -9926,7 +10090,12 @@ SUBROUTINE NUCOND & temcg(1) = temg(1) - tfr ltemq = (temg(1)-163.15)/fqsat+1.5 ltemq = Min( nqsat, Max(1,ltemq) ) - qvs(1) = pqs(1)*tabqvs(ltemq) + ! qvs(1) = pqs(1)*tabqvs(ltemq) + IF ( iqvsopt == 0 ) THEN + qvs(1) = pqs(1)*tabqvs(ltemq) + ELSEIF ( iqvsopt == 1 ) THEN + qvs(1) = rdorv*esbolton*tabqvs(ltemq)/(pres(1) - esbolton*tabqvs(ltemq)) + ENDIF qis(1) = pqs(1)*tabqis(ltemq) qss(1) = qvs(1) @@ -10005,11 +10174,21 @@ SUBROUTINE NUCOND & pqs(mgs) = (380.0)/(pres(mgs)) ltemq = (temg(mgs)-163.15)/fqsat+1.5 ltemq = Min( nqsat, Max(1,ltemq) ) - qvs(mgs) = pqs(mgs)*tabqvs(ltemq) +! qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + IF ( iqvsopt == 0 ) THEN + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + ELSEIF ( iqvsopt == 1 ) THEN + qvs(mgs) = rdorv*esbolton*tabqvs(ltemq)/(pres(mgs) - esbolton*tabqvs(ltemq)) + ENDIF qis(mgs) = pqs(mgs)*tabqis(ltemq) ! qvap(mgs) = max( (qwvp(mgs) + qv0(mgs)), 0.0 ) - es(mgs) = 6.1078e2*tabqvs(ltemq) + IF ( iqvsopt == 0 ) THEN + es(mgs) = 6.1078e2*tabqvs(ltemq) + ELSEIF ( iqvsopt == 1 ) THEN + es(mgs) = esbolton*tabqvs(ltemq) + ENDIF +! es(mgs) = 6.1078e2*tabqvs(ltemq) qss(mgs) = qvs(mgs) @@ -10082,7 +10261,37 @@ SUBROUTINE NUCOND & ccnc(mgs) = an(igs(mgs),jy,kgs(mgs),lccn) + an(igs(mgs),jy,kgs(mgs),lccnuf) ELSE ccnc(mgs) = an(igs(mgs),jy,kgs(mgs),lccn) + IF ( lccna > 1 ) THEN + cnuc(mgs) = ccnc(mgs) + ENDIF + ENDIF + IF ( lcn_nu > 1 ) THEN + ccnc_nu(mgs) = an(igs(mgs),jy,kgs(mgs),lcn_nu) + ENDIF + IF ( lcn_co > 1 ) THEN + ccnc_co(mgs) = an(igs(mgs),jy,kgs(mgs),lcn_co) + ENDIF + IF ( lccnaco > 1 ) THEN + ccnaco(mgs) = an(igs(mgs),jy,kgs(mgs),lccnaco) + ELSE + ccnaco(mgs) = 0.0 + ENDIF + IF ( lccnanu > 1 ) THEN + ccnanu(mgs) = an(igs(mgs),jy,kgs(mgs),lccnanu) + ELSE + ccnanu(mgs) = 0.0 ENDIF + ELSEIF ( lccn > 1 .and. ( ac_opt == 1 .or. ac_opt == 11 ) ) THEN + ccnc(mgs) = an(igs(mgs),jy,kgs(mgs),lccn) + ! ccnc(mgs) = ccnc_ac(mgs) + cnuc(mgs) = ccnc(mgs) + cwnccn(mgs) = cnuc(mgs) + ! write(0,*) 'ccnc_ac,mgs = ', ccnc_ac(mgs),mgs,igs(mgs),jy,kgs(mgs) + ELSEIF ( lccn > 1 .and. ( ac_opt == 2 .or. ac_opt == 22 ) ) THEN + ccnc_nu(mgs) = an(igs(mgs),jy,kgs(mgs),lcn_nu) + ccnc(mgs) = an(igs(mgs),jy,kgs(mgs),lccn) + ! ccnc(mgs) = ccnc_ac(mgs) + ccnc_co(mgs) = an(igs(mgs),jy,kgs(mgs),lcn_co) ELSE ccnc(mgs) = cwnccn(mgs) ENDIF @@ -10094,9 +10303,21 @@ SUBROUTINE NUCOND & cnuf(mgs) = 0.0 IF ( lccna > 1 ) THEN ccna(mgs) = an(igs(mgs),jy,kgs(mgs),lccna) ! predicted count of activated ccn + IF ( ac_opt == 22 ) THEN + IF ( lccnaco > 1 ) THEN + ccnaco(mgs) = an(igs(mgs),jy,kgs(mgs),lccnaco) + ELSE + ccnaco(mgs) = 0.0 + ENDIF + IF ( lccnanu > 1 ) THEN + ccnanu(mgs) = an(igs(mgs),jy,kgs(mgs),lccnanu) + ELSE + ccnanu(mgs) = 0.0 + ENDIF + ENDIF ELSE IF ( lccn > 1 ) THEN - ccna(mgs) = cwnccn(mgs) - ccnc(mgs) ! diagnose activated ccn as background value - remaining unactivated ccn + ccna(mgs) = 0.0 ! WRF driver interface already has ccw subtracted from ccnc ELSE ccna(mgs) = cx(mgs,lc) ! approximation of number of activated ccn ENDIF @@ -10113,9 +10334,13 @@ SUBROUTINE NUCOND & DO mgs = 1,ngscnt ! default value of renucfrac is 0.0 IF ( irenuc /= 6 ) THEN - cnuc(mgs) = Max(ccnc(mgs),cwnccn(mgs))*(1. - renucfrac) + ccnc(mgs)*renucfrac + IF ( irenuc == 2 ) THEN + cnuc(mgs) = Max(ccnc(mgs),cwnccn(mgs))*(1. - renucfrac) + ccnc(mgs)*renucfrac + ELSE + cnuc(mgs) = ccnc(mgs)*(1. - renucfrac) + ccnc(mgs)*renucfrac + ENDIF ELSE - cnuc(mgs) = Max(ccnc(mgs),cwnccn(mgs))*(1. - renucfrac) + Max(0.0,ccnc(mgs) - ccna(mgs))*renucfrac + cnuc(mgs) = ccnc(mgs)*(1. - renucfrac) + Max(0.0,ccnc(mgs) - ccna(mgs))*renucfrac ENDIF IF ( renucfrac >= 0.999 ) THEN IF ( temg(mgs) < 265. ) THEN @@ -10526,16 +10751,27 @@ SUBROUTINE NUCOND & QEVAP= Min( qx(mgs,lc), R1*(qss(mgs)-qvap(mgs)) ) - IF ( qx(mgs,lc) <= QEVAP ) THEN ! GO TO 63 + IF ( qx(mgs,lc) <= QEVAP ) THEN !{ GO TO 63 qwvp(mgs) = qwvp(mgs) + qx(mgs,lc) thetap(mgs) = thetap(mgs) - felvcp(mgs)*qx(mgs,lc)/(pi0(mgs)) IF ( io_flag .and. nxtra > 1 ) THEN axtra(igs(mgs),jy,kgs(mgs),1) = -qx(mgs,lc)/dtp ENDIF qx(mgs,lc) = 0. - IF ( restoreccn ) THEN + IF ( restoreccn ) THEN !{ IF ( lccna > 1 ) THEN - ccna(mgs) = ccna(mgs) - restoreccnfrac*cx(mgs,lc) + tmp = restoreccnfrac*cx(mgs,lc) + IF ( lccnaco > 1 .and. lccnanu > 1 ) THEN + ! restore CCN proportionally to each type, although coarse are presumably already lost to rain + tmp2 = ccna(mgs) + ccnaco(mgs) + ccnanu(mgs) + IF ( tmp2 > 0.0 ) THEN + ccna(mgs) = ccna(mgs) - tmp*ccna(mgs)/tmp2 + ccnaco(mgs) = ccnaco(mgs) - tmp*ccnaco(mgs)/tmp2 + ccnanu(mgs) = ccnanu(mgs) - tmp*ccnanu(mgs)/tmp2 + ENDIF + ELSE + ccna(mgs) = ccna(mgs) - tmp + ENDIF ELSEIF ( irenuc <= 2 ) THEN IF ( .not. invertccn ) THEN ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + restoreccnfrac*cx(mgs,lc) ) ) @@ -10543,16 +10779,27 @@ SUBROUTINE NUCOND & ccnc(mgs) = ccnc(mgs) + restoreccnfrac*cx(mgs,lc) ENDIF ENDIF - ENDIF + ENDIF !} cx(mgs,lc) = 0. - ELSE + ELSE !} { qctmp = qx(mgs,lc) qwvp(mgs) = qwvp(mgs) + QEVAP qx(mgs,lc) = qx(mgs,lc) - QEVAP IF ( qx(mgs,lc) .le. 0. ) THEN IF ( restoreccn ) THEN IF ( lccna > 1 ) THEN - ccna(mgs) = ccna(mgs) - restoreccnfrac*cx(mgs,lc) + tmp = restoreccnfrac*cx(mgs,lc) + IF ( lccnaco > 1 .and. lccnanu > 1 ) THEN + ! restore CCN proportionally to each type, although coarse are presumably already lost to rain + tmp2 = ccna(mgs) + ccnaco(mgs) + ccnanu(mgs) + IF ( tmp2 > 0.0 ) THEN + ccna(mgs) = ccna(mgs) - tmp*ccna(mgs)/tmp2 + ccnaco(mgs) = ccnaco(mgs) - tmp*ccnaco(mgs)/tmp2 + ccnanu(mgs) = ccnanu(mgs) - tmp*ccnanu(mgs)/tmp2 + ENDIF + ELSE + ccna(mgs) = ccna(mgs) - tmp + ENDIF ELSEIF ( irenuc <= 2 ) THEN ! ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + cx(mgs,lc) ) ) ! ccnc(mgs) = ccnc(mgs) + cx(mgs,lc) @@ -10568,7 +10815,19 @@ SUBROUTINE NUCOND & tmp = 0.9*QEVAP*cx(mgs,lc)/qctmp ! let droplets get smaller but also remove some. A factor of 1.0 would maintain same size IF ( restoreccn ) THEN IF ( lccna > 1 ) THEN - ccna(mgs) = ccna(mgs) - restoreccnfrac*tmp + tmp = restoreccnfrac*tmp + IF ( lccnaco > 1 .and. lccnanu > 1 ) THEN + ! restore CCN proportionally to each type, although coarse are presumably already lost to rain + tmp2 = ccna(mgs) + ccnaco(mgs) + ccnanu(mgs) + IF ( tmp2 > 0.0 ) THEN + ccna(mgs) = ccna(mgs) - tmp*ccna(mgs)/tmp2 + ccnaco(mgs) = ccnaco(mgs) - tmp*ccnaco(mgs)/tmp2 + ccnanu(mgs) = ccnanu(mgs) - tmp*ccnanu(mgs)/tmp2 + ENDIF + ELSE + ccna(mgs) = ccna(mgs) - tmp + ENDIF + ! ccna(mgs) = ccna(mgs) - restoreccnfrac*tmp ELSEIF ( irenuc <= 2 ) THEN ! ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + tmp ) ) ! ccnc(mgs) = ccnc(mgs) + tmp @@ -10586,7 +10845,7 @@ SUBROUTINE NUCOND & axtra(igs(mgs),jy,kgs(mgs),1) = -QEVAP/dtp ENDIF - ENDIF + ENDIF !} GO TO 631 @@ -10710,7 +10969,11 @@ SUBROUTINE NUCOND & ltemq = Min( nqsat, Max(1,ltemq) ) ltemq1 = ltemq temp1 = temg(mgs) - p380 = 380.0/pres(mgs) + IF ( iqvsopt == 0 ) THEN + p380 = 380.0/pres(mgs) + ELSE + p380 = esbolton*rdorv/(pres(mgs) - es(mgs)) + ENDIF ! taus = Max( 0.05*dtp, Min(taus, 0.25*dtp ) ) ! nc = NInt(dtp/Min(1.0,0.5*taus)) @@ -10880,7 +11143,11 @@ SUBROUTINE NUCOND & temg(mgs) = theta(mgs)*f1 ltemq = (temg(mgs)-163.15)/fqsat+1.5 ltemq = Min( nqsat, Max(1,ltemq) ) - qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + IF ( iqvsopt == 0 ) THEN + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + ELSEIF ( iqvsopt == 1 ) THEN + qvs(mgs) = rdorv*esbolton*tabqvs(ltemq)/(pres(mgs) - esbolton*tabqvs(ltemq)) + ENDIF ! es(mgs) = 6.1078e2*tabqvs(ltemq) ! @@ -10918,7 +11185,7 @@ SUBROUTINE NUCOND & ! IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 20.0 ) THEN ! test -- fails ! IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 20.0 .and. ccnc(mgs) > 0.1*cwnccn(mgs)) THEN ! test -- is OK IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 20.0 .and. & - ( ccnc(mgs) > 0.05*cwnccn(mgs) .or. ( ac_opt > 0 .and. ccnc_ac(mgs) - cx(mgs,lc) > 0.0 ) ) ) THEN ! test + ( ccnc(mgs) > 0.05*cwnccn(mgs) .or. ( ac_opt > 0 .and. ccnc(mgs) - cx(mgs,lc) > 0.0 ) ) ) THEN ! test ! IF ( ssf(mgs) > ssmx ) THEN ! original condition CALL QVEXCESS(ngs,mgs,qwvp,qv0,qx(1,lc),pres,thetap,theta0,dcloud, & & pi0,tabqvs,nqsat,fqsat,cbw,fcqv1,felvcp,ssmx,pk,ngscnt) @@ -10941,7 +11208,12 @@ SUBROUTINE NUCOND & ! temg(mgs) = theta2temp( theta(mgs), pres(mgs) ) ltemq = (temg(mgs)-163.15)/fqsat+1.5 ltemq = Min( nqsat, Max(1,ltemq) ) - qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + ! qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + IF ( iqvsopt == 0 ) THEN + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + ELSEIF ( iqvsopt == 1 ) THEN + qvs(mgs) = rdorv*esbolton*tabqvs(ltemq)/(pres(mgs) - esbolton*tabqvs(ltemq)) + ENDIF ! es(mgs) = 6.1078e2*tabqvs(ltemq) !.... S. TWOMEY (1959) @@ -10954,11 +11226,11 @@ SUBROUTINE NUCOND & IF ( .not. flag_qndrop ) THEN ! { do not calculate number of droplets if using wrf-chem - IF ( ac_opt == 0 ) THEN + ! IF ( ac_opt == 0 ) THEN cnuctmp = cnuc(mgs) - ELSE - cnuctmp = ccnc_ac(mgs) - ENDIF + ! ELSE + ! cnuctmp = ccnc(mgs) + ! ENDIF ! IF ( ssmax(mgs) .lt. sscb .and. qx(mgs,lc) .gt. qxmin(lc)) THEN IF ( dcloud .gt. qxmin(lc) .and. wvel(mgs) > 0.0) THEN @@ -10991,11 +11263,11 @@ SUBROUTINE NUCOND & ! ccnc(mgs) = 0.0 ENDIF ELSE - cn(mgs) = Min( cn(mgs), ccnc_ac(mgs) ) + cn(mgs) = Min( cn(mgs), ccnc(mgs) ) ENDIF ! cx(mgs,lc) = cx(mgs,lc) + cn(mgs) - IF ( irenuc <= 2 .and. lccna < 1 ) ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) - ccna(mgs) = ccna(mgs) + cn(mgs) + IF ( irenuc <= 2 .and. lccna < 1 ) ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + ccna(mgs) = ccna(mgs) + cn(mgs) ENDIF ! write(91,*) 'nuc1: cn, ix, kz = ',cn(mgs),igs(mgs),kgs(mgs),wvel(mgs),cnexp,ccnc(mgs) @@ -11289,7 +11561,11 @@ SUBROUTINE NUCOND & ltemq = Int( (temp1-163.15)/fqsat+1.5 ) ltemq = Min( nqsat, Max(1,ltemq) ) - c1= pqs(mgs)*tabqvs(ltemq) + IF ( iqvsopt == 0 ) THEN + c1 = pqs(mgs)*tabqvs(ltemq) + ELSEIF ( iqvsopt == 1 ) THEN + c1 = rdorv*esbolton*tabqvs(ltemq)/(pres(mgs) - esbolton*tabqvs(ltemq)) + ENDIF IF ( c1 > 0. ) THEN ssf(mgs) = Max(0.0, 100.*((qv0(mgs) + qwvp(mgs))/c1 - 1.0) ) ! from "new" values ELSE @@ -11367,7 +11643,11 @@ SUBROUTINE NUCOND & ltemq = Min( nqsat, Max(1,ltemq) ) ! c1 = t00(igs(mgs),jy,kgs(mgs))*tabqvs(ltemq) - c1= pqs(mgs)*tabqvs(ltemq) + IF ( iqvsopt == 0 ) THEN + c1 = pqs(mgs)*tabqvs(ltemq) + ELSEIF ( iqvsopt == 1 ) THEN + c1 = rdorv*esbolton*tabqvs(ltemq)/(pres(mgs) - esbolton*tabqvs(ltemq)) + ENDIF ssf(mgs) = 0.0 IF ( c1 > 0. ) THEN @@ -11468,7 +11748,11 @@ SUBROUTINE NUCOND & ltemq = Min( nqsat, Max(1,ltemq) ) ! c1 = t00(igs(mgs),jy,kgs(mgs))*tabqvs(ltemq) - c1= pqs(mgs)*tabqvs(ltemq) + IF ( iqvsopt == 0 ) THEN + c1 = pqs(mgs)*tabqvs(ltemq) + ELSEIF ( iqvsopt == 1 ) THEN + c1 = rdorv*esbolton*tabqvs(ltemq)/(pres(mgs) - esbolton*tabqvs(ltemq)) + ENDIF ssf(mgs) = 0.0 IF ( c1 > 0. ) THEN @@ -11502,14 +11786,24 @@ SUBROUTINE NUCOND & ENDIF + ELSEIF ( irenuc == 9 .or. irenuc == 10 ) THEN ! } { + write(0,*) 'irenuc=9 requires nuwrfmods=1' + + + ELSEIF ( irenuc == 11 ) THEN ! } { + + write(0,*) 'irenuc=11 requires nuwrfmods=1' ENDIF ! } + ccna(mgs) = ccna(mgs) + cn(mgs) + + ENDIF ! irenuc >= 0 .and. .not. flag_qndrop - IF( cx(mgs,lc) .GT. 0. .AND. qx(mgs,lc) .LE. qxmin(lc)) cx(mgs,lc)=0. + ! IF( cx(mgs,lc) .GT. 0. .AND. qx(mgs,lc) .LE. qxmin(lc)) cx(mgs,lc)=0. GO TO 631 !.... NUCLEATION ON CLOUD INFLOW BOUNDARY POINT @@ -11542,39 +11836,39 @@ SUBROUTINE NUCOND & IF ( qvex .gt. 0.0 ) THEN - thetap(mgs) = thetap(mgs) + felvcp(mgs)*qvex/(pi0(mgs)) - IF ( io_flag .and. nxtra > 1 ) THEN - axtra(igs(mgs),jy,kgs(mgs),1) = axtra(igs(mgs),jy,kgs(mgs),1) + qvex/dtp - ENDIF - qwvp(mgs) = qwvp(mgs) - qvex - qx(mgs,lc) = qx(mgs,lc) + qvex - IF ( .not. flag_qndrop) THEN - IF ( imaxsupopt == 1 ) THEN - cn(mgs) = Min( Max(ccnc(mgs),cwnccn(mgs)), rho0(mgs)*qvex/Max( cwmasn5, xmas(mgs,lc) ) ) - ELSEIF ( imaxsupopt == 2 ) THEN - cn(mgs) = Min( Max(ccnc(mgs),cwnccn(mgs)), rho0(mgs)*qvex/Max( cwmasn5, Max(cwmas30,xmas(mgs,lc)) ) ) - ELSEIF ( imaxsupopt == 3 ) THEN - cn(mgs) = Min( Max(ccnc(mgs),cwnccn(mgs)), rho0(mgs)*qvex/Max( cwmasn5, Max(cwmasx,xmas(mgs,lc)) ) ) -! cn(mgs) = 1.5*cxmin - ELSEIF ( imaxsupopt == 4 ) THEN - cn(mgs) = Min( Max(ccnc(mgs),cwnccn(mgs)), rho0(mgs)*qvex/Max( cwmasn5, Max(cwmas20,xmas(mgs,lc)) ) ) + thetap(mgs) = thetap(mgs) + felvcp(mgs)*qvex/(pi0(mgs)) + IF ( io_flag .and. nxtra > 1 ) THEN + axtra(igs(mgs),jy,kgs(mgs),1) = axtra(igs(mgs),jy,kgs(mgs),1) + qvex/dtp ENDIF - IF ( lccna > 1 ) THEN - ccna(mgs) = ccna(mgs) + cn(mgs) - ELSE - ccnc(mgs) = Max( 0.0, ccnc(mgs) - cn(mgs) ) - ENDIF - cx(mgs,lc) = cx(mgs,lc) + cn(mgs) - ENDIF - -! write(iunit,*) 'theta = ',theta0(mgs) + thetap(mgs) + qwvp(mgs) = qwvp(mgs) - qvex + qx(mgs,lc) = qx(mgs,lc) + qvex + IF ( .not. flag_qndrop) THEN + IF ( imaxsupopt == 1 ) THEN + cn(mgs) = Min( Max(ccnc(mgs),cwnccn(mgs)), rho0(mgs)*qvex/Max( cwmasn5, xmas(mgs,lc) ) ) + ELSEIF ( imaxsupopt == 2 ) THEN + cn(mgs) = Min( Max(ccnc(mgs),cwnccn(mgs)), rho0(mgs)*qvex/Max( cwmasn5, Max(cwmas30,xmas(mgs,lc)) ) ) + ELSEIF ( imaxsupopt == 3 ) THEN + cn(mgs) = Min( Max(ccnc(mgs),cwnccn(mgs)), rho0(mgs)*qvex/Max( cwmasn5, Max(cwmasx,xmas(mgs,lc)) ) ) +! cn(mgs) = 1.5*cxmin + ELSEIF ( imaxsupopt == 4 ) THEN + cn(mgs) = Min( Max(ccnc(mgs),cwnccn(mgs)), rho0(mgs)*qvex/Max( cwmasn5, Max(cwmas20,xmas(mgs,lc)) ) ) + ENDIF -! temg(mgs) = theta(mgs)*( pres(mgs) / poo ) ** cap + IF ( lccna > 1 ) THEN + !IF ( ac_opt == 0 ) THEN + ccna(mgs) = ccna(mgs) + cn(mgs) + !ENDIF + ELSE + ccnc(mgs) = Max( 0.0, ccnc(mgs) - cn(mgs) ) + ENDIF - ENDIF + cx(mgs,lc) = cx(mgs,lc) + cn(mgs) - - ENDIF + ENDIF ! flag_qndrop + + ENDIF ! ( qvex .gt. 0.0 ) + + ENDIF ! ( qv1 .gt. (ssmx*qvs1) ) ! ! Calculate droplet volume and check if it is within bounds. @@ -11594,7 +11888,6 @@ SUBROUTINE NUCOND & xmas(mgs,lc) = Max( xmas(mgs,lc), cwmasn ) cx(mgs,lc) = rho0(mgs)*qx(mgs,lc)/xmas(mgs,lc) ! IF ( cx(mgs,lc) > tmp*1.1 ) THEN -! write(0,*) 'nucond: kgs, ccw1,2 = ',kgs(mgs),tmp,cx(mgs,lc) ! ENDIF ENDIF ENDIF @@ -11676,11 +11969,27 @@ SUBROUTINE NUCOND & IF ( ipconc .ge. 2 ) THEN an(igs(mgs),jy,kgs(mgs),lnc) = Max(cx(mgs,lc) , 0.0) + ! IF ( ac_opt > 10 .and. (cx(mgs,lc) > 0. .or. ccna(mgs) > 0. ) ) THEN + ! write(0,*) 'i,k final cx/cna = ',igs(mgs),kgs(mgs),cx(mgs,lc),ccna(mgs) + ! ENDIF + IF ( lss > 1 ) an(igs(mgs),jy,kgs(mgs),lss) = Max( 0.0, ssmax(mgs) ) IF ( ac_opt == 0 ) THEN IF ( lccn .gt. 1 .and. lccna .lt. 1 ) THEN an(igs(mgs),jy,kgs(mgs),lccn) = Max(0.0, ccnc(mgs) ) ENDIF + ELSEIF ( ac_opt == 1 .and. lccn > 1) THEN + an(igs(mgs),jy,kgs(mgs),lccn) = Max( 0.0, ccnc(mgs) ) ! cn are depleted for ac_opt=1 or 2 + ELSEIF ( ac_opt == 11 .and. lccna > 1) THEN + ! an(igs(mgs),jy,kgs(mgs),lccna) = Max( 0.0, ccna(mgs) ) ! done below + ELSEIF ( ac_opt == 2 .and. lccn > 1) THEN + an(igs(mgs),jy,kgs(mgs),lccn) = Max( 0.0, ccnc(mgs) ) + an(igs(mgs),jy,kgs(mgs),lcn_nu) = Max( 0.0, ccnc_nu(mgs) ) + an(igs(mgs),jy,kgs(mgs),lcn_co) = Max( 0.0, ccnc_co(mgs) ) + ELSEIF ( ac_opt == 22 .and. lccna > 1) THEN + ! an(igs(mgs),jy,kgs(mgs),lccna) = Max( 0.0, ccna(mgs) ) ! done below + an(igs(mgs),jy,kgs(mgs),lccnanu) = Max( 0.0, ccnanu(mgs) ) + an(igs(mgs),jy,kgs(mgs),lccnaco) = Max( 0.0, ccnaco(mgs) ) ENDIF IF ( lccnuf .gt. 1 .and. .not. ( lccna .gt. 1 .and. i_uf_or_ccn > 0 ) ) THEN an(igs(mgs),jy,kgs(mgs),lccnuf) = Max(0.0, ccncuf(mgs) ) @@ -11688,7 +11997,7 @@ SUBROUTINE NUCOND & IF ( lccna .gt. 1 ) THEN an(igs(mgs),jy,kgs(mgs),lccna) = Max(0.0, ccna(mgs) ) ENDIF - ENDIF + ENDIF ! ipconc >= 2 IF ( ipconc .ge. 3 .and. rcond == 2 ) THEN an(igs(mgs),jy,kgs(mgs),lnr) = Max(cx(mgs,lr) , 0.0) ENDIF @@ -11721,17 +12030,74 @@ SUBROUTINE NUCOND & ! end of gather scatter (for this jy slice) -!#ifdef COMMAS -! GOTO 9999 -!#endif - ! Redistribute inappreciable cloud particles and charge ! ! Redistribution everywhere in the domain... ! - IF ( .true. ) THEN - - frac = 1.0 ! 0.25 ! 1.0 ! 0.2 +! moved to separate subroutine (below) +! + + + + 9999 RETURN + + END SUBROUTINE NUCOND + + +! ##################################################################### +! ##################################################################### +! Clean up tiny values of mixing ratio +! Redistribute inappreciable cloud particles and charge +! +! Redistribution everywhere in the domain... +! + subroutine smallvalues & + & (nx,ny,nz,na,jyslab & + & ,nor,norz,dtp,nxi & + & ,t0 & + & ,an,dn, w & + & ,t77,flag_qndrop & + & ) + + + implicit none + + integer :: nx,ny,nz,na,nxi + integer :: nor,norz, jyslab ! ,nht,ngt,igsr + real :: dtp ! time step + logical,intent(in) :: flag_qndrop + +! +! external temporary arrays +! + real t77(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real t0(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) + real dn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real w(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + + ! local + + + logical zerocx(lc:lqmx) + + real :: frac, hwdn, tmpg, xdia1, xdia3, cwch,xvol + + integer ix,kz,i,n, km1 + integer :: il + integer :: jy, jgs + real :: chw, g1, z1, tmp, tmp2, fw, tmpmx, qr + + +! Redistribute inappreciable cloud particles and charge +! +! Redistribution everywhere in the domain... +! + jy = 1 + + frac = 1.0 ! 0.25 ! 1.0 ! 0.2 + + cwch = ((3. + alphah)*(2. + alphah)*(1.0 + alphah))**(-1./3.) ! ! alternate test version for ipconc .ge. 3 ! just vaporize stuff to prevent noise in the number concentrations @@ -11747,12 +12113,14 @@ SUBROUTINE NUCOND & DO il = lc,lhab IF ( iresetmoments == 1 .or. iresetmoments == il ) THEN IF ( ln(il) > 1 ) zerocx(il) = ( an(ix,jy,kz,ln(il)) < cxmin ) - IF ( lz(il) > 1 ) zerocx(il) = ( zerocx(il) .or. an(ix,jy,kz,lz(il)) < zxmin ) + IF ( lz(il) > 1 ) zerocx(il) = ( zerocx(il) .or. (an(ix,jy,kz,lz(il)) < zxmin) ) ELSE IF ( il == lc ) THEN - IF ( ln(il) > 1 ) zerocx(il) = ( an(ix,jy,kz,ln(il)) <= 0 ) .and. .not. flag_qndrop ! do not reset if progn=1 (WRF-CHEM) + IF ( ln(il) > 1 ) THEN + zerocx(il) = ( an(ix,jy,kz,ln(il)) <= 0.0 ) .and. .not. flag_qndrop ! do not reset if progn=1 (WRF-CHEM) + ENDIF ELSE - IF ( ln(il) > 1 ) zerocx(il) = ( an(ix,jy,kz,ln(il)) <= 0 ) + IF ( ln(il) > 1 ) zerocx(il) = ( an(ix,jy,kz,ln(il)) <= 0.0 ) ENDIF ENDIF ENDDO @@ -11796,7 +12164,7 @@ SUBROUTINE NUCOND & ENDIF !lzhl - if ( an(ix,jy,kz,lhl) .lt. frac*qxmin(lhl) .or. zerocx(lhl) ) then + if ( (an(ix,jy,kz,lhl) .lt. frac*qxmin(lhl)) .or. zerocx(lhl) ) then ! IF ( an(ix,jy,kz,lhl) .gt. 0 ) THEN an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lhl) @@ -11870,6 +12238,28 @@ SUBROUTINE NUCOND & ENDIF + IF ( lvhl .gt. 1 ) THEN + IF ( an(ix,jy,kz,lvhl) .gt. 0.0 ) THEN + hwdn = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/an(ix,jy,kz,lvhl) + ELSE + hwdn = xdn0(lhl) + ENDIF + hwdn = Max( xdnmn(lhl), hwdn ) + ELSE + hwdn = xdn0(lhl) + ENDIF + + IF ( ipconc >= 5 .and. an(ix,jy,kz,lhl) .gt. qxmin(lhl) ) THEN + qr = an(ix,jy,kz,lhl) + xvol = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/(hwdn*an(ix,jy,kz,lnhl)) + chw = an(ix,jy,kz,lnhl) + + IF ( xvol .lt. xvmn(lhl) .or. xvol .gt. xvmx(lhl) ) THEN + xvol = Min( xvmx(lhl), Max( xvmn(lhl),xvol ) ) + chw = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/(xvol*hwdn) + an(ix,jy,kz,lnhl) = chw + ENDIF + ENDIF ! CHECK INTERCEPT IF ( ipconc == 5 .and. an(ix,jy,kz,lhl) .gt. qxmin(lhl) .and. alphahl .le. 0.1 .and. lnhl .gt. 1 .and. lzhl == 0 ) THEN @@ -11880,9 +12270,9 @@ SUBROUTINE NUCOND & hwdn = xdn0(lhl) ENDIF tmp = (hwdn*an(ix,jy,kz,lnhl))/(dn(ix,jy,kz)*an(ix,jy,kz,lhl)) - tmpg = an(ix,jy,kz,lnhl)*(tmp*(3.14159))**(1./3.) + tmpg = an(ix,jy,kz,lnhl)*(tmp*pi)**(1./3.) IF ( tmpg .lt. cnohlmn ) THEN - tmp = ( (hwdn)/(dn(ix,jy,kz)*an(ix,jy,kz,lhl))*(3.14159))**(1./3.) + tmp = ( (hwdn)/(dn(ix,jy,kz)*an(ix,jy,kz,lhl))*pi)**(1./3.) an(ix,jy,kz,lnhl) = (cnohlmn/tmp)**(3./4.) ENDIF @@ -11932,7 +12322,7 @@ SUBROUTINE NUCOND & ENDIF - if ( an(ix,jy,kz,lh) .lt. frac*qxmin(lh) .or. zerocx(lh) ) then + if ( (an(ix,jy,kz,lh) .lt. frac*qxmin(lh)) .or. zerocx(lh) ) then ! IF ( an(ix,jy,kz,lh) .gt. 0 ) THEN an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lh) @@ -12006,9 +12396,6 @@ SUBROUTINE NUCOND & ENDIF -! CHECK INTERCEPT - IF ( ipconc == 5 .and. an(ix,jy,kz,lh) .gt. qxmin(lh) .and. alphah .le. 0.1 .and. lnh .gt. 1 .and. lzh == 0 ) THEN - IF ( lvh .gt. 1 ) THEN IF ( an(ix,jy,kz,lvh) .gt. 0.0 ) THEN hwdn = dn(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh) @@ -12019,22 +12406,51 @@ SUBROUTINE NUCOND & ELSE hwdn = xdn0(lh) ENDIF + + IF ( ipconc >= 5 .and. an(ix,jy,kz,lh) .gt. qxmin(lh) ) THEN + qr = an(ix,jy,kz,lh) + xvol = dn(ix,jy,kz)*an(ix,jy,kz,lh)/(hwdn*an(ix,jy,kz,lnh)) + chw = an(ix,jy,kz,lnh) + + IF ( xvol .lt. xvmn(lh) .or. xvol .gt. xvmx(lh) ) THEN + xvol = Min( xvmx(lh), Max( xvmn(lh),xvol ) ) + chw = dn(ix,jy,kz)*an(ix,jy,kz,lh)/(xvol*hwdn) + an(ix,jy,kz,lnh) = chw + ENDIF + ENDIF + +! CHECK INTERCEPT + IF ( ipconc == 5 .and. an(ix,jy,kz,lh) .gt. qxmin(lh) .and. alphah .le. 0.1 .and. lnh .gt. 1 .and. lzh == 0 ) THEN + tmp = (hwdn*an(ix,jy,kz,lnh))/(dn(ix,jy,kz)*an(ix,jy,kz,lh)) - tmpg = an(ix,jy,kz,lnh)*(tmp*(3.14159))**(1./3.) + tmpg = an(ix,jy,kz,lnh)*(tmp*pi)**(1./3.) IF ( tmpg .lt. cnohmn ) THEN ! tmpg = an(ix,jy,kz,lnh)*( (hwdn*an(ix,jy,kz,lnh))/(dn(ix,jy,kz)*an(ix,jy,kz,lh))*(3.14159))**(1./3.) ! tmpg = an(ix,jy,kz,lnh)**(4./3.)*( (hwdn)/(dn(ix,jy,kz)*an(ix,jy,kz,lh))*(3.14159))**(1./3.) - tmp = ( (hwdn)/(dn(ix,jy,kz)*an(ix,jy,kz,lh))*(3.14159))**(1./3.) + tmp = ( (hwdn)/(dn(ix,jy,kz)*an(ix,jy,kz,lh))*pi)**(1./3.) an(ix,jy,kz,lnh) = (cnohmn/tmp)**(3./4.) ENDIF ENDIF + + IF ( ipconc == 5 .and. imorrgdnglimit == 1 ) THEN + ! limit on characteristic diameter (i.e., 1/slope) + xdia3 = (xvol*6.*piinv)**(1./3.) + xdia1 = cwch*xdia3 + IF ( xdia1 > morrdnglimit ) THEN + xdia1 = morrdnglimit + xvol = pi/6.0*(xdia1/cwch)**3 + chw = dn(ix,jy,kz)*qr/(xvol*hwdn) + an(ix,jy,kz,lnh) = chw + xdia3 = (xvol*6.*piinv)**(1./3.) + ENDIF + + ENDIF end if - if ( an(ix,jy,kz,ls) .lt. frac*qxmin(ls) .or. zerocx(ls) & ! .or. an(ix,jy,kz,lns) .lt. 0.1 ! .and. - & ) then + if ( (an(ix,jy,kz,ls) .lt. frac*qxmin(ls)) .or. zerocx(ls) ) then IF ( t0(ix,jy,kz) .lt. 273.15 ) THEN ! IF ( an(ix,jy,kz,ls) .gt. 0 ) THEN an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,ls) @@ -12095,8 +12511,7 @@ SUBROUTINE NUCOND & an(ix,jy,kz,lzr) = Max(0.0, an(ix,jy,kz,lzr) ) ENDIF - if ( an(ix,jy,kz,lr) .lt. frac*qxmin(lr) .or. zerocx(lr) & - & ) then + if ( (an(ix,jy,kz,lr) .lt. frac*qxmin(lr)) .or. zerocx(lr) ) then an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lr) an(ix,jy,kz,lr) = 0.0 IF ( ipconc .ge. 3 ) THEN @@ -12113,8 +12528,7 @@ SUBROUTINE NUCOND & ! ! for qci ! - IF ( an(ix,jy,kz,li) .le. frac*qxmin(li) .or. zerocx(li) & ! .or. an(ix,jy,kz,lni) .lt. 0.1 - & ) THEN + IF ( (an(ix,jy,kz,li) .le. frac*qxmin(li)) .or. zerocx(li) ) THEN an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,li) an(ix,jy,kz,li)= 0.0 IF ( ipconc .ge. 1 ) THEN @@ -12122,41 +12536,11 @@ SUBROUTINE NUCOND & ENDIF ENDIF -! -! for qis -! - IF ( lis > 1 ) THEN ! { - IF ( an(ix,jy,kz,lis) .le. frac*qxmin(lis) .or. zerocx(lis) & ! .or. an(ix,jy,kz,lni) .lt. 0.1 - & ) THEN ! { { - an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lis) - an(ix,jy,kz,lis)= 0.0 - IF ( ipconc .ge. 1 ) THEN - an(ix,jy,kz,lnis) = 0.0 - ENDIF - - ELSEIF ( icespheres >= 2 ) THEN ! } { - km1 = Max(1, kz-1) - IF ( 0.5*( w(ix,jy,kz) + w(ix,jy,kz+1)) < -1.0 .or. & - & (icespheres == 3 .and. ( t0(ix,jy,kz) < 232.15 .or. an(ix,jy,kz,lc) < qxmin(lc) ) ) .or. & - & (icespheres == 5 .and. ( t0(ix,jy,kz) < 232.15 .or. & - & ( an(ix,jy,kz,lc) < qxmin(lc) .and. an(ix,jy,km1,lc) < qxmin(lc) )) ) .or. & - & (icespheres == 4 .and. ( t0(ix,jy,kz) < 235.15 )) ) THEN ! transfer to regular ice crystals in downdraft or at low temp - an(ix,jy,kz,li) = an(ix,jy,kz,li) + an(ix,jy,kz,lis) - an(ix,jy,kz,lni) = an(ix,jy,kz,lni) + an(ix,jy,kz,lnis) - an(ix,jy,kz,lis)= 0.0 - an(ix,jy,kz,lnis)= 0.0 - - ENDIF - - ENDIF ! } } - ENDIF ! } - ! ! for qcw ! - IF ( an(ix,jy,kz,lc) .le. frac*qxmin(lc) .or. zerocx(lc) & - & ) THEN + IF ( (an(ix,jy,kz,lc) .le. frac*qxmin(lc)) .or. zerocx(lc) ) THEN an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lc) an(ix,jy,kz,lc)= 0.0 IF ( ipconc .ge. 2 ) THEN @@ -12164,19 +12548,36 @@ SUBROUTINE NUCOND & IF ( irenuc < 5 .and. lccna <= 1 ) THEN IF ( ac_opt == 0 ) THEN an(ix,jy,kz,lccn) = an(ix,jy,kz,lccn) + Max(0.0,an(ix,jy,kz,lnc)) + ELSEIF ( lccn > 1 ) THEN + an(ix,jy,kz,lccn) = an(ix,jy,kz,lccn) + Max(0.0,an(ix,jy,kz,lnc)) ENDIF ELSEIF ( lccna > 1 ) THEN - an(ix,jy,kz,lccna) = Max( 0.0, an(ix,jy,kz,lccna) - Max(0.0,an(ix,jy,kz,lnc)) ) + tmp = Max(0.0,an(ix,jy,kz,lnc)) + IF ( lccnaco > 1 .and. lccnanu > 1 ) THEN + ! restore CCN proportionally to each type, although coarse are presumably already lost to rain + tmp2 = an(ix,jy,kz,lccna) + an(ix,jy,kz,lccnaco) + an(ix,jy,kz,lccnanu) + IF ( tmp2 > 0.0 .and. tmp > 0.0 ) THEN + an(ix,jy,kz,lccna) = Max( 0.0, an(ix,jy,kz,lccna) - tmp*an(ix,jy,kz,lccna)/tmp2 ) + an(ix,jy,kz,lccnaco) = Max( 0.0, an(ix,jy,kz,lccnaco) - tmp*an(ix,jy,kz,lccnaco)/tmp2 ) + an(ix,jy,kz,lccnanu) = Max( 0.0, an(ix,jy,kz,lccnanu) - tmp*an(ix,jy,kz,lccnanu)/tmp2 ) + ENDIF + ELSE + an(ix,jy,kz,lccna) = Max( 0.0, an(ix,jy,kz,lccna) - tmp ) + ENDIF ENDIF ENDIF an(ix,jy,kz,lnc) = 0.0 IF ( lccn > 1 ) an(ix,jy,kz,lccn) = Max( 0.0, an(ix,jy,kz,lccn) ) - IF ( lccna > 0 .and. ac_opt == 0 ) THEN ! apply exponential decay to activated CCN to restore to environmental value +! IF ( lccna > 0 .and. ac_opt == 0 ) THEN ! apply exponential decay to activated CCN to restore to environmental value + IF ( lccna > 0 ) THEN ! apply exponential decay to activated CCN to restore to environmental value IF ( restoreccn ) THEN tmp = an(ix,jy,kz,li) + an(ix,jy,kz,ls) - - IF ( an(ix,jy,kz,lccna) > 1. .and. tmp < qxmin(li) ) an(ix,jy,kz,lccna) = an(ix,jy,kz,lccna)*Exp(-dtp/ccntimeconst) + IF ( tmp < qxmin(li) ) THEN + IF ( an(ix,jy,kz,lccna) > 1. .and. tmp < qxmin(li) ) an(ix,jy,kz,lccna) = an(ix,jy,kz,lccna)*Exp(-dtp/ccntimeconst) + IF ( lccnaco > 1 ) an(ix,jy,kz,lccnaco) = an(ix,jy,kz,lccnaco)*Exp(-dtp/ccntimeconst) + IF ( lccnanu > 1 ) an(ix,jy,kz,lccnanu) = an(ix,jy,kz,lccnanu)*Exp(-dtp/ccntimeconst) + ENDIF ENDIF ELSEIF ( lccn > 1 .and. restoreccn .and. ac_opt == 0 ) THEN ! in this case, we are treating the ccn field as ccna @@ -12185,7 +12586,8 @@ SUBROUTINE NUCOND & ! write(0,*) 'restore: k, qccn,exp = ',kz,qccn,dn(ix,jy,kz)*qccn,Exp(-dtp/ccntimeconst) ! write(0,*) 'ccn1,ccn2 = ',an(ix,jy,kz,lccn),dn(ix,jy,kz)*qccn - Max(0.0 , dn(ix,jy,kz)*qccn - an(ix,jy,kz,lccn))*Exp(-dtp/ccntimeconst) ! ENDIF - IF ( an(ix,jy,kz,lccn) > 1. .and. tmp < qxmin(li) .and. ( an(ix,jy,kz,lccn) < dn(ix,jy,kz)*qccn .or. .not. invertccn ) ) THEN + IF ( an(ix,jy,kz,lccn) > 1. .and. tmp < qxmin(li) .and. & + ( an(ix,jy,kz,lccn) < dn(ix,jy,kz)*qccn .or. .not. invertccn ) ) THEN ! an(ix,jy,kz,lccn) = & ! an(ix,jy,kz,lccn) + Max(0.0 , dn(ix,jy,kz)*qccn - an(ix,jy,kz,lccn))*(1.0 - Exp(-dtp/ccntimeconst)) ! Equivalent form after expanding last term: @@ -12203,20 +12605,8 @@ SUBROUTINE NUCOND & ! end do end do - ENDIF ! true/false - IF ( ndebug .ge. 1 ) write(6,*) 'END OF ICEZVD_DR' -! -! - - - 9999 RETURN - - END SUBROUTINE NUCOND - - -! ##################################################################### -! ##################################################################### + end subroutine smallvalues @@ -12329,7 +12719,8 @@ subroutine nssl_2mom_gs & real rainprod2d(-nor+1:nx+nor,-norz+ng1:nz+norz) real evapprod2d(-nor+1:nx+nor,-norz+ng1:nz+norz) - real alpha2d(-nor+1:nx+nor,-norz+ng1:nz+norz,3) + + real :: alpha2d(-nor+1:nx+nor,-norz+ng1:nz+norz,3) real, parameter :: tfrdry = 243.15 @@ -12401,7 +12792,7 @@ subroutine nssl_2mom_gs & integer i,j,k,i1 integer kzb,kze real slope1, slope2 - real x1, x2, x3 + real x1, x2, x3, y1 real eps,eps2 parameter (eps=1.e-20,eps2=1.e-5) ! @@ -12536,12 +12927,13 @@ subroutine nssl_2mom_gs & real, parameter :: mfrag = 1.0e-10 ! assumed ice fragment mass for collisional splintering (Schuur & Rutledge 00b) double precision cautn(ngs), rh(ngs), nh(ngs) real ex1, ft, rhoinv(ngs) - double precision ec0(ngs) + real :: ec0(ngs) - real ac1,bc, taus, c1,d1,e1,f1,p380,tmp,tmp1,tmp2,tmp3,tmp4,tmp5,tmp6,temp3 ! , sstdy, super - real :: flim + real ac1,bc, c1,d1,e1,f1,p380,tmp,tmp1,tmp2,tmp3,tmp4,tmp5,tmp6,temp3 ! , sstdy, super + real :: flim, xmass real dw,dwr double precision :: tmpz, tmpzmlt + real :: tmpc real ratio, delx, dely real dbigg,volt real chgtmp,fac,mixedphasefac @@ -12708,11 +13100,10 @@ subroutine nssl_2mom_gs & real :: alpha(ngs,lc:lhab) real :: dab0lh(ngs,lc:lhab,lc:lhab) real :: dab1lh(ngs,lc:lhab,lc:lhab) - real :: zx(ngs,lr:lhab) - real :: zxmxd(ngs,lr:lhab) - real :: g1x(ngs,lr:lhab) - - + real :: zx(ngs,lr:lhab) + real :: zxmxd(ngs,lr:lhab) + real :: g1x(ngs,lr:lhab) + real :: g1xmax,g1xmin real :: qsimxdep(ngs) ! max sublimation of qi+qs+qis real :: qsimxsub(ngs) ! max depositionof qi+qs+qis logical,parameter :: DoSublimationFix = .true. @@ -12735,9 +13126,10 @@ subroutine nssl_2mom_gs & real :: qhgt10mm ! mass greater than 10mm real :: qhgt20mm ! mass greater than 20mm real :: fwmhtmp - real, parameter :: fwmhtmptem = -15. ! temperature at which fwmhtmp fully switches to liquid water only being on large particles +! real, parameter :: fwmhtmptem = -15. ! temperature at which fwmhtmp fully switches to liquid water only being on large particles real, parameter :: d1t = (6.0 * 0.268e-3/(917.* pi))**(1./3.) ! d1t is the diameter of the ice sphere with the mass (0.268e-3 kg) of an 8mm spherical drop real, parameter :: srasheym = 0.1389 ! slope fraction from Rasmussen and Heymsfield + real :: dtmp ! real swvent(ngs),hwvent(ngs),rwvent(ngs),hlvent(ngs),hwventy(ngs),hlventy(ngs),rwventz(ngs) real hxventtmp @@ -12757,6 +13149,7 @@ subroutine nssl_2mom_gs & real qhlmlr0, qhlmlr05, qhlmlr1, qhlmlr2,qhlmlr3, qhlmlr12, qhlmlr23 real qxd1, cxd1, zxd1 ! mass and number up to mltdiam1 real qxd05, cxd05 ! mass and number up to mltdiam1/2 + real :: qrbreak, crbreaksmall, crbreak, zrbreak, breakbin real :: qxd(ndiam+4), cxd(ndiam+4), qhml(ndiam+4), qhml0(ndiam+4) real :: dqxd(ndiam+4), dcxd(ndiam+4), dqhml(ndiam+4) @@ -12887,6 +13280,7 @@ subroutine nssl_2mom_gs & ! real qsaci(ngs) real qsacis(ngs) + real csacis(ngs) real qhaci(ngs) real qhacs(ngs) @@ -12895,6 +13289,7 @@ subroutine nssl_2mom_gs & real :: chacis0(ngs) real :: csaci0(ngs) ! collision rate only + real :: csacis0(ngs) ! collision rate only real :: chaci0(ngs) ! collision rate only real :: chacs0(ngs) ! collision rate only real :: chlaci0(ngs) @@ -13045,7 +13440,7 @@ subroutine nssl_2mom_gs & real ehxw(ngs),ehlw(ngs),egmw(ngs),ehw(ngs) real err(ngs),esr(ngs),eglr(ngs),eghr(ngs),efr(ngs) real ehxr(ngs),ehlr(ngs),egmr(ngs) - real eri(ngs),esi(ngs),egli(ngs),eghi(ngs),efi(ngs),efis(ngs) + real eri(ngs),esi(ngs),esis(ngs),egli(ngs),eghi(ngs),efi(ngs),efis(ngs) real ehxi(ngs),ehli(ngs),egmi(ngs),ehi(ngs),ehis(ngs),ehlis(ngs) real ers(ngs),ess(ngs),egls(ngs),eghs(ngs),efs(ngs),ehs(ngs),ehsfac(ngs) real ehscnv(ngs) @@ -13054,7 +13449,7 @@ subroutine nssl_2mom_gs & real ehsclsn(ngs),ehiclsn(ngs),ehisclsn(ngs) real efsclsn(ngs),eficlsn(ngs),efisclsn(ngs) real ehlsclsn(ngs),ehliclsn(ngs),ehlisclsn(ngs) - real esiclsn(ngs) + real esiclsn(ngs),esisclsn(ngs) real :: ehs_collsn = 0.5, ehi_collsn = 1.0 real :: efs_collsn = 0.5, efi_collsn = 1.0 @@ -13634,6 +14029,7 @@ subroutine nssl_2mom_gs & do ix = nxmpb,itile pqs(1) = t00(ix,jy,kz) + pres(1) = pn(ix,jy,kz) + pb(kz) theta(1) = an(ix,jy,kz,lt) temg(1) = t0(ix,jy,kz) @@ -13641,7 +14037,12 @@ subroutine nssl_2mom_gs & tqvcon = temg(1)-cbw ltemq = (temg(1)-163.15)/fqsat + 1.5 ltemq = Min( nqsat, Max(1,ltemq) ) - qvs(1) = pqs(1)*tabqvs(ltemq) + IF ( iqvsopt == 0 ) THEN + qvs(1) = pqs(1)*tabqvs(ltemq) + ELSEIF ( iqvsopt == 1 ) THEN + qvs(1) = rdorv*esbolton*tabqvs(ltemq)/(pres(1) - esbolton*tabqvs(ltemq)) + ENDIF + IF ( iqis0 == 1 .or. temg(1) <= tfr+0.5 ) THEN qis(1) = pqs(1)*tabqis(ltemq) ELSE @@ -13727,7 +14128,13 @@ subroutine nssl_2mom_gs & pqs(mgs) = (380.0)/(pres(mgs)) ltemq = (temg(mgs)-163.15)/fqsat+1.5 ltemq = Min( nqsat, Max(1,ltemq) ) - qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + + IF ( iqvsopt == 0 ) THEN + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + ELSEIF ( iqvsopt == 1 ) THEN + qvs(mgs) = rdorv*esbolton*tabqvs(ltemq)/(pres(mgs) - esbolton*tabqvs(ltemq)) + ENDIF + IF ( iqis0 == 1 .or. temg(mgs) <= tfr+0.5 ) THEN qis(mgs) = pqs(mgs)*tabqis(ltemq) ELSE @@ -13960,6 +14367,12 @@ subroutine nssl_2mom_gs & IF ( ipconc .ge. 6 ) THEN + tmp = alphamax - 1.0 + g1xmax = (6.0 + tmp)*(5.0 + tmp)*(4.0 + tmp)/ & + & ((3.0 + tmp)*(2.0 + tmp)*(1.0 + tmp)) + g1xmin = (6.0 + alphamin)*(5.0 + alphamin)*(4.0 + alphamin)/ & + & ((3.0 + alphamin)*(2.0 + alphamin)*(1.0 + alphamin)) + IF ( lz(lr) .lt. 1 ) THEN g1x(:,lr) = (6.0 + alphar)*(5.0 + alphar)*(4.0 + alphar)/ & & ((3.0 + alphar)*(2.0 + alphar)*(1.0 + alphar)) @@ -13984,6 +14397,18 @@ subroutine nssl_2mom_gs & ENDIF + IF ( ipconc == 5 ) THEN + ! set up factors for ihlcnh=3 conversion + g1x(:,lr) = (6.0 + alphar)*(5.0 + alphar)*(4.0 + alphar)/ & + & ((3.0 + alphar)*(2.0 + alphar)*(1.0 + alphar)) + g1x(:,lh) = (6.0 + alphah)*(5.0 + alphah)*(4.0 + alphah)/ & + & ((3.0 + alphah)*(2.0 + alphah)*(1.0 + alphah)) + IF ( lhl > 0 ) THEN + g1x(:,lhl) = (6.0 + alphahl)*(5.0 + alphahl)*(4.0 + alphahl)/ & + & ((3.0 + alphahl)*(2.0 + alphahl)*(1.0 + alphahl)) + ENDIF + ENDIF + scx(:,:) = 0.0 ! ! set shape parameters @@ -14098,7 +14523,6 @@ subroutine nssl_2mom_gs & tmp = qx(mgs,li)+qx(mgs,ls)+qx(mgs,lh) IF ( lhl > 1 ) tmp = tmp + qx(mgs,lhl) - IF ( lf > 1 ) tmp = tmp + qx(mgs,lf) cvm = cv+cvv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) & +cpigb*(tmp) @@ -14259,7 +14683,7 @@ subroutine nssl_2mom_gs & ! alpha(mgs,lr) = Min(alphamax, c1r*tanh(c2r*(xdia(mgs,lr,3)*1000. - c3r)) + c4r) ! IF ( igs(mgs) == 19 ) write(0,*) 'imy: i,k,alpr,xdia = ',igs(mgs),kgs(mgs),alpha(mgs,lr),xdia(mgs,lr,3)*1000. - ! M&M-C 2010: + ! Milbrandt & M-C 2010: tmp = 4. + alphar i = Int(dgami*(tmp)) del = tmp - dgam*i @@ -14280,7 +14704,7 @@ subroutine nssl_2mom_gs & xdia(mgs,lh,3) = (xv(mgs,lh)*6.*piinv)**(1./3.) ! mwfac*xdia(mgs,lh,1) ! (xv(mgs,lh)*cwc0*6.0)**(1./3.) ! alpha(mgs,lh) = Min(alphamax, c1h*tanh(c2h*(xdia(mgs,lh,3)*1000. - c3h)) + c4h) - ! M&M-C 2010: + ! Milbrandt & M-C 2010: tmp = 4. + dnu(lh) i = Int(dgami*(tmp)) del = tmp - dgam*i @@ -14802,7 +15226,7 @@ subroutine nssl_2mom_gs & ! check for artificial breakup (graupel/hail larger than allowed max size) - IF ( imaxdiaopt == 1 ) THEN + IF ( imaxdiaopt == 1 .or. il /= lr ) THEN xvbarmax = xvmx(il) ELSEIF ( imaxdiaopt == 2 ) THEN ! test against maximum mass diameter xvbarmax = xvmx(il) /((3. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il)))) @@ -14829,12 +15253,21 @@ subroutine nssl_2mom_gs & IF ( tmp < cx(mgs,il) ) THEN ! artificial breakup has happened, so need to adjust reflectivity and find new shape parameter g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2) - zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) ) +! zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) ) + ! check if incoming zx is consistent + ! Z from incoming cx, qx, and alpha + tmpz = g1/(pi/6.*xdn(mgs,il))**2 * ((rho0(mgs)*qx(mgs,il))**2)/tmp + IF ( tmpz > zx(mgs,il) ) THEN + tmpc = g1/(pi/6.*xdn(mgs,il))**2 * ((rho0(mgs)*qx(mgs,il))**2)/zx(mgs,il) + cx(mgs,il) = Max(cx(mgs,il), tmpc) + ! find cx that gives zx + ENDIF + zx(mgs,il) = g1/(pi/6.*xdn(mgs,il))**2 * ((rho0(mgs)*qx(mgs,il))**2)/cx(mgs,il) an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) - chw = cx(mgs,il) - qr = qx(mgs,il) - z = zx(mgs,il) + qr = qx(mgs,il) + chw = cx(mgs,il) + z = zx(mgs,il) rdi = z*(pi/6.*xdn(mgs,il))**2*chw/((rho0(mgs)*qr)**2) alp = (6.0+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & @@ -14948,12 +15381,12 @@ subroutine nssl_2mom_gs & gf1palp(mgs) = y IF ( iferwisventr == 2 ) THEN +! ventrn = Gamma(alphar + 2.5 + br/2.)/Gamma(alphar + 1.) ! adapted from Wisner et al. 1972 tmp = alpha(mgs,lr) + 2.5 + br/2. i = Int(dgami*(tmp)) del = tmp - dgam*i x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami -! ventrx(mgs) = Gamma_sp(alpha(mgs,lr) + 1.5 + br/6.)/Gamma_sp(alpha(mgs,lr) + 1.) ventrxn(mgs) = x/y @@ -15128,9 +15561,9 @@ subroutine nssl_2mom_gs & call setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & & xmas,vtxbar,xdn,xvmn,xvmx,xv,cdx,cdxgs, & - & ipconc,ndebug,ngs,nz,kgs,fadvisc, & + & ipconc,ndebug,ngs,nz,igs,kgs,fadvisc, & & cwmasn,cwmasx,cwradn,cnina,cimn,cimx, & - & itype1,itype2,temcg,infdo,alpha,0,axx,bxx) ! ,cdh,cdhl) + & itype1,itype2,temcg,infdo,alpha,axx,bxx,0) ! ,cdh,cdhl) ! & itype1,itype2,temcg,infdo,alpha,0,axh,bxh,axhl,bxhl) ! ,cdh,cdhl) @@ -15336,8 +15769,9 @@ subroutine nssl_2mom_gs & IF ( qx(mgs,il) > qxmin(il) .and. ivshdgs > 0 ) THEN ! tmpdiam is weighted diameter of d^(shedalp-1), so for shedalp=3, this is the area-weighted diameter or maximum mass diameter. - tmpdiam = (shedalp+alpha(mgs,il))*xdia(mgs,il,1) ! *( xdn(mgs,il)/917. )**(1./3.) ! erm added density factor for equiv. solid ice sphere 10.12.2015 - + ! tmpdiam = (shedalp+alpha(mgs,il))*xdia(mgs,il,1) ! *( xdn(mgs,il)/917. )**(1./3.) ! erm added density factor for equiv. solid ice sphere 10.12.2015 + tmpdiam = (shedalp+0.0)*xdia(mgs,il,1) ! *( xdn(mgs,il)/917. )**(1./3.) ! erm added density factor for equiv. solid ice sphere 10.12.2015 + ! imltshddmr IF ( tmpdiam > sheddiam0 ) THEN vshdgs(mgs,il) = 0.523599*(1.5e-3)**3/massfacshr ! 1.5mm drops from very large ice ELSEIF ( tmpdiam > sheddiam ) THEN ! intermediate size @@ -15497,7 +15931,7 @@ subroutine nssl_2mom_gs & if (xdia(mgs,lc,1).gt.ewi_dcmin .and. xdia(mgs,li,1).gt.ewi_dimin) then ! erm 5/10/2007 test following change: ! if (xdia(mgs,lc,1).gt.12.0e-06 .and. xdia(mgs,li,1).gt.50.0e-06) then - eiw(mgs) = 0.5 + eiw(mgs) = eiw0 end if if ( temg(mgs) .ge. 273.15 ) eiw(mgs) = 0.0 end if @@ -15672,6 +16106,7 @@ subroutine nssl_2mom_gs & ! ENDIF if ( temg(mgs) .gt. 273.15 ) esi(mgs) = 0.0 end if + ! ! ! @@ -16370,24 +16805,6 @@ subroutine nssl_2mom_gs & end do - IF ( lis > 1 .and. ipconc >= 5 ) THEN - do mgs = 1,ngscnt - qhacis(mgs) = 0.0 - qhacis0(mgs) = 0.0 - IF ( ehis(mgs) .gt. 0.0 ) THEN - - vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,lis,1))**2 + & - & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,lis,1) ) - - qhacis0(mgs) = 0.25*pi*ehisclsn(mgs)*cx(mgs,lh)*qx(mgs,lis)*vt* & - & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & - & dab1lh(mgs,lh,lis)*xdia(mgs,lh,3)*xdia(mgs,lis,3) + & - & da1(li)*xdia(mgs,lis,3)**2 ) - qhacis(mgs) = Min( ehis(mgs)*qhacis0(mgs), qxmxd(mgs,lis) ) - ENDIF - end do - ENDIF - ! ! do mgs = 1,ngscnt @@ -16638,6 +17055,9 @@ subroutine nssl_2mom_gs & end do ENDIF ! + qhlacis(:) = 0.0 + qhlacis0(:) = 0.0 + qhlacs(:) = 0.0 qhlacs0(:) = 0.0 IF ( lhl .gt. 1 ) THEN @@ -16759,7 +17179,7 @@ subroutine nssl_2mom_gs & ni = ni + cx(mgs,li)*Exp(- (40.e-6/xdia(mgs,li,1))**3 ) ENDIF IF ( imurain == 1 ) THEN ! gamma of diameter - IF ( iacrsize /= 4 ) THEN + IF ( iacrsize /= 4 ) THEN IF ( iacrsize .eq. 1 ) THEN ratio = 500.e-6/xdia(mgs,lr,1) ELSEIF ( iacrsize .eq. 2 ) THEN @@ -16793,10 +17213,10 @@ subroutine nssl_2mom_gs & qr = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*qx(mgs,lr) - ELSE ! iacrsize == 4 : use all - nr = cx(mgs,lr) - qr = qx(mgs,lr) - ENDIF + ELSE ! iacrsize == 4 : use all + nr = cx(mgs,lr) + qr = qx(mgs,lr) + ENDIF vt = Sqrt((vtxbar(mgs,lr,1)-vtxbar(mgs,li,1))**2 + & & 0.04*vtxbar(mgs,lr,1)*vtxbar(mgs,li,1) ) @@ -16805,9 +17225,9 @@ subroutine nssl_2mom_gs & & ( da0(li)*xdia(mgs,li,3)**2 + & & dab1lh(mgs,li,lr)*xdia(mgs,lh,3)*xdia(mgs,li,3) + & & da1(lr)*xdia(mgs,lr,3)**2 ) - + qiacr(mgs) = Min( qrmxd(mgs), qiacr(mgs) ) - + ciacr(mgs) = 0.25*pi*eri(mgs)*ni*nr*vt* & & ( da0(li)*xdia(mgs,li,3)**2 + & @@ -16895,7 +17315,13 @@ subroutine nssl_2mom_gs & ! ave. diam of freezing drops in microns IF ( qiacr(mgs)*dtp > qxmin(lh) .and. ciacr(mgs) > 1.e-3 ) THEN tmpdiam = 1.e6*( 6.*qiacr(mgs)/(1000.*pi*ciacr(mgs) ) )**(1./3.) ! avg. diameter of newly frozen drops in microns - csplinter(mgs) = lawson_splinter_fac*tmpdiam**4*ciacr(mgs) + fac = 1.0 + IF ( nsplinter .eq. 1001 ) THEN + ! fac = 0.2/sqrt(2.0*pi*10.**2)*Exp(-0.5*((258.-temg(mgs))/10.)**2 ) ! temperature dependence from Sullivan et al. 2018 ACP + ! ELSE + fac = 0.2*Exp(-0.5*((258.-temg(mgs))/10.)**2 ) ! temperature dependence from Sullivan et al. 2018 ACP + ENDIF + csplinter(mgs) = fac*lawson_splinter_fac*tmpdiam**4*ciacr(mgs) ENDIF ELSEIF ( nsplinter .ge. 0 ) THEN csplinter(mgs) = nsplinter*ciacr(mgs) @@ -16961,7 +17387,7 @@ subroutine nssl_2mom_gs & if ( ipconc .ge. 2 .or. ipelec .ge. 9 ) then do mgs = 1,ngscnt ciacw(mgs) = 0.0 - IF ( eiw(mgs) .gt. 0.0 ) THEN + IF ( eiw(mgs) .gt. 0.0 .and. xmas(mgs,lc) > 0.0 ) THEN ciacw(mgs) = qiacw(mgs)*rho0(mgs)/xmas(mgs,lc) ciacw(mgs) = min(ciacw(mgs),ccmxd(mgs)) ENDIF @@ -16972,6 +17398,7 @@ subroutine nssl_2mom_gs & if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 18' if ( ipconc .ge. 2 .or. ipelec .ge. 1 ) then do mgs = 1,ngscnt + tmp1 = 0.0 cracw(mgs) = 0.0 cracr(mgs) = 0.0 ec0(mgs) = 1.e9 @@ -16987,7 +17414,7 @@ subroutine nssl_2mom_gs & & + 2.0*gf2*xdia(mgs,lc,1)*xdia(mgs,lr,1) & & + gf3*xdia(mgs,lr,2) ) ENDIF - ELSE ! IF ( ipconc .ge. 3 .and. + ELSE ! IF ( ipconc .ge. 3 .and. ) IF ( dmrauto <= 0 .or. rho0(mgs)*qx(mgs,lr) > 1.2*xl2p(mgs) ) THEN !{ IF ( 0.5*xdia(mgs,lr,3) .gt. rh(mgs) ) THEN ! { .or. cx(mgs,lr) .gt. nh(mgs) ! IF ( qx(mgs,lc) .gt. qxmin(lc) .and. qx(mgs,lr) .gt. qxmin(lr) ) THEN @@ -17016,7 +17443,7 @@ subroutine nssl_2mom_gs & ! Rain self collection (cracr) and break-up (factor of ec0) ! ! - ec0(mgs) = 2.e9 + ec0(mgs) = 1.0 ! 2.e9 IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN rwrad = 0.5*xdia(mgs,lr,3) @@ -17032,38 +17459,120 @@ subroutine nssl_2mom_gs & tmp = xdia(mgs,lr,3) - 0.1e-3 ENDIF -! IF ( xdia(mgs,lr,3) .gt. 2.0e-3 .or. icracr <= 0 ) THEN - IF ( tmp .gt. 1.9e-3 .or. icracr <= 0 ) THEN +! Using collection efficiency factor ec0 to simulate break-up that off-sets self-collection (Zieger 1985; Cohard & Pinty 2000) +! ec0 is 1 for rain diameter < 600 microns and then drop off toward zero until diameter of 2mm to represent passive breakup +! ec0 does not go negative here (i.e., does not follow other versions that create extra breakup at large rain diameter) + IF ( ( tmp .gt. 1.9e-3 .and. irainbreak /= 10 .and. irainbreak /= 20 ) .or. icracr <= 0 ) THEN ec0(mgs) = 0.0 cracr(mgs) = 0.0 + IF ( ibincracr == 3 ) THEN + tmp1 = aa1*(cx(mgs,lr)*xv(mgs,lr))**2* & + & (alpha(mgs,lr) + 6.)*(alpha(mgs,lr) + 5.)*(alpha(mgs,lr) + 4.)/ & + & ((alpha(mgs,lr) + 3.)*(alpha(mgs,lr) + 2.)*(alpha(mgs,lr) + 1.)) + ENDIF ELSE IF ( dmrauto <= 0 .or. rho0(mgs)*qx(mgs,lr) > 1.2*xl2p(mgs) ) THEN - IF ( xdia(mgs,lr,3) .lt. 6.1e-4 ) THEN + + IF ( xdia(mgs,lr,3) .lt. 6.1e-4 .or. irainbreak == 10 ) THEN ec0(mgs) = 1.0 ELSE - ec0(mgs) = Exp(-50.0*(50.0*(xdia(mgs,lr,3) - 6.0e-4))) + ec0(mgs) = Exp( -2500.0*(xdia(mgs,lr,3) - 6.0e-4) ) ENDIF + IF ( rwrad .ge. 50.e-6 ) THEN - cracr(mgs) = ec0(mgs)*aa2*cx(mgs,lr)**2*xv(mgs,lr) + tmp1 = aa2*cx(mgs,lr)**2*xv(mgs,lr) + cracr(mgs) = ec0(mgs)*tmp1 + IF ( irainbreak == 20 ) THEN + cracr(mgs) = tmp1 + ENDIF ELSE IF ( imurain == 3 ) THEN cracr(mgs) = ec0(mgs)*aa1*(cx(mgs,lr)*xv(mgs,lr))**2* & & (alpha(mgs,lr) + 2.)/(alpha(mgs,lr) + 1.) ELSE ! imurain == 1 - cracr(mgs) = ec0(mgs)*aa1*(cx(mgs,lr)*xv(mgs,lr))**2* & + tmp1 = aa1*(cx(mgs,lr)*xv(mgs,lr))**2* & & (alpha(mgs,lr) + 6.)*(alpha(mgs,lr) + 5.)*(alpha(mgs,lr) + 4.)/ & & ((alpha(mgs,lr) + 3.)*(alpha(mgs,lr) + 2.)*(alpha(mgs,lr) + 1.)) - + cracr(mgs) = ec0(mgs)*tmp1 + IF ( irainbreak == 20 ) THEN + cracr(mgs) = tmp1 + ENDIF ENDIF - ENDIF + ENDIF ! rwrad > 50 ! cracr(mgs) = Min(cracr(mgs),crmxd(mgs)) - ENDIF - ENDIF - ENDIF + ENDIF ! dmrauto <= 0 + ENDIF ! tmp > 1.9e-3 + + IF ( irainbreak == 100 ) THEN ! Morrison breakup + ec0(mgs) = 1.0 + IF ( xdia(mgs,lr,1) > 300.e-6 ) THEN + ec0(mgs) = 2. - Exp(2300.*(xdia(mgs,lr,1)-300.e-6)) + ENDIF + cracr(mgs) = 5.78*ec0(mgs)*cx(mgs,lr)*qx(mgs,lr) + ENDIF + + ENDIF ! ( qx(mgs,lr) .gt. qxmin(lr) ) + + ! active breakup option + crbreak = 0.0 + IF ( irainbreak == 1 .or. irainbreak == 10 ) THEN + crbreak = Max( 0.0, rainbreakfac* (rho0(mgs)*qx(mgs,lr))**2 ) ! hand fit to lower range of wkqss output + cracr(mgs) = cracr(mgs) - crbreak ! cracr is subtracted, so negative value for breakup + ELSEIF ( irainbreak == 2 .or. irainbreak == 20 ) THEN + ! irainbreak == 20 does not work as intended + crbreak = Max( 0.0, rainbreakfac*(1. - ec0(mgs))*(rho0(mgs)*qx(mgs,lr))**2 ) ! hand fit to lower range of wkqss output +! crbreak = Max(0.0, -0.18 + 1.139e6 * (rho0(mgs)*qx(mgs,lr) + 0.00038106)**2) + cracr(mgs) = cracr(mgs) - crbreak ! cracr is subtracted, so negative value for breakup + ELSEIF ( irainbreak == 11 .and. rho0(mgs)*qx(mgs,lr) > qrbrthresh1 .and. ipconc >= 5 ) THEN + + ! Ad hoc method to break up drops in the DSD tail (D > draintail) + + ratio = Min( maxratiolu, draintail/xdia(mgs,lr,1) ) + ! mass + tmp2 = gaminterp(ratio,alpha(mgs,lr),4,1) + qxd1 = qx(mgs,lr)*(tmp2) + qrbreak = dtpinv*qxd1 + + crbreaksmall = rho0(mgs)*qrbreak/(xdn(mgs,lr)*pi/6.*drsmall**3) + IF ( ( qxd1 > qxmin(lr)) ) THEN + + ! number + tmp = gaminterp(ratio,alpha(mgs,lr),1,1) + IF ( ipconc == 5 ) THEN + ! tmp = Min( 0.2, tmp ) + ENDIF + cxd1 = cx(mgs,lr)*( tmp) + IF ( rho0(mgs)*qx(mgs,lr) > qrbrthresh2 ) THEN + flim = 1.0 + ELSE + flim = (rho0(mgs)*qx(mgs,lr) - qrbrthresh1)/(qrbrthresh2 - qrbrthresh1) + ENDIF + crbreak = flim*(crbreaksmall - dtpinv*cxd1) + +! IF ( kgs(mgs) == 1 .and. qx(mgs,lr) > 0.1e-3 ) THEN +! write(0,*) 'crbreak: ',crbreak,crbreaksmall,dtpinv*cxd1,cx(mgs,lr),cracr(mgs) - crbreak +! ENDIF + cracr(mgs) = cracr(mgs) - crbreak ! cracr is subtracted, so negative value for breakup + + ! reflectivity -- not used yet: goes into zracr +! IF ( ipconc >= 6 .and. lzr > 1 ) THEN +! tmp3 = gaminterp(ratio,alpha(mgs,lr),11,1) +! zxd1 = zx(mgs,lr)*(tmp3) +! zrbreak = dtpinv*zxd1 +! ELSE +! zxd1 = 0 +! ENDIF +! zrbreak = Max(0.0, zrbreak - crbreaksmall*drsmall**6) + ELSEIF ( irainbreak == 12 ) THEN + crbreak = Max( 0.0, 3.8098 * (rho0(mgs)*qx(mgs,lr))**1.9416 ) ! best fit to lower range of wkqss (collision only) output + cracr(mgs) = cracr(mgs) - crbreak ! cracr is subtracted, so negative value for breakup + ENDIF + ENDIF ! cracw(mgs) = min(cracw(mgs),cxmxd(mgs,lc)) + end do end if @@ -17144,24 +17653,6 @@ subroutine nssl_2mom_gs & end if - chacis(:) = 0.0 - if ( lis > 1 .and. ipconc .ge. 5 .or. ipelec .ge. 1 ) then - do mgs = 1,ngscnt - IF ( ehis(mgs) .gt. 0.0 .or. ( ehisclsn(mgs) > 0.0 .and. ipelec > 0 )) THEN - - vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,lis,1))**2 + & - & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,lis,1) ) - - chacis0(mgs) = 0.25*pi*ehisclsn(mgs)*cx(mgs,lh)*cx(mgs,lis)*vt* & - & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & - & dab0lh(mgs,lh,lis)*xdia(mgs,lh,3)*xdia(mgs,lis,3) + & - & da0(lis)*xdia(mgs,lis,3)**2 ) - - - chacis(mgs) = min(ehis(mgs)*chacis0(mgs),cxmxd(mgs,lis)) - ENDIF - end do - end if ! ! if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22nn' @@ -17269,28 +17760,6 @@ subroutine nssl_2mom_gs & end if - IF ( lis > 1 .and. ipconc .ge. 5) THEN - - if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22kk' - chlacis(:) = 0.0 - chlacis0(:) = 0.0 - do mgs = 1,ngscnt - IF ( lhl .gt. 1 .and. ( ehlis(mgs) .gt. 0.0 .or. (ipelec > 0 .and. ehlisclsn(mgs) > 0.0) ) ) THEN - - vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,lis,1))**2 + & - & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,lis,1) ) - - chlacis0(mgs) = 0.25*pi*ehlisclsn(mgs)*cx(mgs,lhl)*cx(mgs,lis)*vt* & - & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & - & dab0(lhl,lis)*xdia(mgs,lhl,3)*xdia(mgs,lis,3) + & - & da0(lis)*xdia(mgs,lis,3)**2 ) - - - chlacis(mgs) = min(ehlis(mgs)*chlacis0(mgs),cxmxd(mgs,lis)) - ENDIF - end do - ENDIF - ! ! if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22jj' @@ -17380,7 +17849,8 @@ subroutine nssl_2mom_gs & tmp = crcnw(mgs) tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) ! try mass*diameter-weighted average of old and new Dmr (using full qc mass) - crcnw(mgs) = (tmp*xdia(mgs,lc,3)*qx(mgs,lc)+tmp2*xdia(mgs,lr,3)*qx(mgs,lr))/(xdia(mgs,lc,3)*qx(mgs,lc)+xdia(mgs,lr,3)*qx(mgs,lr)) + crcnw(mgs) = (tmp*xdia(mgs,lc,3)*qx(mgs,lc)+tmp2*xdia(mgs,lr,3)*qx(mgs,lr))/ & + (xdia(mgs,lc,3)*qx(mgs,lc)+xdia(mgs,lr,3)*qx(mgs,lr)) ELSEIF ( ( dmropt == 7 ) .and. qx(mgs,lr) > qxmin(lr) ) THEN tmp = crcnw(mgs) tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) @@ -17390,7 +17860,8 @@ subroutine nssl_2mom_gs & tmp = crcnw(mgs) tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) ! try sqrt(diameter)-weighted average of old and new Dmr - crcnw(mgs) = (tmp*sqrt(xdia(mgs,lc,3))+tmp2*sqrt(xdia(mgs,lr,3)))/(sqrt(xdia(mgs,lc,3))+sqrt(xdia(mgs,lr,3))) + crcnw(mgs) = (tmp*sqrt(xdia(mgs,lc,3))+tmp2*sqrt(xdia(mgs,lr,3)))/ & + (sqrt(xdia(mgs,lc,3))+sqrt(xdia(mgs,lr,3))) ENDIF ELSEIF ( dmrauto == 1 .and. cx(mgs,lr) > cxmin) THEN IF ( qx(mgs,lr) > qxmin(lr) ) THEN @@ -17659,16 +18130,45 @@ subroutine nssl_2mom_gs & ELSE !{ - - IF ( ipconc >= 6 .and. lzr > 1 ) THEN + + IF ( ipconc >= 5 .or. lzr > 1 ) THEN + + cxd1 = crfrz(mgs)*dtp + qxd1 = qrfrz(mgs)*dtp + ! interpolate along x, i.e., ratio; tmp1 = ziacrratio(i,j) + delx*dqiacrratioinv*(ziacrratio(ip1,j) - ziacrratio(i,j)) tmp2 = ziacrratio(i,jp1) + delx*dqiacrratioinv*(ziacrratio(ip1,jp1) - ziacrratio(i,jp1)) ! interpolate along alpha; - zrfrz(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*zx(mgs,lr)*dtpinv + IF ( ipconc >= 6 .and. lzr > 1 ) THEN + zxd1 = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*zx(mgs,lr) + ! Do the correction for alphamax + zrfrz(mgs) = zxd1*dtpinv + ! tmp4 is the Z from the converted particles assuming shape of alphamax + tmp3 = g1xmax*(rho0(mgs)*qxd1)**2/((pi*xdn(mgs,lh)/6.0)**2) + tmp4 = tmp3/cxd1 + IF ( tmp4 > zxd1 ) THEN ! calculate new graupel/fd number to match zxd1 + ! increase cxd1 to make z,q,c rates consistent + ! cxd1 = g1xmax*(rho0(mgs)*qxd1)**2/(zxd1*(pi*xdn(mgs,lh)/6.0)**2) + cxd1 = tmp3/zxd1 + crfrzf(mgs) = dtpinv*cxd1 + ENDIF + ELSE + ! tmp5 is rain reflectivity moment + tmp5 = g1x(mgs,lr)*(rho0(mgs)*qx(mgs,lr))**2/((pi*xdn(mgs,lr)/6.)**2*cx(mgs,lr)) + zxd1 = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*tmp5 + ! tmp4 is the reflectivity of the newly-converted graupel particles (use g1x(lh) for loss term) + ! which we want to match zxd1 to prevent spurious increase in total reflectivity + tmp3 = g1x(mgs,lr)*(rho0(mgs)*qxd1)**2/((pi*xdn(mgs,lr)/6.0)**2) + tmp4 = tmp3/cxd1 + IF ( tmp4 > zxd1 ) THEN ! calculate new FD number to match zxd1 + crfrzf(mgs) = tmp3/zxd1*dtpinv + ENDIF + ENDIF ENDIF + IF ( ibiggsmallrain > 0 .and. xv(mgs,lr) < 2.*xvmn(lr) .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN ! IF ( ibiggsmallrain > 0 .and. xv(mgs,lr) < xvbiggsnow .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN @@ -17706,7 +18206,7 @@ subroutine nssl_2mom_gs & ! j = Int(Max(0.0,Min(15.,alpha(mgs,lr)))*dqiacralphainv) ! j = Int(Max(alphamin,Min(alphamax,alpha(mgs,lr)))*dqiacralphainv) IF ( alp0flag ) THEN - j = Int(Max(0.0,Min(15.,alpha(mgs,lr)))*dqiacralphainv) + j = Int(Max(0.0,Min(alphamax,alpha(mgs,lr)))*dqiacralphainv) ELSE j = Int(Max(minalphalu,Min(maxalphalu,alpha(mgs,lr)))*dqiacralphainv) ENDIF @@ -17892,7 +18392,13 @@ subroutine nssl_2mom_gs & tmp = 0 IF ( qrfrz(mgs)*dtp > qxmin(lh) .and. crfrz(mgs) > 1.e-3 ) THEN tmpdiam = 1.e6*( 6.*qrfrz(mgs)/(1000.*pi*crfrz(mgs) ))**(1./3.) ! avg. diameter of newly frozen drops in microns - tmp = lawson_splinter_fac*tmpdiam**4*crfrz(mgs) + fac = 1.0 + IF ( nsplinter .eq. 1001 ) THEN + ! fac = 0.2/sqrt(2.0*pi*10.**2)*Exp(-0.5*((258.-temg(mgs))/10.)**2 ) ! temperature dependence from Sullivan et al. 2018 ACP + ! ELSE + fac = 0.2*Exp(-0.5*((258.-temg(mgs))/10.)**2 ) ! temperature dependence from Sullivan et al. 2018 ACP + ENDIF + tmp = fac*lawson_splinter_fac*tmpdiam**4*crfrz(mgs) ENDIF ELSEIF ( nsplinter .gt. 0 ) THEN tmp = nsplinter*crfrz(mgs) @@ -18358,6 +18864,7 @@ subroutine nssl_2mom_gs & IF ( ipconc >= 7 ) THEN + ! vent coeff. for reflectivity rate from evaporation alpr = Min(alpharmax,alpha(mgs,lr) ) tmp = alpr + 5.5 + br/2. @@ -18667,8 +19174,6 @@ subroutine nssl_2mom_gs & ELSEIF ( ibinhlmlr == 1 ) THEN ! use incomplete gamma functions to approximate the bin results -! #ifdef 1 -! #if (defined 1) && defined( COMMAS ) || defined( COMMASTMP ) ELSEIF ( ibinhlmlr == -1 ) THEN ! OLD VERSION use incomplete gamma functions to approximate the bin results @@ -19119,11 +19624,11 @@ subroutine nssl_2mom_gs & felscptmp = (fels(mgs)-rw*temg(mgs))/cvm ENDIF - IF ( eqtset > 2 ) THEN - pipert(mgs) = pipert(mgs) + (0 & - & +felspi(mgs)*dqci(mgs) & - & +felvpi(mgs)*dqcw(mgs))*dtp - ENDIF +! IF ( eqtset > 2 ) THEN +! pipert(mgs) = pipert(mgs) + (0 & +! & +felspi(mgs)*dqci(mgs) & +! & +felvpi(mgs)*dqcw(mgs)) ! *dtp +! ENDIF ! ! @@ -19141,7 +19646,13 @@ subroutine nssl_2mom_gs & tqvcon = temgtmp-cbw ltemq = (temgtmp-163.15)/fqsat+1.5 ltemq = Min( nqsat, Max(1,ltemq) ) - qvstmp = pqs(mgs)*tabqvs(ltemq) + + IF ( iqvsopt == 0 ) THEN + qvstmp = pqs(mgs)*tabqvs(ltemq) + ELSEIF ( iqvsopt == 1 ) THEN + qvstmp = rdorv*esbolton*tabqvs(ltemq)/(pres(mgs) - esbolton*tabqvs(ltemq)) + ENDIF + qisstmp = pqs(mgs)*tabqis(ltemq) qctmp(mgs) = max( 0.0, qctmp(mgs) ) qitmp(mgs) = max( 0.0, qitmp(mgs) ) @@ -19365,8 +19876,8 @@ subroutine nssl_2mom_gs & ! ELSE ! cscnis(mgs) = 0.0 ! ENDIF + ! write(91,*) 'qi,qscni = ',igs(mgs),kgs(mgs),qx(mgs,li),qscni(mgs),cscnis(mgs),qidpv(mgs) ENDIF - IF ( iscni .ne. 4 ) THEN ! crystal aggregation to become snow ! erm 9/5/08 commented second line and added xv to 1st line (zrnic et al 1993) @@ -19407,7 +19918,133 @@ subroutine nssl_2mom_gs & end if end do + IF ( incwet < 1 ) THEN + dhwet(:) = d1t + dhlwet(:) = d1t + dfwet(:) = d1t + ENDIF + IF ( incwet >= 1 ) THEN + ! 'incwet' = incomplete gamma for wet growth + ! Find diameter where wet growth starts, then compute dry and wet growth + ! over [dwet,infinity]. Subtract dry growth from qxacw etc. to get total + ! dry growth part + dhwet(:) = dg0thresh + 0.0001 + dhlwet(:) = dg0thresh + 0.0001 + dfwet(:) = dg0thresh + 0.0001 + + DO mgs = 1,ngscnt + + sqrtrhovt = Sqrt( rhovt(mgs) ) + fventh = sqrtrhovt*(fpndl(mgs)**(1./3.)) * (fakvisc(mgs))**(-0.5) + fventm = sqrtrhovt*(fschm(mgs)**(1./3.)) * (fakvisc(mgs))**(-0.5) + ltemq = (tfr-163.15)/fqsat+1.5 + qvs0 = pqs(mgs)*tabqvs(ltemq) + denomdp = felf(mgs) + fcw(mgs)*temcg(mgs) + denominvdp = 1.d0/(felf(mgs) + fcw(mgs)*temcg(mgs)) + + IF (((qhacw(mgs) + qhacr(mgs))*dtp > qxmin(lh) .and. qx(mgs,lh) > hlcnhqmin .and. & + temg(mgs) .le. tfr + wetgrthtoffset .and. temg(mgs) .ge. 243.15 ) ) THEN +! dw = 0.01*( Exp( -temcg(mgs)/( 1.1e4 * rho0(mgs)*ehw(mgs)*qx(mgs,lc) - 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0 ) ) - 1.0 ) +! dwr = 0.01*( Exp( -temcg(mgs)/( 1.1e4 * rho0(mgs)*(ehw(mgs)*qx(mgs,lc)+ehr(mgs)*qx(mgs,lr)) - & +! 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0 ) ) - 1.0 ) + x = 1.1e4 * rho0(mgs)*(ehw(mgs)*qx(mgs,lc)+ehr(mgs)*qx(mgs,lr)) - & + 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0 + IF ( x > 1.e-20 ) THEN + arg = Min(70.0, (-temcg(mgs)/x )) ! prevent overflow of the exp function in 32 bit + dwr = 0.01*(exp(arg) - 1.0) + ELSE + dwr = 1.e30 + ENDIF + d = dwr + + IF ( dwr < 0.2 .and. dwr > 0.0 .and. rho0(mgs)*(qx(mgs,lc)+qx(mgs,lr)) > 1.e-4 ) THEN + + h1 = ( -ftka(mgs)*temcg(mgs) - felv(mgs)*fwvdf(mgs)*rho0(mgs)*(qx(mgs,lv) - qvs0) ) + h2 = ehi(mgs)*qx(mgs,li)*rho0(mgs)*fci(mgs)*temcg(mgs) + h3 = Max(dwehwmin, ehw(mgs))*qx(mgs,lc) + h4 = ehr(mgs)* qx(mgs,lr) + ! iterate to find minimum diameter for wet growth. Start with value of dwr + DO n = 1,10 + d = Max(d, 1.e-4) + dold = d + vth = axx(mgs,lh)*d**bxx(mgs,lh) + x2 = fventh*sqrtrhovt*Sqrt(d*vth) + IF ( x2 > 1.4 ) THEN + ah = 0.78 + 0.308*x2 ! heat ventillation + ELSE + ah = 1.0 + 0.108*x2**2 ! mass ventillation (Beard and Pruppacher 1971, eq. 9) + ENDIF + + + d = 8.*ah*h1/ & + ( ( Max(0.001,vth - vtxbar(mgs,lc,1))*h3 + & + Max(0.001,vth - vtxbar(mgs,lr,1))*h4) *rho0(mgs)*denomdp + & + Max(0.001,vth - vtxbar(mgs,li,1))*h2) + + IF ( Abs(dold - d)/dold < 0.05 .or. ( n > 3 .and. d > dg0thresh ) ) EXIT + + ENDDO + ENDIF + + dhwet(mgs) = Min(dg0thresh + 0.0001, Max( d, dwetmin )) + ELSE + dhwet(mgs) = dg0thresh + 0.0001 + ENDIF + + IF (((qhlacw(mgs) + qhlacr(mgs))*dtp > qxmin(lhl) .and. qx(mgs,lhl) > 0.01e-3 & + .and. temg(mgs) .le. tfr + wetgrthtoffset .and. temg(mgs) .ge. 243.15 ) ) THEN +! dw = 0.01*( Exp( -temcg(mgs)/( 1.1e4 * rho0(mgs)*ehlw(mgs)*qx(mgs,lc) - 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0 ) ) - 1.0 ) +! dwr = 0.01*( Exp( -temcg(mgs)/( 1.1e4 * rho0(mgs)*(ehlw(mgs)*qx(mgs,lc)+ehlr(mgs)*qx(mgs,lr)) - & +! 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0 ) ) - 1.0 ) + x = 1.1e4 * rho0(mgs)*(ehlw(mgs)*qx(mgs,lc)+ehlr(mgs)*qx(mgs,lr)) - & + 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0 + IF ( x > 1.e-20 ) THEN + arg = Min(70.0, (-temcg(mgs)/x )) ! prevent overflow of the exp function in 32 bit + dwr = 0.01*(exp(arg) - 1.0) + ELSE + dwr = 1.e30 + ENDIF + d = dwr + IF ( dwr < 0.2 .and. dwr > 0.0 .and. rho0(mgs)*(qx(mgs,lc)+qx(mgs,lr)) > 1.e-4 ) THEN + +! write(91,*) 'dw,dwr,temcg = ',100.*dw,100.*dwr,temcg(mgs) + h1 = ( -ftka(mgs)*temcg(mgs) - felv(mgs)*fwvdf(mgs)*rho0(mgs)*(qx(mgs,lv) - qvs0) ) + h2 = ehi(mgs)*qx(mgs,li)*rho0(mgs)*fci(mgs)*temcg(mgs) + h3 = Max(dwehwmin, ehlw(mgs))*qx(mgs,lc) + h4 = ehlr(mgs)* qx(mgs,lr) + ! iterate to find minimum diameter for wet growth. Start with value of dwr + DO n = 1,10 + d = Max(d, 1.e-4) + dold = d + vth = axx(mgs,lhl)*d**bxx(mgs,lhl) + x2 = fventh*sqrtrhovt*Sqrt(d*vth) + IF ( x2 > 1.4 ) THEN + ah = 0.78 + 0.308*x2 ! heat ventillation + ELSE + ah = 1.0 + 0.108*x2**2 ! mass ventillation (Beard and Pruppacher 1971, eq. 9) + ENDIF + + + d = 8.*ah*h1/ & + ( ( Max(0.001,vth - vtxbar(mgs,lc,1))*h3 + & + Max(0.001,vth - vtxbar(mgs,lr,1))*h4) *rho0(mgs)*denomdp + & + Max(0.001,vth - vtxbar(mgs,li,1))*h2) + + IF ( Abs(dold - d)/dold < 0.05 .or. ( n > 3 .and. d > dg0thresh ) ) EXIT + + ENDDO + ENDIF + + dhlwet(mgs) = Min(dg0thresh + 0.0001, Max( d, dwetmin ) ) + ELSE + dhlwet(mgs) = dg0thresh + 0.0001 + ENDIF + + + ENDDO + + ENDIF ! incwet @@ -19448,12 +20085,88 @@ subroutine nssl_2mom_gs & ! IF ( dnu(lh) .ne. 0. ) THEN ! qhwet(mgs) = qhdry(mgs) ! ELSE - IF ( incwet == 0 ) THEN + ! IF ( incwet == 0 ) THEN qhwet(mgs) = & & ( xdia(mgs,lh,1)*hwvent(mgs)*cx(mgs,lh)*fwet1(mgs) & & + fwet2(mgs)*(qhaci(mgs) + qhacs(mgs)) ) - qhwet(mgs) = max( 0.0, qhwet(mgs)) - ELSE + qhwet(mgs) = max( 0.0, qhwet(mgs)) + + IF ( incwet == 1 .and. qhwet(mgs) < qhdry(mgs) .and. dhwet(mgs) < dg0thresh ) THEN + ! ELSE + ! IF ( dhwet(mgs) < dg0thresh ) THEN + ! find portion of qc and qr collection that are dry/wet growth for d > dwet + + ratio = Min( maxratiolu, dhwet(mgs)/xdia(mgs,lh,1) ) + + tmp1 = gaminterp(ratio,alpha(mgs,lh),13,1) ! alpha + 3 + tmp2 = gaminterp(ratio,alpha(mgs,lh),12,1) ! alpha + 2 + tmp3 = gaminterp(ratio,alpha(mgs,lh), 9,1) ! alpha + 1 + + IF ( qhacw(mgs)*dtp > qxmin(lh) ) THEN + vt = abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1)) + + qxacwtmp = 0.25*pi*ehw(mgs)*cx(mgs,lh)*(qx(mgs,lc)-qcwresv(mgs))*vt* & + & ( tmp1*da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & tmp2*dab1lh(mgs,lh,lc)*xdia(mgs,lh,3)*xdia(mgs,lc,3) + & + & tmp3*da1lc(mgs)*xdia(mgs,lc,3)**2 ) + ELSE + qxacwtmp = 0.0 + ENDIF + + IF ( qhacr(mgs)*dtp > qxmin(lh) ) THEN + + vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,lr,1))**2 + & + & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,lr,1) ) + + qxacrtmp = 0.25*pi*ehr(mgs)*cx(mgs,lh)*qx(mgs,lr)*vt* & + & ( tmp1*da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & tmp2*dab1lh(mgs,lh,lr)*xdia(mgs,lh,3)*xdia(mgs,lr,3) + & + & tmp3*da1lr(mgs)*xdia(mgs,lr,3)**2 ) + ELSE + qxacrtmp = 0.0 + ENDIF + + ! hwvent is where the size dependency is, so hxventtmp gives the portion for d > dwet + x = gaminterp(ratio,alpha(mgs,lh),9,1) ! alpha + 1 + y = gaminterp(ratio,alpha(mgs,lh),3,1) ! alpha + b/2 + 5/2 + + hxventtmp = 0.78*x + y*hwventy(mgs) ! & + + ! find the ice and snow collection for d > dwet + qxacitmp = 0.0 + IF ( qhaci(mgs)*dtp > qxmin(lh) ) THEN + vt = abs(vtxbar(mgs,lh,1)-vtxbar(mgs,li,1)) + + qxacitmp = 0.25*pi*ehiclsn(mgs)*cx(mgs,lh)*qx(mgs,li)*vt* & + & ( tmp1*da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & tmp2*dab1lh(mgs,lh,li)*xdia(mgs,lh,3)*xdia(mgs,li,3) + & + & tmp3*da1(li)*xdia(mgs,li,3)**2 ) + ENDIF + + qxacstmp = 0.0 + IF ( qhacs(mgs)*dtp > qxmin(lh) ) THEN + vt = abs(vtxbar(mgs,lh,1)-vtxbar(mgs,ls,1)) + + qxacstmp = 0.25*pi*ehsclsn(mgs)*cx(mgs,lh)*qx(mgs,ls)*vt* & + & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & dab1lh(mgs,lh,ls)*xdia(mgs,lh,3)*xdia(mgs,ls,3) + & + & da1(ls)*xdia(mgs,ls,3)**2 ) + ENDIF + + qxwettmp = & + & xdia(mgs,lh,1)*hxventtmp*cx(mgs,lh)*fwet1(mgs) & + & + fwet2(mgs)*(qxacitmp + qxacstmp) + + ! as dry growth but subtract part for D > Dw and add wet growth for D > Dw + qhwet(mgs) = qhacw(mgs) + qhacr(mgs) + qhaci(mgs) + qhacs(mgs) & + - ehi(mgs)*qxacitmp - ehs(mgs)*qxacstmp & + - qxacwtmp - qxacrtmp + qxwettmp + + ! qhacw(mgs) = Min( qhacw(mgs), 0.5*qx(mgs,lc)*dtpinv ) + + ! ELSE ! for dwet > 15cm, just assume dry growth + ! qhwet(mgs) = qhdry(mgs) + ! ENDIF ENDIF ! ENDIF @@ -19461,13 +20174,88 @@ subroutine nssl_2mom_gs & qhlwet(mgs) = 0.0 IF ( lhl .gt. 1 ) THEN - IF ( incwet == 0 ) THEN + !IF ( incwet == 0 ) THEN qhlwet(mgs) = & & ( xdia(mgs,lhl,1)*hlvent(mgs)*cx(mgs,lhl)*fwet1(mgs) & & + fwet2(mgs)*(qhlaci(mgs) + qhlacs(mgs)) ) qhlwet(mgs) = max( 0.0, qhlwet(mgs)) - ELSE + IF ( incwet == 1 .and. qhlwet(mgs) < qhldry(mgs) .and. dhlwet(mgs) < dg0thresh ) THEN + !ELSE +!! || defined (WRFEXTRAS) + ! IF ( dhlwet(mgs) < dg0thresh ) THEN + ! find portion of qc and qr collection that are dry/wet growth for d > dwet + + ratio = Min( maxratiolu, dhlwet(mgs)/xdia(mgs,lhl,1) ) + + tmp1 = gaminterp(ratio,alpha(mgs,lhl),13,2) ! alpha + 3 + tmp2 = gaminterp(ratio,alpha(mgs,lhl),12,2) ! alpha + 2 + tmp3 = gaminterp(ratio,alpha(mgs,lhl), 9,2) ! alpha + 1 + + IF ( qhlacw(mgs)*dtp > qxmin(lhl) ) THEN + vt = abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,lc,1)) + + qxacwtmp = 0.25*pi*ehlw(mgs)*cx(mgs,lhl)*(qx(mgs,lc)-qcwresv(mgs))*vt* & + & ( tmp1*da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & tmp2*dab1lh(mgs,lhl,lc)*xdia(mgs,lhl,3)*xdia(mgs,lc,3) + & + & tmp3*da1lc(mgs)*xdia(mgs,lc,3)**2 ) + ELSE + qxacwtmp = 0.0 + ENDIF + + IF ( qhlacr(mgs)*dtp > qxmin(lhl) ) THEN + + vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,lr,1))**2 + & + & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,lr,1) ) + + qxacrtmp = 0.25*pi*ehlr(mgs)*cx(mgs,lhl)*qx(mgs,lr)*vt* & + & ( tmp1*da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & tmp2*dab1lh(mgs,lhl,lr)*xdia(mgs,lhl,3)*xdia(mgs,lr,3) + & + & tmp3*da1lr(mgs)*xdia(mgs,lr,3)**2 ) + ELSE + qxacrtmp = 0.0 + ENDIF + + x = gaminterp(ratio,alpha(mgs,lhl),9,2) ! alpha + 1 + y = gaminterp(ratio,alpha(mgs,lhl),3,2) ! alpha + b/2 + 5/2 + + hxventtmp = 0.78*x + y*hlventy(mgs) ! & + + qxacitmp = 0.0 + IF ( qhlaci(mgs)*dtp > qxmin(lhl) ) THEN + vt = abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,li,1)) + + qxacitmp = 0.25*pi*ehliclsn(mgs)*cx(mgs,lhl)*qx(mgs,li)*vt* & + & ( tmp1*da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & tmp2*dab1lh(mgs,lhl,li)*xdia(mgs,lhl,3)*xdia(mgs,li,3) + & + & tmp3*da1(li)*xdia(mgs,li,3)**2 ) + ENDIF + + qxacstmp = 0.0 + IF ( qhlacs(mgs)*dtp > qxmin(lhl) ) THEN + vt = abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,ls,1)) + + qxacstmp = 0.25*pi*ehlsclsn(mgs)*cx(mgs,lhl)*qx(mgs,ls)*vt* & + & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & dab1lh(mgs,lhl,ls)*xdia(mgs,lhl,3)*xdia(mgs,ls,3) + & + & da1(ls)*xdia(mgs,ls,3)**2 ) + ENDIF + + qxwettmp = & + & xdia(mgs,lhl,1)*hxventtmp*cx(mgs,lhl)*fwet1(mgs) & + & + fwet2(mgs)*(qxacitmp + qxacstmp) + + ! qhlacw(mgs) + qhlacr(mgs) - qxacwtmp - qxacrtmp is the 'dry' growth + ! at smaller diameters +! qhlwet(mgs) = qhlacw(mgs) + qhlacr(mgs) - qxacwtmp - qxacrtmp + qxwettmp + ! as dry growth but subtract part for D > Dw and add wet growth for D > Dw + qhlwet(mgs) = qhlacw(mgs) + qhlacr(mgs) + qhlaci(mgs) + qhlacs(mgs) & + - ehli(mgs)*qxacitmp - ehls(mgs)*qxacstmp & + - qxacwtmp - qxacrtmp + qxwettmp + + ! ELSE + ! qhlwet(mgs) = qhldry(mgs) + ! ENDIF ENDIF ! incwet ENDIF @@ -19876,14 +20664,20 @@ subroutine nssl_2mom_gs & ltest = xdia(mgs,lh,1)*(4. + alpha(mgs,lh)) > Abs( hlcnhdia ) ! test on mass-weighted diameter ENDIF + ! if incwet > 0, then should use dhwet here to avoid calculating again IF ( iusedw == 0 .and. ihlcnh == 1 ) THEN dg0(mgs) = -1. ELSE - IF (((qhacw(mgs) + qhacr(mgs))*dtp > qxmin(lh) .and. qx(mgs,lh) > hlcnhqmin .and. temg(mgs) .le. tfr-2.0 & - .and. temg(mgs) .gt. dwtempmin ) .or. ( wetgrowth(mgs) .and. qx(mgs,lh) > hlcnhqmin ) ) THEN + IF ( temg(mgs) .le. tfr+hailcnvtoffset .and. & + (( (qhacw(mgs) + qhacr(mgs))*dtp > qxmin(lh) .and. qx(mgs,lh) > hlcnhqmin & + .and. temg(mgs) .gt. dwtempmin ) .or. ( wetgrowth(mgs) .and. qx(mgs,lh) > hlcnhqmin )) ) THEN ! dw = 0.01*( Exp( -temcg(mgs)/( 1.1e4 * rho0(mgs)*ehw(mgs)*qx(mgs,lc) - 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0 ) ) - 1.0 ) ! dwr = 0.01*( Exp( -temcg(mgs)/( 1.1e4 * rho0(mgs)*(ehw(mgs)*qx(mgs,lc)+ehr(mgs)*qx(mgs,lr)) - & ! 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0 ) ) - 1.0 ) + IF ( incwet > 0 ) THEN + d = dhwet(mgs) + ELSE + ! First guess for dwet (not that good, but it is something) x = 1.1e4 * rho0(mgs)*(ehw(mgs)*qx(mgs,lc)+ehr(mgs)*qx(mgs,lr)) - & 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0 IF ( x > 1.e-20 ) THEN @@ -19892,7 +20686,7 @@ subroutine nssl_2mom_gs & ELSE dwr = 1.e30 ENDIF - d = dwr + d = Min(dwr, dg0thresh + 0.0001) IF ( dwr < 0.2 .and. dwr > 0.0 .and. rho0(mgs)*(qx(mgs,lc)+qx(mgs,lr)) > 1.e-4 ) THEN sqrtrhovt = Sqrt( rhovt(mgs) ) fventh = sqrtrhovt*(fpndl(mgs)**(1./3.)) * (fakvisc(mgs))**(-0.5) @@ -19945,21 +20739,26 @@ subroutine nssl_2mom_gs & IF ( Abs(dold - d)/dold < 0.05 .or. ( n > 3 .and. d > dg0thresh ) ) EXIT ENDDO - ENDIF + + d = Min( d, dg0thresh + 0.0001 ) + ENDIF ! dwr < 0.2 .and. dwr > 0.0 + ENDIF ! incwet - dg0(mgs) = Min( dwmax, Max( d, dwmin ) ) + ! dg0(mgs) = Min( dwmax, Max( d, dwmin ) ) + dg0(mgs) = Max( d, dwmin ) ELSE - IF ( qx(mgs,lh) > qxmin(lh) .and. qx(mgs,lh) > hlcnhqmin .and. temg(mgs) .le. tfr-2.0 ) THEN - dg0(mgs) = dwmax - ELSE + ! IF ( qx(mgs,lh) > qxmin(lh) .and. qx(mgs,lh) > hlcnhqmin .and. temg(mgs) .le. tfr+hailcnvtoffset ) THEN + ! dg0(mgs) = dwmax + ! ELSE dg0(mgs) = dg0thresh + 0.0001 - ENDIF + ! ENDIF ENDIF IF ( ihlcnh == 3 .and. (qhacw(mgs) + qhacr(mgs))*dtp > qxmin(lh) .and. qx(mgs,lh) > hlcnhqmin & - .and. temg(mgs) .le. tfr-2.0 ) THEN + .and. temg(mgs) .le. tfr+hailcnvtoffset .and. temg(mgs) > 238.0 ) THEN ! set a secondary condition on to capture large graupel that is riming but not in wet growth - dg0(mgs) = Min( dg0(mgs), dg0thresh - 0.0001 ) +! dg0(mgs) = Min( dg0(mgs), dg0thresh - 0.0001 ) + dg0(mgs) = Min( dg0(mgs), dwmax ) ENDIF ENDIF @@ -19973,7 +20772,7 @@ subroutine nssl_2mom_gs & & ltest .and. qx(mgs,lh) .gt. hlcnhqmin ) .or. wtest ) THEN ! { ! : xdia(mgs,lh,3) .gt. 2.e-3 .and. qx(mgs,lh) .gt. 1.0e-3 THEN ! 0823.2008 erm test ! IF ( xdia(mgs,lh,3) .gt. 1.e-3 ) THEN - IF ( qhacw(mgs) .gt. 0.0 .and. qhacw(mgs) .gt. qhaci(mgs) .and. temg(mgs) .le. tfr-2.0 ) THEN ! { + IF ( qhacw(mgs) .gt. 0.0 .and. qhacw(mgs) .gt. qhaci(mgs) .and. temg(mgs) .le. tfr+hailcnvtoffset ) THEN ! { ! dh0 is the diameter dividing wet growth from dry growth (Ziegler 1985), modified by MY05 ! dh0 = 0.01*(exp(temcg(mgs)/(1.1e4*(qx(mgs,lc)+qx(mgs,lr)) - ! : 1.3e3*qx(mgs,li) + 1.0e-3 ) ) - 1.0) @@ -19987,6 +20786,7 @@ subroutine nssl_2mom_gs & ELSE dh0 = 1.e30 ENDIF + dg0(mgs) = Min(dh0, dg0thresh + 0.0001) ENDIF ! wtest ! dh0 = Max( dh0, 5.e-3 ) @@ -20021,7 +20821,7 @@ subroutine nssl_2mom_gs & IF ( wtest .and. & - ( qhacw(mgs)*dtp > qxmin(lh) .and. temg(mgs) .lt. tfr-2. .and. qx(mgs,lh) > hlcnhqmin ) ) THEN + ( qhacw(mgs)*dtp > qxmin(lh) .and. temg(mgs) .lt. tfr+hailcnvtoffset .and. qx(mgs,lh) > hlcnhqmin ) ) THEN ! convert number, mass, and reflectivity for d > dw IF ( ipconc == 5 ) THEN ! dg0(mgs) = Min( dg0(mgs), hldia1 ) @@ -20075,10 +20875,42 @@ subroutine nssl_2mom_gs & tmp3 = gaminterp(ratio,alpha(mgs,lh),11,1) zxd1 = flim*zx(mgs,lh)*(tmp3) zhlcnh(mgs) = dtpinv*zxd1 + + ! tmp4 is the Z from the converted particles assuming shape of alphamax + tmp3 = g1xmax*(rho0(mgs)*qxd1)**2/((pi*xdn(mgs,lh)/6.0)**2) + tmp4 = tmp3/cxd1 + IF ( tmp4 > zxd1 ) THEN ! calculate new hail number to match zxd1 + ! increase cxd1 to make z,q,c rates consistent + ! cxd1 = g1xmax*(rho0(mgs)*qxd1)**2/(zxd1*(pi*xdn(mgs,lh)/6.0)**2) + cxd1 = tmp3/zxd1 + chlcnhhl(mgs) = dtpinv*cxd1 + ENDIF ELSE zxd1 = 0 ENDIF + IF ( ipconc == 5 ) THEN ! Adjust cxd1 by reflectivity removed from graupel + tmp3 = gaminterp(ratio,alpha(mgs,lh),11,1) + ! tmp5 is graupel reflectivity moment + tmp5 = g1x(mgs,lh)*(rho0(mgs)*qx(mgs,lh))**2/((pi*xdn(mgs,lh)/6.)**2*cx(mgs,lh)) + zxd1 = flim*(tmp3)*tmp5 + ! tmp4 is the reflectivity of the newly-converted graupel particles (use g1x(lh) for loss term) + ! which we want to match zxd1 to prevent spurious increase in total reflectivity + tmp3 = g1x(mgs,lh)*(rho0(mgs)*qxd1)**2/((pi*xdn(mgs,lh)/6.0)**2) + tmp4 = tmp3/cxd1 + IF ( tmp4 > zxd1 ) THEN ! calculate new hail number to match zxd1 + ! cxd1 = g1x(mgs,lhl)*(rho0(mgs)*qxd1)**2/(zxd1*pi*xdn(mgs,lh)/6.0) ! trial form results in tiny hail + ! want the adjust size of the new hail so that Z is conserved, so increase number of + ! particles to make qxd1,zxd1, and C consistent. + ! want zxd1 = g1x(mgs,lh)*(rho0(mgs)*qxd1)**2/(c*(pi*xdn(mgs,lh)/6.0)**2) + ! Use g1x(mgs,lh) here instead of g1x(mgs,lhl) because rzxhlh will then multiply + ! by g1x(mgs,lhl)/g1x(mgs,lh) + ! cxd1 = g1x(mgs,lh)*(rho0(mgs)*qxd1)**2/(zxd1*(pi*xdn(mgs,lh)/6.0)**2) + cxd1 = tmp3/zxd1 + chlcnhhl(mgs) = dtpinv*cxd1 ! multiplied later by rzxhlh(mgs) + ENDIF + ENDIF + ELSE qhlcnh(mgs) = 0.0 ENDIF @@ -20104,7 +20936,7 @@ subroutine nssl_2mom_gs & ! convert number, mass, and reflectivity for d > hldia1, ! regardless of wet growth status, but as long as riming > 0 DO mgs = 1,ngscnt - IF ( qhacw(mgs)*dtp > qxmin(lh) .and. temg(mgs) .lt. tfr-2. .and. qx(mgs,lh) > qxmin(lh) ) THEN + IF ( qhacw(mgs)*dtp > qxmin(lh) .and. temg(mgs) .lt. tfr+hailcnvtoffset .and. qx(mgs,lh) > qxmin(lh) ) THEN ratio = Min( maxratiolu, hldia1/xdia(mgs,lh,1) ) ! number @@ -20139,7 +20971,7 @@ subroutine nssl_2mom_gs & ! qhlcnh(mgs) = 0.0 ! chlcnh(mgs) = 0.0 if ( wetgrowth(mgs) .and. temg(mgs) .lt. tfr-5. .and. qx(mgs,lh) > qxmin(lh) ) then - if ( qhacw(mgs).gt.1.e-6 .and. xdn(mgs,lh) > 700. ) then + if ( qhacw(mgs).gt.1.e-6 .and. ( xdn(mgs,lh) > 700. .or. lvh == 0 ) ) then qhlcnh(mgs) = & ((pi*xdn(mgs,lh)*cx(mgs,lh)) / (6.0*rho0(mgs)*dtp)) & *exp(-hldia1/xdia(mgs,lh,1)) & @@ -20872,6 +21704,7 @@ subroutine nssl_2mom_gs & ! ! ! + if (ndebug .gt. 0 ) write(0,*) 'dbg = 8a' ! ! @@ -20907,6 +21740,7 @@ subroutine nssl_2mom_gs & ! Cloud ice ! ! IF ( ipconc .ge. 1 ) THEN + if (ndebug .gt. 0 ) write(0,*) 'cloud ice sum' IF ( warmonly < 0.5 ) THEN IF ( ffrzs < 1.0 ) THEN @@ -20952,7 +21786,7 @@ subroutine nssl_2mom_gs & & +chlmul1(mgs) & & + csplinter(mgs) + csplinter2(mgs) & & +csmul(mgs) - + pccii(mgs) = pccii(mgs)*(1. - ffrzs) pccid(mgs) = & ! & il5(mgs)*(-cscni(mgs) - cscnvi(mgs) & ! - cwaci(mgs) & @@ -21073,6 +21907,7 @@ subroutine nssl_2mom_gs & pccii(mgs) = pccii(mgs) - (1.-frac)*il5(mgs)*(cwfrzc(mgs)+cwctfzc(mgs))*(1. - ffrzs) IF ( lhl .gt. 1 ) chlacw(mgs) = frac*chlacw(mgs) + ! STOP ENDIF @@ -21097,16 +21932,16 @@ subroutine nssl_2mom_gs & ! & -csmlr(mgs)/rzxs(mgs) & & -csmlrr(mgs) & & - cimlr(mgs) ) & + & - Min(0.0,cracr(mgs)) & ! cracr is negative if there is enough breakup & -crshr(mgs) !null at this point when wet snow/graupel included pcrwd(mgs) = & & il5(mgs)*(-ciacr(mgs) - crfrz(mgs) ) & ! - cipacr(mgs)) ! > -csacr(mgs) & & - chacr(mgs) - chlacr(mgs) & & +crcev(mgs) & - & - cracr(mgs) + & - Max(0.0,cracr(mgs)) ! > -il5(mgs)*ciracr(mgs) - ELSEIF ( warmonly < 0.8 ) THEN pcrwi(mgs) = & & crcnw(mgs) & @@ -21982,14 +22817,6 @@ subroutine nssl_2mom_gs & zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacr(mgs) ) ! zhacrf(mgs) = g1*zhacr - -! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lh)+dtp*qhacr(mgs))**2)/(cx(mgs,lh)) - - IF ( z > zx(mgs,lh) ) THEN -! zhacr(mgs) = (z - zx(mgs,lh))*dtpinv - ELSE -! zhacr(mgs) = 0.0 - ENDIF ENDIF ! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( tmp ) * qhacr(mgs) ) @@ -22000,12 +22827,7 @@ subroutine nssl_2mom_gs & ! : ((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) IF ( qhacw(mgs) .gt. 0.0 ) THEN ! zhacw(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacw(mgs) ) - zhacw(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacw(mgs) ) - -! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lh)+dtp*(qhacw(mgs)-qhmul1(mgs)))**2)/(cx(mgs,lh)) - IF ( z > zx(mgs,lh) ) THEN -! zhacw(mgs) = (z - zx(mgs,lh))*dtpinv - ENDIF + zhacw(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacw(mgs) ) ENDIF ELSE ! } { ! this is not used because of the 'true' above @@ -22081,18 +22903,18 @@ subroutine nssl_2mom_gs & r = rho0(mgs)*qhcns(mgs)/vhcns(mgs) ! density of new graupel particles IF ( imusnow == 3 ) THEN zhcns(mgs) = 3.6476*rho0(mgs)**2*(alpha(mgs,ls)+2.)/(r**2*(alpha(mgs,ls)+1.)) * & - & ( 2.*tmp * qhcns(mgs) - tmp**2 * chcns(mgs) ) + & ( 2.*tmp * qhcns(mgs) - tmp**2 * chcnsh(mgs) ) ELSE write(0,*) 'Value of imusnow not valid. Must be 3 (fix me for =1). imusnow = ',imusnow STOP ENDIF ENDIF - IF ( qhcni(mgs) > 0.0 .and. chcni(mgs) > 0.0 .and. cx(mgs,li) > cxmin .and. vhcni(mgs) > 0 ) THEN + IF ( qhcni(mgs) > 0.0 .and. chcnih(mgs) > 0.0 .and. cx(mgs,li) > cxmin .and. vhcni(mgs) > 0 ) THEN tmp = qx(mgs,li)/cx(mgs,li) r = rho0(mgs)*qhcni(mgs)/vhcni(mgs) ! density of new graupel particles zhcni(mgs) = 3.6476*rho0(mgs)**2*(alpha(mgs,li)+2.)/(r**2*(alpha(mgs,li)+1.)) * & - & ( 2.*tmp * qhcni(mgs) - tmp**2 * chcni(mgs) ) + & ( 2.*tmp * qhcni(mgs) - tmp**2 * chcnih(mgs) ) ENDIF @@ -22115,14 +22937,6 @@ subroutine nssl_2mom_gs & & - il5(mgs)*zhlcnh(mgs) - IF ( igs(mgs) == 44 .and. kgs(mgs) == 23 .or. dtp*( pqhwi(mgs) + pqhwd(mgs) ) > qxmin(lh) ) THEN -! write(0,*) 'i,k,time = ',igs(mgs),kgs(mgs),time_real -! write(0,*) 'pzhwi,d = ',pzhwi(mgs),pzhwd(mgs),dtp*( pzhwi(mgs) + pzhwd(mgs) ),zx(mgs,lh) -! write(0,*) 'pqhwi,d = ',pqhwi(mgs),pqhwd(mgs),dtp*( pqhwi(mgs) + pqhwd(mgs) ),qx(mgs,lh) -! write(0,*) 'pchwi,d = ',pchwi(mgs),pchwd(mgs),dtp*( pchwi(mgs) + pchwd(mgs) ),cx(mgs,lh) - ENDIF - - ! IF ( zhcnhl(mgs) < 0.0 ) THEN ! write(0,*) 'Problem with zhcnhl! zhcnhl,qhcnhl,chcnhl = ',zhcnhl(mgs),qhcnhl(mgs),chcnhl(mgs) ! write(0,*) 'g1,tmp = ',g1x(mgs,lhl),tmp @@ -22384,7 +23198,7 @@ subroutine nssl_2mom_gs & zracw(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*tmp * qracw(mgs) ) ENDIF - IF ( cracr(mgs) > 0.0 .and. cx(mgs,lr) > 0.0 ) THEN + IF ( cracr(mgs) /= 0.0 .and. cx(mgs,lr) > 0.0 ) THEN zracr(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*1000.))**2*( tmp**2 * cracr(mgs) ) ENDIF @@ -22399,7 +23213,7 @@ subroutine nssl_2mom_gs & IF ( iferwisventr == 2 ) THEN vent1 = Min(0.0, (12./(pii*xdn(mgs,lr)))*xdia(mgs,lr,1)**3*fvce(mgs)*rwcap(mgs)*rwventz(mgs)) - zrcev(mgs) = Max( zrcev(mgs), vent1 ) + zrcev(mgs) = Max( dble(zrcev(mgs)), vent1 ) ENDIF ! IF ( ny == 2 .and. igs(mgs) == 20 ) THEN ! write(0,*) 'k,zrcevold,new,maxdep : ',kgs(mgs),zrcev(mgs),vent1,-zxmxd(mgs,lr),alpha(mgs,lr),cx(mgs,lr) @@ -22528,7 +23342,8 @@ subroutine nssl_2mom_gs & ! > + rho0(mgs)*qhshr(mgs)/xdn(mgs,lh) !xdn(mgs,lr) ! ENDIF - IF ( lzh > 1 .and. qx(mgs,lh) > qxmin(lh) ) THEN + IF ( lzh > 1 .and. qx(mgs,lh) > qxmin(lh) .and. & + vx(mgs,lh) + dtp*(pvhwi(mgs) + pvhwd(mgs)) > rho0(mgs)*qxmin(lh)/900. ) THEN ! Calculate change in reflectivity due to density changes xdn_new = rho0(mgs)*(qx(mgs,lh) + dtp*(pqhwi(mgs) + pqhwd(mgs) ))/ & @@ -22637,7 +23452,8 @@ subroutine nssl_2mom_gs & & + rho0(mgs)*(1-il5(mgs))*vhlmlr(mgs)/xdn(mgs,lhl) & & + vhlshdr(mgs) - vhlsoak(mgs) - IF ( lzhl > 1 .and. qx(mgs,lhl) > qxmin(lhl) ) THEN + IF ( lzhl > 1 .and. qx(mgs,lhl) > qxmin(lhl) .and. & + vx(mgs,lhl) + dtp*(pvhli(mgs) + pvhld(mgs)) > rho0(mgs)*qxmin(lhl)/900. ) THEN ! Calculate change in reflectivity due to density changes xdn_new = rho0(mgs)*(qx(mgs,lhl) + dtp*(pqhli(mgs) + pqhld(mgs) ))/ & @@ -22874,12 +23690,17 @@ subroutine nssl_2mom_gs & ! write(iunit,*) il5(mgs)*qscni(mgs), qscnvi(mgs) write(iunit,*) il5(mgs)*qsaci(mgs) - write(iunit,*) il5(mgs)*qrfrzs(mgs) + write(iunit,*) il5(mgs)*qrfrzs(mgs), qiacrs(mgs) write(iunit,*) il5(mgs)*qiacrs(mgs),il3(mgs)*(qiacrf(mgs)+qracif(mgs)),il3(mgs),qiacrf(mgs),qracif(mgs) write(iunit,*) il5(mgs)*qsdpv(mgs), qscev(mgs) - write(iunit,*) qsacw(mgs) + write(iunit,*) qsacw(mgs),qwfrzc(mgs), qwctfzc(mgs), qicichr(mgs) write(iunit,*) qsacr(mgs), qscnh(mgs) - write(iunit,*) 'pqswi = ',pqswi(mgs) + write(iunit,*) il2(mgs)*qsacr(mgs) + write(iunit,*) il5(mgs)*qicicnt(mgs)*ffrzs + write(iunit,*) il3(mgs)*(qiacrf(mgs)+qracif(mgs)) ! only applies for ipconc <= 3 + write(iunit,*) Max(0.0, qscev(mgs)) + write(iunit,*) qsacw(mgs) + qscnh(mgs) + write(iunit,*) 'pqswi = ',pqswi(mgs) write(iunit,*) -qhcns(mgs) write(iunit,*) -qracs(mgs) write(iunit,*) -qhacs(mgs) @@ -23054,6 +23875,7 @@ subroutine nssl_2mom_gs & qwvp(mgs) = qwvp(mgs) + & & dtp*(pqwvi(mgs)+pqwvd(mgs)) + ! qcwresv(mgs) = qx(mgs,lc) ! temporary save of old qc value qx(mgs,lc) = qx(mgs,lc) + & & dtp*(pqcwi(mgs)+pqcwd(mgs)) qx(mgs,lr) = qx(mgs,lr) + & @@ -23358,7 +24180,11 @@ subroutine nssl_2mom_gs & ltemq = (temg(mgs)-163.15)/fqsat+1.5 ltemq = Min( nqsat, Max(1,ltemq) ) - qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + IF ( iqvsopt == 0 ) THEN + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + ELSEIF ( iqvsopt == 1 ) THEN + qvs(mgs) = rdorv*esbolton*tabqvs(ltemq)/(pres(mgs) - esbolton*tabqvs(ltemq)) + ENDIF IF ( ( qvap(mgs) > qvs(mgs) .or. qx(mgs,lc) > qxmin(lc) ) .and. temg(mgs) > tfrh ) THEN tmp = (qvap(mgs) - qvs(mgs))/(1. + qvs(mgs)*felv(mgs)**2/(cp*rw*temg(mgs)**2) ) @@ -23402,7 +24228,11 @@ subroutine nssl_2mom_gs & ltemq = (temg(mgs)-163.15)/fqsat+1.5 ltemq = Min( nqsat, Max(1,ltemq) ) - qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + IF ( iqvsopt == 0 ) THEN + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + ELSEIF ( iqvsopt == 1 ) THEN + qvs(mgs) = rdorv*esbolton*tabqvs(ltemq)/(pres(mgs) - esbolton*tabqvs(ltemq)) + ENDIF qis(mgs) = pqs(mgs)*tabqis(ltemq) qss(mgs) = qvs(mgs) if ( temg(mgs) .lt. tfr ) then @@ -23470,7 +24300,7 @@ subroutine nssl_2mom_gs & IF ( eqtset > 2 ) THEN pipert(mgs) = pipert(mgs) & & +(felspi(mgs)*dqci(mgs) & - & +felvpi(mgs)*dqcw(mgs))*dtp + & +felvpi(mgs)*dqcw(mgs)) ! *dtp (remove dtp since dqxx are not rates) ENDIF end if ! dqwv(mgs) .lt. 0. (end of evap/sublim) @@ -23540,7 +24370,7 @@ subroutine nssl_2mom_gs & IF ( eqtset > 2 ) THEN pipert(mgs) = pipert(mgs) + (0 & & +felspi(mgs)*dqci(mgs) & - & +felvpi(mgs)*dqcw(mgs))*dtp + & +felvpi(mgs)*dqcw(mgs)) ! *dtp (remove dtp since dqxx are not rates) ENDIF qwvp(mgs) = qwvp(mgs) - ( dqvcnd(mgs) ) @@ -23564,7 +24394,12 @@ subroutine nssl_2mom_gs & tqvcon = temg(mgs)-cbw ltemq = (temg(mgs)-163.15)/fqsat+1.5 ltemq = Min( nqsat, Max(1,ltemq) ) - qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + + IF ( iqvsopt == 0 ) THEN + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + ELSEIF ( iqvsopt == 1 ) THEN + qvs(mgs) = rdorv*esbolton*tabqvs(ltemq)/(pres(mgs) - esbolton*tabqvs(ltemq)) + ENDIF qis(mgs) = pqs(mgs)*tabqis(ltemq) qx(mgs,lc) = max( 0.0, qx(mgs,lc) ) qitmp(mgs) = max( 0.0, qitmp(mgs) ) @@ -23718,7 +24553,7 @@ subroutine nssl_2mom_gs & IF ( qx(mgs,il) .le. 0.0 ) THEN cx(mgs,il) = 0.0 ELSE !{ - IF ( cx(mgs,il) .gt. cxmin ) THEN !{ + IF ( cx(mgs,il) .gt. cxmin .and. qx(mgs,il) > qxmin(il) ) THEN !{ only do this if mass is sufficient ! xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*Max(1.0e-9,cx(mgs,il))) ! xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*Max(cxmin,cx(mgs,il))) xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*cx(mgs,il)) @@ -23729,7 +24564,8 @@ subroutine nssl_2mom_gs & ! 8/26/2015 erm: apply imaxdiaopt for 2-moment also IF ( imaxdiaopt == 1 .or. il == lc .or. il == li .or. (il == lr .and. imurain == 3) .or. & - & (il == ls .and. imusnow == 3 ) ) THEN + & (il == ls .and. imusnow == 3 ) .or. ( il >= lh .and. lh > 0 ) ) THEN +! IF ( imaxdiaopt == 1 .or. (il == lr .and. imurain == 3) .or. .not. (il == lr .and. imurain == 1) ) THEN xvbarmax = xvmx(il) ELSEIF ( imaxdiaopt == 2 ) THEN ! test against maximum mass diameter xvbarmax = xvmx(il) /((3. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il)))) @@ -24053,8 +24889,8 @@ subroutine nssl_2mom_gs & qr = qx(mgs,il) z = zx(mgs,il) - IF ( zx(mgs,il) .gt. 0. ) THEN !{ - + IF ( zx(mgs,il) .gt. zxmin .and. qr > qxmin(il) .and. chw > cxmin ) THEN !{ + ! rdi = z*(pi/6.*1000.)**2*chw/((rho0(mgs)*qr)**2) rdi = z*(pi/6.*xdn(mgs,il))**2*chw/((rho0(mgs)*qr)**2) diff --git a/phys/module_mp_ntu.F b/phys/module_mp_ntu.F index d4fc4ee33d..5629d63415 100644 --- a/phys/module_mp_ntu.F +++ b/phys/module_mp_ntu.F @@ -661,12 +661,10 @@ REAL FUNCTION GAMLN(XX) ! Referred to y = y+1.D0 ser = ser+cof(J)/y ENDDO -#if (DWORDSIZE == 8 && RWORDSIZE == 8) +#ifdef DOUBLE_PRECISION GAMLN = TMP+LOG(stp*ser/X) -#elif (DWORDSIZE == 8 && RWORDSIZE == 4) - GAMLN = SNGL(TMP+LOG(stp*ser/X)) #else -! This is a temporary hack assuming double precision is 8 bytes. + GAMLN = SNGL(TMP+LOG(stp*ser/X)) #endif END FUNCTION GAMLN diff --git a/phys/module_mp_radar.F b/phys/module_mp_radar.F index 31aaf6988c..9587042140 100644 --- a/phys/module_mp_radar.F +++ b/phys/module_mp_radar.F @@ -38,20 +38,24 @@ MODULE module_mp_radar INTEGER, PARAMETER, PUBLIC:: nrbins = 50 DOUBLE PRECISION, DIMENSION(nrbins+1), PUBLIC:: xxDx DOUBLE PRECISION, DIMENSION(nrbins), PUBLIC:: xxDs,xdts,xxDg,xdtg + DOUBLE PRECISION, DIMENSION(nrbins), PUBLIC:: xxDh,xdth DOUBLE PRECISION, PARAMETER, PUBLIC:: lamda_radar = 0.10 ! in meters DOUBLE PRECISION, PUBLIC:: K_w, PI5, lamda4 COMPLEX*16, PUBLIC:: m_w_0, m_i_0 DOUBLE PRECISION, DIMENSION(nrbins+1), PUBLIC:: simpson DOUBLE PRECISION, DIMENSION(3), PARAMETER, PUBLIC:: basis = & (/1.d0/3.d0, 4.d0/3.d0, 1.d0/3.d0/) - REAL, DIMENSION(4), PUBLIC:: xcre, xcse, xcge, xcrg, xcsg, xcgg + REAL, DIMENSION(4), PUBLIC:: xcre, xcse, xcge, xche, xcrg, xcsg, xcgg, xchg REAL, PUBLIC:: xam_r, xbm_r, xmu_r, xobmr REAL, PUBLIC:: xam_s, xbm_s, xmu_s, xoams, xobms, xocms REAL, PUBLIC:: xam_g, xbm_g, xmu_g, xoamg, xobmg, xocmg - REAL, PUBLIC:: xorg2, xosg2, xogg2 + REAL, PUBLIC:: xam_h, xbm_h, xmu_h, xoamh, xobmh, xocmh + REAL, PUBLIC:: xorg2, xosg2, xogg2, xohg2 INTEGER, PARAMETER, PUBLIC:: slen = 20 CHARACTER(len=slen), PUBLIC:: & + mixingrulestring_h, matrixstring_h, inclusionstring_h, & + hoststring_h, hostmatrixstring_h, hostinclusionstring_h, & mixingrulestring_s, matrixstring_s, inclusionstring_s, & hoststring_s, hostmatrixstring_s, hostinclusionstring_s, & mixingrulestring_g, matrixstring_g, inclusionstring_g, & @@ -60,6 +64,7 @@ MODULE module_mp_radar !..Single melting snow/graupel particle 90% meltwater on external sfc DOUBLE PRECISION, PARAMETER:: melt_outside_s = 0.9d0 DOUBLE PRECISION, PARAMETER:: melt_outside_g = 0.9d0 + DOUBLE PRECISION, PARAMETER:: melt_outside_h = 0.9d0 CHARACTER*256:: radar_debug @@ -95,12 +100,20 @@ subroutine radar_init hoststring_s(n:n) = char(0) hostmatrixstring_s(n:n) = char(0) hostinclusionstring_s(n:n) = char(0) + mixingrulestring_g(n:n) = char(0) matrixstring_g(n:n) = char(0) inclusionstring_g(n:n) = char(0) hoststring_g(n:n) = char(0) hostmatrixstring_g(n:n) = char(0) hostinclusionstring_g(n:n) = char(0) + + mixingrulestring_h(n:n) = char(0) + matrixstring_h(n:n) = char(0) + inclusionstring_h(n:n) = char(0) + hoststring_h(n:n) = char(0) + hostmatrixstring_h(n:n) = char(0) + hostinclusionstring_h(n:n) = char(0) enddo mixingrulestring_s = 'maxwellgarnett' @@ -117,6 +130,13 @@ subroutine radar_init hostmatrixstring_g = 'icewater' hostinclusionstring_g = 'spheroidal' + mixingrulestring_h = 'maxwellgarnett' + hoststring_h = 'air' + matrixstring_h = 'water' + inclusionstring_h = 'spheroidal' + hostmatrixstring_h = 'icewater' + hostinclusionstring_h = 'spheroidal' + !..Create bins of snow (from 100 microns up to 2 cm). xxDx(1) = 100.D-6 xxDx(nrbins+1) = 0.02d0 @@ -141,6 +161,18 @@ subroutine radar_init xdtg(n) = xxDx(n+1) - xxDx(n) enddo +!..Create bins of hail (from 100 microns up to 5 cm). + xxDx(1) = 100.D-6 + xxDx(nrbins+1) = 0.05d0 + do n = 2, nrbins + xxDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nrbins) & + *DLOG(xxDx(nrbins+1)/xxDx(1)) +DLOG(xxDx(1))) + enddo + do n = 1, nrbins + xxDh(n) = DSQRT(xxDx(n)*xxDx(n+1)) + xdth(n) = xxDx(n+1) - xxDx(n) + enddo + !..The calling program must set the m(D) relations and gamma shape !.. parameter mu for rain, snow, and graupel. Easily add other types @@ -174,6 +206,15 @@ subroutine radar_init enddo xogg2 = 1./xcgg(2) + xche(1) = 1. + xbm_h + xche(2) = 1. + xmu_h + xche(3) = 1. + xbm_h + xmu_h + xche(4) = 1. + 2.*xbm_h + xmu_h + do n = 1, 4 + xchg(n) = WGAMMA(xche(n)) + enddo + xohg2 = 1./xchg(2) + xobmr = 1./xbm_r xoams = 1./xam_s xobms = 1./xbm_s @@ -181,6 +222,9 @@ subroutine radar_init xoamg = 1./xam_g xobmg = 1./xbm_g xocmg = xoamg**xobmg + xoamh = 1./xam_h + xobmh = 1./xbm_h + xocmh = xoamh**xobmh end subroutine radar_init diff --git a/phys/module_mp_rcon.F b/phys/module_mp_rcon.F new file mode 100644 index 0000000000..de22441244 --- /dev/null +++ b/phys/module_mp_rcon.F @@ -0,0 +1,6221 @@ +!+---+-----------------------------------------------------------------+ +! +! RELEASED JANUARY 2025 +! +! This is the WRF module for the RCON microphysics scheme, the intent +! of which is to improve warm rain representation within the Thompson-Eidhammer scheme. +! +! RCON is based heavily on the Thompson-Eidhammer scheme with a couple significant +! changes that improve upon the code in module_mp_rcon.F to generate more realistic +! rainfall during warm rain events with additional benefits for cold rain, especially +! warm processes during cold rain events. +! +! Most deviations from the Thompson-Eidhammer scheme are marked with one of the following comments: +! !RC, !RC !\RC (for blocks) +! +! +! Among the most significant changes for rain productions are 1) the use of a wider cloud water DSD +! of lognormal shape instead of the gamma DSD used by the Thompson–Eidhammer parameterization and +! 2) enhancement of the cloud-to-rain autoconversion parameterization to accomodate the new shape. +! The changes here also allow for sedimentation of cloud water within the lowest model layer, which +! effectively creates a drizzle mode in the scheme. One new diagnostic is provided in wrfout, CLOUDNC, +! which is the accumulated cloud water at the surface, i.e. drizzle. +! +! A future version of this scheme will introduce an expanded aerosol table to increase accuracy of cloud representation. +! +! +! Further details and extensive evaluation of the rain/cloud changes is found in the following paper: +! Conrick, R., C. F. Mass, and L. McMurdie, 2023: Improving Simulations of Warm Rain in a Bulk Microphysics Scheme. +! Mon. Wea. Rev., 152, 169–185, https://doi.org/10.1175/MWR-D-23-0035.1. +! +! +! +! NOTE 1: The intent of this scheme is for the Thompson aerosol options to be used. +! Either the climotological aerosol data or the 'default' profile may be used. +! NOTE 2: The Thompson hail scheme is NOT supported at this time. +! +! +! Questions/comments/bugs? +! Contact Robert Conrick at robert.conrick@gmail.com or Clifford Mass at cmass@uw.edu +! +! +! +!+---+-----------------------------------------------------------------+ +!wrft:model_layer:physics +!+---+-----------------------------------------------------------------+ +! + + + MODULE module_mp_rcon + + USE module_wrf_error + USE module_mp_radar +#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) + USE module_dm, ONLY : wrf_dm_max_real +#endif + USE module_model_constants, only : RE_QC_BG, RE_QI_BG, RE_QS_BG + + IMPLICIT NONE + + LOGICAL, PARAMETER, PRIVATE:: iiwarm = .false. + LOGICAL, PRIVATE:: is_aerosol_aware = .false. + LOGICAL, PARAMETER, PRIVATE:: dustyIce = .true. + LOGICAL, PARAMETER, PRIVATE:: homogIce = .true. + LOGICAL, PRIVATE:: is_hail_aware = .false. + + INTEGER, PARAMETER, PRIVATE:: IFDRY = 0 + REAL, PARAMETER, PRIVATE:: T_0 = 273.15 + REAL, PARAMETER, PRIVATE:: PI = 3.1415926536 + +!..Densities of rain, snow, graupel, and cloud ice. + REAL, PARAMETER, PRIVATE:: rho_w = 1000.0 + REAL, PRIVATE:: rho_s = 100.0 + REAL, PARAMETER, PRIVATE:: rho_i = 890.0 + INTEGER, PARAMETER, PRIVATE:: NRHG = 9 + INTEGER, PARAMETER, PRIVATE:: NRHG1 = 1 + INTEGER :: dimNRHG + + REAL, DIMENSION(NRHG), PARAMETER, PRIVATE:: & + rho_g = (/50., 100., 200., 300., 400., 500., 600., 700., 800./) + INTEGER, PARAMETER :: idx_bg1 = 5 ! index for rhog when mp=8 or 28 + +!..Prescribed number of cloud droplets. Set according to known data or +!.. roughly 100 per cc (100.E6 m^-3) for Maritime cases and +!.. 300 per cc (300.E6 m^-3) for Continental. Gamma shape parameter, +!.. mu_c, calculated based on Nt_c is important in autoconversion +!.. scheme. In 2-moment cloud water, Nt_c represents a maximum of +!.. droplet concentration and nu_c is also variable depending on local +!.. droplet number concentration. + REAL, PARAMETER, PRIVATE:: Nt_c = 100.E6 + REAL, PARAMETER, PRIVATE:: Nt_c_max = 1999.E6 + +!..Declaration of constants for assumed CCN/IN aerosols when none in +!.. the input data. Look inside the init routine for modifications +!.. due to surface land-sea points or vegetation characteristics. + REAL, PARAMETER, PRIVATE:: naIN0 = 1.5E6 + REAL, PARAMETER, PRIVATE:: naIN1 = 0.5E6 + REAL, PARAMETER, PRIVATE:: naCCN0 = 300.0E6 + REAL, PARAMETER, PRIVATE:: naCCN1 = 50.0E6 + REAL, PARAMETER, PRIVATE:: naBC0 = 150.0E6 + REAL, PARAMETER, PRIVATE:: naBC1 = 25.0E6 + +!..Generalized gamma distributions for rain, graupel and cloud ice. +!.. N(D) = N_0 * D**mu * exp(-lamda*D); mu=0 is exponential. + REAL, PARAMETER, PRIVATE:: mu_r = 0.0 + REAL, PARAMETER, PRIVATE:: mu_g = 0.0 + REAL, PARAMETER, PRIVATE:: mu_i = 0.0 + REAL, PRIVATE:: mu_c + +!..Sum of two gamma distrib for snow (Field et al. 2005). +!.. N(D) = M2**4/M3**3 * [Kap0*exp(-M2*Lam0*D/M3) +!.. + Kap1*(M2/M3)**mu_s * D**mu_s * exp(-M2*Lam1*D/M3)] +!.. M2 and M3 are the (bm_s)th and (bm_s+1)th moments respectively +!.. calculated as function of ice water content and temperature. + REAL, PARAMETER, PRIVATE:: mu_s = 0.6357 + REAL, PARAMETER, PRIVATE:: Kap0 = 490.6 + REAL, PARAMETER, PRIVATE:: Kap1 = 17.46 + REAL, PARAMETER, PRIVATE:: Lam0 = 20.78 + REAL, PARAMETER, PRIVATE:: Lam1 = 3.29 + +!..Y-intercept parameter for graupel is not constant and depends on +!.. mixing ratio. Also, when mu_g is non-zero, these become equiv +!.. y-intercept for an exponential distrib and proper values are +!.. computed based on same mixing ratio and total number concentration. + REAL, PARAMETER, PRIVATE:: gonv_min = 1.E2 + REAL, PARAMETER, PRIVATE:: gonv_max = 1.E6 + +!..Mass power law relations: mass = am*D**bm +!.. Snow from Field et al. (2005), others assume spherical form. + REAL, PARAMETER, PRIVATE:: am_r = PI*rho_w/6.0 + REAL, PARAMETER, PRIVATE:: bm_r = 3.0 + REAL, PARAMETER, PRIVATE:: am_s = 0.069 + REAL, PARAMETER, PRIVATE:: bm_s = 2.0 + REAL, DIMENSION(NRHG), PARAMETER,PRIVATE:: am_g = (/ & + & PI*rho_g(1)/6.0, PI*rho_g(2)/6.0, PI*rho_g(3)/6.0, & + & PI*rho_g(4)/6.0, PI*rho_g(5)/6.0, PI*rho_g(6)/6.0, & + & PI*rho_g(7)/6.0, PI*rho_g(8)/6.0, PI*rho_g(9)/6.0 /) + REAL, PARAMETER, PRIVATE:: bm_g = 3.0 + REAL, PARAMETER, PRIVATE:: am_i = PI*rho_i/6.0 + REAL, PARAMETER, PRIVATE:: bm_i = 3.0 + +!..Fallspeed power laws relations: v = (av*D**bv)*exp(-fv*D) +!.. Rain from Ferrier (1994), ice, snow, and graupel from +!.. Thompson et al (2008). Coefficient fv is zero for graupel/ice. + REAL, PARAMETER, PRIVATE:: av_r = 4854.0 + REAL, PARAMETER, PRIVATE:: bv_r = 1.0 + REAL, PARAMETER, PRIVATE:: fv_r = 195.0 + REAL, PARAMETER, PRIVATE:: av_s = 40.0 + REAL, PARAMETER, PRIVATE:: bv_s = 0.55 + REAL, PARAMETER, PRIVATE:: fv_s = 100.0 + REAL, PARAMETER, PRIVATE:: av_g_old = 442.0 + REAL, PARAMETER, PRIVATE:: bv_g_old = 0.89 + REAL, DIMENSION(NRHG), PRIVATE:: & ! Computed from A. Heymsfield: Best - Reynolds relation + & av_g = (/ 45.9173813, 67.0867386, 98.0158463, 122.353378, & + & 143.204224, 161.794724, 178.762115, 194.488785, & + & 209.225876/) + REAL, DIMENSION(NRHG), PRIVATE:: & ! Computed from A. Heymsfield: Best - Reynolds relation + & bv_g = (/0.640961647, 0.640961647, 0.640961647, 0.640961647, & + & 0.640961647, 0.640961647, 0.640961647, 0.640961647, & + & 0.640961647/) + REAL, PARAMETER, PRIVATE:: a_coeff = 0.47244157 + REAL, PARAMETER, PRIVATE:: b_coeff = 0.54698726 + REAL, PARAMETER, PRIVATE:: av_i = 1493.9 + REAL, PARAMETER, PRIVATE:: bv_i = 1.0 + REAL, PARAMETER, PRIVATE:: av_c = 0.316946E8 + REAL, PARAMETER, PRIVATE:: bv_c = 2.0 + +!..Capacitance of sphere and plates/aggregates: D**3, D**2 + REAL, PARAMETER, PRIVATE:: C_cube = 0.5 + REAL, PARAMETER, PRIVATE:: C_sqrd = 0.15 + +!..Collection efficiencies. Rain/snow/graupel collection of cloud +!.. droplets use variables (Ef_rw, Ef_sw, Ef_gw respectively) and +!.. get computed elsewhere because they are dependent on stokes +!.. number. + REAL, PARAMETER, PRIVATE:: Ef_si = 0.05 + REAL, PARAMETER, PRIVATE:: Ef_rs = 0.95 + REAL, PARAMETER, PRIVATE:: Ef_rg = 0.75 + REAL, PARAMETER, PRIVATE:: Ef_ri = 0.95 + +!..Minimum microphys values +!.. R1 value, 1.E-12, cannot be set lower because of numerical +!.. problems with Paul Field's moments and should not be set larger +!.. because of truncation problems in snow/ice growth. + REAL, PARAMETER, PRIVATE:: R1 = 1.E-12 + REAL, PARAMETER, PRIVATE:: R2 = 1.E-6 + REAL, PARAMETER, PRIVATE:: eps = 1.E-15 + +!..Constants in Cooper curve relation for cloud ice number. + REAL, PARAMETER, PRIVATE:: TNO = 5.0 + REAL, PARAMETER, PRIVATE:: ATO = 0.304 + +!..Rho_not used in fallspeed relations (rho_not/rho)**.5 adjustment. + REAL, PARAMETER, PRIVATE:: rho_not = 101325.0/(287.05*298.0) + +!..Schmidt number + REAL, PARAMETER, PRIVATE:: Sc = 0.632 + REAL, PRIVATE:: Sc3 + +!..Homogeneous freezing temperature + REAL, PARAMETER, PRIVATE:: HGFR = 235.16 + +!..Water vapor and air gas constants at constant pressure + REAL, PARAMETER, PRIVATE:: Rv = 461.5 + REAL, PARAMETER, PRIVATE:: oRv = 1./Rv + REAL, PARAMETER, PRIVATE:: R = 287.04 + REAL, PARAMETER, PRIVATE:: Cp = 1004.0 + REAL, PARAMETER, PRIVATE:: R_uni = 8.314 ! J (mol K)-1 + + DOUBLE PRECISION, PARAMETER, PRIVATE:: k_b = 1.38065E-23 ! Boltzmann constant [J/K] + DOUBLE PRECISION, PARAMETER, PRIVATE:: M_w = 18.01528E-3 ! molecular mass of water [kg/mol] + DOUBLE PRECISION, PARAMETER, PRIVATE:: M_a = 28.96E-3 ! molecular mass of air [kg/mol] + DOUBLE PRECISION, PARAMETER, PRIVATE:: N_avo = 6.022E23 ! Avogadro number [1/mol] + DOUBLE PRECISION, PARAMETER, PRIVATE:: ma_w = M_w / N_avo ! mass of water molecule [kg] + REAL, PARAMETER, PRIVATE:: ar_volume = 4./3.*PI*(2.5e-6)**3 ! assume radius of 0.025 micrometer, 2.5e-6 cm + +!..Enthalpy of sublimation, vaporization, and fusion at 0C. + REAL, PARAMETER, PRIVATE:: lsub = 2.834E6 + REAL, PARAMETER, PRIVATE:: lvap0 = 2.5E6 + REAL, PARAMETER, PRIVATE:: lfus = lsub - lvap0 + REAL, PARAMETER, PRIVATE:: olfus = 1./lfus + +!..Ice initiates with this mass (kg), corresponding diameter calc. +!..Min diameters and mass of cloud, rain, snow, and graupel (m, kg). + REAL, PARAMETER, PRIVATE:: xm0i = 1.E-12 + REAL, PARAMETER, PRIVATE:: D0c = 1.E-6 + REAL, PARAMETER, PRIVATE:: D0r = 50.E-6 + REAL, PARAMETER, PRIVATE:: D0s = 300.E-6 + REAL, PARAMETER, PRIVATE:: D0g = 350.E-6 + REAL, PRIVATE:: D0i, xm0s, xm0g + +!..Lookup table dimensions + INTEGER, PARAMETER, PRIVATE:: nbins = 100 + INTEGER, PARAMETER, PRIVATE:: nbc = nbins + INTEGER, PARAMETER, PRIVATE:: nbi = nbins + INTEGER, PARAMETER, PRIVATE:: nbr = nbins + INTEGER, PARAMETER, PRIVATE:: nbs = nbins + INTEGER, PARAMETER, PRIVATE:: nbg = nbins + INTEGER, PARAMETER, PRIVATE:: ntb_c = 37 + INTEGER, PARAMETER, PRIVATE:: ntb_i = 64 + INTEGER, PARAMETER, PRIVATE:: ntb_r = 37 + INTEGER, PARAMETER, PRIVATE:: ntb_s = 37 + INTEGER, PARAMETER, PRIVATE:: ntb_g = 37 + INTEGER, PARAMETER, PRIVATE:: ntb_g1 = 37 + INTEGER, PARAMETER, PRIVATE:: ntb_r1 = 37 + INTEGER, PARAMETER, PRIVATE:: ntb_i1 = 55 + INTEGER, PARAMETER, PRIVATE:: ntb_t = 9 + INTEGER, PRIVATE:: nic1, nic2, nii2, nii3, nir2, nir3, nis2, nig2, nig3 + INTEGER, PARAMETER, PRIVATE:: ntb_arc = 7 + INTEGER, PARAMETER, PRIVATE:: ntb_arw = 9 + INTEGER, PARAMETER, PRIVATE:: ntb_art = 7 + INTEGER, PARAMETER, PRIVATE:: ntb_arr = 5 + INTEGER, PARAMETER, PRIVATE:: ntb_ark = 4 + INTEGER, PARAMETER, PRIVATE:: ntb_IN = 55 + INTEGER, PRIVATE:: niIN2 + + DOUBLE PRECISION, DIMENSION(nbins+1):: xDx + DOUBLE PRECISION, DIMENSION(nbc):: Dc, dtc + DOUBLE PRECISION, DIMENSION(nbi):: Di, dti + DOUBLE PRECISION, DIMENSION(nbr):: Dr, dtr + DOUBLE PRECISION, DIMENSION(nbs):: Ds, dts + DOUBLE PRECISION, DIMENSION(nbg):: Dg, dtg + DOUBLE PRECISION, DIMENSION(nbc):: t_Nc + +!..Lookup tables for cloud water content (kg/m**3). + REAL, DIMENSION(ntb_c), PARAMETER, PRIVATE:: & + r_c = (/1.e-6,2.e-6,3.e-6,4.e-6,5.e-6,6.e-6,7.e-6,8.e-6,9.e-6, & + 1.e-5,2.e-5,3.e-5,4.e-5,5.e-5,6.e-5,7.e-5,8.e-5,9.e-5, & + 1.e-4,2.e-4,3.e-4,4.e-4,5.e-4,6.e-4,7.e-4,8.e-4,9.e-4, & + 1.e-3,2.e-3,3.e-3,4.e-3,5.e-3,6.e-3,7.e-3,8.e-3,9.e-3, & + 1.e-2/) + +!..Lookup tables for cloud ice content (kg/m**3). + REAL, DIMENSION(ntb_i), PARAMETER, PRIVATE:: & + r_i = (/1.e-10,2.e-10,3.e-10,4.e-10, & + 5.e-10,6.e-10,7.e-10,8.e-10,9.e-10, & + 1.e-9,2.e-9,3.e-9,4.e-9,5.e-9,6.e-9,7.e-9,8.e-9,9.e-9, & + 1.e-8,2.e-8,3.e-8,4.e-8,5.e-8,6.e-8,7.e-8,8.e-8,9.e-8, & + 1.e-7,2.e-7,3.e-7,4.e-7,5.e-7,6.e-7,7.e-7,8.e-7,9.e-7, & + 1.e-6,2.e-6,3.e-6,4.e-6,5.e-6,6.e-6,7.e-6,8.e-6,9.e-6, & + 1.e-5,2.e-5,3.e-5,4.e-5,5.e-5,6.e-5,7.e-5,8.e-5,9.e-5, & + 1.e-4,2.e-4,3.e-4,4.e-4,5.e-4,6.e-4,7.e-4,8.e-4,9.e-4, & + 1.e-3/) + +!..Lookup tables for rain content (kg/m**3). + REAL, DIMENSION(ntb_r), PARAMETER, PRIVATE:: & + r_r = (/1.e-6,2.e-6,3.e-6,4.e-6,5.e-6,6.e-6,7.e-6,8.e-6,9.e-6, & + 1.e-5,2.e-5,3.e-5,4.e-5,5.e-5,6.e-5,7.e-5,8.e-5,9.e-5, & + 1.e-4,2.e-4,3.e-4,4.e-4,5.e-4,6.e-4,7.e-4,8.e-4,9.e-4, & + 1.e-3,2.e-3,3.e-3,4.e-3,5.e-3,6.e-3,7.e-3,8.e-3,9.e-3, & + 1.e-2/) + +!..Lookup tables for graupel content (kg/m**3). + REAL, DIMENSION(ntb_g), PARAMETER, PRIVATE:: & + r_g = (/1.e-6,2.e-6,3.e-6,4.e-6,5.e-6,6.e-6,7.e-6,8.e-6,9.e-6, & + 1.e-5,2.e-5,3.e-5,4.e-5,5.e-5,6.e-5,7.e-5,8.e-5,9.e-5, & + 1.e-4,2.e-4,3.e-4,4.e-4,5.e-4,6.e-4,7.e-4,8.e-4,9.e-4, & + 1.e-3,2.e-3,3.e-3,4.e-3,5.e-3,6.e-3,7.e-3,8.e-3,9.e-3, & + 1.e-2/) + +!..Lookup tables for snow content (kg/m**3). + REAL, DIMENSION(ntb_s), PARAMETER, PRIVATE:: & + r_s = (/1.e-6,2.e-6,3.e-6,4.e-6,5.e-6,6.e-6,7.e-6,8.e-6,9.e-6, & + 1.e-5,2.e-5,3.e-5,4.e-5,5.e-5,6.e-5,7.e-5,8.e-5,9.e-5, & + 1.e-4,2.e-4,3.e-4,4.e-4,5.e-4,6.e-4,7.e-4,8.e-4,9.e-4, & + 1.e-3,2.e-3,3.e-3,4.e-3,5.e-3,6.e-3,7.e-3,8.e-3,9.e-3, & + 1.e-2/) + +!..Lookup tables for rain y-intercept parameter (/m**4). + REAL, DIMENSION(ntb_r1), PARAMETER, PRIVATE:: & + N0r_exp = (/1.e6,2.e6,3.e6,4.e6,5.e6,6.e6,7.e6,8.e6,9.e6, & + 1.e7,2.e7,3.e7,4.e7,5.e7,6.e7,7.e7,8.e7,9.e7, & + 1.e8,2.e8,3.e8,4.e8,5.e8,6.e8,7.e8,8.e8,9.e8, & + 1.e9,2.e9,3.e9,4.e9,5.e9,6.e9,7.e9,8.e9,9.e9, & + 1.e10/) + +!..Lookup tables for graupel y-intercept parameter (/m**4). + REAL, DIMENSION(ntb_g1), PARAMETER, PRIVATE:: & + N0g_exp = (/1.e2,2.e2,3.e2,4.e2,5.e2,6.e2,7.e2,8.e2,9.e2, & + 1.e3,2.e3,3.e3,4.e3,5.e3,6.e3,7.e3,8.e3,9.e3, & + 1.e4,2.e4,3.e4,4.e4,5.e4,6.e4,7.e4,8.e4,9.e4, & + 1.e5,2.e5,3.e5,4.e5,5.e5,6.e5,7.e5,8.e5,9.e5, & + 1.e6/) + +!..Lookup tables for ice number concentration (/m**3). + REAL, DIMENSION(ntb_i1), PARAMETER, PRIVATE:: & + Nt_i = (/1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0, & + 1.e1,2.e1,3.e1,4.e1,5.e1,6.e1,7.e1,8.e1,9.e1, & + 1.e2,2.e2,3.e2,4.e2,5.e2,6.e2,7.e2,8.e2,9.e2, & + 1.e3,2.e3,3.e3,4.e3,5.e3,6.e3,7.e3,8.e3,9.e3, & + 1.e4,2.e4,3.e4,4.e4,5.e4,6.e4,7.e4,8.e4,9.e4, & + 1.e5,2.e5,3.e5,4.e5,5.e5,6.e5,7.e5,8.e5,9.e5, & + 1.e6/) + +!..Aerosol table parameter: Number of available aerosols, vertical +!.. velocity, temperature, aerosol mean radius, and hygroscopicity. + REAL, DIMENSION(ntb_arc), PARAMETER, PRIVATE:: & + ta_Na = (/10.0, 31.6, 100.0, 316.0, 1000.0, 3160.0, 10000.0/) + REAL, DIMENSION(ntb_arw), PARAMETER, PRIVATE:: & + ta_Ww = (/0.01, 0.0316, 0.1, 0.316, 1.0, 3.16, 10.0, 31.6, 100.0/) + REAL, DIMENSION(ntb_art), PARAMETER, PRIVATE:: & + ta_Tk = (/243.15, 253.15, 263.15, 273.15, 283.15, 293.15, 303.15/) + REAL, DIMENSION(ntb_arr), PARAMETER, PRIVATE:: & + ta_Ra = (/0.01, 0.02, 0.04, 0.08, 0.16/) + REAL, DIMENSION(ntb_ark), PARAMETER, PRIVATE:: & + ta_Ka = (/0.2, 0.4, 0.6, 0.8/) + +!..Lookup tables for IN concentration (/m**3) from 0.001 to 1000/Liter. + REAL, DIMENSION(ntb_IN), PARAMETER, PRIVATE:: & + Nt_IN = (/1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0, & + 1.e1,2.e1,3.e1,4.e1,5.e1,6.e1,7.e1,8.e1,9.e1, & + 1.e2,2.e2,3.e2,4.e2,5.e2,6.e2,7.e2,8.e2,9.e2, & + 1.e3,2.e3,3.e3,4.e3,5.e3,6.e3,7.e3,8.e3,9.e3, & + 1.e4,2.e4,3.e4,4.e4,5.e4,6.e4,7.e4,8.e4,9.e4, & + 1.e5,2.e5,3.e5,4.e5,5.e5,6.e5,7.e5,8.e5,9.e5, & + 1.e6/) + +!..For snow moments conversions (from Field et al. 2005) + REAL, DIMENSION(10), PARAMETER, PRIVATE:: & + sa = (/ 5.065339, -0.062659, -3.032362, 0.029469, -0.000285, & + 0.31255, 0.000204, 0.003199, 0.0, -0.015952/) + REAL, DIMENSION(10), PARAMETER, PRIVATE:: & + sb = (/ 0.476221, -0.015896, 0.165977, 0.007468, -0.000141, & + 0.060366, 0.000079, 0.000594, 0.0, -0.003577/) + +!..Temperatures (5 C interval 0 to -40) used in lookup tables. + REAL, DIMENSION(ntb_t), PARAMETER, PRIVATE:: & + Tc = (/-0.01, -5., -10., -15., -20., -25., -30., -35., -40./) + +!..Lookup tables for various accretion/collection terms. +!.. ntb_x refers to the number of elements for rain, snow, graupel, +!.. and temperature array indices. Variables beginning with t-p/c/m/n +!.. represent lookup tables. Save compile-time memory by making +!.. allocatable (2009Jun12, J. Michalakes). + INTEGER, PARAMETER, PRIVATE:: R8SIZE = 8 + INTEGER, PARAMETER, PRIVATE:: R4SIZE = 4 + REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:,:,:,:):: & + tcg_racg, tmr_racg, tcr_gacr, & ! tmg_gacr + tnr_racg, tnr_gacr + REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:,:,:):: & + tcs_racs1, tmr_racs1, tcs_racs2, tmr_racs2, & + tcr_sacr1, tms_sacr1, tcr_sacr2, tms_sacr2, & + tnr_racs1, tnr_racs2, tnr_sacr1, tnr_sacr2 + REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:,:,:):: & + tpi_qcfz, tni_qcfz + REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:,:,:):: & + tpi_qrfz, tpg_qrfz, tni_qrfz, tnr_qrfz + REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:):: & + tps_iaus, tni_iaus, tpi_ide + REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:):: t_Efrw + REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:):: t_Efsw + REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:,:):: tnr_rev + REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:,:):: & + tpc_wev, tnc_wev + REAL (KIND=R4SIZE), ALLOCATABLE, DIMENSION(:,:,:,:,:):: tnccn_act + +!..Variables holding a bunch of exponents and gamma values (cloud water, +!.. cloud ice, rain, snow, then graupel). + REAL, DIMENSION(5,15), PRIVATE:: cce, ccg + REAL, DIMENSION(15), PRIVATE:: ocg1, ocg2 + REAL, DIMENSION(7), PRIVATE:: cie, cig + REAL, PRIVATE:: oig1, oig2, obmi + REAL, DIMENSION(13), PRIVATE:: cre, crg + REAL, PRIVATE:: ore1, org1, org2, org3, obmr + REAL, DIMENSION(17), PRIVATE:: cse, csg + REAL, PRIVATE:: oams, obms, ocms + REAL, DIMENSION(12,NRHG), PRIVATE:: cge, cgg + REAL, PRIVATE:: oge1, ogg1, ogg2, ogg3, obmg + REAL, DIMENSION(NRHG), PRIVATE:: oamg, ocmg + +!..Declaration of precomputed constants in various rate eqns. + REAL:: t1_qr_qc, t1_qr_qi, t2_qr_qi, t1_qg_qc, t1_qs_qc, t1_qs_qi + REAL:: t1_qr_ev, t2_qr_ev + REAL:: t1_qs_sd, t2_qs_sd, t1_qg_sd, t2_qg_sd + REAL:: t1_qs_me, t2_qs_me, t1_qg_me, t2_qg_me + +!+---+ +!+---+-----------------------------------------------------------------+ +!..END DECLARATIONS +!+---+-----------------------------------------------------------------+ +!+---+ +!ctrlL + + CONTAINS + + SUBROUTINE rcon_init(hgt, orho, nwfa2d, nbca2d, ng, & + nwfa, nifa, nbca, wif_input_opt, frc_urb2d, & + dx, dy, is_start, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte) + + IMPLICIT NONE + + INTEGER, INTENT(IN):: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + REAL, DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(IN):: hgt + +!..OPTIONAL variables that control application of hail-aware scheme + REAL, DIMENSION(ims:ime,kms:kme,jms:jme), OPTIONAL, INTENT(INOUT) :: ng + +!..OPTIONAL variables that control application of aerosol-aware scheme + + REAL, DIMENSION(ims:ime,kms:kme,jms:jme), OPTIONAL, INTENT(INOUT) :: nwfa, nifa, nbca + REAL, DIMENSION(ims:ime,jms:jme), OPTIONAL, INTENT(INOUT) :: nwfa2d, nbca2d + REAL, DIMENSION(ims:ime,kms:kme,jms:jme), OPTIONAL, INTENT(IN) :: orho + REAL, DIMENSION(ims:ime,jms:jme), OPTIONAL, INTENT(IN) :: frc_urb2d + REAL, OPTIONAL, INTENT(IN) :: DX, DY + LOGICAL, OPTIONAL, INTENT(IN) :: is_start + INTEGER, OPTIONAL, INTENT(IN) :: wif_input_opt + CHARACTER*256:: mp_debug + + + INTEGER:: i, j, k, l, m, n + REAL:: h_01, niIN3, niCCN3, niBC3, max_test, z1 + LOGICAL:: micro_init, has_CCN, has_IN + +!+---+ + + if (PRESENT(ng)) then + is_hail_aware = .TRUE. + dimNRHG = NRHG + else + av_g(idx_bg1) = av_g_old + bv_g(idx_bg1) = bv_g_old + dimNRHG = NRHG1 + endif + + is_aerosol_aware = .FALSE. + micro_init = .FALSE. + has_CCN = .FALSE. + has_IN = .FALSE. + + write(mp_debug,*) ' DEBUG checking column of hgt ', its+1,jts+1 + CALL wrf_debug(250, mp_debug) + do k = kts, kte + write(mp_debug,*) ' DEBUGT k, hgt = ', k, hgt(its+1,k,jts+1) + CALL wrf_debug(250, mp_debug) + enddo + + if (PRESENT(nwfa2d) .AND. PRESENT(nwfa) .AND. PRESENT(nifa)) is_aerosol_aware = .TRUE. + + if (is_aerosol_aware) then + +!..Check for existing aerosol data, both CCN and IN aerosols. If missing +!.. fill in just a basic vertical profile, somewhat boundary-layer following. + +#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) + max_test = wrf_dm_max_real ( MAXVAL(nwfa(its:ite-1,:,jts:jte-1)) ) +#else + max_test = MAXVAL ( nwfa(its:ite-1,:,jts:jte-1) ) +#endif + + if (max_test .lt. eps) then + write(mp_debug,*) ' Apparently there are no initial CCN aerosols.' + CALL wrf_debug(100, mp_debug) + write(mp_debug,*) ' checked column at point (i,j) = ', its,jts + CALL wrf_debug(100, mp_debug) + do j = jts, min(jde-1,jte) + do i = its, min(ide-1,ite) + if (hgt(i,1,j).le.1000.0) then + h_01 = 0.8 + elseif (hgt(i,1,j).ge.2500.0) then + h_01 = 0.01 + else + h_01 = 0.8*cos(hgt(i,1,j)*0.001 - 1.0) + endif + niCCN3 = -1.0*ALOG(naCCN1/naCCN0)/h_01 + nwfa(i,1,j) = naCCN1+naCCN0*exp(-((hgt(i,2,j)-hgt(i,1,j))/1000.)*niCCN3) + z1=hgt(i,2,j)-hgt(i,1,j) + nwfa2d(i,j) = nwfa(i,1,j) * 0.000196 * (50./z1) + do k = 2, kte + nwfa(i,k,j) = naCCN1+naCCN0*exp(-((hgt(i,k,j)-hgt(i,1,j))/1000.)*niCCN3) + enddo + enddo + enddo + else + has_CCN = .TRUE. + write(mp_debug,*) ' Apparently initial CCN aerosols are present.' + CALL wrf_debug(100, mp_debug) + write(mp_debug,*) ' column sum at point (i,j) = ', its,jts, SUM(nwfa(its,:,jts)) + CALL wrf_debug(100, mp_debug) + endif + + +#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) + max_test = wrf_dm_max_real ( MAXVAL(nifa(its:ite-1,:,jts:jte-1)) ) +#else + max_test = MAXVAL ( nifa(its:ite-1,:,jts:jte-1) ) +#endif + + if (max_test .lt. eps) then + write(mp_debug,*) ' Apparently there are no initial IN aerosols.' + CALL wrf_debug(100, mp_debug) + write(mp_debug,*) ' checked column at point (i,j) = ', its,jts + CALL wrf_debug(100, mp_debug) + do j = jts, min(jde-1,jte) + do i = its, min(ide-1,ite) + if (hgt(i,1,j).le.1000.0) then + h_01 = 0.8 + elseif (hgt(i,1,j).ge.2500.0) then + h_01 = 0.01 + else + h_01 = 0.8*cos(hgt(i,1,j)*0.001 - 1.0) + endif + niIN3 = -1.0*ALOG(naIN1/naIN0)/h_01 + nifa(i,1,j) = naIN1+naIN0*exp(-((hgt(i,2,j)-hgt(i,1,j))/1000.)*niIN3) + do k = 2, kte + nifa(i,k,j) = naIN1+naIN0*exp(-((hgt(i,k,j)-hgt(i,1,j))/1000.)*niIN3) + enddo + enddo + enddo + else + has_IN = .TRUE. + write(mp_debug,*) ' Apparently initial IN aerosols are present.' + CALL wrf_debug(100, mp_debug) + write(mp_debug,*) ' column sum at point (i,j) = ', its,jts, SUM(nifa(its,:,jts)) + CALL wrf_debug(100, mp_debug) + endif + + + if ( wif_input_opt .eq. 2 ) then + +#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) + max_test = wrf_dm_max_real ( MAXVAL(nbca(its:ite-1,:,jts:jte-1)) ) +#else + max_test = MAXVAL ( nbca(its:ite-1,:,jts:jte-1) ) +#endif + + if (max_test .lt. eps) then + write(mp_debug,*) ' Apparently there are no initial BC aerosols.' + CALL wrf_debug(100, mp_debug) + write(mp_debug,*) ' checked column at point (i,j) = ', its,jts + CALL wrf_debug(100, mp_debug) + do j = jts, min(jde-1,jte) + do i = its, min(ide-1,ite) + if (hgt(i,1,j).le.1000.0) then + h_01 = 0.8 + elseif (hgt(i,1,j).ge.2500.0) then + h_01 = 0.01 + else + h_01 = 0.8*cos(hgt(i,1,j)*0.001 - 1.0) + endif + niBC3 = -1.0*ALOG(naBC1/naBC0)/h_01 + nbca(i,1,j) = naBC1+naBC0*exp(-((hgt(i,2,j)-hgt(i,1,j))/1000.)*niBC3) + z1=hgt(i,2,j)-hgt(i,1,j) + nbca2d(i,j) = nbca(i,1,j) * 0.000098 * (50./z1) * (1. + frc_urb2d(i,j)) + do k = 2, kte + nbca(i,k,j) = naBC1+naBC0*exp(-((hgt(i,k,j)-hgt(i,1,j))/1000.)*niBC3) + enddo + enddo + enddo + else + write(mp_debug,*) ' Apparently initial BC aerosols are present.' + CALL wrf_debug(100, mp_debug) + write(mp_debug,*) ' column sum at point (i,j) = ', its,jts, SUM(nbca(its,:,jts)) + CALL wrf_debug(100, mp_debug) + endif + + endif + + endif + + +!..Allocate space for lookup tables (J. Michalakes 2009Jun08). + + if (.NOT. ALLOCATED(tcg_racg) ) then + ALLOCATE(tcg_racg(ntb_g1,ntb_g,dimNRHG,ntb_r1,ntb_r)) + micro_init = .TRUE. + endif + + if (.NOT. ALLOCATED(tmr_racg)) ALLOCATE(tmr_racg(ntb_g1,ntb_g,dimNRHG,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tcr_gacr)) ALLOCATE(tcr_gacr(ntb_g1,ntb_g,dimNRHG,ntb_r1,ntb_r)) + ! if (.NOT. ALLOCATED(tmg_gacr)) ALLOCATE(tmg_gacr(ntb_g1,ntb_g,dimNRHG,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tnr_racg)) ALLOCATE(tnr_racg(ntb_g1,ntb_g,dimNRHG,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tnr_gacr)) ALLOCATE(tnr_gacr(ntb_g1,ntb_g,dimNRHG,ntb_r1,ntb_r)) + + if (.NOT. ALLOCATED(tcs_racs1)) ALLOCATE(tcs_racs1(ntb_s,ntb_t,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tmr_racs1)) ALLOCATE(tmr_racs1(ntb_s,ntb_t,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tcs_racs2)) ALLOCATE(tcs_racs2(ntb_s,ntb_t,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tmr_racs2)) ALLOCATE(tmr_racs2(ntb_s,ntb_t,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tcr_sacr1)) ALLOCATE(tcr_sacr1(ntb_s,ntb_t,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tms_sacr1)) ALLOCATE(tms_sacr1(ntb_s,ntb_t,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tcr_sacr2)) ALLOCATE(tcr_sacr2(ntb_s,ntb_t,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tms_sacr2)) ALLOCATE(tms_sacr2(ntb_s,ntb_t,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tnr_racs1)) ALLOCATE(tnr_racs1(ntb_s,ntb_t,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tnr_racs2)) ALLOCATE(tnr_racs2(ntb_s,ntb_t,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tnr_sacr1)) ALLOCATE(tnr_sacr1(ntb_s,ntb_t,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tnr_sacr2)) ALLOCATE(tnr_sacr2(ntb_s,ntb_t,ntb_r1,ntb_r)) + + if (.NOT. ALLOCATED(tpi_qcfz)) ALLOCATE(tpi_qcfz(ntb_c,nbc,45,ntb_IN)) + if (.NOT. ALLOCATED(tni_qcfz)) ALLOCATE(tni_qcfz(ntb_c,nbc,45,ntb_IN)) + + if (.NOT. ALLOCATED(tpi_qrfz)) ALLOCATE(tpi_qrfz(ntb_r,ntb_r1,45,ntb_IN)) + if (.NOT. ALLOCATED(tpg_qrfz)) ALLOCATE(tpg_qrfz(ntb_r,ntb_r1,45,ntb_IN)) + if (.NOT. ALLOCATED(tni_qrfz)) ALLOCATE(tni_qrfz(ntb_r,ntb_r1,45,ntb_IN)) + if (.NOT. ALLOCATED(tnr_qrfz)) ALLOCATE(tnr_qrfz(ntb_r,ntb_r1,45,ntb_IN)) + + if (.NOT. ALLOCATED(tps_iaus)) ALLOCATE(tps_iaus(ntb_i,ntb_i1)) + if (.NOT. ALLOCATED(tni_iaus)) ALLOCATE(tni_iaus(ntb_i,ntb_i1)) + if (.NOT. ALLOCATED(tpi_ide)) ALLOCATE(tpi_ide(ntb_i,ntb_i1)) + + if (.NOT. ALLOCATED(t_Efrw)) ALLOCATE(t_Efrw(nbr,nbc)) + if (.NOT. ALLOCATED(t_Efsw)) ALLOCATE(t_Efsw(nbs,nbc)) + + if (.NOT. ALLOCATED(tnr_rev)) ALLOCATE(tnr_rev(nbr, ntb_r1, ntb_r)) + if (.NOT. ALLOCATED(tpc_wev)) ALLOCATE(tpc_wev(nbc,ntb_c,nbc)) + if (.NOT. ALLOCATED(tnc_wev)) ALLOCATE(tnc_wev(nbc,ntb_c,nbc)) + + if (.NOT. ALLOCATED(tnccn_act)) & + ALLOCATE(tnccn_act(ntb_arc,ntb_arw,ntb_art,ntb_arr,ntb_ark)) + + if (micro_init) then + +!..From Martin et al. (1994), assign gamma shape parameter mu for cloud +!.. drops according to general dispersion characteristics (disp=~0.25 +!.. for Maritime and 0.45 for Continental). +!.. disp=SQRT((mu+2)/(mu+1) - 1) so mu varies from 15 for Maritime +!.. to 2 for really dirty air. This not used in 2-moment cloud water +!.. scheme and nu_c used instead and varies from 2 to 15 (integer-only). + mu_c = MIN(15., (1000.E6/Nt_c + 2.)) + +!..Schmidt number to one-third used numerous times. + Sc3 = Sc**(1./3.) + +!..Compute min ice diam from mass, min snow/graupel mass from diam. + D0i = (xm0i/am_i)**(1./bm_i) + xm0s = am_s * D0s**bm_s + xm0g = am_g(NRHG) * D0g**bm_g + +!..These constants various exponents and gamma() assoc with cloud, +!.. rain, snow, and graupel. + do n = 1, 15 + cce(1,n) = n + 1. + cce(2,n) = bm_r + n + 1. + cce(3,n) = bm_r + n + 4. + cce(4,n) = n + bv_c + 1. + cce(5,n) = bm_r + n + bv_c + 1. + ccg(1,n) = WGAMMA(cce(1,n)) + ccg(2,n) = WGAMMA(cce(2,n)) + ccg(3,n) = WGAMMA(cce(3,n)) + ccg(4,n) = WGAMMA(cce(4,n)) + ccg(5,n) = WGAMMA(cce(5,n)) + ocg1(n) = 1./ccg(1,n) + ocg2(n) = 1./ccg(2,n) + enddo + + cie(1) = mu_i + 1. + cie(2) = bm_i + mu_i + 1. + cie(3) = bm_i + mu_i + bv_i + 1. + cie(4) = mu_i + bv_i + 1. + cie(5) = mu_i + 2. + cie(6) = bm_i*0.5 + mu_i + bv_i + 1. + cie(7) = bm_i*0.5 + mu_i + 1. + cig(1) = WGAMMA(cie(1)) + cig(2) = WGAMMA(cie(2)) + cig(3) = WGAMMA(cie(3)) + cig(4) = WGAMMA(cie(4)) + cig(5) = WGAMMA(cie(5)) + cig(6) = WGAMMA(cie(6)) + cig(7) = WGAMMA(cie(7)) + oig1 = 1./cig(1) + oig2 = 1./cig(2) + obmi = 1./bm_i + + cre(1) = bm_r + 1. + cre(2) = mu_r + 1. + cre(3) = bm_r + mu_r + 1. + cre(4) = bm_r*2. + mu_r + 1. + cre(5) = mu_r + bv_r + 1. + cre(6) = bm_r + mu_r + bv_r + 1. + cre(7) = bm_r*0.5 + mu_r + bv_r + 1. + cre(8) = bm_r + mu_r + bv_r + 3. + cre(9) = mu_r + bv_r + 3. + cre(10) = mu_r + 2. + cre(11) = 0.5*(bv_r + 5. + 2.*mu_r) + cre(12) = bm_r*0.5 + mu_r + 1. + cre(13) = bm_r*2. + mu_r + bv_r + 1. + do n = 1, 13 + crg(n) = WGAMMA(cre(n)) + enddo + obmr = 1./bm_r + ore1 = 1./cre(1) + org1 = 1./crg(1) + org2 = 1./crg(2) + org3 = 1./crg(3) + + cse(1) = bm_s + 1. + cse(2) = bm_s + 2. + cse(3) = bm_s*2. + cse(4) = bm_s + bv_s + 1. + cse(5) = bm_s*2. + bv_s + 1. + cse(6) = bm_s*2. + 1. + cse(7) = bm_s + mu_s + 1. + cse(8) = bm_s + mu_s + 2. + cse(9) = bm_s + mu_s + 3. + cse(10) = bm_s + mu_s + bv_s + 1. + cse(11) = bm_s*2. + mu_s + bv_s + 1. + cse(12) = bm_s*2. + mu_s + 1. + cse(13) = bv_s + 2. + cse(14) = bm_s + bv_s + cse(15) = mu_s + 1. + cse(16) = 1.0 + (1.0 + bv_s)/2. + cse(17) = bm_s + bv_s + 2. + do n = 1, 17 + csg(n) = WGAMMA(cse(n)) + enddo + oams = 1./am_s + obms = 1./bm_s + ocms = oams**obms + + cge(1,:) = bm_g + 1. + cge(2,:) = mu_g + 1. + cge(3,:) = bm_g + mu_g + 1. + cge(4,:) = bm_g*2. + mu_g + 1. + cge(10,:) = mu_g + 2. + cge(12,:) = bm_g*0.5 + mu_g + 1. + do m = 1, NRHG + cge(5,m) = bm_g*2. + mu_g + bv_g(m) + 1. + cge(6,m) = bm_g + mu_g + bv_g(m) + 1. + cge(7,m) = bm_g*0.5 + mu_g + bv_g(m) + 1. + cge(8,m) = mu_g + bv_g(m) + 1. ! not used + cge(9,m) = mu_g + bv_g(m) + 3. + cge(11,m) = 0.5*(bv_g(m) + 5. + 2.*mu_g) + enddo + do m = 1, NRHG + do n = 1, 12 + cgg(n,m) = WGAMMA(cge(n,m)) + enddo + enddo + oamg = 1./am_g + obmg = 1./bm_g + do m = 1, NRHG + oamg(m) = 1./am_g(m) + ocmg(m) = oamg(m)**obmg + enddo + oge1 = 1./cge(1,1) + ogg1 = 1./cgg(1,1) + ogg2 = 1./cgg(2,1) + ogg3 = 1./cgg(3,1) + +!+---+-----------------------------------------------------------------+ +!..Simplify various rate eqns the best we can now. +!+---+-----------------------------------------------------------------+ + +!..Rain collecting cloud water and cloud ice + t1_qr_qc = PI*.25*av_r * crg(9) + t1_qr_qi = PI*.25*av_r * crg(9) + t2_qr_qi = PI*.25*am_r*av_r * crg(8) + +!..Graupel collecting cloud water +! t1_qg_qc = PI*.25*av_g * cgg(9) + +!..Snow collecting cloud water + t1_qs_qc = PI*.25*av_s + +!..Snow collecting cloud ice + t1_qs_qi = PI*.25*av_s + +!..Evaporation of rain; ignore depositional growth of rain. + t1_qr_ev = 0.78 * crg(10) + t2_qr_ev = 0.308*Sc3*SQRT(av_r) * crg(11) + +!..Sublimation/depositional growth of snow + t1_qs_sd = 0.86 + t2_qs_sd = 0.28*Sc3*SQRT(av_s) + +!..Melting of snow + t1_qs_me = PI*4.*C_sqrd*olfus * 0.86 + t2_qs_me = PI*4.*C_sqrd*olfus * 0.28*Sc3*SQRT(av_s) + +!..Sublimation/depositional growth of graupel + t1_qg_sd = 0.86 * cgg(10,1) +! t2_qg_sd = 0.28*Sc3*SQRT(av_g) * cgg(11) + +!..Melting of graupel + t1_qg_me = PI*4.*C_cube*olfus * 0.86 * cgg(10,1) +! t2_qg_me = PI*4.*C_cube*olfus * 0.28*Sc3*SQRT(av_g) * cgg(11) + +!..Constants for helping find lookup table indexes. + nic2 = NINT(ALOG10(r_c(1))) + nii2 = NINT(ALOG10(r_i(1))) + nii3 = NINT(ALOG10(Nt_i(1))) + nir2 = NINT(ALOG10(r_r(1))) + nir3 = NINT(ALOG10(N0r_exp(1))) + nis2 = NINT(ALOG10(r_s(1))) + nig2 = NINT(ALOG10(r_g(1))) + nig3 = NINT(ALOG10(N0g_exp(1))) + niIN2 = NINT(ALOG10(Nt_IN(1))) + +!..Create bins of cloud water (from min diameter up to 100 microns). + Dc(1) = D0c*1.0d0 + dtc(1) = D0c*1.0d0 + do n = 2, nbc + Dc(n) = Dc(n-1) + 1.0D-6 + dtc(n) = (Dc(n) - Dc(n-1)) + enddo + +!..Create bins of cloud ice (from min diameter up to 5x min snow size). + xDx(1) = D0i*1.0d0 + xDx(nbi+1) = 2.0d0*D0s + do n = 2, nbi + xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbi) & + *DLOG(xDx(nbi+1)/xDx(1)) +DLOG(xDx(1))) + enddo + do n = 1, nbi + Di(n) = DSQRT(xDx(n)*xDx(n+1)) + dti(n) = xDx(n+1) - xDx(n) + enddo + +!..Create bins of rain (from min diameter up to 5 mm). + xDx(1) = D0r*1.0d0 + xDx(nbr+1) = 0.005d0 + do n = 2, nbr + xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbr) & + *DLOG(xDx(nbr+1)/xDx(1)) +DLOG(xDx(1))) + enddo + do n = 1, nbr + Dr(n) = DSQRT(xDx(n)*xDx(n+1)) + dtr(n) = xDx(n+1) - xDx(n) + enddo + +!..Create bins of snow (from min diameter up to 2 cm). + xDx(1) = D0s*1.0d0 + xDx(nbs+1) = 0.02d0 + do n = 2, nbs + xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbs) & + *DLOG(xDx(nbs+1)/xDx(1)) +DLOG(xDx(1))) + enddo + do n = 1, nbs + Ds(n) = DSQRT(xDx(n)*xDx(n+1)) + dts(n) = xDx(n+1) - xDx(n) + enddo + +!..Create bins of graupel (from min diameter up to 5 cm). + xDx(1) = D0g*1.0d0 + xDx(nbg+1) = 0.05d0 + do n = 2, nbg + xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbg) & + *DLOG(xDx(nbg+1)/xDx(1)) +DLOG(xDx(1))) + enddo + do n = 1, nbg + Dg(n) = DSQRT(xDx(n)*xDx(n+1)) + dtg(n) = xDx(n+1) - xDx(n) + enddo + +!..Create bins of cloud droplet number concentration (1 to 3000 per cc). + xDx(1) = 1.0d0 + xDx(nbc+1) = 3000.0d0 + do n = 2, nbc + xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbc) & + *DLOG(xDx(nbc+1)/xDx(1)) +DLOG(xDx(1))) + enddo + do n = 1, nbc + t_Nc(n) = DSQRT(xDx(n)*xDx(n+1)) * 1.D6 + enddo + nic1 = DLOG(t_Nc(nbc)/t_Nc(1)) + +!+---+-----------------------------------------------------------------+ +!..Create lookup tables for most costly calculations. +!+---+-----------------------------------------------------------------+ + + do m = 1, ntb_r + do k = 1, ntb_r1 + do n = 1, dimNRHG + do j = 1, ntb_g + do i = 1, ntb_g1 + tcg_racg(i,j,n,k,m) = 0.0d0 + tmr_racg(i,j,n,k,m) = 0.0d0 + tcr_gacr(i,j,n,k,m) = 0.0d0 + !tmg_gacr(i,j,n,k,m) = 0.0d0 + tnr_racg(i,j,n,k,m) = 0.0d0 + tnr_gacr(i,j,n,k,m) = 0.0d0 + enddo + enddo + enddo + enddo + enddo + + do m = 1, ntb_r + do k = 1, ntb_r1 + do j = 1, ntb_t + do i = 1, ntb_s + tcs_racs1(i,j,k,m) = 0.0d0 + tmr_racs1(i,j,k,m) = 0.0d0 + tcs_racs2(i,j,k,m) = 0.0d0 + tmr_racs2(i,j,k,m) = 0.0d0 + tcr_sacr1(i,j,k,m) = 0.0d0 + tms_sacr1(i,j,k,m) = 0.0d0 + tcr_sacr2(i,j,k,m) = 0.0d0 + tms_sacr2(i,j,k,m) = 0.0d0 + tnr_racs1(i,j,k,m) = 0.0d0 + tnr_racs2(i,j,k,m) = 0.0d0 + tnr_sacr1(i,j,k,m) = 0.0d0 + tnr_sacr2(i,j,k,m) = 0.0d0 + enddo + enddo + enddo + enddo + + do m = 1, ntb_IN + do k = 1, 45 + do j = 1, ntb_r1 + do i = 1, ntb_r + tpi_qrfz(i,j,k,m) = 0.0d0 + tni_qrfz(i,j,k,m) = 0.0d0 + tpg_qrfz(i,j,k,m) = 0.0d0 + tnr_qrfz(i,j,k,m) = 0.0d0 + enddo + enddo + do j = 1, nbc + do i = 1, ntb_c + tpi_qcfz(i,j,k,m) = 0.0d0 + tni_qcfz(i,j,k,m) = 0.0d0 + enddo + enddo + enddo + enddo + + do j = 1, ntb_i1 + do i = 1, ntb_i + tps_iaus(i,j) = 0.0d0 + tni_iaus(i,j) = 0.0d0 + tpi_ide(i,j) = 0.0d0 + enddo + enddo + + do j = 1, nbc + do i = 1, nbr + t_Efrw(i,j) = 0.0 + enddo + do i = 1, nbs + t_Efsw(i,j) = 0.0 + enddo + enddo + + do k = 1, ntb_r + do j = 1, ntb_r1 + do i = 1, nbr + tnr_rev(i,j,k) = 0.0d0 + enddo + enddo + enddo + + do k = 1, nbc + do j = 1, ntb_c + do i = 1, nbc + tpc_wev(i,j,k) = 0.0d0 + tnc_wev(i,j,k) = 0.0d0 + enddo + enddo + enddo + + do m = 1, ntb_ark + do l = 1, ntb_arr + do k = 1, ntb_art + do j = 1, ntb_arw + do i = 1, ntb_arc + tnccn_act(i,j,k,l,m) = 1.0 + enddo + enddo + enddo + enddo + enddo + + CALL wrf_debug(150, 'CREATING MICROPHYSICS LOOKUP TABLES ... ') + WRITE (wrf_err_message, '(a, f5.2, a, f5.2, a, f5.2, a, f5.2)') & + ' using: mu_c=',mu_c,' mu_i=',mu_i,' mu_r=',mu_r,' mu_g=',mu_g + CALL wrf_debug(150, wrf_err_message) + +!..Read a static file containing CCN activation of aerosols. The +!.. data were created from a parcel model by Feingold & Heymsfield with +!.. further changes by Eidhammer and Kriedenweis. + if (is_aerosol_aware) then + CALL wrf_debug(200, ' calling table_ccnAct routine') + call table_ccnAct + endif + +!..Collision efficiency between rain/snow and cloud water. + CALL wrf_debug(200, ' creating qc collision eff tables') + call table_Efrw + call table_Efsw + +!..Drop evaporation. + CALL wrf_debug(200, ' creating rain evap table') + call table_dropEvap + +!..Initialize various constants for computing radar reflectivity. + xam_r = am_r + xbm_r = bm_r + xmu_r = mu_r + xam_s = am_s + xbm_s = bm_s + xmu_s = mu_s + xam_g = am_g(idx_bg1) + xbm_g = bm_g + xmu_g = mu_g + call radar_init + + if (.not. iiwarm) then + +!..Rain collecting graupel & graupel collecting rain. + CALL wrf_debug(200, ' creating rain collecting graupel table') + + call qr_acr_qg(dimNRHG) + +!..Rain collecting snow & snow collecting rain. + CALL wrf_debug(200, ' creating rain collecting snow table') + call qr_acr_qs + +!..Cloud water and rain freezing (Bigg, 1953). + CALL wrf_debug(200, ' creating freezing of water drops table') + call freezeH2O + +!..Conversion of some ice mass into snow category. + CALL wrf_debug(200, ' creating ice converting to snow table') + call qi_aut_qs + + endif + + CALL wrf_debug(150, ' ... DONE microphysical lookup tables') + + endif + + END SUBROUTINE rcon_init +!+---+-----------------------------------------------------------------+ +!ctrlL +!+---+-----------------------------------------------------------------+ +!..This is a wrapper routine designed to transfer values from 3D to 1D. +!+---+-----------------------------------------------------------------+ + SUBROUTINE mp_rcon_driver(qv, qc, qr, qi, qs, qg, qb, ni, nr, nc, ng,& + nwfa, nifa, nbca, nwfa2d, nifa2d, nbca2d, & + aer_init_opt, wif_input_opt, & + th, pii, p, w, dz, & + dt_in, itimestep, & + RAINNC, RAINNCV, & + CLOUDNC, & !RC + SNOWNC, SNOWNCV, & + GRAUPELNC, GRAUPELNCV, SR, & +#if ( WRF_CHEM == 1 ) + wetscav_on, rainprod, evapprod, & +#endif + refl_10cm, diagflag, ke_diag, do_radar_ref, & + re_cloud, re_ice, re_snow, & + has_reqc, has_reqi, has_reqs, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + its,ite, jts,jte, kts,kte & ! tile dims + ) !RC + + + implicit none + +!..Subroutine arguments + INTEGER, INTENT(IN):: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: & + qv, qc, qr, qi, qs, qg, ni, nr, th + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT):: & + nc, nwfa, nifa, nbca, qb, ng + REAL, DIMENSION(ims:ime, jms:jme), OPTIONAL, INTENT(IN):: nwfa2d, nifa2d, & + nbca2d + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: & + re_cloud, re_ice, re_snow + INTEGER, INTENT(IN):: has_reqc, has_reqi, has_reqs +#if ( WRF_CHEM == 1 ) + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: & + rainprod, evapprod +#endif + + !RC + REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT):: CLOUDNC + + !\RC + + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN):: & + pii, p, w, dz + REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT):: & + RAINNC, RAINNCV, SR + REAL, DIMENSION(ims:ime, jms:jme), OPTIONAL, INTENT(INOUT):: & + SNOWNC, SNOWNCV, GRAUPELNC, GRAUPELNCV + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: & + refl_10cm + REAL, INTENT(IN):: dt_in + INTEGER, INTENT(IN):: itimestep + INTEGER, OPTIONAL, INTENT(IN):: aer_init_opt, wif_input_opt +#if ( WRF_CHEM == 1 ) + LOGICAL, INTENT(in) :: wetscav_on +#endif + +!..Local variables + REAL, DIMENSION(kts:kte):: & + qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, qb1d, & + ni1d, nr1d, nc1d, ng1d, nwfa1d, nifa1d, nbca1d,& + t1d, p1d, w1d, dz1d, rho, dBZ + REAL, DIMENSION(kts:kte):: re_qc1d, re_qi1d, re_qs1d +#if ( WRF_CHEM == 1 ) + REAL, DIMENSION(kts:kte):: & + rainprod1d, evapprod1d +#endif + + REAL, DIMENSION(its:ite, jts:jte):: pcp_ra, pcp_sn, pcp_gr, pcp_ic + REAL:: dt, pptrain, pptsnow, pptgraul, pptice, pptcloud !RC; added pptcloud + REAL:: qc_max, qr_max, qs_max, qi_max, qg_max, ni_max, nr_max + REAL:: nwfa1 + REAL:: ygra1, zans1 + DOUBLE PRECISION:: lamg, lam_exp, lamr, N0_min, N0_exp + INTEGER:: i, j, k, k_0, k_inj + INTEGER:: imax_qc,imax_qr,imax_qi,imax_qs,imax_qg,imax_ni,imax_nr + INTEGER:: jmax_qc,jmax_qr,jmax_qi,jmax_qs,jmax_qg,jmax_ni,jmax_nr + INTEGER:: kmax_qc,kmax_qr,kmax_qi,kmax_qs,kmax_qg,kmax_ni,kmax_nr + INTEGER:: i_start, j_start, i_end, j_end + LOGICAL, OPTIONAL, INTENT(IN) :: diagflag + INTEGER, OPTIONAL, INTENT(IN) :: do_radar_ref, ke_diag + CHARACTER*256:: mp_debug + + integer :: kediagloc + +!+---+ + + i_start = its + j_start = jts + i_end = MIN(ite, ide-1) + j_end = MIN(jte, jde-1) + +!..For idealized testing by developer. +! if ( (ide-ids+1).gt.4 .and. (jde-jds+1).lt.4 .and. & +! ids.eq.its.and.ide.eq.ite.and.jds.eq.jts.and.jde.eq.jte) then +! i_start = its + 2 +! i_end = ite +! j_start = jts +! j_end = jte +! endif + + dt = dt_in + + qc_max = 0. + qr_max = 0. + qs_max = 0. + qi_max = 0. + qg_max = 0 + ni_max = 0. + nr_max = 0. + imax_qc = 0 + imax_qr = 0 + imax_qi = 0 + imax_qs = 0 + imax_qg = 0 + imax_ni = 0 + imax_nr = 0 + jmax_qc = 0 + jmax_qr = 0 + jmax_qi = 0 + jmax_qs = 0 + jmax_qg = 0 + jmax_ni = 0 + jmax_nr = 0 + kmax_qc = 0 + kmax_qr = 0 + kmax_qi = 0 + kmax_qs = 0 + kmax_qg = 0 + kmax_ni = 0 + kmax_nr = 0 + do i = 1, 256 + mp_debug(i:i) = char(0) + enddo + + if (.NOT. is_aerosol_aware .AND. PRESENT(nc) .AND. PRESENT(nwfa) & + .AND. PRESENT(nifa) .AND. PRESENT(nwfa2d)) then + write(mp_debug,*) 'WARNING, nc-nwfa-nifa-nwfa2d present but is_aerosol_aware is FALSE' + CALL wrf_debug(0, mp_debug) + endif + + j_loop: do j = j_start, j_end + i_loop: do i = i_start, i_end + + pptrain = 0. + pptcloud = 0. !RC + pptsnow = 0. + pptgraul = 0. + pptice = 0. + RAINNCV(i,j) = 0. + IF ( PRESENT (snowncv) ) THEN + SNOWNCV(i,j) = 0. + ENDIF + IF ( PRESENT (graupelncv) ) THEN + GRAUPELNCV(i,j) = 0. + ENDIF + SR(i,j) = 0. + + do k = kts, kte + t1d(k) = th(i,k,j)*pii(i,k,j) + p1d(k) = p(i,k,j) + w1d(k) = w(i,k,j) + dz1d(k) = dz(i,k,j) + qv1d(k) = qv(i,k,j) + qc1d(k) = qc(i,k,j) + qi1d(k) = qi(i,k,j) + qr1d(k) = qr(i,k,j) + qs1d(k) = qs(i,k,j) + qg1d(k) = qg(i,k,j) + ni1d(k) = ni(i,k,j) + nr1d(k) = nr(i,k,j) + rho(k) = 0.622*p1d(k)/(R*t1d(k)*(qv1d(k)+0.622)) + enddo + if (is_aerosol_aware) then + do k = kts, kte + nc1d(k) = nc(i,k,j) + nwfa1d(k) = nwfa(i,k,j) + nifa1d(k) = nifa(i,k,j) + if (wif_input_opt .eq. 2) then + nbca1d(k) = nbca(i,k,j) + else + nbca1d(k) = 0.0 + endif + enddo + nwfa1 = nwfa2d(i,j) + else + do k = kts, kte + nc1d(k) = Nt_c/rho(k) + nwfa1d(k) = 11.1E6/rho(k) + nifa1d(k) = naIN1*0.01/rho(k) + nbca1d(k) = 5.55E6/rho(k) + enddo + endif + +!..If not the variable-density graupel-hail hybrid, then set the vol mixing +!.. ratio to mass mixing ratio divided by constant density (500kg/m3) value. + + if (is_hail_aware) then + do k = kts, kte + ng1d(k) = ng(i,k,j) + qb1d(k) = qb(i,k,j) + enddo + else + + do k = kte, kts, -1 + if (qg1d(k).gt.R1) then + ygra1 = alog10(max(1.E-9, qg1d(k)*rho(k))) + zans1 = 3.0 + 2./7.*(ygra1+8.) + zans1 = MAX(2., MIN(zans1, 6.)) + N0_exp = 10.**(zans1) + lam_exp = (N0_exp*am_g(idx_bg1)*cgg(1,1)/(rho(k)*qg1d(k)))**oge1 + lamg = lam_exp * (cgg(3,1)*ogg2*ogg1)**obmg + ng1d(k) = cgg(2,1)*ogg3*rho(k)*qg1d(k)*lamg**bm_g / am_g(idx_bg1) + ng1d(k) = MAX(R2, ng1d(k)/rho(k)) + qb1d(k) = qg1d(k)/rho_g(idx_bg1) + else + ng1d(k) = 0 + qb1d(k) = 0 + endif + enddo + endif + + call mp_rcon(aer_init_opt, wif_input_opt, & + qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, qb1d, ni1d, & + nr1d, nc1d, ng1d, nwfa1d, nifa1d, nbca1d, t1d, p1d, w1d, dz1d, & + pptrain, pptcloud, pptsnow, pptgraul, pptice, & +#if ( WRF_CHEM == 1 ) + wetscav_on, rainprod1d, evapprod1d, & +#endif + kts, kte, dt, i, j) !RC + + pcp_ra(i,j) = pptrain + pcp_sn(i,j) = pptsnow + pcp_gr(i,j) = pptgraul + pcp_ic(i,j) = pptice + RAINNCV(i,j) = pptrain + pptsnow + pptgraul + pptice + pptcloud !RC + RAINNC(i,j) = RAINNC(i,j) + pptrain + pptsnow + pptgraul + pptice + pptcloud !RC + CLOUDNC(i,j) = CLOUDNC(i,j) + pptcloud !RC + IF ( PRESENT(snowncv) .AND. PRESENT(snownc) ) THEN + SNOWNCV(i,j) = pptsnow + pptice + SNOWNC(i,j) = SNOWNC(i,j) + pptsnow + pptice + ENDIF + IF ( PRESENT(graupelncv) .AND. PRESENT(graupelnc) ) THEN + GRAUPELNCV(i,j) = pptgraul + GRAUPELNC(i,j) = GRAUPELNC(i,j) + pptgraul + ENDIF + SR(i,j) = (pptsnow + pptgraul + pptice)/(RAINNCV(i,j)+1.e-12) + + +!.. +!..BEGIN AEROSOL EMISSIONS +!.. +!..Reset lowest model level to initial state aerosols (fake sfc source). +!.. Changed 13 May 2013 to fake emissions in which nwfa2d is aerosol +!.. number tendency (number per kg per second). + if (is_aerosol_aware) then +!..Add anthropogenic emissions +!-GT nwfa1d(kts) = nwfa1 + nwfa1d(kts) = nwfa1d(kts) + nwfa2d(i,j)*dt_in + nifa1d(kts) = nifa1d(kts) + nifa2d(i,j)*dt_in + if (wif_input_opt .eq. 2) then + nbca1d(kts) = nbca1d(kts) + nbca2d(i,j)*dt_in + else + nbca1d(kts) = 0.0 + endif +!.. +!..END AEROSOL EMISSIONS +!.. + + do k = kts, kte + nc(i,k,j) = nc1d(k) + nwfa(i,k,j) = nwfa1d(k) + nifa(i,k,j) = nifa1d(k) + if (wif_input_opt .eq. 2) then + nbca(i,k,j) = nbca1d(k) + else + nbca(i,k,j) = 0.0 + endif + enddo + endif + if (is_hail_aware) then + do k = kts, kte + ng(i,k,j) = ng1d(k) + qb(i,k,j) = qb1d(k) + enddo + endif + + do k = kts, kte + qv(i,k,j) = qv1d(k) + qc(i,k,j) = qc1d(k) + qi(i,k,j) = qi1d(k) + qr(i,k,j) = qr1d(k) + qs(i,k,j) = qs1d(k) + qg(i,k,j) = qg1d(k) + ni(i,k,j) = ni1d(k) + nr(i,k,j) = nr1d(k) + th(i,k,j) = t1d(k)/pii(i,k,j) +#if ( WRF_CHEM == 1 ) + IF ( wetscav_on ) THEN + rainprod(i,k,j) = rainprod1d(k) + evapprod(i,k,j) = evapprod1d(k) + ENDIF +#endif + if (qc1d(k) .gt. qc_max) then + imax_qc = i + jmax_qc = j + kmax_qc = k + qc_max = qc1d(k) + elseif (qc1d(k) .lt. 0.0) then + write(mp_debug,*) 'WARNING, negative qc ', qc1d(k), & + ' at i,j,k=', i,j,k + CALL wrf_debug(150, mp_debug) + endif + if (qr1d(k) .gt. qr_max) then + imax_qr = i + jmax_qr = j + kmax_qr = k + qr_max = qr1d(k) + elseif (qr1d(k) .lt. 0.0) then + write(mp_debug,*) 'WARNING, negative qr ', qr1d(k), & + ' at i,j,k=', i,j,k + CALL wrf_debug(150, mp_debug) + endif + if (nr1d(k) .gt. nr_max) then + imax_nr = i + jmax_nr = j + kmax_nr = k + nr_max = nr1d(k) + elseif (nr1d(k) .lt. 0.0) then + write(mp_debug,*) 'WARNING, negative nr ', nr1d(k), & + ' at i,j,k=', i,j,k + CALL wrf_debug(150, mp_debug) + endif + if (qs1d(k) .gt. qs_max) then + imax_qs = i + jmax_qs = j + kmax_qs = k + qs_max = qs1d(k) + elseif (qs1d(k) .lt. 0.0) then + write(mp_debug,*) 'WARNING, negative qs ', qs1d(k), & + ' at i,j,k=', i,j,k + CALL wrf_debug(150, mp_debug) + endif + if (qi1d(k) .gt. qi_max) then + imax_qi = i + jmax_qi = j + kmax_qi = k + qi_max = qi1d(k) + elseif (qi1d(k) .lt. 0.0) then + write(mp_debug,*) 'WARNING, negative qi ', qi1d(k), & + ' at i,j,k=', i,j,k + CALL wrf_debug(150, mp_debug) + endif + if (qg1d(k) .gt. qg_max) then + imax_qg = i + jmax_qg = j + kmax_qg = k + qg_max = qg1d(k) + elseif (qg1d(k) .lt. 0.0) then + write(mp_debug,*) 'WARNING, negative qg ', qg1d(k), & + ' at i,j,k=', i,j,k + CALL wrf_debug(150, mp_debug) + endif + if (ni1d(k) .gt. ni_max) then + imax_ni = i + jmax_ni = j + kmax_ni = k + ni_max = ni1d(k) + elseif (ni1d(k) .lt. 0.0) then + write(mp_debug,*) 'WARNING, negative ni ', ni1d(k), & + ' at i,j,k=', i,j,k + CALL wrf_debug(150, mp_debug) + endif + if (qv1d(k) .lt. 0.0) then + write(mp_debug,*) 'WARNING, negative qv ', qv1d(k), & + ' at i,j,k=', i,j,k + CALL wrf_debug(150, mp_debug) + if (k.lt.kte-2 .and. k.gt.kts+1) then + write(mp_debug,*) ' below and above are: ', qv(i,k-1,j), qv(i,k+1,j) + CALL wrf_debug(150, mp_debug) + qv(i,k,j) = MAX(1.E-7, 0.5*(qv(i,k-1,j) + qv(i,k+1,j))) + else + qv(i,k,j) = 1.E-7 + endif + endif + enddo + + IF ( PRESENT (diagflag) ) THEN + if (diagflag .and. do_radar_ref == 1) then + + IF ( present(ke_diag) ) THEN + kediagloc = ke_diag + ELSE + kediagloc = kte + ENDIF + + call calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & + ng1d, qb1d, t1d, p1d, dBZ, kts, kte, i, j, kediagloc) + do k = kts, kte + refl_10cm(i,k,j) = MAX(-35., dBZ(k)) + enddo + endif + ENDIF + + IF (has_reqc.ne.0 .and. has_reqi.ne.0 .and. has_reqs.ne.0) THEN + do k = kts, kte + re_qc1d(k) = RE_QC_BG + re_qi1d(k) = RE_QI_BG + re_qs1d(k) = RE_QS_BG + enddo + call calc_effectRad (t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d, & + re_qc1d, re_qi1d, re_qs1d, kts, kte) + do k = kts, kte + re_cloud(i,k,j) = MAX(RE_QC_BG, MIN(re_qc1d(k), 75.E-6)) !RC + re_ice(i,k,j) = MAX(RE_QI_BG, MIN(re_qi1d(k), 125.E-6)) + re_snow(i,k,j) = MAX(RE_QS_BG, MIN(re_qs1d(k), 999.E-6)) + enddo + ENDIF + + enddo i_loop + enddo j_loop + +! DEBUG - GT + write(mp_debug,'(a,7(a,e13.6,1x,a,i3,a,i3,a,i3,a,1x))') 'MP-GT:', & + 'qc: ', qc_max, '(', imax_qc, ',', jmax_qc, ',', kmax_qc, ')', & + 'qr: ', qr_max, '(', imax_qr, ',', jmax_qr, ',', kmax_qr, ')', & + 'qi: ', qi_max, '(', imax_qi, ',', jmax_qi, ',', kmax_qi, ')', & + 'qs: ', qs_max, '(', imax_qs, ',', jmax_qs, ',', kmax_qs, ')', & + 'qg: ', qg_max, '(', imax_qg, ',', jmax_qg, ',', kmax_qg, ')', & + 'ni: ', ni_max, '(', imax_ni, ',', jmax_ni, ',', kmax_ni, ')', & + 'nr: ', nr_max, '(', imax_nr, ',', jmax_nr, ',', kmax_nr, ')' + CALL wrf_debug(150, mp_debug) +! END DEBUG - GT + + do i = 1, 256 + mp_debug(i:i) = char(0) + enddo + + END SUBROUTINE mp_rcon_driver + +!+---+-----------------------------------------------------------------+ +!ctrlL +!+---+-----------------------------------------------------------------+ +!+---+-----------------------------------------------------------------+ +!.. This subroutine computes the moisture tendencies of water vapor, +!.. cloud droplets, rain, cloud ice (pristine), snow, and graupel. +!.. Previously this code was based on Reisner et al (1998), but few of +!.. those pieces remain. A complete description is now found in +!.. Thompson et al. (2004, 2008). +!+---+-----------------------------------------------------------------+ +! + subroutine mp_rcon (aer_init_opt, wif_input_opt, & + qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, qb1d, & + ni1d, nr1d, nc1d, ng1d, nwfa1d, nifa1d, nbca1d, & + t1d, p1d, w1d, dzq, & + pptrain, pptcloud, pptsnow, pptgraul, pptice, & !RC +#if ( WRF_CHEM == 1 ) + wetscav_on, rainprod, evapprod, & +#endif + kts, kte, dt, ii, jj) + + implicit none + +!..Sub arguments + INTEGER, OPTIONAL, INTENT(IN):: aer_init_opt, wif_input_opt + INTEGER, INTENT(IN):: kts, kte, ii, jj + REAL, DIMENSION(kts:kte), INTENT(INOUT):: & + qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, qb1d, & + ni1d, nr1d, nc1d, ng1d, nwfa1d, nifa1d, nbca1d, t1d + REAL, DIMENSION(kts:kte), INTENT(IN):: p1d, w1d, dzq + REAL, INTENT(INOUT):: pptrain, pptsnow, pptgraul, pptice, pptcloud !RC + REAL, INTENT(IN):: dt +#if ( WRF_CHEM == 1 ) + REAL, DIMENSION(kts:kte), INTENT(INOUT):: & + rainprod, evapprod + LOGICAL, INTENT(IN) :: wetscav_on +#endif + +!..Local variables + REAL, DIMENSION(kts:kte):: tten, qvten, qcten, qiten, qrten, & + qsten, qgten, qbten, niten, nrten, ncten, ngten, nwfaten, nifaten, & + nbcaten + + DOUBLE PRECISION, DIMENSION(kts:kte):: prw_vcd + + DOUBLE PRECISION, DIMENSION(kts:kte):: pnc_wcd, & + pnc_scw, pnc_gcw + + DOUBLE PRECISION, DIMENSION(kts:kte):: pna_rca, pna_sca, pna_gca, & + pnd_rcd, pnd_scd, pnd_gcd, pnb_rcb, pnb_scb, pnb_gcb + + DOUBLE PRECISION, DIMENSION(kts:kte):: prr_rcs, & + prr_rcg, prr_sml, prr_gml, & + prr_rci, prv_rev, & + pnr_rcs, pnr_rcg, & + pnr_rci, pnr_sml, pnr_gml, & + pnr_rev, pnr_rcr, pnr_rfz + + DOUBLE PRECISION, DIMENSION(kts:kte):: pri_inu, pni_inu, pri_ihm, & + pni_ihm, pri_wfz, pni_wfz, & + pri_rfz, pni_rfz, pri_ide, & + pni_ide, pri_rci, pni_rci, & + pni_sci, pni_iau, pri_iha, pni_iha + + DOUBLE PRECISION, DIMENSION(kts:kte):: prs_iau, prs_sci, prs_rcs, & + prs_scw, prs_sde, prs_ihm, & + prs_ide + + DOUBLE PRECISION, DIMENSION(kts:kte):: prg_scw, prg_rfz, prg_gde, & + prg_gcw, prg_rci, prg_rcs, prg_rcg, prg_ihm, & + png_rcs, png_rcg, png_scw, png_gde, & + pbg_scw, pbg_rfz, pbg_gcw, pbg_rci, pbg_rcs, pbg_rcg, & + pbg_sml, pbg_gml + + DOUBLE PRECISION, PARAMETER:: zeroD0 = 0.0d0 + + REAL, DIMENSION(kts:kte):: temp, twet, pres, qv + REAL, DIMENSION(kts:kte):: rc, ri, rr, rs, rg, rb + REAL, DIMENSION(kts:kte):: ni, nr, nc, ns, ng, nwfa, nifa, nbca + REAL, DIMENSION(kts:kte):: rho, rhof, rhof2 + REAL, DIMENSION(kts:kte):: qvs, qvsi, delQvs + REAL, DIMENSION(kts:kte):: satw, sati, ssatw, ssati + REAL, DIMENSION(kts:kte):: diffu, visco, vsc2, & + tcond, lvap, ocp, lvt2 + + DOUBLE PRECISION, DIMENSION(kts:kte):: ilamg, N0_r, N0_g + DOUBLE PRECISION:: N0_melt + REAL, DIMENSION(kts:kte):: mvd_r, mvd_c, mvd_g + REAL, DIMENSION(kts:kte):: smob, smo2, smo1, smo0, & + smoc, smod, smoe, smof, smog + + REAL, DIMENSION(kts:kte):: sed_r,sed_s,sed_g,sed_i,sed_n,sed_c,sed_b + + REAL:: rgvm, delta_tp, orho, lfus2 + REAL, DIMENSION(5):: onstep + DOUBLE PRECISION:: N0_exp, N0_min, lam_exp, lamc, lamr, lamg + DOUBLE PRECISION:: lami, ilami + REAL:: xDc, Dc_b, Dc_g, xDi, xDr, xDs, xDg, Ds_m, Dg_m + DOUBLE PRECISION:: Dr_star, Dc_star + REAL:: zeta1, zeta, taud, tau + REAL:: stoke_r, stoke_s, stoke_g, stoke_i + REAL:: vti, vtr, vts, vtg, vtc + REAL:: xrho_g, afall, vtg1, vtg2 + REAL:: bfall = 3*b_coeff - 1 + REAL, DIMENSION(kts:kte+1):: vtik, vtnik, vtrk, vtnrk, vtsk, vtgk, & + vtngk, vtck, vtnck + REAL, DIMENSION(kts:kte):: vts_boost + REAL:: M0, slam1, slam2 + REAL:: Mrat, ils1, ils2, t1_vts, t2_vts, t3_vts, t4_vts, C_snow + REAL:: a_, b_, loga_, A1, A2, tf + REAL:: tempc, tc0, r_mvd1, r_mvd2, xkrat + REAL:: dew_t, Tlcl, The + REAL:: xnc, xri, xni, xmi, oxmi, xrc, xrr, xnr, xrg, xng, xrb + REAL:: xsat, rate_max, sump, ratio + REAL:: clap, fcd, dfcd + REAL:: otemp, rvs, rvs_p, rvs_pp, gamsc, alphsc, t1_evap, t1_subl + REAL:: r_frac, g_frac, const_Ri, rime_dens + REAL:: Ef_rw, Ef_sw, Ef_gw, Ef_rr + REAL:: Ef_ra, Ef_sa, Ef_ga + REAL:: dtsave, odts, odt, odzq, hgt_agl + REAL:: xslw1, ygra1, zans1, eva_factor + REAL:: SR, melt_f + INTEGER:: i, k, k2, n, nn, nstep, k_0, kbot, IT, iexfrq, k_melting + INTEGER, DIMENSION(5):: ksed1 + INTEGER:: nir, nis, nig, nii, nic, niin + INTEGER:: idx_tc, idx_t, idx_s, idx_g1, idx_g, idx_r1, idx_r, & + idx_i1, idx_i, idx_c, idx, idx_d, idx_n, idx_in + INTEGER, DIMENSION(kts:kte):: idx_bg + + LOGICAL:: melti, no_micro + LOGICAL, DIMENSION(kts:kte):: L_qc, L_qi, L_qr, L_qs, L_qg + LOGICAL:: debug_flag + CHARACTER*256:: mp_debug + INTEGER:: nu_c + + + !RC; processes and microphysical quantities necessary for this scheme. + !RC; included below in case someone wants to output easier. + DOUBLE PRECISION, DIMENSION(kts:kte):: & + prr_wau,pnr_wau,pnc_wau, & + prr_rcw,pnc_rcw,ilamr,ilamc + !/RC + + !RC; lognormal variables + REAL:: ln_varx,ln_tmp1,ln_tmp2 + REAL, DIMENSION(kts:kte):: ln_dn + REAL, DIMENSION(kts:kte):: ln_sigma + REAL:: sigma_d + !/RC + +!+---+ + + debug_flag = .false. +! if (ii.eq.901 .and. jj.eq.379) debug_flag = .true. + if(debug_flag) then + write(mp_debug, *) 'DEBUG INFO, mp_rcon at (i,j) ', ii, ', ', jj + CALL wrf_debug(550, mp_debug) + endif + + no_micro = .true. + dtsave = dt + odt = 1./dt + odts = 1./dtsave + iexfrq = 1 + +!+---+-----------------------------------------------------------------+ +!.. Source/sink terms. First 2 chars: "pr" represents source/sink of +!.. mass while "pn" represents source/sink of number. Next char is one +!.. of "v" for water vapor, "r" for rain, "i" for cloud ice, "w" for +!.. cloud water, "s" for snow, and "g" for graupel. Next chars +!.. represent processes: "de" for sublimation/deposition, "ev" for +!.. evaporation, "fz" for freezing, "ml" for melting, "au" for +!.. autoconversion, "nu" for ice nucleation, "hm" for Hallet/Mossop +!.. secondary ice production, and "c" for collection followed by the +!.. character for the species being collected. ALL of these terms are +!.. positive (except for deposition/sublimation terms which can switch +!.. signs based on super/subsaturation) and are treated as negatives +!.. where necessary in the tendency equations. +!+---+-----------------------------------------------------------------+ + + do k = kts, kte + tten(k) = 0. + qvten(k) = 0. + qcten(k) = 0. + qiten(k) = 0. + qrten(k) = 0. + qsten(k) = 0. + qgten(k) = 0. + ngten(k) = 0. + qbten(k) = 0. + niten(k) = 0. + nrten(k) = 0. + ncten(k) = 0. + nwfaten(k) = 0. + nifaten(k) = 0. + nbcaten(k) = 0. + + prw_vcd(k) = 0. + + pnc_wcd(k) = 0. + pnc_wau(k) = 0. + pnc_rcw(k) = 0. + pnc_scw(k) = 0. + pnc_gcw(k) = 0. + + prv_rev(k) = 0. + prr_wau(k) = 0. + prr_rcw(k) = 0. + prr_rcs(k) = 0. + prr_rcg(k) = 0. + prr_sml(k) = 0. + prr_gml(k) = 0. + prr_rci(k) = 0. + pnr_wau(k) = 0. + pnr_rcs(k) = 0. + pnr_rcg(k) = 0. + pnr_rci(k) = 0. + pnr_sml(k) = 0. + pnr_gml(k) = 0. + pnr_rev(k) = 0. + pnr_rcr(k) = 0. + pnr_rfz(k) = 0. + + pri_inu(k) = 0. + pni_inu(k) = 0. + pri_ihm(k) = 0. + pni_ihm(k) = 0. + pri_wfz(k) = 0. + pni_wfz(k) = 0. + pri_rfz(k) = 0. + pni_rfz(k) = 0. + pri_ide(k) = 0. + pni_ide(k) = 0. + pri_rci(k) = 0. + pni_rci(k) = 0. + pni_sci(k) = 0. + pni_iau(k) = 0. + pri_iha(k) = 0. + pni_iha(k) = 0. + + prs_iau(k) = 0. + prs_sci(k) = 0. + prs_rcs(k) = 0. + prs_scw(k) = 0. + prs_sde(k) = 0. + prs_ihm(k) = 0. + prs_ide(k) = 0. + + prg_scw(k) = 0. + prg_rfz(k) = 0. + prg_gde(k) = 0. + prg_gcw(k) = 0. + prg_rci(k) = 0. + prg_rcs(k) = 0. + prg_rcg(k) = 0. + prg_ihm(k) = 0. + ! new source/sink terms for 3-moment graupel + png_scw(k) = 0. + png_rcs(k) = 0. + png_rcg(k) = 0. + png_gde(k) = 0. + + pbg_scw(k) = 0. + pbg_rfz(k) = 0. + pbg_gcw(k) = 0. + pbg_rci(k) = 0. + pbg_rcs(k) = 0. + pbg_rcg(k) = 0. + pbg_sml(k) = 0. + pbg_gml(k) = 0. + + pna_rca(k) = 0. + pna_sca(k) = 0. + pna_gca(k) = 0. + + pnd_rcd(k) = 0. + pnd_scd(k) = 0. + pnd_gcd(k) = 0. + + pnb_rcb(k) = 0. + pnb_scb(k) = 0. + pnb_gcb(k) = 0. + enddo +#if ( WRF_CHEM == 1 ) + if ( wetscav_on ) then + do k = kts, kte + rainprod(k) = 0. + evapprod(k) = 0. + enddo + endif +#endif + +!..Bug fix (2016Jun15), prevent use of uninitialized value(s) of snow moments. + do k = kts, kte + smo0(k) = 0. + smo1(k) = 0. + smo2(k) = 0. + smob(k) = 0. + smoc(k) = 0. + smod(k) = 0. + smoe(k) = 0. + smof(k) = 0. + smog(k) = 0. + ns(k) = 0. + mvd_r(k) = 0. + mvd_c(k) = 0. + enddo + +!+---+-----------------------------------------------------------------+ +!..Put column of data into local arrays. +!+---+-----------------------------------------------------------------+ + do k = kts, kte + temp(k) = t1d(k) + qv(k) = MAX(1.E-10, qv1d(k)) + pres(k) = p1d(k) + rho(k) = 0.622*pres(k)/(R*temp(k)*(qv(k)+0.622)) + if (is_aerosol_aware) then + if (aer_init_opt .lt. 2) then ! Constant or climatology (e.g., GOCART) + nwfa(k) = MAX(11.1E6, MIN(9999.E6, nwfa1d(k)*rho(k))) + nifa(k) = MAX(naIN1*0.01, MIN(9999.E6, nifa1d(k)*rho(k))) + if (wif_input_opt .eq. 2) then ! Considering BC aerosol + nbca(k) = MAX(5.55E6, MIN(9999.E6, nbca1d(k)*rho(k))) + else + nbca(k) = 0.0 + endif + else ! First guess (e.g., GEOS-5) + nwfa(k) = MAX(0.0, nwfa1d(k)*rho(k)) + nifa(k) = MAX(0.0, nifa1d(k)*rho(k)) + if (wif_input_opt .eq. 2) then ! Considering BC aerosol + nbca(k) = MAX(0.0, nbca1d(k)*rho(k)) + else + nbca(k) = 0.0 + endif + endif + else + nwfa(k) = MAX(11.1E6, MIN(9999.E6, nwfa1d(k)*rho(k))) + nifa(k) = MAX(naIN1*0.01, MIN(9999.E6, nifa1d(k)*rho(k))) + nbca(k) = MAX(5.55E6, MIN(9999.E6, nbca1d(k)*rho(k))) + endif + + + ln_sigma(k) = 0.20 !RC + + !RC; This whole if block is written to accomodate lognormal cloud water. + if (qc1d(k) .gt. R1) then + no_micro = .false. + rc(k) = qc1d(k)*rho(k) + nc(k) = MAX(2., MIN(nc1d(k)*rho(k), Nt_c_max)) + L_qc(k) = .true. + + ! RC; set variable sigma + sigma_d = (rc(k)/nc(k))**(0.3333) + ln_sigma(k) = sigma_d*(-1.185E3) + 0.815 + ln_sigma(k) = MAX(ln_sigma(k) , 0.2) + ln_sigma(k) = MIN(ln_sigma(k) , 0.7) + !/RC + + xDc = ( ( (1./am_r)*(rc(k)/nc(k)) )**obmr ) + if (xDc.lt. D0c) then + xDc = D0c + elseif (xDc.gt. D0r*2.) then + xDc = D0r*2. + endif + + ln_dn(k) = xDc * EXP(-1.5 * ln_sigma(k)*ln_sigma(k)) !RC + nc(k) = MAX( 2. , MIN( DBLE(Nt_c_max) , (1./am_r)*rc(k)*EXP(-4.5*ln_sigma(k)*ln_sigma(k))*(1. / ( xDc*EXP(-1.5*ln_sigma(k)*ln_sigma(k)) ))**3. ) ) !RC + mvd_c(k) = MIN( D0r*2., ln_dn(k)*EXP(3.*ln_sigma(k)*ln_sigma(k)) ) !RC + + if (.NOT. is_aerosol_aware) nc(k) = Nt_c + + else + qc1d(k) = 0.0 + nc1d(k) = 0.0 + rc(k) = R1 + nc(k) = 2. + L_qc(k) = .false. + endif + !\RC + + + if (qi1d(k) .gt. R1) then + no_micro = .false. + ri(k) = qi1d(k)*rho(k) + ni(k) = MAX(R2, ni1d(k)*rho(k)) + if (ni(k).le. R2) then + lami = cie(2)/5.E-6 + ni(k) = MIN(999.D3, cig(1)*oig2*ri(k)/am_i*lami**bm_i) + endif + L_qi(k) = .true. + lami = (am_i*cig(2)*oig1*ni(k)/ri(k))**obmi + ilami = 1./lami + xDi = (bm_i + mu_i + 1.) * ilami + if (xDi.lt. 5.E-6) then + lami = cie(2)/5.E-6 + ni(k) = MIN(999.D3, cig(1)*oig2*ri(k)/am_i*lami**bm_i) + elseif (xDi.gt. 300.E-6) then + lami = cie(2)/300.E-6 + ni(k) = cig(1)*oig2*ri(k)/am_i*lami**bm_i + endif + else + qi1d(k) = 0.0 + ni1d(k) = 0.0 + ri(k) = R1 + ni(k) = R2 + L_qi(k) = .false. + endif + + if (qr1d(k) .gt. R1) then + no_micro = .false. + rr(k) = qr1d(k)*rho(k) + nr(k) = MAX(R2, nr1d(k)*rho(k)) + if (nr(k).le. R2) then + mvd_r(k) = 1.0E-3 + lamr = (3.0 + mu_r + 0.672) / mvd_r(k) + nr(k) = crg(2)*org3*rr(k)*lamr**bm_r / am_r + endif + L_qr(k) = .true. + lamr = (am_r*crg(3)*org2*nr(k)/rr(k))**obmr + mvd_r(k) = (3.0 + mu_r + 0.672) / lamr + if (mvd_r(k) .gt. 2.5E-3) then + mvd_r(k) = 2.5E-3 + lamr = (3.0 + mu_r + 0.672) / mvd_r(k) + nr(k) = crg(2)*org3*rr(k)*lamr**bm_r / am_r + elseif (mvd_r(k) .lt. D0r*0.75) then + mvd_r(k) = D0r*0.75 + lamr = (3.0 + mu_r + 0.672) / mvd_r(k) + nr(k) = crg(2)*org3*rr(k)*lamr**bm_r / am_r + endif + else + qr1d(k) = 0.0 + nr1d(k) = 0.0 + rr(k) = R1 + nr(k) = R2 + L_qr(k) = .false. + endif + if (qs1d(k) .gt. R1) then + no_micro = .false. + rs(k) = qs1d(k)*rho(k) + L_qs(k) = .true. + else + qs1d(k) = 0.0 + rs(k) = R1 + L_qs(k) = .false. + endif + if (qg1d(k) .gt. R1) then + no_micro = .false. + L_qg(k) = .true. + rg(k) = qg1d(k)*rho(k) + ng(k) = MAX(R2, ng1d(k)*rho(k)) + rb(k) = MAX(qg1d(k)/rho_g(NRHG), qb1d(k)) + rb(k) = MIN(qg1d(k)/rho_g(1), rb(k)) + qb1d(k) = rb(k) + idx_bg(k) = MAX(1,MIN(NINT(qg1d(k)/rb(k) *0.01)+1,NRHG)) + if (ng(k).le. R2) then + mvd_g(k) = 1.5E-3 + lamg = (3.0 + mu_g + 0.672) / mvd_g(k) + ng(k) = cgg(2,1)*ogg3*rg(k)*lamg**bm_g / am_g(idx_bg(k)) + endif + lamg = (am_g(idx_bg(k))*cgg(3,1)*ogg2*ng(k)/rg(k))**obmg + mvd_g(k) = (3.0 + mu_g + 0.672) / lamg + if (mvd_g(k) .gt. 25.4E-3) then + mvd_g(k) = 25.4E-3 + lamg = (3.0 + mu_g + 0.672) / mvd_g(k) + ng(k) = cgg(2,1)*ogg3*rg(k)*lamg**bm_g / am_g(idx_bg(k)) + elseif (mvd_g(k) .lt. D0r) then + mvd_g(k) = D0r + lamg = (3.0 + mu_g + 0.672) / mvd_g(k) + ng(k) = cgg(2,1)*ogg3*rg(k)*lamg**bm_g / am_g(idx_bg(k)) + endif + else + qg1d(k) = 0.0 + ng1d(k) = 0.0 + qb1d(k) = 0.0 + idx_bg(k) = idx_bg1 + rg(k) = R1 + ng(k) = R2 + rb(k) = R1/rho(k)/rho_g(NRHG) + L_qg(k) = .false. + endif + if (.not. is_hail_aware) idx_bg(k) = idx_bg1 + enddo + +!+---+-----------------------------------------------------------------+ +! if (debug_flag) then +! write(mp_debug,*) 'DEBUG-VERBOSE at (i,j) ', ii, ', ', jj +! CALL wrf_debug(550, mp_debug) +! do k = kts, kte +! write(mp_debug, '(a,i3,f8.2,1x,f7.2,1x, 13(1x,e13.6))') & +! & 'VERBOSE: ', k, pres(k)*0.01, temp(k)-273.15, qv(k), rc(k), rr(k), ri(k), rs(k), rg(k), nc(k), nr(k), ni(k), ng(k), rb(k), nwfa(k), nifa(k) +! CALL wrf_debug(550, mp_debug) +! enddo +! endif +!+---+-----------------------------------------------------------------+ + +!+---+-----------------------------------------------------------------+ +!..Derive various thermodynamic variables frequently used. +!.. Saturation vapor pressure (mixing ratio) over liquid/ice comes from +!.. Flatau et al. 1992; enthalpy (latent heat) of vaporization from +!.. Bohren & Albrecht 1998; others from Pruppacher & Klett 1978. +!+---+-----------------------------------------------------------------+ + k_melting = 0 + do k = kts, kte + tempc = temp(k) - 273.15 + rhof(k) = SQRT(RHO_NOT/rho(k)) + rhof2(k) = SQRT(rhof(k)) + qvs(k) = rslf(pres(k), temp(k)) + delQvs(k) = MAX(0.0, rslf(pres(k), 273.15)-qv(k)) + if (tempc .le. 0.0) then + qvsi(k) = rsif(pres(k), temp(k)) + else + qvsi(k) = qvs(k) + k_melting = MAX(k, k_melting) + endif + satw(k) = qv(k)/qvs(k) + sati(k) = qv(k)/qvsi(k) + ssatw(k) = satw(k) - 1. + ssati(k) = sati(k) - 1. + if (abs(ssatw(k)).lt. eps) ssatw(k) = 0.0 + if (abs(ssati(k)).lt. eps) ssati(k) = 0.0 + if (no_micro .and. ssati(k).gt. 0.0) no_micro = .false. + diffu(k) = 2.11E-5*(temp(k)/273.15)**1.94 * (101325./pres(k)) + if (tempc .ge. 0.0) then + visco(k) = (1.718+0.0049*tempc)*1.0E-5 + else + visco(k) = (1.718+0.0049*tempc-1.2E-5*tempc*tempc)*1.0E-5 + endif + ocp(k) = 1./(Cp*(1.+0.887*qv(k))) + vsc2(k) = SQRT(rho(k)/visco(k)) + lvap(k) = lvap0 + (2106.0 - 4218.0)*tempc + tcond(k) = (5.69 + 0.0168*tempc)*1.0E-5 * 418.936 + twet(k) = temp(k) + enddo + + if (k_melting .gt. 0) then + do k = kts, k_melting + if (satw(k) .lt. 0.999) then + dew_t = MIN(temp(k)-0.001, t_dew(pres(k), qv(k))) + Tlcl = t_lcl(temp(k), dew_t) + The = theta_e(pres(k), temp(k), qv(k), Tlcl) + twet(k) = MIN(temp(k), compT_fr_The(The, pres(k))) + endif + enddo + endif + +!+---+-----------------------------------------------------------------+ +!..If no existing hydrometeor species and no chance to initiate ice or +!.. condense cloud water, just exit quickly! +!+---+-----------------------------------------------------------------+ + + if (no_micro) return + +!+---+-----------------------------------------------------------------+ +!..Calculate y-intercept, slope, and useful moments for snow. +!+---+-----------------------------------------------------------------+ + if (.not. iiwarm) then + do k = kts, kte + if (.not. L_qs(k)) CYCLE + tc0 = MIN(-0.1, temp(k)-273.15) + smob(k) = rs(k)*oams + +!..All other moments based on reference, 2nd moment. If bm_s.ne.2, +!.. then we must compute actual 2nd moment and use as reference. + if (bm_s.gt.(2.0-1.e-3) .and. bm_s.lt.(2.0+1.e-3)) then + smo2(k) = smob(k) + else + loga_ = sa(1) + sa(2)*tc0 + sa(3)*bm_s & + + sa(4)*tc0*bm_s + sa(5)*tc0*tc0 & + + sa(6)*bm_s*bm_s + sa(7)*tc0*tc0*bm_s & + + sa(8)*tc0*bm_s*bm_s + sa(9)*tc0*tc0*tc0 & + + sa(10)*bm_s*bm_s*bm_s + a_ = 10.0**loga_ + b_ = sb(1) + sb(2)*tc0 + sb(3)*bm_s & + + sb(4)*tc0*bm_s + sb(5)*tc0*tc0 & + + sb(6)*bm_s*bm_s + sb(7)*tc0*tc0*bm_s & + + sb(8)*tc0*bm_s*bm_s + sb(9)*tc0*tc0*tc0 & + + sb(10)*bm_s*bm_s*bm_s + smo2(k) = (smob(k)/a_)**(1./b_) + endif + +!..Calculate 0th moment. Represents snow number concentration. + loga_ = sa(1) + sa(2)*tc0 + sa(5)*tc0*tc0 + sa(9)*tc0*tc0*tc0 + a_ = 10.0**loga_ + b_ = sb(1) + sb(2)*tc0 + sb(5)*tc0*tc0 + sb(9)*tc0*tc0*tc0 + smo0(k) = a_ * smo2(k)**b_ + +!..Calculate 1st moment. Useful for depositional growth and melting. + loga_ = sa(1) + sa(2)*tc0 + sa(3) & + + sa(4)*tc0 + sa(5)*tc0*tc0 & + + sa(6) + sa(7)*tc0*tc0 & + + sa(8)*tc0 + sa(9)*tc0*tc0*tc0 & + + sa(10) + a_ = 10.0**loga_ + b_ = sb(1)+ sb(2)*tc0 + sb(3) + sb(4)*tc0 & + + sb(5)*tc0*tc0 + sb(6) & + + sb(7)*tc0*tc0 + sb(8)*tc0 & + + sb(9)*tc0*tc0*tc0 + sb(10) + smo1(k) = a_ * smo2(k)**b_ + +!..Calculate bm_s+1 (th) moment. Useful for diameter calcs. + loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(1) & + + sa(4)*tc0*cse(1) + sa(5)*tc0*tc0 & + + sa(6)*cse(1)*cse(1) + sa(7)*tc0*tc0*cse(1) & + + sa(8)*tc0*cse(1)*cse(1) + sa(9)*tc0*tc0*tc0 & + + sa(10)*cse(1)*cse(1)*cse(1) + a_ = 10.0**loga_ + b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(1) + sb(4)*tc0*cse(1) & + + sb(5)*tc0*tc0 + sb(6)*cse(1)*cse(1) & + + sb(7)*tc0*tc0*cse(1) + sb(8)*tc0*cse(1)*cse(1) & + + sb(9)*tc0*tc0*tc0 + sb(10)*cse(1)*cse(1)*cse(1) + smoc(k) = a_ * smo2(k)**b_ + +!..Calculate snow number concentration (explicit integral, not smo0) + M0 = smob(k)/smoc(k) + Mrat = smob(k)*M0*M0*M0 + slam1 = M0 * Lam0 + slam2 = M0 * Lam1 + ns(k) = Mrat*Kap0/slam1 & + + Mrat*Kap1*M0**mu_s*csg(15)/slam2**cse(15) + +!..Calculate bv_s+2 (th) moment. Useful for riming. + loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(13) & + + sa(4)*tc0*cse(13) + sa(5)*tc0*tc0 & + + sa(6)*cse(13)*cse(13) + sa(7)*tc0*tc0*cse(13) & + + sa(8)*tc0*cse(13)*cse(13) + sa(9)*tc0*tc0*tc0 & + + sa(10)*cse(13)*cse(13)*cse(13) + a_ = 10.0**loga_ + b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(13) + sb(4)*tc0*cse(13) & + + sb(5)*tc0*tc0 + sb(6)*cse(13)*cse(13) & + + sb(7)*tc0*tc0*cse(13) + sb(8)*tc0*cse(13)*cse(13) & + + sb(9)*tc0*tc0*tc0 + sb(10)*cse(13)*cse(13)*cse(13) + smoe(k) = a_ * smo2(k)**b_ + +!..Calculate 1+(bv_s+1)/2 (th) moment. Useful for depositional growth. + loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(16) & + + sa(4)*tc0*cse(16) + sa(5)*tc0*tc0 & + + sa(6)*cse(16)*cse(16) + sa(7)*tc0*tc0*cse(16) & + + sa(8)*tc0*cse(16)*cse(16) + sa(9)*tc0*tc0*tc0 & + + sa(10)*cse(16)*cse(16)*cse(16) + a_ = 10.0**loga_ + b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(16) + sb(4)*tc0*cse(16) & + + sb(5)*tc0*tc0 + sb(6)*cse(16)*cse(16) & + + sb(7)*tc0*tc0*cse(16) + sb(8)*tc0*cse(16)*cse(16) & + + sb(9)*tc0*tc0*tc0 + sb(10)*cse(16)*cse(16)*cse(16) + smof(k) = a_ * smo2(k)**b_ + +!..Calculate bm_s + bv_s+2 (th) moment. Useful for riming into graupel. + loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(17) & + + sa(4)*tc0*cse(17) + sa(5)*tc0*tc0 & + + sa(6)*cse(17)*cse(17) + sa(7)*tc0*tc0*cse(17) & + + sa(8)*tc0*cse(17)*cse(17) + sa(9)*tc0*tc0*tc0 & + + sa(10)*cse(17)*cse(17)*cse(17) + a_ = 10.0**loga_ + b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(17) + sb(4)*tc0*cse(17) & + + sb(5)*tc0*tc0 + sb(6)*cse(17)*cse(17) & + + sb(7)*tc0*tc0*cse(17) + sb(8)*tc0*cse(17)*cse(17) & + + sb(9)*tc0*tc0*tc0 + sb(10)*cse(17)*cse(17)*cse(17) + smog(k) = a_ * smo2(k)**b_ + + enddo + +!+---+-----------------------------------------------------------------+ +!..Calculate y-intercept, slope values for graupel. +!+---+-----------------------------------------------------------------+ + + do k = kte, kts, -1 + lamg = (am_g(idx_bg(k))*cgg(3,1)*ogg2*ng(k)/rg(k))**obmg + ilamg(k) = 1./lamg + N0_g(k) = ng(k)*ogg2*lamg**cge(2,1) + enddo + + endif + +!+---+-----------------------------------------------------------------+ +!..Calculate y-intercept, slope values for rain. +!+---+-----------------------------------------------------------------+ + do k = kte, kts, -1 + lamr = (am_r*crg(3)*org2*nr(k)/rr(k))**obmr + ilamr(k) = 1./lamr + mvd_r(k) = (3.0 + mu_r + 0.672) / lamr + N0_r(k) = nr(k)*org2*lamr**cre(2) + enddo + +!+---+-----------------------------------------------------------------+ +!..Compute warm-rain process terms (except evap done later). +!+---+-----------------------------------------------------------------+ + + do k = kts, kte + +!..Rain self-collection follows Seifert, 1994 and drop break-up +!.. follows Verlinde and Cotton, 1993. + if (L_qr(k) .and. mvd_r(k).gt. D0r) then + Ef_rr = 1.0 - EXP(2300.0*(mvd_r(k)-1950.0E-6)) + pnr_rcr(k) = Ef_rr * 2.0*nr(k)*rr(k) + endif + + + !RC + mvd_c(k) = D0c + ln_dn(k) = 0.0 + if (L_qc(k)) then + xDc = ( ( (1./am_r)*(rc(k)/nc(k)) )**obmr ) ! dv_bar in paper + ln_dn(k) = xDc * EXP(-1.5 * ln_sigma(k)*ln_sigma(k)) + mvd_c(k) = MIN( D0r*2., ln_dn(k)*EXP(3.*ln_sigma(k)*ln_sigma(k)) ) + endif + !/RC + + !RC; Autoconversion follows Nickerson et al. 1986 + if (rc(k) .gt. 0.01e-3) then + ln_varx = EXP(9*ln_sigma(k)*ln_sigma(k))-1. + ln_tmp1 = 0.067*rc(k)*rc(k)*(1.0E16*((rc(k)/nc(k))**1.3333)*((ln_varx)**0.5) - 2.7 ) + ln_tmp2 = 1.0E4*( (rc(k)*(ln_varx**0.5)/nc(k) )**obmr ) - 1.2 + + prr_wau(k) = MAX( 0.d0,DBLE(ln_tmp1)*DBLE(ln_tmp2)) + prr_wau(k) = MIN(DBLE(rc(k)*odts), prr_wau(k)) + pnr_wau(k) = prr_wau(k) / (am_r*200.*D0r*D0r*D0r) + pnc_wau(k) = MIN(DBLE(nc(k)*odts), prr_wau(k) & + / (am_r*mvd_c(k)*mvd_c(k)*mvd_c(k))) + endif + !RC; End new autoconversion + +!..Rain collecting cloud water. In CE, assume Dc<1). Either way, only bother to do sedimentation below +!.. 1st level that contains any sedimenting particles (k=ksed1 on down). +!.. New in v3.0+ is computing separate for rain, ice, snow, and +!.. graupel species thus making code faster with credit to J. Schmidt. +!+---+-----------------------------------------------------------------+ + nstep = 0 + onstep(:) = 1.0 + ksed1(:) = 1 + do k = kte+1, kts, -1 + vtrk(k) = 0. + vtnrk(k) = 0. + vtik(k) = 0. + vtnik(k) = 0. + vtsk(k) = 0. + vtgk(k) = 0. + vtngk(k) = 0. + vtck(k) = 0. + vtnck(k) = 0. + enddo + + if (ANY(L_qr .eqv. .true.)) then + do k = kte, kts, -1 + vtr = 0. + rhof(k) = SQRT(RHO_NOT/rho(k)) + + if (rr(k).gt. R1) then + lamr = (am_r*crg(3)*org2*nr(k)/rr(k))**obmr + vtr = rhof(k)*av_r*crg(6)*org3 * lamr**cre(3) & + *((lamr+fv_r)**(-cre(6))) + vtrk(k) = vtr +! First below is technically correct: +! vtr = rhof(k)*av_r*crg(5)*org2 * lamr**cre(2) & +! *((lamr+fv_r)**(-cre(5))) +! Test: make number fall faster (but still slower than mass) +! Goal: less prominent size sorting + vtr = rhof(k)*av_r*crg(7)/crg(12) * lamr**cre(12) & + *((lamr+fv_r)**(-cre(7))) + vtnrk(k) = vtr + else + vtrk(k) = vtrk(k+1) + vtnrk(k) = vtnrk(k+1) + endif + + if (MAX(vtrk(k),vtnrk(k)) .gt. 1.E-3) then + ksed1(1) = MAX(ksed1(1), k) + delta_tp = dzq(k)/(MAX(vtrk(k),vtnrk(k))) + nstep = MAX(nstep, INT(DT/delta_tp + 1.)) + endif + enddo + if (ksed1(1) .eq. kte) ksed1(1) = kte-1 + if (nstep .gt. 0) onstep(1) = 1./REAL(nstep) + endif + +!+---+-----------------------------------------------------------------+ + + if (ANY(L_qc .eqv. .true.)) then + hgt_agl = 0. + do k = kts, kte-1 + if (rc(k) .gt. R2) ksed1(5) = k + hgt_agl = hgt_agl + dzq(k) + if (hgt_agl .gt. 500.0) goto 151 + enddo + 151 continue + + do k = ksed1(5), kts, -1 + vtc = 0. + !RC; Adjustments to cloud fallspeed integrals. Allows drizzle mode. + if (rc(k) .gt. R1 .and. w1d(k) .lt. 0.1E-1) then !RC; allow sedimentation only when w<0.01m/s + xDc = ( ( (1./am_r)*(rc(k)/nc(k)) )**obmr ) + vtc = (av_c*(xDc * EXP(-1.5 * ln_sigma(k)*ln_sigma(k)))**bv_c)*EXP(5.*ln_sigma(k)*ln_sigma(k)) + vtck(k) = MIN(0.1d0,vtc) !RC; These get big, so we need to limit it to 0.1 + vtc = (av_c*(xDc * EXP(-1.5 * ln_sigma(k)*ln_sigma(k)))**bv_c)*EXP(1.3*ln_sigma(k)*ln_sigma(k)) + vtnck(k) = MIN(0.1d0,vtc) + !\RC + endif + enddo + endif + +!+---+-----------------------------------------------------------------+ + + if (.not. iiwarm) then + + if (ANY(L_qi .eqv. .true.)) then + nstep = 0 + do k = kte, kts, -1 + vti = 0. + + if (ri(k).gt. R1) then + lami = (am_i*cig(2)*oig1*ni(k)/ri(k))**obmi + ilami = 1./lami + vti = rhof(k)*av_i*cig(3)*oig2 * ilami**bv_i + vtik(k) = vti +! First below is technically correct: +! vti = rhof(k)*av_i*cig(4)*oig1 * ilami**bv_i +! Goal: less prominent size sorting + vti = rhof(k)*av_i*cig(6)/cig(7) * ilami**bv_i + vtnik(k) = vti + else + vtik(k) = vtik(k+1) + vtnik(k) = vtnik(k+1) + endif + + if (vtik(k) .gt. 1.E-3) then + ksed1(2) = MAX(ksed1(2), k) + delta_tp = dzq(k)/vtik(k) + nstep = MAX(nstep, INT(DT/delta_tp + 1.)) + endif + enddo + if (ksed1(2) .eq. kte) ksed1(2) = kte-1 + if (nstep .gt. 0) onstep(2) = 1./REAL(nstep) + endif + +!+---+-----------------------------------------------------------------+ + + if (ANY(L_qs .eqv. .true.)) then + nstep = 0 + do k = kte, kts, -1 + vts = 0. + + if (rs(k).gt. R1) then + xDs = smoc(k) / smob(k) + Mrat = 1./xDs + ils1 = 1./(Mrat*Lam0 + fv_s) + ils2 = 1./(Mrat*Lam1 + fv_s) + t1_vts = Kap0*csg(4)*ils1**cse(4) + t2_vts = Kap1*Mrat**mu_s*csg(10)*ils2**cse(10) + ils1 = 1./(Mrat*Lam0) + ils2 = 1./(Mrat*Lam1) + t3_vts = Kap0*csg(1)*ils1**cse(1) + t4_vts = Kap1*Mrat**mu_s*csg(7)*ils2**cse(7) + vts = rhof(k)*av_s * (t1_vts+t2_vts)/(t3_vts+t4_vts) + if (prr_sml(k) .gt. 0.0) then + SR = rs(k)/(rs(k)+rr(k)) + vtsk(k) = vts*SR + (1.-SR)*vtrk(k) + else + vtsk(k) = vts*vts_boost(k) + endif + else + vtsk(k) = vtsk(k+1) + endif + + if (vtsk(k) .gt. 1.E-3) then + ksed1(3) = MAX(ksed1(3), k) + delta_tp = dzq(k)/vtsk(k) + nstep = MAX(nstep, INT(DT/delta_tp + 1.)) + endif + enddo + if (ksed1(3) .eq. kte) ksed1(3) = kte-1 + if (nstep .gt. 0) onstep(3) = 1./REAL(nstep) + endif + +!+---+-----------------------------------------------------------------+ + + if (ANY(L_qg .eqv. .true.)) then + nstep = 0 + do k = kte, kts, -1 + vtg = 0. + + if (rg(k).gt. R1) then + if (is_hail_aware) then + xrho_g = MAX(rho_g(1),MIN(rg(k)/rho(k)/rb(k),rho_g(NRHG))) + afall = a_coeff*((4.0*xrho_g*9.8)/(3.0*rho(k)))**b_coeff + afall = afall * visco(k)**(1.0-2.0*b_coeff) + else + afall = av_g_old + bfall = bv_g_old + endif + vtg = rhof(k)*afall*cgg(6,idx_bg(k))*ogg3 * ilamg(k)**bfall + vtgk(k) = vtg +! Goal: less prominent size sorting +! the ELSE section below is technically (mathematically) correct: + if (mu_g .eq. 0) then + vtg = rhof(k)*afall*cgg(7,idx_bg(k))/cgg(12,idx_bg(k)) * ilamg(k)**bfall + else + vtg = rhof(k)*afall*cgg(8,idx_bg(k))*ogg2 * ilamg(k)**bfall + endif + vtngk(k) = vtg + else + vtgk(k) = vtgk(k+1) + vtngk(k) = vtngk(k+1) + endif + + if (vtgk(k) .gt. 1.E-3) then + ksed1(4) = MAX(ksed1(4), k) + delta_tp = dzq(k)/vtgk(k) + nstep = MAX(nstep, INT(DT/delta_tp + 1.)) + endif + enddo + if (ksed1(4) .eq. kte) ksed1(4) = kte-1 + if (nstep .gt. 0) onstep(4) = 1./REAL(nstep) + endif + endif + +!+---+-----------------------------------------------------------------+ +!..Sedimentation of mixing ratio is the integral of v(D)*m(D)*N(D)*dD, +!.. whereas neglect m(D) term for number concentration. Therefore, +!.. cloud ice has proper differential sedimentation. +!+---+-----------------------------------------------------------------+ + + if (ANY(L_qr .eqv. .true.)) then + nstep = NINT(1./onstep(1)) + do n = 1, nstep + do k = kte, kts, -1 + sed_r(k) = vtrk(k)*rr(k) + sed_n(k) = vtnrk(k)*nr(k) + enddo + k = kte + odzq = 1./dzq(k) + orho = 1./rho(k) + qrten(k) = qrten(k) - sed_r(k)*odzq*onstep(1)*orho + nrten(k) = nrten(k) - sed_n(k)*odzq*onstep(1)*orho + rr(k) = MAX(R1, rr(k) - sed_r(k)*odzq*DT*onstep(1)) + nr(k) = MAX(R2, nr(k) - sed_n(k)*odzq*DT*onstep(1)) + do k = ksed1(1), kts, -1 + odzq = 1./dzq(k) + orho = 1./rho(k) + qrten(k) = qrten(k) + (sed_r(k+1)-sed_r(k)) & + *odzq*onstep(1)*orho + nrten(k) = nrten(k) + (sed_n(k+1)-sed_n(k)) & + *odzq*onstep(1)*orho + rr(k) = MAX(R1, rr(k) + (sed_r(k+1)-sed_r(k)) & + *odzq*DT*onstep(1)) + nr(k) = MAX(R2, nr(k) + (sed_n(k+1)-sed_n(k)) & + *odzq*DT*onstep(1)) + enddo + + if (rr(kts).gt.R1*1000.) & + pptrain = pptrain + sed_r(kts)*DT*onstep(1) + enddo + endif + +!+---+-----------------------------------------------------------------+ + + if (ANY(L_qc .eqv. .true.)) then + do k = kte, kts, -1 + sed_c(k) = vtck(k)*rc(k) + sed_n(k) = vtnck(k)*nc(k) + enddo + do k = ksed1(5), kts, -1 + odzq = 1./dzq(k) + orho = 1./rho(k) + qcten(k) = qcten(k) + (sed_c(k+1)-sed_c(k)) *odzq*orho + ncten(k) = ncten(k) + (sed_n(k+1)-sed_n(k)) *odzq*orho + rc(k) = MAX(R1, rc(k) + (sed_c(k+1)-sed_c(k)) *odzq*DT) + nc(k) = MAX(10., nc(k) + (sed_n(k+1)-sed_n(k)) *odzq*DT) + enddo + !RC; next two lines we allow cloud water to contribute to surface precip. + !RC; No need for the onstep() variable since cloud water falls so slowly. + if (rc(kts) .gt. R1*1000.) then + pptcloud = pptcloud + sed_c(kts)*DT + endif + + endif + +!+---+-----------------------------------------------------------------+ + + if (ANY(L_qi .eqv. .true.)) then + nstep = NINT(1./onstep(2)) + do n = 1, nstep + do k = kte, kts, -1 + sed_i(k) = vtik(k)*ri(k) + sed_n(k) = vtnik(k)*ni(k) + enddo + k = kte + odzq = 1./dzq(k) + orho = 1./rho(k) + qiten(k) = qiten(k) - sed_i(k)*odzq*onstep(2)*orho + niten(k) = niten(k) - sed_n(k)*odzq*onstep(2)*orho + ri(k) = MAX(R1, ri(k) - sed_i(k)*odzq*DT*onstep(2)) + ni(k) = MAX(R2, ni(k) - sed_n(k)*odzq*DT*onstep(2)) + do k = ksed1(2), kts, -1 + odzq = 1./dzq(k) + orho = 1./rho(k) + qiten(k) = qiten(k) + (sed_i(k+1)-sed_i(k)) & + *odzq*onstep(2)*orho + niten(k) = niten(k) + (sed_n(k+1)-sed_n(k)) & + *odzq*onstep(2)*orho + ri(k) = MAX(R1, ri(k) + (sed_i(k+1)-sed_i(k)) & + *odzq*DT*onstep(2)) + ni(k) = MAX(R2, ni(k) + (sed_n(k+1)-sed_n(k)) & + *odzq*DT*onstep(2)) + enddo + + if (ri(kts).gt.R1*1000.) & + pptice = pptice + sed_i(kts)*DT*onstep(2) + enddo + endif + +!+---+-----------------------------------------------------------------+ + + if (ANY(L_qs .eqv. .true.)) then + nstep = NINT(1./onstep(3)) + do n = 1, nstep + do k = kte, kts, -1 + sed_s(k) = vtsk(k)*rs(k) + enddo + k = kte + odzq = 1./dzq(k) + orho = 1./rho(k) + qsten(k) = qsten(k) - sed_s(k)*odzq*onstep(3)*orho + rs(k) = MAX(R1, rs(k) - sed_s(k)*odzq*DT*onstep(3)) + do k = ksed1(3), kts, -1 + odzq = 1./dzq(k) + orho = 1./rho(k) + qsten(k) = qsten(k) + (sed_s(k+1)-sed_s(k)) & + *odzq*onstep(3)*orho + rs(k) = MAX(R1, rs(k) + (sed_s(k+1)-sed_s(k)) & + *odzq*DT*onstep(3)) + enddo + + if (rs(kts).gt.R1*1000.) & + pptsnow = pptsnow + sed_s(kts)*DT*onstep(3) + enddo + endif + +!+---+-----------------------------------------------------------------+ + + if (ANY(L_qg .eqv. .true.)) then + nstep = NINT(1./onstep(4)) + do n = 1, nstep + do k = kte, kts, -1 + sed_g(k) = vtgk(k)*rg(k) + sed_n(k) = vtngk(k)*ng(k) + sed_b(k) = vtgk(k)*rb(k) + enddo + k = kte + odzq = 1./dzq(k) + orho = 1./rho(k) + qgten(k) = qgten(k) - sed_g(k)*odzq*onstep(4)*orho + ngten(k) = ngten(k) - sed_n(k)*odzq*onstep(4)*orho + qbten(k) = qbten(k) - sed_b(k)*odzq*onstep(4) + rg(k) = MAX(R1, rg(k) - sed_g(k)*odzq*DT*onstep(4)) + ng(k) = MAX(R2, ng(k) - sed_n(k)*odzq*DT*onstep(4)) + rb(k) = MAX(R1/rho(k)/rho_g(NRHG), rb(k) - sed_b(k)*odzq*DT*onstep(4)) + do k = ksed1(4), kts, -1 + odzq = 1./dzq(k) + orho = 1./rho(k) + qgten(k) = qgten(k) + (sed_g(k+1)-sed_g(k)) & + *odzq*onstep(4)*orho + ngten(k) = ngten(k) + (sed_n(k+1)-sed_n(k)) & + *odzq*onstep(4)*orho + qbten(k) = qbten(k) + (sed_b(k+1)-sed_b(k)) & + *odzq*onstep(4) + rg(k) = MAX(R1, rg(k) + (sed_g(k+1)-sed_g(k)) & + *odzq*DT*onstep(4)) + ng(k) = MAX(R2, ng(k) + (sed_n(k+1)-sed_n(k)) & + *odzq*DT*onstep(4)) + rb(k) = MAX(rg(k)/rho(k)/rho_g(NRHG), rb(k) + (sed_b(k+1)-sed_b(k)) & + *odzq*DT*onstep(4)) + enddo + + if (rg(kts).gt.R1*1000.) & + pptgraul = pptgraul + sed_g(kts)*DT*onstep(4) + enddo + endif + +!+---+-----------------------------------------------------------------+ +!.. Instantly melt any cloud ice into cloud water if above 0C and +!.. instantly freeze any cloud water found below HGFR. +!+---+-----------------------------------------------------------------+ + if (.not. iiwarm) then + do k = kts, kte + xri = MAX(0.0, qi1d(k) + qiten(k)*DT) + if ( (temp(k).gt. T_0) .and. (xri.gt. 0.0) ) then + qcten(k) = qcten(k) + xri*odt + ncten(k) = ncten(k) + ni1d(k)*odt + qiten(k) = qiten(k) - xri*odt + niten(k) = -ni1d(k)*odt + tten(k) = tten(k) - lfus*ocp(k)*xri*odt*(1-IFDRY) + endif + + xrc = MAX(0.0, qc1d(k) + qcten(k)*DT) + if ( (temp(k).lt. HGFR) .and. (xrc.gt. 0.0) ) then + lfus2 = lsub - lvap(k) + xnc = nc1d(k) + ncten(k)*DT + qiten(k) = qiten(k) + xrc*odt + niten(k) = niten(k) + xnc*odt + qcten(k) = qcten(k) - xrc*odt + ncten(k) = ncten(k) - xnc*odt + tten(k) = tten(k) + lfus2*ocp(k)*xrc*odt*(1-IFDRY) + endif + enddo + endif + +!+---+-----------------------------------------------------------------+ +!.. All tendencies computed, apply and pass back final values to parent. +!+---+-----------------------------------------------------------------+ + do k = kts, kte + t1d(k) = t1d(k) + tten(k)*DT + qv1d(k) = MAX(1.E-10, qv1d(k) + qvten(k)*DT) + qc1d(k) = qc1d(k) + qcten(k)*DT + nc1d(k) = MAX(2./rho(k), MIN(nc1d(k) + ncten(k)*DT, Nt_c_max)) + if (is_aerosol_aware) then + if (aer_init_opt .lt. 2) then + nwfa1d(k) = MAX(11.1E6, MIN(9999.E6, & + (nwfa1d(k)+nwfaten(k)*DT))) + nifa1d(k) = MAX(naIN1*0.01, MIN(9999.E6, & + (nifa1d(k)+nifaten(k)*DT))) + if (wif_input_opt .eq. 2) then + nbca1d(k) = MAX(5.55E6, MIN(9999.E6, & + (nbca1d(k)+nbcaten(k)*DT))) + else + nbca1d(k) = 0.0 + endif + else + nwfa1d(k) = MAX(0.0, (nwfa1d(k)+nwfaten(k)*DT)) + nifa1d(k) = MAX(0.0, (nifa1d(k)+nifaten(k)*DT)) + if (wif_input_opt .eq. 2) then + nbca1d(k) = MAX(0.0, (nbca1d(k)+nbcaten(k)*DT)) + else + nbca1d(k) = 0.0 + endif + endif + else + nwfa1d(k) = MAX(11.1E6, MIN(9999.E6, & + (nwfa1d(k)+nwfaten(k)*DT))) + nifa1d(k) = MAX(naIN1*0.01, MIN(9999.E6, & + (nifa1d(k)+nifaten(k)*DT))) + nbca1d(k) = MAX(5.55E6, MIN(9999.E6, & + (nbca1d(k)+nbcaten(k)*DT))) + endif + + if (qc1d(k) .le. R1) then + qc1d(k) = 0.0 + nc1d(k) = 0.0 + else + !RC; Lognormal size adjustments + xDc = ( ( (1./am_r)*(qc1d(k)/nc1d(k)) )**obmr ) + if (xDc.lt. D0c) then + xDc = D0c + elseif (xDc.gt. D0r*2.) then + xDc = D0r*2. + endif + nc1d(k) = MAX(2., MIN( DBLE(Nt_c_max/rho(k)), (1./am_r)*qc1d(k)*EXP(-4.5*ln_sigma(k)*ln_sigma(k))*(1. / ( xDc*EXP(-1.5*ln_sigma(k)*ln_sigma(k)) ))**3. )) + !RC; end adjustments + endif + + qi1d(k) = qi1d(k) + qiten(k)*DT + ni1d(k) = MAX(R2/rho(k), ni1d(k) + niten(k)*DT) + if (qi1d(k) .le. R1) then + qi1d(k) = 0.0 + ni1d(k) = 0.0 + else + lami = (am_i*cig(2)*oig1*ni1d(k)/qi1d(k))**obmi + ilami = 1./lami + xDi = (bm_i + mu_i + 1.) * ilami + if (xDi.lt. 5.E-6) then + lami = cie(2)/5.E-6 + elseif (xDi.gt. 300.E-6) then + lami = cie(2)/300.E-6 + endif + ni1d(k) = MIN(cig(1)*oig2*qi1d(k)/am_i*lami**bm_i, & + 999.D3/rho(k)) + endif + qr1d(k) = qr1d(k) + qrten(k)*DT + nr1d(k) = MAX(R2/rho(k), nr1d(k) + nrten(k)*DT) + if (qr1d(k) .le. R1) then + qr1d(k) = 0.0 + nr1d(k) = 0.0 + else + lamr = (am_r*crg(3)*org2*nr1d(k)/qr1d(k))**obmr + mvd_r(k) = (3.0 + mu_r + 0.672) / lamr + if (mvd_r(k) .gt. 2.5E-3) then + mvd_r(k) = 2.5E-3 + elseif (mvd_r(k) .lt. D0r*0.75) then + mvd_r(k) = D0r*0.75 + endif + lamr = (3.0 + mu_r + 0.672) / mvd_r(k) + nr1d(k) = crg(2)*org3*qr1d(k)*lamr**bm_r / am_r + endif + qs1d(k) = qs1d(k) + qsten(k)*DT + if (qs1d(k) .le. R1) qs1d(k) = 0.0 + qg1d(k) = qg1d(k) + qgten(k)*DT + ng1d(k) = MAX(R2/rho(k), ng1d(k) + ngten(k)*DT) + if (qg1d(k) .le. R1) then + qg1d(k) = 0.0 + ng1d(k) = 0.0 + qb1d(k) = 0.0 + else + qb1d(k) = MAX(qg1d(k)/rho_g(NRHG), qb1d(k) + qbten(k)*DT) + qb1d(k) = MIN(qg1d(k)/rho_g(1), qb1d(k)) + idx_bg(k) = MAX(1,MIN(NINT(qg1d(k)/qb1d(k) *0.01)+1,NRHG)) + if (.not. is_hail_aware) idx_bg(k) = idx_bg1 + lamg = (am_g(idx_bg(k))*cgg(3,1)*ogg2*ng1d(k)/qg1d(k))**obmg + mvd_g(k) = (3.0 + mu_g + 0.672) / lamg + if (mvd_g(k) .gt. 25.4E-3) then + mvd_g(k) = 25.4E-3 + elseif (mvd_g(k) .lt. D0r) then + mvd_g(k) = D0r + endif + lamg = (3.0 + mu_g + 0.672) / mvd_g(k) + ng1d(k) = cgg(2,1)*ogg3*qg1d(k)*lamg**bm_g / am_g(idx_bg(k)) + endif + + !RC; We set ilamc to 0 if qc 0. + IMPLICIT NONE + REAL, INTENT(IN):: XX + DOUBLE PRECISION, PARAMETER:: STP = 2.5066282746310005D0 + DOUBLE PRECISION, DIMENSION(6), PARAMETER:: & + COF = (/76.18009172947146D0, -86.50532032941677D0, & + 24.01409824083091D0, -1.231739572450155D0, & + .1208650973866179D-2, -.5395239384953D-5/) + DOUBLE PRECISION:: SER,TMP,X,Y + INTEGER:: J + + X=XX + Y=X + TMP=X+5.5D0 + TMP=(X+0.5D0)*LOG(TMP)-TMP + SER=1.000000000190015D0 + DO 11 J=1,6 + Y=Y+1.D0 + SER=SER+COF(J)/Y +11 CONTINUE + GAMMLN=TMP+LOG(STP*SER/X) + END FUNCTION GAMMLN +! (C) Copr. 1986-92 Numerical Recipes Software 2.02 +!+---+-----------------------------------------------------------------+ + REAL FUNCTION GAMMP(A,X) +! --- COMPUTES THE INCOMPLETE GAMMA FUNCTION P(A,X) +! --- SEE ABRAMOWITZ AND STEGUN 6.5.1 +! --- USES GCF,GSER + IMPLICIT NONE + REAL, INTENT(IN):: A,X + REAL:: GAMMCF,GAMSER,GLN + GAMMP = 0. + IF((X.LT.0.) .OR. (A.LE.0.)) THEN + PRINT *, 'BAD ARGUMENTS IN GAMMP' + RETURN + ELSEIF(X.LT.A+1.)THEN + CALL GSER(GAMSER,A,X,GLN) + GAMMP=GAMSER + ELSE + CALL GCF(GAMMCF,A,X,GLN) + GAMMP=1.-GAMMCF + ENDIF + END FUNCTION GAMMP +! (C) Copr. 1986-92 Numerical Recipes Software 2.02 +!+---+-----------------------------------------------------------------+ + REAL FUNCTION WGAMMA(y) + + IMPLICIT NONE + REAL, INTENT(IN):: y + + WGAMMA = EXP(GAMMLN(y)) + + END FUNCTION WGAMMA +!+---+-----------------------------------------------------------------+ +! THIS FUNCTION CALCULATES THE LIQUID SATURATION VAPOR MIXING RATIO AS +! A FUNCTION OF TEMPERATURE AND PRESSURE +! + REAL FUNCTION RSLF(P,T) + + IMPLICIT NONE + REAL, INTENT(IN):: P, T + REAL:: ESL,X + REAL, PARAMETER:: C0= .611583699E03 + REAL, PARAMETER:: C1= .444606896E02 + REAL, PARAMETER:: C2= .143177157E01 + REAL, PARAMETER:: C3= .264224321E-1 + REAL, PARAMETER:: C4= .299291081E-3 + REAL, PARAMETER:: C5= .203154182E-5 + REAL, PARAMETER:: C6= .702620698E-8 + REAL, PARAMETER:: C7= .379534310E-11 + REAL, PARAMETER:: C8=-.321582393E-13 + + X=MAX(-80.,T-273.16) + +! ESL=612.2*EXP(17.67*X/(T-29.65)) + ESL=C0+X*(C1+X*(C2+X*(C3+X*(C4+X*(C5+X*(C6+X*(C7+X*C8))))))) + ESL=MIN(ESL, P*0.15) ! Even with P=1050mb and T=55C, the sat. vap. pres only contributes to ~15% of total pres. + RSLF=.622*ESL/(P-ESL) + +! ALTERNATIVE +! ; Source: Murphy and Koop, Review of the vapour pressure of ice and +! supercooled water for atmospheric applications, Q. J. R. +! Meteorol. Soc (2005), 131, pp. 1539-1565. +! ESL = EXP(54.842763 - 6763.22 / T - 4.210 * ALOG(T) + 0.000367 * T +! + TANH(0.0415 * (T - 218.8)) * (53.878 - 1331.22 +! / T - 9.44523 * ALOG(T) + 0.014025 * T)) + + END FUNCTION RSLF +!+---+-----------------------------------------------------------------+ +! THIS FUNCTION CALCULATES THE ICE SATURATION VAPOR MIXING RATIO AS A +! FUNCTION OF TEMPERATURE AND PRESSURE +! + REAL FUNCTION RSIF(P,T) + + IMPLICIT NONE + REAL, INTENT(IN):: P, T + REAL:: ESI,X + REAL, PARAMETER:: C0= .609868993E03 + REAL, PARAMETER:: C1= .499320233E02 + REAL, PARAMETER:: C2= .184672631E01 + REAL, PARAMETER:: C3= .402737184E-1 + REAL, PARAMETER:: C4= .565392987E-3 + REAL, PARAMETER:: C5= .521693933E-5 + REAL, PARAMETER:: C6= .307839583E-7 + REAL, PARAMETER:: C7= .105785160E-9 + REAL, PARAMETER:: C8= .161444444E-12 + + X=MAX(-80.,T-273.16) + ESI=C0+X*(C1+X*(C2+X*(C3+X*(C4+X*(C5+X*(C6+X*(C7+X*C8))))))) + ESI=MIN(ESI, P*0.15) + RSIF=.622*ESI/max(1.e-4,(P-ESI)) + +! ALTERNATIVE +! ; Source: Murphy and Koop, Review of the vapour pressure of ice and +! supercooled water for atmospheric applications, Q. J. R. +! Meteorol. Soc (2005), 131, pp. 1539-1565. +! ESI = EXP(9.550426 - 5723.265/T + 3.53068*ALOG(T) - 0.00728332*T) + + END FUNCTION RSIF + +!+---+-----------------------------------------------------------------+ + real function iceDeMott(tempc, qv, qvs, qvsi, rho, nifa) + implicit none + + REAL, INTENT(IN):: tempc, qv, qvs, qvsi, rho, nifa + +!..Local vars + REAL:: satw, sati, siw, p_x, si0x, dtt, dsi, dsw, dab, fc, hx + REAL:: ntilde, n_in, nmax, nhat, mux, xni, nifa_cc + REAL, PARAMETER:: p_c1 = 1000. + REAL, PARAMETER:: p_rho_c = 0.76 + REAL, PARAMETER:: p_alpha = 1.0 + REAL, PARAMETER:: p_gam = 2. + REAL, PARAMETER:: delT = 5. + REAL, PARAMETER:: T0x = -40. + REAL, PARAMETER:: Sw0x = 0.97 + REAL, PARAMETER:: delSi = 0.1 + REAL, PARAMETER:: hdm = 0.15 + REAL, PARAMETER:: p_psi = 0.058707*p_gam/p_rho_c + REAL, PARAMETER:: aap = 1. + REAL, PARAMETER:: bbp = 0. + REAL, PARAMETER:: y1p = -35. + REAL, PARAMETER:: y2p = -25. + REAL, PARAMETER:: rho_not0 = 101325./(287.05*273.15) + +!+---+ + + xni = 0.0 +! satw = qv/qvs +! sati = qv/qvsi +! siw = qvs/qvsi +! p_x = -1.0261+(3.1656e-3*tempc)+(5.3938e-4*(tempc*tempc)) & +! + (8.2584e-6*(tempc*tempc*tempc)) +! si0x = 1.+(10.**p_x) +! if (sati.ge.si0x .and. satw.lt.0.985) then +! dtt = delta_p (tempc, T0x, T0x+delT, 1., hdm) +! dsi = delta_p (sati, Si0x, Si0x+delSi, 0., 1.) +! dsw = delta_p (satw, Sw0x, 1., 0., 1.) +! fc = dtt*dsi*0.5 +! hx = min(fc+((1.-fc)*dsw), 1.) +! ntilde = p_c1*p_gam*((exp(12.96*(sati-1.1)))**0.3) / p_rho_c +! if (tempc .le. y1p) then +! n_in = ntilde +! elseif (tempc .ge. y2p) then +! n_in = p_psi*p_c1*exp(12.96*(sati-1.)-0.639) +! else +! if (tempc .le. -30.) then +! nmax = p_c1*p_gam*(exp(12.96*(siw-1.1)))**0.3/p_rho_c +! else +! nmax = p_psi*p_c1*exp(12.96*(siw-1.)-0.639) +! endif +! ntilde = MIN(ntilde, nmax) +! nhat = MIN(p_psi*p_c1*exp(12.96*(sati-1.)-0.639), nmax) +! dab = delta_p (tempc, y1p, y2p, aap, bbp) +! n_in = MIN(nhat*(ntilde/nhat)**dab, nmax) +! endif +! mux = hx*p_alpha*n_in*rho +! xni = mux*((6700.*nifa)-200.)/((6700.*5.E5)-200.) +! elseif (satw.ge.0.985 .and. tempc.gt.HGFR-273.15) then + nifa_cc = MAX(0.5, nifa*RHO_NOT0*1.E-6/rho) +! xni = 3.*nifa_cc**(1.25)*exp((0.46*(-tempc))-11.6) ! [DeMott, 2015] + xni = (5.94e-5*(-tempc)**3.33) & ! [DeMott, 2010] + * (nifa_cc**((-0.0264*(tempc))+0.0033)) + xni = xni*rho/RHO_NOT0 * 1000. +! endif + + iceDeMott = MAX(0., xni) + + end FUNCTION iceDeMott + +!+---+-----------------------------------------------------------------+ +!..Newer research since Koop et al (2001) suggests that the freezing +!.. rate should be lower than original paper, so J_rate is reduced +!.. by two orders of magnitude. + + real function iceKoop(temp, qv, qvs, naero, dt) + implicit none + + REAL, INTENT(IN):: temp, qv, qvs, naero, DT + REAL:: mu_diff, a_w_i, delta_aw, log_J_rate, J_rate, prob_h, satw + REAL:: xni + + xni = 0.0 + satw = qv/qvs + mu_diff = 210368.0 + (131.438*temp) - (3.32373E6/temp) & + & - (41729.1*alog(temp)) + a_w_i = exp(mu_diff/(R_uni*temp)) + delta_aw = satw - a_w_i + log_J_rate = -906.7 + (8502.0*delta_aw) & + & - (26924.0*delta_aw*delta_aw) & + & + (29180.0*delta_aw*delta_aw*delta_aw) + log_J_rate = MIN(20.0, log_J_rate) + J_rate = 10.**log_J_rate ! cm-3 s-1 + prob_h = MIN(1.-exp(-J_rate*ar_volume*DT), 1.) + if (prob_h .gt. 0.) then + xni = MIN(prob_h*naero, 1000.E3) + endif + + iceKoop = MAX(0.0, xni) + + end FUNCTION iceKoop + +!+---+-----------------------------------------------------------------+ +!.. Helper routine for Phillips et al (2008) ice nucleation. Trude + + REAL FUNCTION delta_p (yy, y1, y2, aa, bb) + IMPLICIT NONE + + REAL, INTENT(IN):: yy, y1, y2, aa, bb + REAL:: dab, A, B, a0, a1, a2, a3 + + A = 6.*(aa-bb)/((y2-y1)*(y2-y1)*(y2-y1)) + B = aa+(A*y1*y1*y1/6.)-(A*y1*y1*y2*0.5) + a0 = B + a1 = A*y1*y2 + a2 = -A*(y1+y2)*0.5 + a3 = A/3. + + if (yy.le.y1) then + dab = aa + else if (yy.ge.y2) then + dab = bb + else + dab = a0+(a1*yy)+(a2*yy*yy)+(a3*yy*yy*yy) + endif + + if (dab.lt.aa) then + dab = aa + endif + if (dab.gt.bb) then + dab = bb + endif + delta_p = dab + + END FUNCTION delta_p + +!+---+-----------------------------------------------------------------+ +!ctrlL + +!+---+-----------------------------------------------------------------+ +!..Compute _radiation_ effective radii of cloud water, ice, and snow. +!.. These are entirely consistent with microphysics assumptions, not +!.. constant or otherwise ad hoc as is internal to most radiation +!.. schemes. Since only the smallest snowflakes should impact +!.. radiation, compute from first portion of complicated Field number +!.. distribution, not the second part, which is the larger sizes. +!+---+-----------------------------------------------------------------+ + + subroutine calc_effectRad (t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d, & + & re_qc1d, re_qi1d, re_qs1d, kts, kte) + + IMPLICIT NONE + +!..Sub arguments + INTEGER, INTENT(IN):: kts, kte + REAL, DIMENSION(kts:kte), INTENT(IN):: & + & t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d + REAL, DIMENSION(kts:kte), INTENT(INOUT):: re_qc1d, re_qi1d, re_qs1d +!..Local variables + INTEGER:: k + REAL, DIMENSION(kts:kte):: rho, rc, nc, ri, ni, rs + REAL:: smo2, smob, smoc + REAL:: tc0, loga_, a_, b_ + DOUBLE PRECISION:: lamc, lami + LOGICAL:: has_qc, has_qi, has_qs + INTEGER:: inu_c + real, dimension(15), parameter:: g_ratio = (/24,60,120,210,336, & + & 504,720,990,1320,1716,2184,2730,3360,4080,4896/) + + DOUBLE PRECISION:: ln_sigma,ln_dn,sigma_d !RC + + has_qc = .false. + has_qi = .false. + has_qs = .false. + + re_qc1d(:) = RE_QC_BG + re_qi1d(:) = RE_QI_BG + re_qs1d(:) = RE_QS_BG + + do k = kts, kte + rho(k) = 0.622*p1d(k)/(R*t1d(k)*(qv1d(k)+0.622)) + rc(k) = MAX(R1, qc1d(k)*rho(k)) + nc(k) = MAX(2., MIN(nc1d(k)*rho(k), Nt_c_max)) + if (.NOT. is_aerosol_aware) nc(k) = Nt_c + if (rc(k).gt.R1 .and. nc(k).gt.R2) has_qc = .true. + ri(k) = MAX(R1, qi1d(k)*rho(k)) + ni(k) = MAX(R2, ni1d(k)*rho(k)) + if (ri(k).gt.R1 .and. ni(k).gt.R2) has_qi = .true. + rs(k) = MAX(R1, qs1d(k)*rho(k)) + if (rs(k).gt.R1) has_qs = .true. + enddo + + !RC; New effective radii calculation for cloud. + if (has_qc) then + do k = kts, kte + re_qc1d(k) = 2.49E-6 + if (rc(k).le.R1 .or. nc(k).le.R2) CYCLE + sigma_d = (rc(k)/nc(k))**(0.3333) + ln_sigma = sigma_d*(-1.185E3) + 0.815 + ln_sigma = MAX(ln_sigma , 0.2) + ln_sigma = MIN(ln_sigma , 0.7) + + ln_dn = EXP(-3.0*0.5*ln_sigma**2)*(6.*rc(k)/(PI*nc(k)*1000.))**0.3333 + re_qc1d(k) = MAX(2.51E-6, MIN(SNGL(0.5D0 * (ln_dn*EXP(2.5*ln_sigma*ln_sigma) ) ), 75.E-6)) + enddo + endif + !/RC + + if (has_qi) then + do k = kts, kte + if (ri(k).le.R1 .or. ni(k).le.R2) CYCLE + lami = (am_i*cig(2)*oig1*ni(k)/ri(k))**obmi + re_qi1d(k) = MAX(2.51E-6, MIN(SNGL(0.5D0 * DBLE(3.+mu_i)/lami), 125.E-6)) + enddo + endif + + if (has_qs) then + do k = kts, kte + if (rs(k).le.R1) CYCLE + tc0 = MIN(-0.1, t1d(k)-273.15) + smob = rs(k)*oams + +!..All other moments based on reference, 2nd moment. If bm_s.ne.2, +!.. then we must compute actual 2nd moment and use as reference. + if (bm_s.gt.(2.0-1.e-3) .and. bm_s.lt.(2.0+1.e-3)) then + smo2 = smob + else + loga_ = sa(1) + sa(2)*tc0 + sa(3)*bm_s & + & + sa(4)*tc0*bm_s + sa(5)*tc0*tc0 & + & + sa(6)*bm_s*bm_s + sa(7)*tc0*tc0*bm_s & + & + sa(8)*tc0*bm_s*bm_s + sa(9)*tc0*tc0*tc0 & + & + sa(10)*bm_s*bm_s*bm_s + a_ = 10.0**loga_ + b_ = sb(1) + sb(2)*tc0 + sb(3)*bm_s & + & + sb(4)*tc0*bm_s + sb(5)*tc0*tc0 & + & + sb(6)*bm_s*bm_s + sb(7)*tc0*tc0*bm_s & + & + sb(8)*tc0*bm_s*bm_s + sb(9)*tc0*tc0*tc0 & + & + sb(10)*bm_s*bm_s*bm_s + smo2 = (smob/a_)**(1./b_) + endif +!..Calculate bm_s+1 (th) moment. Useful for diameter calcs. + loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(1) & + & + sa(4)*tc0*cse(1) + sa(5)*tc0*tc0 & + & + sa(6)*cse(1)*cse(1) + sa(7)*tc0*tc0*cse(1) & + & + sa(8)*tc0*cse(1)*cse(1) + sa(9)*tc0*tc0*tc0 & + & + sa(10)*cse(1)*cse(1)*cse(1) + a_ = 10.0**loga_ + b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(1) + sb(4)*tc0*cse(1) & + & + sb(5)*tc0*tc0 + sb(6)*cse(1)*cse(1) & + & + sb(7)*tc0*tc0*cse(1) + sb(8)*tc0*cse(1)*cse(1) & + & + sb(9)*tc0*tc0*tc0 + sb(10)*cse(1)*cse(1)*cse(1) + smoc = a_ * smo2**b_ + re_qs1d(k) = MAX(5.01E-6, MIN(0.5*(smoc/smob), 999.E-6)) + enddo + endif + + end subroutine calc_effectRad + +!+---+-----------------------------------------------------------------+ +!..Compute radar reflectivity assuming 10 cm wavelength radar and using +!.. Rayleigh approximation. Only complication is melted snow/graupel +!.. which we treat as water-coated ice spheres and use Uli Blahak's +!.. library of routines. The meltwater fraction is simply the amount +!.. of frozen species remaining from what initially existed at the +!.. melting level interface. +!+---+-----------------------------------------------------------------+ + + subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & + ng1d, qb1d, t1d, p1d, dBZ, kts, kte, ii, jj, ke_diag) + + IMPLICIT NONE + +!..Sub arguments + INTEGER, INTENT(IN):: kts, kte, ii, jj, ke_diag + REAL, DIMENSION(kts:kte), INTENT(IN):: & + qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, ng1d, qb1d, t1d, p1d + REAL, DIMENSION(kts:kte), INTENT(INOUT):: dBZ +! REAL, DIMENSION(kts:kte), INTENT(INOUT):: vt_dBZ + +!..Local variables + REAL, DIMENSION(kts:kte):: temp, pres, qv, rho, rhof + REAL, DIMENSION(kts:kte):: rc, rr, nr, rs, rg, ng, rb + + DOUBLE PRECISION, DIMENSION(kts:kte):: ilamr, ilamg, N0_r, N0_g + REAL, DIMENSION(kts:kte):: mvd_r + REAL, DIMENSION(kts:kte):: smob, smo2, smoc, smoz + REAL:: oM3, M0, Mrat, slam1, slam2, xDs + REAL:: ils1, ils2, t1_vts, t2_vts, t3_vts, t4_vts + REAL:: vtr_dbz_wt, vts_dbz_wt, vtg_dbz_wt + + REAL, DIMENSION(kts:kte):: ze_rain, ze_snow, ze_graupel + INTEGER, DIMENSION(kts:kte):: idx_bg + + DOUBLE PRECISION:: N0_exp, N0_min, lam_exp, lamr, lamg + REAL:: a_, b_, loga_, tc0 + DOUBLE PRECISION:: fmelt_s, fmelt_g + + INTEGER:: i, k, k_0, kbot, n, ktop + LOGICAL:: melti + LOGICAL, DIMENSION(kts:kte):: L_qr, L_qs, L_qg + + DOUBLE PRECISION:: cback, x, eta, f_d + REAL:: xslw1, ygra1, zans1 + INTEGER :: k_0loop + +!+---+ + + do k = kts, kte + dBZ(k) = -35.0 + enddo + +!+---+-----------------------------------------------------------------+ +!..Put column of data into local arrays. +!+---+-----------------------------------------------------------------+ + + do k = kts, kte + temp(k) = t1d(k) + qv(k) = MAX(1.E-10, qv1d(k)) + pres(k) = p1d(k) + rho(k) = 0.622*pres(k)/(R*temp(k)*(qv(k)+0.622)) + rhof(k) = SQRT(RHO_NOT/rho(k)) + rc(k) = MAX(R1, qc1d(k)*rho(k)) + if (qr1d(k) .gt. R1) then + rr(k) = qr1d(k)*rho(k) + nr(k) = MAX(R2, nr1d(k)*rho(k)) + lamr = (am_r*crg(3)*org2*nr(k)/rr(k))**obmr + ilamr(k) = 1./lamr + N0_r(k) = nr(k)*org2*lamr**cre(2) + mvd_r(k) = (3.0 + mu_r + 0.672) * ilamr(k) + L_qr(k) = .true. + else + rr(k) = R1 + nr(k) = R1 + mvd_r(k) = 50.E-6 + L_qr(k) = .false. + endif + if (qs1d(k) .gt. R2) then + rs(k) = qs1d(k)*rho(k) + L_qs(k) = .true. + else + rs(k) = R1 + L_qs(k) = .false. + endif + if (qg1d(k) .gt. R2) then + rg(k) = qg1d(k)*rho(k) + ng(k) = MAX(R2, ng1d(k)*rho(k)) + rb(k) = MAX(qg1d(k)/rho_g(NRHG), qb1d(k)) + rb(k) = MIN(qg1d(k)/rho_g(1), rb(k)) + idx_bg(k) = MAX(1,MIN(NINT(qg1d(k)/rb(k) *0.01)+1,NRHG)) + if (.not. is_hail_aware) idx_bg(k) = idx_bg1 + L_qg(k) = .true. + else + rg(k) = R1 + ng(k) = R2 + idx_bg(k) = idx_bg1 + L_qg(k) = .false. + endif + enddo + +!+---+-----------------------------------------------------------------+ +!..Calculate y-intercept, slope, and useful moments for snow. +!+---+-----------------------------------------------------------------+ + do k = kts, kte + smo2(k) = 0. + smob(k) = 0. + smoc(k) = 0. + smoz(k) = 0. + enddo + if ( ( ke_diag > kts .and. ANY(L_qs .eqv. .true.) ) .or. & + (ke_diag == kts .and. L_qs(kts) .eqv. .true. ) ) then + do k = kts, ke_diag ! kte + if (.not. L_qs(k)) CYCLE + tc0 = MIN(-0.1, temp(k)-273.15) + smob(k) = rs(k)*oams + +!..All other moments based on reference, 2nd moment. If bm_s.ne.2, +!.. then we must compute actual 2nd moment and use as reference. + if (bm_s.gt.(2.0-1.e-3) .and. bm_s.lt.(2.0+1.e-3)) then + smo2(k) = smob(k) + else + loga_ = sa(1) + sa(2)*tc0 + sa(3)*bm_s & + & + sa(4)*tc0*bm_s + sa(5)*tc0*tc0 & + & + sa(6)*bm_s*bm_s + sa(7)*tc0*tc0*bm_s & + & + sa(8)*tc0*bm_s*bm_s + sa(9)*tc0*tc0*tc0 & + & + sa(10)*bm_s*bm_s*bm_s + a_ = 10.0**loga_ + b_ = sb(1) + sb(2)*tc0 + sb(3)*bm_s & + & + sb(4)*tc0*bm_s + sb(5)*tc0*tc0 & + & + sb(6)*bm_s*bm_s + sb(7)*tc0*tc0*bm_s & + & + sb(8)*tc0*bm_s*bm_s + sb(9)*tc0*tc0*tc0 & + & + sb(10)*bm_s*bm_s*bm_s + smo2(k) = (smob(k)/a_)**(1./b_) + endif + +!..Calculate bm_s+1 (th) moment. Useful for diameter calcs. + loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(1) & + & + sa(4)*tc0*cse(1) + sa(5)*tc0*tc0 & + & + sa(6)*cse(1)*cse(1) + sa(7)*tc0*tc0*cse(1) & + & + sa(8)*tc0*cse(1)*cse(1) + sa(9)*tc0*tc0*tc0 & + & + sa(10)*cse(1)*cse(1)*cse(1) + a_ = 10.0**loga_ + b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(1) + sb(4)*tc0*cse(1) & + & + sb(5)*tc0*tc0 + sb(6)*cse(1)*cse(1) & + & + sb(7)*tc0*tc0*cse(1) + sb(8)*tc0*cse(1)*cse(1) & + & + sb(9)*tc0*tc0*tc0 + sb(10)*cse(1)*cse(1)*cse(1) + smoc(k) = a_ * smo2(k)**b_ + +!..Calculate bm_s*2 (th) moment. Useful for reflectivity. + loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(3) & + & + sa(4)*tc0*cse(3) + sa(5)*tc0*tc0 & + & + sa(6)*cse(3)*cse(3) + sa(7)*tc0*tc0*cse(3) & + & + sa(8)*tc0*cse(3)*cse(3) + sa(9)*tc0*tc0*tc0 & + & + sa(10)*cse(3)*cse(3)*cse(3) + a_ = 10.0**loga_ + b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(3) + sb(4)*tc0*cse(3) & + & + sb(5)*tc0*tc0 + sb(6)*cse(3)*cse(3) & + & + sb(7)*tc0*tc0*cse(3) + sb(8)*tc0*cse(3)*cse(3) & + & + sb(9)*tc0*tc0*tc0 + sb(10)*cse(3)*cse(3)*cse(3) + smoz(k) = a_ * smo2(k)**b_ + enddo + endif + +!+---+-----------------------------------------------------------------+ +!..Calculate y-intercept, slope values for graupel. +!+---+-----------------------------------------------------------------+ + + if (ANY(L_qg .eqv. .true.)) then + do k = kte, kts, -1 + lamg = (am_g(idx_bg(k))*cgg(3,1)*ogg2*ng(k)/rg(k))**obmg + ilamg(k) = 1./lamg + N0_g(k) = ng(k)*ogg2*lamg**cge(2,1) + enddo + else + ilamg(:) = 0. + N0_g(:) = 0. + endif + +!+---+-----------------------------------------------------------------+ +!..Locate K-level of start of melting (k_0 is level above). +!+---+-----------------------------------------------------------------+ + melti = .false. + k_0 = kts + do k = kte-1, kts, -1 + if ( (temp(k).gt.273.15) .and. L_qr(k) & + & .and. (L_qs(k+1).or.L_qg(k+1)) ) then + k_0 = MAX(k+1, k_0) + melti=.true. + goto 195 + endif + enddo + 195 continue + +! Set loop limit for wet ice according to whether the full 3D field is needed or just k=1 + k_0loop = Min(k_0, ke_diag+1) + +!+---+-----------------------------------------------------------------+ +!..Do not do the so-called bright band if using the variable density +!.. graupel-hail category since the density increases during melting and +!.. will account for bright band behavior explicitly. +!+---+-----------------------------------------------------------------+ +! if (is_hail_aware) melti = .false. + +!+---+-----------------------------------------------------------------+ +!..Assume Rayleigh approximation at 10 cm wavelength. Rain (all temps) +!.. and non-water-coated snow and graupel when below freezing are +!.. simple. Integrations of m(D)*m(D)*N(D)*dD. +!+---+-----------------------------------------------------------------+ + + do k = kts, ke_diag ! kte + ze_rain(k) = 1.e-22 + ze_snow(k) = 1.e-22 + ze_graupel(k) = 1.e-22 + if (L_qr(k)) ze_rain(k) = N0_r(k)*crg(4)*ilamr(k)**cre(4) + if (L_qs(k)) ze_snow(k) = (0.176/0.93) * (6.0/PI)*(6.0/PI) & + & * (am_s/900.0)*(am_s/900.0)*smoz(k) + if (L_qg(k)) ze_graupel(k) = (0.176/0.93) * (6.0/PI)*(6.0/PI) & + & * (am_g(idx_bg(k))/900.0)*(am_g(idx_bg(k))/900.0) & + & * N0_g(k)*cgg(4,1)*ilamg(k)**cge(4,1) + enddo + +!+---+-----------------------------------------------------------------+ +!..Special case of melting ice (snow/graupel) particles. Assume the +!.. ice is surrounded by the liquid water. Fraction of meltwater is +!.. extremely simple based on amount found above the melting level. +!.. Uses code from Uli Blahak (rayleigh_soak_wetgraupel and supporting +!.. routines). +!+---+-----------------------------------------------------------------+ + + if (.not. iiwarm .and. melti .and. k_0.ge.2) then + do k = k_0loop-1, kts, -1 + +!..Reflectivity contributed by melting snow + if (L_qs(k) .and. L_qs(k_0) ) then + fmelt_s = MAX(0.05d0, MIN(1.0d0-rs(k)/rs(k_0), 0.99d0)) + eta = 0.d0 + oM3 = 1./smoc(k) + M0 = (smob(k)*oM3) + Mrat = smob(k)*M0*M0*M0 + slam1 = M0 * Lam0 + slam2 = M0 * Lam1 + do n = 1, nrbins + x = am_s * xxDs(n)**bm_s + call rayleigh_soak_wetgraupel (x, DBLE(ocms), DBLE(obms), & + & fmelt_s, melt_outside_s, m_w_0, m_i_0, lamda_radar, & + & CBACK, mixingrulestring_s, matrixstring_s, & + & inclusionstring_s, hoststring_s, & + & hostmatrixstring_s, hostinclusionstring_s) + f_d = Mrat*(Kap0*DEXP(-slam1*xxDs(n)) & + & + Kap1*(M0*xxDs(n))**mu_s * DEXP(-slam2*xxDs(n))) + eta = eta + f_d * CBACK * simpson(n) * xdts(n) + enddo + ze_snow(k) = SNGL(lamda4 / (pi5 * K_w) * eta) + endif + +!..Reflectivity contributed by melting graupel + +! if (L_qg(k) .and. L_qg(k_0) ) then +! fmelt_g = MAX(0.05d0, MIN(1.0d0-rg(k)/rg(k_0), 0.99d0)) +! eta = 0.d0 +! lamg = 1./ilamg(k) +! do n = 1, nrbins +! x = am_g(idx_bg(k)) * xxDg(n)**bm_g +! call rayleigh_soak_wetgraupel (x, DBLE(ocmg(idx_bg(k))), DBLE(obmg), & +! & fmelt_g, melt_outside_g, m_w_0, m_i_0, lamda_radar, & +! & CBACK, mixingrulestring_g, matrixstring_g, & +! & inclusionstring_g, hoststring_g, & +! & hostmatrixstring_g, hostinclusionstring_g) +! f_d = N0_g(k)*xxDg(n)**mu_g * DEXP(-lamg*xxDg(n)) +! eta = eta + f_d * CBACK * simpson(n) * xdtg(n) +! enddo +! ze_graupel(k) = SNGL(lamda4 / (pi5 * K_w) * eta) +! endif + + enddo + endif + + do k = ke_diag, kts, -1 + dBZ(k) = 10.*log10((ze_rain(k)+ze_snow(k)+ze_graupel(k))*1.d18) + enddo + + +!..Reflectivity-weighted terminal velocity (snow, rain, graupel, mix). +! do k = kte, kts, -1 +! vt_dBZ(k) = 1.E-3 +! if (rs(k).gt.R2) then +! Mrat = smob(k) / smoc(k) +! ils1 = 1./(Mrat*Lam0 + fv_s) +! ils2 = 1./(Mrat*Lam1 + fv_s) +! t1_vts = Kap0*csg(5)*ils1**cse(5) +! t2_vts = Kap1*Mrat**mu_s*csg(11)*ils2**cse(11) +! ils1 = 1./(Mrat*Lam0) +! ils2 = 1./(Mrat*Lam1) +! t3_vts = Kap0*csg(6)*ils1**cse(6) +! t4_vts = Kap1*Mrat**mu_s*csg(12)*ils2**cse(12) +! vts_dbz_wt = rhof(k)*av_s * (t1_vts+t2_vts)/(t3_vts+t4_vts) +! if (temp(k).ge.273.15 .and. temp(k).lt.275.15) then +! vts_dbz_wt = vts_dbz_wt*1.5 +! elseif (temp(k).ge.275.15) then +! vts_dbz_wt = vts_dbz_wt*2.0 +! endif +! else +! vts_dbz_wt = 1.E-3 +! endif + +! if (rr(k).gt.R1) then +! lamr = 1./ilamr(k) +! vtr_dbz_wt = rhof(k)*av_r*crg(13)*(lamr+fv_r)**(-cre(13)) & +! & / (crg(4)*lamr**(-cre(4))) +! else +! vtr_dbz_wt = 1.E-3 +! endif + +! if (rg(k).gt.R2) then +! lamg = 1./ilamg(k) +! vtg_dbz_wt = rhof(k)*av_g(idx_bg(k))*cgg(5,idx_bg(k))*lamg**(-cge(5,idx_bg(k))) & +! & / (cgg(4,1)*lamg**(-cge(4,1))) +! else +! vtg_dbz_wt = 1.E-3 +! endif + +! vt_dBZ(k) = (vts_dbz_wt*ze_snow(k) + vtr_dbz_wt*ze_rain(k) & +! & + vtg_dbz_wt*ze_graupel(k)) & +! & / (ze_rain(k)+ze_snow(k)+ze_graupel(k)) +! enddo + + end subroutine calc_refl10cm +! +!+---+-----------------------------------------------------------------+ +! + real function theta_e(pres_Pa,temp_K,w_non,tlcl_K) +!.. +!.. The following code was based on Bolton (1980) eqn #43 +!.. and claims to have 0.3 K maximum error within -35 < T < 35 C +!.. pres_Pa = Pressure in Pascals +!.. temp_K = Temperature in Kelvin +!.. w_non = mixing ratio (non-dimensional = kg/kg) +!.. tlcl_K = Temperature at Lifting Condensation Level (K) +!.. + IMPLICIT NONE + + real:: pres_Pa, temp_K, w_non, tlcl_K + real:: pp, tt, rr, tlc, power, xx, p1, p2 + +!+---+ + + pp = pres_Pa + tt = temp_K + rr = w_non + 1.e-8 + tlc = tlcl_K + + power=(0.2854*(1.0 - (0.28*rr) )) + xx = tt * (100000.0/pp)**power + + p1 = (3.376/tlc) - 0.00254 + p2 = (rr*1000.0) * (1.0 + 0.81*rr) + + theta_e = xx * exp(p1*p2) + + return + end +! +!+---+-----------------------------------------------------------------+ +! + real function t_lcl(temp_K,tdew_K) +!.. +!.. The following code was based on Bolton (1980) eqn #15 +!.. and claims to have 0.1 K maximum error within -35 < T < 35 C +!.. temp_K = Temperature in Kelvin +!.. tdew_K = Dewpoint T at Lifting Condensation Level (K) +!.. + IMPLICIT NONE + + real:: temp_K, tdew_K + real:: tt, tttd, denom + +!+---+ + + tt = temp_K + tttd= tdew_K + denom= ( 1.0/(tttd-56.0) ) + (log(tt/tttd)/800.) + t_lcl = ( 1.0 / denom ) + 56.0 + return + end +! +!+---+-----------------------------------------------------------------+ +! + real function t_dew(pres_Pa,w_non) +!.. +!.. pres_Pa = Pressure in Pascals +!.. w_non = mixing ratio (non-dimensional = kg/kg) +!.. + IMPLICIT NONE + + real:: pres_Pa, w_non + real:: p, RR, ES, ESLN + +!+---+ + + p = pres_Pa + RR=w_non+1e-8 + ES=P*RR/(.622+RR) + ESLN=LOG(ES) + T_Dew=(35.86*ESLN-4947.2325)/(ESLN-23.6837) + return + end +! +!+---+-----------------------------------------------------------------+ +! + real function theta_wetb(thetae_K) +!.. +!.. Eqn below was gotten from polynomial fit to data in +!.. Smithsonian Meteorological Tables showing Theta-e +!.. and Theta-w +!.. + IMPLICIT NONE + + real:: thetae_K + real:: x, answer + +!+---+ + + real*8 c(0:6), d(0:6) + data c/-1.00922292e-10, -1.47945344e-8, -1.7303757e-6 & + & ,-0.00012709, 1.15849867e-6, -3.518296861e-9 & + & ,3.5741522e-12/ + data d/0.00000000, -3.5223513e-10, -5.7250807e-8 & + & ,-5.83975422e-6, 4.72445163e-8, -1.13402845e-10 & + & ,8.729580402e-14/ + + x=min(475.0,thetae_K) + + if( x .le. 335.5 ) then + answer = c(0)+x*(c(1)+x*(c(2)+x*(c(3)+x*(c(4)+x*(c(5)+ & + & x*c(6) ))))) + else + answer = d(0)+x*(d(1)+x*(d(2)+x*(d(3)+x*(d(4)+x*(d(5)+ & + & x*d(6) ))))) + endif + + theta_wetb = answer + 273.15 + + return + end +! +!+---+-----------------------------------------------------------------+ +! + real function compT_fr_The(thelcl_K,pres_Pa) +!.. +!.. pres_Pa = Pressure in Pascals +!.. thelcl = Theta-e at LCL (units in Kelvin) +!.. +!.. Temperature (K) is returned given Theta-e at LCL +!.. and a pressure. This describes a moist-adiabat. +!.. This temperature is the parcel temp at level Pres +!.. along moist adiabat described by theta-e. +!.. + IMPLICIT NONE + + real:: thelcl_K, pres_Pa + real:: guess, epsilon, w1, w2, tenu, tenup, cor, thwlcl_K + integer:: iter + +!+---+ + + guess= (thelcl_K - 0.5 * ( max(thelcl_K-270., 0.))**1.05) & + & * (pres_Pa/100000.0)**.2 + epsilon=0.01 + do iter=1,100 + w1 = rslf(pres_Pa,guess) + w2 = rslf(pres_Pa,guess+1.) + tenu = theta_e(pres_Pa,guess,w1,guess) + tenup = theta_e(pres_Pa,guess+1,w2,guess+1.) + cor = (thelcl_K - tenu) / (tenup - tenu) + guess = guess + cor + if( (cor.lt.epsilon) .and. (-cor.lt.epsilon) ) then + compT_fr_The=guess + return + endif + enddo +! print*, ' convergence not reached ' + thwlcl_K=theta_wetb(thelcl_K) + compT_fr_The = thwlcl_K*((pres_Pa/100000.0)**0.286) + + return + end + +!+---+-----------------------------------------------------------------+ +!+---+-----------------------------------------------------------------+ +END MODULE module_mp_rcon +!+---+-----------------------------------------------------------------+ diff --git a/phys/module_mp_udm.F b/phys/module_mp_udm.F new file mode 100644 index 0000000000..2a98ac582c --- /dev/null +++ b/phys/module_mp_udm.F @@ -0,0 +1,4488 @@ +! +!>\file module_mp_udm.F90 +!! +!! This file is the module_mp_udm micorphysics shceme. +!! author Songyou Hong [hong@ucar.edu, songyouhong@gmail.com] +!! + module module_mp_udm + use module_mp_radar + use module_gfs_machine , only : kind_phys +! +!------------------------------------------------------------------------------- +! parameters for microphysical processes +! + real, parameter, private :: & + dtcldcr = 180. ,& !< maximum time step for sub-cycling loops [s] + n0r = 8.e6 ,& !< intercept parameter for rain [m-4] + n0s = 2.e6 ,& !< intercept parameter for snow at 0c [m-4] + n0g = 4.e6 ,& !< intercept parameter for graupel [m-4] + n0h = 4.e4 ,& !< intercept parameter for hail [m-4] + n0smax = 1.e11 ,& !< maximum n0s (t=-90c unlimited) [m-4] + alpha = .12 ,& !< .122 exponent factor for n0s computation + avti = 1.49e4 ,& !< a constant for vt of hexagonal ice + bvti = 1.31 ,& !< a constant for vt of hexagonal ice + cxmi = (1./11.9)**2,&!< a constant for mass of hexagonal ice + dxmi = 2.0 ,& !< a constant for mass of hexagonal ice + pi_ = 3.141593,& !< pi only for ice mass computation + deni = 500. ,& !< density of cloud ice [kgm-3] + avtis = 2.71e3 ,& !< a constant for vt of spherical ice + bvtis = 1.0 ,& !< a constant for vt of spherical ice + cxmis = pi_*deni/6.,& !< a constant for mass of spherical ice + dxmis = 3.0 ,& !< a constant for mass of spherical ice + avtr = 841.9 ,& !< a constant for terminal velocity of rain + bvtr = 0.8 ,& !< a constant for terminal velocity of rain + avts = 11.72 ,& !< a constant for terminal velocity of snow + bvts = .41 ,& !< a constant for terminal velocity of snow + avtg = 553.1 ,& !< a constant for terminal velocity of graupel + bvtg = 0.97 ,& !< a constant for terminal velocity of graupel + deng = 500. ,& !< density of graupel [kgm-3] + avth = 168.0 ,& !< a constant for terminal velocity of hail + bvth = 0.72 ,& !< a constant for terminal velocity of hail + denh = 912. ,& !< density of hail [kgm-3] + lamdasmax = 1.e5 ,& !< maximum slope for snow (10micro) [m-1] + lamdagmax = 2.e4 ,& !< maximum slope for graupel (50micro) [m-1] + lamdahmax = 2.e4 ,& !< maximum slope for hail (50micro) [m-1] + peaut = .55 ,& !< collection efficiency in autoconversion + r0 = .8e-5 ,& !< threshold radius in autoconversion [m] + xncr = 3.e8 ,& !< number concentration of cloud droplets [m-3] + xmyu = 1.718e-5,& !< the dynamic viscosity [kgm-1s-1] + dimax = 500.e-6 ,& !< maximum cloud-ice diamter [m] + ni0max = 500.e3 ,& !< maximum ice nuclei particles (inp) [m-3] + pfrz1 = 100. ,& !< constant in biggs freezing + pfrz2 = 0.66 ,& !< constant in biggs freezing + qcmin = 1.e-12 ,& !< minimun values for qr, qs, and qg [kgkg-1] + qrmin = 1.e-9 ,& !< minimun values for qr, qs, and qg [kgkg-1] + eacrc = 1.0 ,& !< snow/cloud-water collection efficiency + eachs = 1.0 ,& !< hail/snow collection efficiency + eachg = 0.5 ,& !< hail/graupel collection efficiency + cd = 0.6 ,& !< drag coefficient for hailstone + dens = 100. ,& !< density of snow [kgm-3] + qs0 = 0.6e-3 !< threshold for snow aggretion [kgkg-1] +! + real, parameter, private :: & + drmin = 50.e-6 ,& !< minimum diameter for rain [m] + drmax = 5000.e-6 ,& !< maximum diameter for rain [m] + drcoeff = (24.)**(.3333333),& !< factor for raindrop diameter 2.89 + lamdarmax = drcoeff/(drmin*.1) ,& !< maximum slope for rain [m-1] + lamdarmin = drcoeff/(drmax*10.) ,& !< minimum slope for rain [m-1] + nrmin = 1.e-6 ,& !< nr minimum [m-3] + nrmax = 300.e6 ,& !< nr maximum [m-3] + dcmin = 1.e-6 ,& !< minimum diameter for clouds [m] + dcmax = 100.e-6 ,& !< maximum diameter for clouds [m] + lamdacmax = 1./(dcmin*.1),& !< maximum slope for cloud [m-1] + lamdacmin = 1./(dcmax*10.),& !< minimum slope for cloud [m-1] + ncmin = 1.e-3 ,& !< nc minimum [m-3] + ncmax = 30000.e6,& !< nc maximum [m-3] + satmax = 0.0048 ,& !< supersatuation for ccn activation + actk = 0.6 ,& !< a constant for ccn activation + actr = 1.5e-6 ,& !< initial radius for activated cloud [m] + ncrk1 = 3.03e3 ,& !< Long’s kernel coefficient [m-3s-1] + ncrk2 = 2.59e15 ,& !< Long’s kernel coefficient [m-3s-1] + di5000 = 5000.e-6 ,& !< diameter [m] + di2000 = 2000.e-6 ,& !< diameter [m] + di1000 = 1000.e-6 ,& !< diameter [m] + di600 = 600.e-6 ,& !< diameter [m] + di100 = 100.e-6 ,& !< diameter [m] + di82 = 82.e-6 ,& !< diameter [m] + di50 = 50.e-6 ,& !< diameter [m] + di15 = 15.e-6 ,& !< diameter [m] + di5 = 5.e-6 ,& !< diameter [m] + di2 = 2.e-6 ,& !< diameter [m] + di1 = 1.e-6 !< diameter [m] + real, parameter, private :: & + ccn_0 = 50.e+6, & !< background ccn [m-3] + ccnmax = 20000.e+6,& !< maximum ccn [m-3] + ccnmin = 50.e+6 !< minimum ccn [m-3] +!------------------------------------------------------------------------------- +! min max effective radius (m) +! + real, parameter, private :: & + recmin = 2.51e-6 ,& !< minimum effective radius for cloud [m] + recmax = 50.e-6 ,& !< maximum effective radius for cloud [m] + reimin = 5.01e-6 ,& !< minimum effective radius for ice [m] + reimax = 125.e-6 ,& !< maximum effective radius for ice [m] + resmin = 25.e-6 ,& !< minimum effective radius for snow [m] + resmax = 999.e-6 !< maximum effective radius for snow [m] +!------------------------------------------------------------------------------- +! semi_lagrangian option sub-stepping (greater than 100 means single-loop) +! + real, parameter, private :: & + sedi_semi_cfl = 10000.0 +!------------------------------------------------------------------------------- +! inline expansion table for saturation vapor pressure fsvp_water and fsvp +! +! use constant, only : cliq_,cice_,cvap_,cpd_,hvap_,hsub_,psat_,rd_,rv_,ttp_ +! + integer, parameter :: nxsvp = 7501 + real :: c1xsvp,c2xsvp + real, dimension(nxsvp) :: tbsvp + integer, parameter :: nxsvpw = nxsvp + real :: c1xsvpw,c2xsvpw + real, dimension(nxsvpw) :: tbsvpw +! + real, parameter, private :: & + cliq_ = 4.1900e+3 ,& !< specific heat of liquid water [jkg-1k-1] + cice_ = 2.1060e+3 ,& !< specific heat of ice water [jkg-1k-1] + cvap_ = 1.8700e+3 ,& !< specific heat of vapor water [jkg-1k-1] + cpd_ = 1.00464e+3 ,& !< specific heat of dry air [jkg-1k-1] + hvap_ = 2.5010e+6 ,& !< latent heat for vaporization [jkg-1] + hsub_ = 2.8340e+6 ,& !< latent heat for sublimation [jkg-1] + psat_ = 6.1078e+2 ,& !< saturated vapor pressure at 0c [pa] + rd_ = 2.8704e+2 ,& !< gas constant for dry air [jkg-1k-1] + rv_ = 4.6150e+2 ,& !< gas constant for water vapor [jkg-1k-1] + ttp_ = 2.7316e+2 !< temperature at triple point [k] + real, parameter, private :: & + psatk = psat_, & + dldt = cvap_-cliq_, & + dldti = cvap_-cice_, & + xa = -dldt/rv_, & + xb = xa+hvap_/(rv_*ttp_), & + xai = -dldti/rv_, & + xbi = xai+hsub_/(rv_*ttp_) +!------------------------------------------------------------------------------- +! inline expansion table for shape parameter dependent sedimentation +! + integer, parameter :: nxshape = 9991 !< 10 micro to 10 mm every 1 micro + real :: c1xshape,c2xshape + real, dimension(nxshape) :: tbshape +!------------------------------------------------------------------------------- +! inline expansion table for lb2017 autoconversion +! + integer, parameter :: nxaut = 9991 !< 0.1 micro to 100 micro every 0.1 + integer, parameter :: numax = 15 !< maximum dispersion parameter + real :: c1xaut,c2xaut + double precision, dimension(nxaut,numax) :: tbaut_qc_tot, tbaut_qc_sub + double precision, dimension(nxaut,numax) :: tbaut_nc_tot, tbaut_nc_sub +!------------------------------------------------------------------------------- +! apply temperature dependent ice habbit....based on aspect ratio concept +! of Um et al. (2015, acp) and Matrosov et al. (2020, jamc) +! + real, parameter, private :: & + t1_sphere = -10. ,& !< threshold for spherical ice [C] + t2_sphere = -33. !< threshold for hexagonal ice [C] +!------------------------------------------------------------------------------- +! miscellaneous... +! + real, parameter, private :: & + zero_0 = 0.0 ,& + one_1 = 1.0 + logical, parameter, private :: flgzero = .true. +!------------------------------------------------------------------------------- +! save the microphysics constants that are initialzed in init driver +! + real, save :: & + qc_ocean,qc_land,qck1,pidnc,bvtr1,bvtr2,bvtr3,bvtr4,bvtr5, & + bvtr6,bvtr7, bvtr2o5,bvtr3o5, & + g1pbr,g2pbr,g3pbr,g4pbr,g5pbr,g6pbr,g7pbr, & + g5pbro2,g7pbro2,pi,pisq, & + pvtr,pvtrn,eacrr,pacrr,pidn0r,pidnr, & + precr1,precr2,roqimax,bvts1,bvts2, & + bvts3,bvts4,g1pbs,g3pbs,g4pbs,g5pbso2, & + pvts,pacrs,precs1,precs2,pidn0s,xlv1,pacrc, & + bvtg1,bvtg2,bvtg3,bvtg4,g1pbg,g3pbg,g4pbg, & + g5pbgo2,pvtg,pacrg,precg1,precg2,pidn0g, & + g6pbgh,precg3,bvth2,bvth3,bvth4,g3pbh,g4pbh,g5pbho2,pacrh,pvth, & + prech1,prech2,prech3,pidn0h, & + rslopehmax,rslopehbmax,rslopeh2max,rslopeh3max, & + rslopecmax,rslopec2max,rslopec3max, & + rslopermax,rslopesmax,rslopegmax, & + rsloperbmax,rslopesbmax,rslopegbmax, & + rsloper2max,rslopes2max,rslopeg2max, & + rsloper3max,rslopes3max,rslopeg3max + real, dimension(numax), private, save :: ccg, ocg1 + real, parameter, private :: bm_r1 = 3.0 + real, parameter, private :: obmr1 = 1./bm_r1 + real, save :: mrmin +! +!------------------------------------------------------------------------------- +contains +!------------------------------------------------------------------------------- +! +subroutine udm(th, q, qc, qr, qi, qs, qg, qh & + ,nn, nc, nr & + ,den, pii, p, delz & + ,delt,g, cpd, cpv, ccn0, rd, rv, t0c & + ,ep1, ep2, qmin & + ,xls, xlv0, xlf0, den0, denr & + ,cliq,cice,psat & + ,xland & + ,xice & + ,rain, rainncv & + ,snow, snowncv & + ,hail, hailncv & + ,sr & + ,refl_10cm, diagflag, do_radar_ref & + ,graupel, graupelncv & + ,itimestep & + ,has_reqc, has_reqi, has_reqs & ! for radiation + ,re_cloud, re_ice, re_snow & ! for radiation + ,ids,ide, jds,jde, kds,kde & + ,ims,ime, jms,jme, kms,kme & + ,its,ite, jts,jte, kts,kte & + ) +!------------------------------------------------------------------------------- + implicit none +!------------------------------------------------------------------------------- +! + integer, intent(in ) :: itimestep + integer, intent(in ) :: ids,ide, jds,jde, kds,kde , & + ims,ime, jms,jme, kms,kme , & + its,ite, jts,jte, kts,kte + real, intent(in ) :: delt, g, ccn0, rd, rv, t0c, & + den0, cpd, cpv, ep1, ep2, & + qmin, xls, xlv0, xlf0, cliq, & + cice, psat, denr + real, dimension( ims:ime , jms:jme ), intent(in) :: xland + real, dimension( ims:ime , jms:jme ), intent(in) :: xice + real, dimension( ims:ime , kms:kme , jms:jme ), & + intent(in ) :: & + den, & + pii, & + p, & + delz + real, dimension( ims:ime , kms:kme , jms:jme ), & + intent(inout) :: & + th, & + q, & + qc, & + qi, & + qr, & + qs, & + qg, & + qh + real, dimension( ims:ime , kms:kme , jms:jme ), & + intent(inout) :: & + nn, & + nc, & + nr + real, dimension( ims:ime , jms:jme ), & + intent(inout) :: rain, & + rainncv, & + sr + real, dimension( ims:ime , jms:jme ), optional, & + intent(inout) :: snow, & + snowncv, & + graupel, & + graupelncv, & + hail, & + hailncv +! +! for radiation interation +! + integer, intent(in):: & + has_reqc, & + has_reqi, & + has_reqs + real, dimension( ims:ime, kms:kme, jms:jme ), & + intent(inout):: & + re_cloud, & + re_ice, & + re_snow +!------------------------------------------------------------------------------- +! +! local variables +! + integer, dimension( its:ite , jts:jte ) :: slimsk + real, dimension( its:ite , kts:kte ) :: t + real, dimension( its:ite , kts:kte, 2 ) :: qci + real, dimension( its:ite , kts:kte, 4 ) :: qrs, ncr + integer :: i,j,k +! +! for reflectivlity +! + real, dimension( kts:kte) :: qv1d, t1d, p1d, qr1d, nr1d, qs1d, qg1d, dbz + real, dimension( kts:kte) :: qh1d + real, dimension( kts:kte ) :: den1d, qc1d, nc1d, qi1d + real, dimension( kts:kte ) :: re_qc, re_qi, re_qs + integer, optional, intent(in) :: do_radar_ref + logical, optional, intent(in) :: diagflag + real, dimension( ims:ime, kms:kme, jms:jme ), & + optional, intent(inout) :: refl_10cm +! +!------------------------------------------------------------------------------- +! + if (itimestep==1) then + do j = jms,jme + do k = kms,kme + do i = ims,ime + nn(i,k,j) = ccn0 + enddo + enddo + enddo + endif +! + do j=jts,jte + do i=its,ite + if(xland(i,j) > 1.) then + slimsk(i,j) = 0 + else + slimsk(i,j) = 1 + endif + if(xice(i,j) > 0.5) slimsk(i,j) = 2 + enddo + enddo +! + do j=jts,jte + do k=kts,kte + do i=its,ite + t(i,k)=th(i,k,j)*pii(i,k,j) + qci(i,k,1) = qc(i,k,j) + qci(i,k,2) = qi(i,k,j) + qrs(i,k,1) = qr(i,k,j) + qrs(i,k,2) = qs(i,k,j) + qrs(i,k,3) = qg(i,k,j) + qrs(i,k,4) = qh(i,k,j) + ncr(i,k,1) = nn(i,k,j) + ncr(i,k,2) = nc(i,k,j) + ncr(i,k,3) = nr(i,k,j) + enddo + enddo +! + call udm2d(t, q(ims,kms,j), qci, qrs & + ,ncr & + ,den(ims,kms,j) & + ,p(ims,kms,j), delz(ims,kms,j) & + ,delt,g, cpd, cpv, rd, rv, t0c & + ,ep1, ep2, qmin & + ,xls, xlv0, xlf0, den0, denr & + ,cliq,cice,psat & + ,j & + ,slimsk(its,j) & + ,rain(ims,j),rainncv(ims,j) & + ,sr(ims,j) & + ,ids,ide, jds,jde, kds,kde & + ,ims,ime, jms,jme, kms,kme & + ,its,ite, jts,jte, kts,kte & + ,snow(ims,j),snowncv(ims,j) & + ,graupel(ims,j),graupelncv(ims,j) & + ,hail(ims,j),hailncv(ims,j) & + ) + do k=kts,kte + do i=its,ite + th(i,k,j)=t(i,k)/pii(i,k,j) + qc(i,k,j) = qci(i,k,1) + qi(i,k,j) = qci(i,k,2) + qr(i,k,j) = qrs(i,k,1) + qs(i,k,j) = qrs(i,k,2) + qg(i,k,j) = qrs(i,k,3) + qh(i,k,j) = qrs(i,k,4) + nn(i,k,j) = ncr(i,k,1) + nc(i,k,j) = ncr(i,k,2) + nr(i,k,j) = ncr(i,k,3) + enddo + enddo +!------------------------------------------------------------------------------- + if ( present (diagflag) ) then + if (diagflag .and. do_radar_ref==1) then + do i=its,ite + do k=kts,kte + t1d(k)=th(i,k,j)*pii(i,k,j) + p1d(k)=p(i,k,j) + qv1d(k)=q(i,k,j) + qr1d(k)=qr(i,k,j) + qs1d(k)=qs(i,k,j) + qg1d(k)=qg(i,k,j) + qh1d(k)=qh(i,k,j) + nr1d(k) = nr(i,k,j) + enddo + call udm_mp_reflectivity (qv1d, qr1d, qs1d, qg1d, & + nr1d, & + qh1d, & + t1d, p1d, dbz, kts, kte, i, j) + do k = kts, kte + refl_10cm(i,k,j) = max(-35., dbz(k)) + enddo + enddo + endif + endif +! + if (has_reqc.ne.0 .and. has_reqi.ne.0 .and. has_reqs.ne.0) then + do i=its,ite + do k=kts,kte + re_qc(k) = recmin + re_qi(k) = reimin + re_qs(k) = resmin + t1d(k) = th(i,k,j)*pii(i,k,j) + qc1d(k) = qc(i,k,j) + qi1d(k) = qi(i,k,j) + qs1d(k) = qs(i,k,j) + nc1d(k) = nc(i,k,j) + enddo + call udm_mp_effective_radius(t1d,qc1d,qi1d,qs1d,den1d,qmin, t0c & + ,nc1d & + ,re_qc, re_qi, re_qs, kts, kte, i, j) + do k=kts,kte + re_cloud(i,k,j) = max(recmin, min(re_qc(k), recmax)) + re_ice(i,k,j) = max(reimin, min(re_qi(k), reimax)) + re_snow(i,k,j) = max(resmin, min(re_qs(k), resmax)) + enddo + enddo + endif ! has_reqc, etc... +!------------------------------------------------------------------------------- + enddo +end subroutine udm +!------------------------------------------------------------------------------- +! +! +!------------------------------------------------------------------------------- +subroutine udm2d(t1, q1 & + ,qci1, qrs1 & + ,ncr1 & + ,den1, p1, delz1 & + ,delt,g, cpd, cpv, rd, rv, t0c & + ,ep1, ep2, qmin & + ,xls, xlv0, xlf0, den0, denr & + ,cliq,cice,psat & + ,lat & + ,slimsk & + ,rain,rainncv & + ,sr & + ,ids,ide, jds,jde, kds,kde & + ,ims,ime, jms,jme, kms,kme & + ,its,ite, jts,jte, kts,kte & + ,snow,snowncv & + ,graupel,graupelncv & + ,hail,hailncv & + ) +! +!------------------------------------------------------------------------------- +!=============================================================================== +!! The Unified Forecast System (ufs) Double Moment Microphyiscs Scheme (udm mp) +!! largely adopts ice microphys processes of wrf Single-Moment (WSM) and warm +!! microphysics from wrf Double-Moment (WDM) schemes, with bug fixes and +!! revisions based on literature and accumulated realism. udm MP utilizes +!! the in-cloud microphysics concept (Kim and Hong 2018) and physically based +!! autoconversion of Lee and Baik (2017) by solving the stochastic collection +!! equation. For grauel and hail, the corresponding termimal velocity is updated +!! The semi-lagrangian sedimentation of Juang and Hong (2010) is reconfigured +!! for computational efficiency and numerical accuracy. +!! The scheme incorporates aerosol data interacting with cloud condensation +!! nuclei (CCN) ice nuclei particles (INP) as options. +!! +!! All productions terms are optimized by introducing a cloud top definition. +!! +!! All units are in m.k.s. and source/sink terms in kgkg-1s-1. +!! +!! udm mp scheme, developed by songyou hong, haiqin li, jian-wen bao (noaa) +!! jimy dhdhia (ncar), spring, summer, fall, and winter 2021-2025 +!! wdm mp scheme, coded by kyo-sun lim and songyou hong (yonsei univ.), +!! fall 2008 +!! wsm mp scheme, coded by songyou hong, jeong-ock jade lim (yonsei univ.), +!! jimy dudhia, and shu-hua chen (ncar),summer 2002 +!! ncep mp scheme, coded by songyou hong, henry juang, qingyun zhao (ncep), +!! summer 1997 +!! references : +!! heymsfield et al(hey, 2018) j. atmos. Sci. +!! kim and and hong (kh, 2018) j. atmos. sci. +!! lee and baik (lb2017, 2017) j. atmos. sci. +!! juang and hong (jh, 2010) mon. wea. rev. +!! lim and hong (lh, 2010) mon. wea. rev. +!! dudhia, hong and lim (dhl, 2008) j. meteor. soc. japan +!! hong and lim (hl, 2006) j. korean meteor. soc. +!! hong, dudhia, and chen (hdc, 2004) mon. wea. rev. +!! hong, juang, and zhao (hjz, 1998) mon. wea. rev. +!! +!! \section structure +!! --- udm_mp --- |- slope_rain slope_snow slope_graupel slope_hail +!! | +!! |- semi_lagrangian +!! | +!! |- cldf_diag +!! | +!! |- udminit +!! | | +!! | ------ rgmma +!! | +!! |- adjust_number_concent +!! | +!! |- find_cloud_top +!! | +!! |- udm_mp_effective_radius +!! | +!! |- udm_mp_reflectivity +!! | +!! |- udm_funct_shape_setup +!! | | +!! | ------ fshapex, fshape +!! | +!! |- udm_funct_svp_setup +!! | | +!! | ------ fsvpx, fsvpxw, fsvp, fsvp_water +!! | +!! |- udm_funct_lb2017_setup +!! | | +!! | ------ funct_aut_qc_tot, funct_aut_qc_sub, +!! | ------ funct_aut_nc_tot, funct_aut_nc_sub, +!! | +!! \ section input and output +!! input : +!! delt - timestep +!! g, cpd, cpv, t0c, den0, - constant +!! rd, rv, ep1, ep2, qmin, +!! xls, xlv0, xlf0, denr, +!! cliq, cice, psat +!! ids, ide, jds, jde, kds, kde - dimension +!! ims, ime, jms, jme, kms, kme +!! its, ite, jts, jte, kts, kte +!! ncloud - number of hydrometeor +!! p - pressure, pa +!! delz - depth of model layer, m +!! +!! inout : +!! t1 - temperautre +!! q1 - specific humidity +!! q2 - mixing ratio of cloud, rain, ice, and snow +!! qc, qr, qi, qc +!! rain, rainncv - precipitation +!! sr - ratio of snow to rain +!! +!------------------------------------------------------------------------------- + implicit none +!------------------------------------------------------------------------------- +! +! passing variables +! + integer , intent(in ) :: & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + real , intent(in ) :: delt + real , intent(in ) :: g, cpd, cpv, t0c,& + rd, rv, ep1, ep2 + integer, dimension( its:ite ) , intent(in ) :: slimsk + real , intent(in ) :: & + qmin, xls, & + xlv0, xlf0, & + den0, denr, & + cliq, cice, psat + integer , intent(in ) :: lat + real, dimension( ims:ime,kms:kme ), intent(in ) :: p1 + real, dimension( ims:ime,kms:kme ), intent(in ) :: delz1 + real, dimension( ims:ime,kms:kme ), intent(inout) :: q1 + real, dimension( its:ite,kts:kte ), intent(inout) :: t1 + real, dimension( ims:ime,kms:kme ) , intent(in ) :: den1 + real, dimension( its:ite,kts:kte,2 ), intent(inout) :: qci1 + real, dimension( its:ite,kts:kte,4 ), intent(inout) :: qrs1 + real, dimension( its:ite,kts:kte,3 ), intent(inout) :: ncr1 + real, dimension( ims:ime ) , intent(inout) :: rain + real, dimension( ims:ime ), optional , intent(inout) :: snow + real, dimension( ims:ime ), optional , intent(inout) :: graupel + real, dimension( ims:ime ), optional , intent(inout) :: hail + real, dimension( ims:ime ) , intent(inout) :: rainncv + real, dimension( ims:ime ) , intent(inout) :: sr + real, dimension( ims:ime ), optional , intent(inout) :: snowncv + real, dimension( ims:ime ), optional , intent(inout) :: graupelncv + real, dimension( ims:ime ), optional , intent(inout) :: hailncv +! +! local variables +! + real, dimension( its:ite ) :: dxmeter + real, dimension( kts:kte , its:ite ) :: & + q, & + den, & + t, & + p, & + delz, & + dend, & + denfac, & + xlv, & + xlf, & + cpm + real, dimension( kts:kte , its:ite , 2) :: & + qci + real, dimension( kts:kte , its:ite , 4) :: & + qrs + real, dimension( kts:kte, 4) :: & + rslope, & + rslope2, & + rslope3, & + rslopeb + real, dimension( kts:kte , its:ite , 3) :: ncr + real, dimension( kts:kte ) :: & + rh_mul, & + rh_ice, & + qsat_mul, & + qsat_ice, & + vtr, & + vts, & + vtg, & + vth, & + vtmean, & + sumice, & + vti, & + vtis, & + ni, & + ni0, & + mi, & + di, & + dis, & + denqr, & + denqs, & + denqg, & + denqh, & + denqi, & + n0sfac, & + diffus, & + viscok, & + viscod, & + ab_mul, & + ab_ice, & + venfac + real, dimension( kts:kte ) :: & + rslopec, & + rslopec2, & + rslopec3, & + dc, & + dr, & + denqn + real, dimension( kts:kte ) :: & + pigen, & + pcond, & + prevp, & + psevp, & + pgevp, & + pidep, & + psdep, & + pgdep, & + phdep, & + praut, & + psaut, & + pgaut, & + piacr, & + pracw, & + praci, & + pracs, & + psacw, & + psaci, & + psacr, & + phaut, & + phacr, & + phacs, & + phacg, & + phaci, & + phmlt, & + pheml, & + phevp, & + primh, & + pvapg, & + pvaph, & + pgwet, & + phwet, & + pgaci_w, & + phaci_w, & + nhacw, & + nhacr, & + nheml, & + pgacw, & + phacw, & + pracg, & + pgaci, & + pgacr, & + pgacs, & + paacw, & + psmlt, & + pgmlt, & + pseml, & + pgeml + real, dimension( kts:kte ) :: & + pcact, & + nraut, & + nracw, & + ncevp, & + nccol, & + nrcol, & + nsacw, & + ngacw, & + niacr, & + nsacr, & + ngacr, & + naacw, & + nseml, & + ngeml, & + ncact + real, dimension( kts:kte ) :: & + satrdt, & + supice, & + supsat, & + tcelci, & + cldf + real :: & + qrpath, & + qspath, & + qgpath, & + qipath, & + precip_r, & + precip_s, & + precip_g, & + precip_i + logical, dimension( kts:kte ) :: & + ifsat, & + ifice +! +! lb2017 autoconversion +! + real, dimension( kts:kte ) :: ncaut + integer :: nu_c + logical :: L_qc + real :: L_c, n_c + double precision :: n0c, n0csq, lamc + double precision, parameter :: vt0_c = 1.09734d8 + double precision, parameter :: kc_aut = 1.35429d14 + double precision, parameter :: alpha_aut = 0.88 + double precision, dimension(0:42) :: gamma1 + double precision :: & + qc_tot, qc_sub, qc_aut, & + nc_tot, nc_sub, nc_aut, nr_aut +! +! miscellaneous variables +! + real :: & + rdtcld,conden, x, y, z, a, b, c, d, e, & + coeres, dtcld, eacrs, acrfac, egi, & + ehi, rs0, ghw1, ghw2, ghw3, ghw4, precip_h, qhpath, & + qimax, roqi0, lamdar, diameter, & + precip_sum, precip_ice, factor, source, htotal, & + hvalue, pfrzdtc, pfrzdtr, & + tstepsnow, tstepgraupel, tstephail, & + alpha2, delta2, delta3, dtcfl, dr_embryo,temp + real :: gfac, sfac, nfrzdtr, nfrzdtc, qnpath + real, dimension( kts:kte ) :: qrconcr, qrcon, taucon + real, dimension( kts:kte ) :: vtn + integer :: nstep, niter, n, lond, latd, & + i, j, k, loop, loops, idim, kdim + integer :: ktopini, ktopmax, ktop + integer :: ktopqc, ktopqi, ktopqr, ktopqs, ktopqg, ktopqh, ktoprh + real, dimension( kts:kte ) :: tmp1d + logical :: flgcld, lqc, lqi, lqr, lqs, lqg, lqh +!------------------------------------------------------------------------------- +! preparation .... +! + idim = ite-its+1 + kdim = kte-kts+1 + ktopini = kte - 1 + lond = (ite-its)/2 + 1 + latd = 1 + dxmeter(:) = 10000. + dr_embryo = 1./(pi*denr/6.*di82**3) +!------------------------------------------------------------------------------- +! assign passing variables to local arrays +! + t(:,:) = 0.; q(:,:) = 0.; p(:,:) =0. + delz(:,:) = 0.; den(:,:) = 0.; dend(:,:) =0.; denfac(:,:) = 0. + do k = kts, kte + do i = its, ite + t(k,i) = t1(i,k) + q(k,i) = q1(i,k) + p(k,i) = p1(i,k) + delz(k,i) = delz1(i,k) + den(k,i) = den1(i,k) + dend(k,i) = (p(k,i)/t(k,i)-den(k,i)*rv)/(rd-rv) ! dry density + denfac(k,i) = sqrt(den0/den(k,i)) + enddo + enddo +!------------------------------------------------------------------------------- +! padding 0 for negative values generated by dynamics - optional +! + qci(:,:,:) = qmin + qrs(:,:,:) = qmin + ncr(:,:,:) = qmin +! + ktop = ktopini + do k = kts, kte + do i = its, ite + if(flgzero) then + qci(k,i,1) = max(qci1(i,k,1),0.0) + qci(k,i,2) = max(qci1(i,k,2),0.0) + qrs(k,i,1) = max(qrs1(i,k,1),0.0) + qrs(k,i,2) = max(qrs1(i,k,2),0.0) + qrs(k,i,3) = max(qrs1(i,k,3),0.0) + qrs(k,i,4) = max(qrs1(i,k,4),0.0) + ncr(k,i,1) = min(max(ncr1(i,k,1),ccnmin),ccnmax) + ncr(k,i,2) = max(ncr1(i,k,2),0.0) + ncr(k,i,3) = max(ncr1(i,k,3),0.0) + else + qci(k,i,1) = qci1(i,k,1) + qci(k,i,2) = qci1(i,k,2) + qrs(k,i,1) = qrs1(i,k,1) + qrs(k,i,2) = qrs1(i,k,2) + qrs(k,i,3) = qrs1(i,k,3) + qrs(k,i,4) = qrs1(i,k,4) + ncr(k,i,1) = min(max(ncr1(i,k,1),ccnmin),ccnmax) + ncr(k,i,2) = ncr1(i,k,2) + ncr(k,i,3) = ncr1(i,k,3) + endif + enddo + enddo +!------------------------------------------------------------------------------- +! initialize the surface rain, snow, graupel and etc.... +! + do i = its, ite + if(present (snowncv) .and. present (snow)) snowncv(i) = 0. + if(present (graupelncv) .and. present (graupel)) graupelncv(i) = 0. + if(present (hailncv) .and. present (hail)) hailncv(i) = 0. + enddo + rainncv(:) = 0.; sr(:) = 0. + cpm(:,:) = 0.; xlv(:,:) = 0.; xlf(:,:) = 0. +!------------------------------------------------------------------------------- +! latent heat for phase changes and heat capacity. emanuel(1994) +! + do k = kts, ktop + do i = its, ite + cpm(k,i) = cpd*(1.-max(q(k,i),qmin)) + max(q(k,i),qmin)*cpv + xlv(k,i) = xlv0 - xlv1*(t(k,i)-t0c) + xlf(k,i) = xls - xlv(k,i) + enddo + enddo +!=============================================================================== +! +! inner loop wih the time step of dtcldcr (default = 180 sec) +! +!=============================================================================== +! compute the sub-cycling time steps. +! + loops = max(ceiling(delt/dtcldcr),1) + dtcld = delt/loops + if(delt<=dtcldcr) dtcld = delt + rdtcld = 1./dtcld +! +!------------------------------------------------------------------------------- +! + inner_loop : do loop = 1, loops ! sub-stepping with cld timestep = 180s +! +!------------------------------------------------------------------------------- +! + i_loop : do i = its, ite ! i-loop for one-dimensional code +! +!------------------------------------------------------------------------------- +! + qsat_mul(:) = 0.; rh_mul(:) = 0. + qsat_ice(:) = 0.; rh_ice(:) = 0. + ktopqc = 0; ktopqi = 0; ktopqr = 0; ktopqs = 0; ktopqg = 0; ktoprh = 0 + ktopqh = 0 +! + ktop = ktopini + do k = kts, ktop + qsat_mul(k) = fsvp_water(t(k,i),p(k,i)) !< mul means water in korean + qsat_mul(k) = ep2 * qsat_mul(k) / (p(k,i) - qsat_mul(k)) + qsat_mul(k) = max(qsat_mul(k),qmin) + rh_mul(k) = max(q(k,i) / qsat_mul(k),qmin) + qsat_ice(k) = fsvp(t(k,i),p(k,i)) + qsat_ice(k) = ep2 * qsat_ice(k) / (p(k,i) - qsat_ice(k)) + qsat_ice(k) = max(qsat_ice(k),qmin) + rh_ice(k) = max(q(k,i) / qsat_ice(k),qmin) + enddo +!=============================================================================== +! compute internal functions +! optimizatin : A**B => exp(log(A)*(B)) +!------------------------------------------------------------------------------- +! x : temperature, y: pressure, z: density +! diffus: diffusion coefficient of the water vapr ! 8.794e-5*x**1.81/y +! diffus(x,y) = 8.794e-5 * exp(log(x)*(1.81)) / y +! viscok: kinematic viscosity(m2s-1) ! 1.496e-6*x**1.5/(x+120.)/z +! viscok(x,z) = 1.496e-6 * (x*sqrt(x)) /(x+120.)/z +! viscod: dynamic viscosity(kgm-1s-1) ! 1.414e3*viscok*z +! viscod(x,z) = 1.414e3*viscok(x,z)*z +! ab: thermodynamic terms, a and b in the denominator associated with +! heat conduction and vapor diffusion +! ab(a,b,c,d,e) = d*a*a/(viscod(c,d)*rv*c*c)+1./(e*diffus(c,b)) +! venfac: parameter associated with the ventilation effects +! + do k = ktop, kts, -1 + diffus(k) = (8.794e-5*exp(log(t(k,i))*(1.81)))/p(k,i) + viscok(k) = (1.496e-6*(t(k,i)*sqrt(t(k,i))))/(t(k,i)+120.)/den(k,i) + viscod(k) = 1.414e3*viscok(k)*den(k,i) + ab_mul(k) = ((den(k,i)*xlv(k,i)*xlv(k,i)))/(viscod(k)*(rv*t(k,i)*t(k,i))) & + + 1./(qsat_mul(k)*diffus(k)) + ab_ice(k) = ((den(k,i)*xls*xls))/(viscod(k)*(rv*t(k,i)*t(k,i))) & + + 1./(qsat_ice(k)*diffus(k)) + venfac(k) = (exp(.3333333*log(viscok(k)/(diffus(k)))) & + * sqrt(sqrt(den0/(den(k,i)))))/sqrt(viscok(k)) + enddo +!------------------------------------------------------------------------------- +! re-define cloud top for numerical efficiencies +! + lqc = .false. + lqi = .false. + lqr = .false. + lqs = .false. + lqg = .false. + lqh = .false. + flgcld = .false. + call find_cloud_top(1,kdim,ktopini,qci(:,i,1),zero_0,ktopqc) + call find_cloud_top(1,kdim,ktopini,qci(:,i,2),zero_0,ktopqi) + call find_cloud_top(1,kdim,ktopini,qrs(:,i,1),zero_0,ktopqr) + call find_cloud_top(1,kdim,ktopini,qrs(:,i,2),zero_0,ktopqs) + call find_cloud_top(1,kdim,ktopini,qrs(:,i,3),zero_0,ktopqg) + call find_cloud_top(1,kdim,ktopini,qrs(:,i,4),zero_0,ktopqh) + call find_cloud_top(1,kdim,ktopini,rh_ice(:), one_1,ktoprh) + if(ktopqc>0.0) lqc = .true. + if(ktopqi>0.0) lqi = .true. + if(ktopqr>0.0) lqr = .true. + if(ktopqs>0.0) lqs = .true. + if(ktopqg>0.0) lqg = .true. + if(ktopqh>0.0) lqh = .true. + ktopmax = max(ktopqc,ktopqi,ktopqr,ktopqs,ktopqg,ktopqh,ktoprh) +!------------------------------------------------------------------------------- +! early checkout +! + if(lqc .or. lqi .or. lqr .or. lqs .or. lqg .or. lqh) flgcld = .true. + if((.not.flgcld) .and. ktoprh>0.0) flgcld = .true. + if(.not.flgcld) then + cycle i_loop + endif +!------------------------------------------------------------------------------- +! initialize the local variables +! + temp = 0. ; hvalue = 0. ; htotal = 0. ; source = 0. + pcond(:) = 0. ; pigen(:) = 0. + praut(:) = 0. ; psaut(:) = 0. ; pgaut(:) = 0. + pidep(:) = 0. ; psdep(:) = 0. ; pgdep(:) = 0. + pracw(:) = 0. ; praci(:) = 0. ; pracs(:) = 0. + psacw(:) = 0. ; psaci(:) = 0. ; psacr(:) = 0. + pgacw(:) = 0. ; pgaci(:) = 0. ; pgacr(:) = 0. ; pgacs(:) = 0. + paacw(:) = 0. ; piacr(:) = 0. + psmlt(:) = 0. ; pgmlt(:) = 0. ; pseml(:) = 0. ; pgeml(:) = 0. + prevp(:) = 0. ; psevp(:) = 0. ; pgevp(:) = 0. + denqr(:) = 0. ; denqs(:) = 0. ; denqi(:) = 0. + vtr(:) = 0. ; vts(:) = 0. ; vtg(:) = 0. ; vti(:) = 0. + qrpath = 0. ; qspath = 0. ; qgpath = 0. ; qipath = 0. + precip_r = 0. ; precip_s = 0. ; precip_g = 0. ; precip_i = 0. + satrdt(:)= 0. ; supsat(:)= 0. ; tcelci(:)= 0. ; supice(:)= 0. + ifsat(:) = .false.; ifice(:) =.false. + ni(:) = 1.e3 ; mi(:) = 0. ; cldf(:) = 1. + sumice(:) = 0. ; vtmean(:) = 0.0 ; n0sfac(:) = 0. + tstepsnow = 0. ; tstepgraupel = 0. ; tstephail = 0. + lamdar = 0. ; diameter = 0. ; eacrs = 0. ; egi =0. + roqi0 = 0. ; acrfac = 0. ; ni0(:) = 0. + qimax = 0. ; alpha2 = 0. ; coeres = 0. + pfrzdtc = 0. ; pfrzdtr = 0. + pcact(:) = 0. ; nsacw(:) = 0. ; ngacw(:) = 0. ; naacw(:) = 0. + niacr(:) = 0. ; nsacr(:) = 0. ; ngacr(:) = 0. ; nseml(:) = 0. + ngeml(:) = 0. ; nracw(:) = 0. ; nccol(:) = 0. ; nrcol(:) = 0. + ncact(:) = 0. ; nraut(:) = 0. ; ncevp(:) = 0. ; denqn(:) = 0. + vtn(:) = 0. ; dc(:) = 0. ; dr(:) = 0. ; di(:) = 0. + qrcon(:)= 0. ; qrconcr(:) = 0. ; taucon(:) = 0. ; tmp1d(:) = 0. + qnpath = 0. ; sfac = 0. ; gfac = 0. + nfrzdtc = 0. ; nfrzdtr = 0. + phdep(:)= 0. ; phaut(:) = 0. ; pracg(:) = 0. ; phacw(:) = 0. + phaci(:)= 0. ; phacr(:) = 0. ; phacs(:) = 0. ; phacg(:) = 0. + phmlt(:)= 0. ; pheml(:) = 0. ; phevp(:) = 0. ; primh(:) = 0. + pvapg(:)= 0. ; pvaph(:) = 0. ; pgwet(:) = 0. ; phwet(:) = 0. + pgaci_w(:)= 0. ; phaci_w(:) = 0. ; qhpath = 0. ; vth(:) = 0. + nhacw(:) = 0. ; nhacr(:) = 0. ; nheml(:)= 0. ; precip_h = 0. + ncaut(:) = 0. ; L_qc = .true. ; n0c = 0. ; n0csq = 0. + L_c = 0. ; n_c = 0. ; lamc = 0. ; nu_c = 0 + gamma1(:) = 0. ; qc_tot = 0. ; qc_sub = 0. ; qc_aut = 0. + nc_tot = 0. ; nc_sub = 0. ; nc_aut = 0. ; nr_aut = 0. + dis(:) = 0. ; vtis(:) = 0. + ktop = ktopmax + do k = ktop, kts, -1 + if(qci(k,i,1) < qcmin) ncr(k,i,2) =0. + if(qrs(k,i,1) < qrmin) ncr(k,i,3) =0. + enddo +!=============================================================================== +! +! adjustment of nc and nr according to avaialble size of clouds and rain +! +!=============================================================================== + call adjust_number_concent(ktopqr,kdim,qrs(:,i,1),ncr(:,i,3),den(:,i), & + pidnr,drcoeff,qrmin,nrmin,nrmax,di1000,drmin,drmax) + call adjust_number_concent(ktopqc,kdim,qci(:,i,1),ncr(:,i,2),den(:,i), & + pidnc,one_1,qcmin,ncmin,ncmax,di15, dcmin, dcmax) +!------------------------------------------------------------------------------- +! obtain in-cloud properties +! + ktop = max(ktopqc,ktopqi) + call cldf_diag(1,kdim,t(:,i),p(:,i),q(:,i),qci(:,i,1),qci(:,i,2), & + dxmeter(i),cldf(:),ktop) +! + do k = ktop, kts, -1 +! change condensate variables to in-cloud variables + if(cldf(k)>0.) then + qci(k,i,1) = qci(k,i,1) / cldf(k) + qci(k,i,2) = qci(k,i,2) / cldf(k) + qrs(k,i,1) = qrs(k,i,1) / cldf(k) + qrs(k,i,2) = qrs(k,i,2) / cldf(k) + qrs(k,i,3) = qrs(k,i,3) / cldf(k) + qrs(k,i,4) = qrs(k,i,4) / cldf(k) + endif + enddo +!------------------------------------------------------------------------------- +! update the slope parameters for microphysics computation +! + ktop = ktopqr + call slope_rain(1,kdim,ktop,qrs(:,i,1),den(:,i),denfac(:,i),t(:,i), & + ncr(:,i,3), & + rslope(:,1),rslopeb(:,1),rslope2(:,1),rslope3(:,1),vtr(:)) + ktop = ktopqs + call slope_snow(1,kdim,ktop,qrs(:,i,2),den(:,i),denfac(:,i),t(:,i), & + rslope(:,2),rslopeb(:,2),rslope2(:,2),rslope3(:,2),vts(:)) + ktop = ktopqg + call slope_graupel(1,kdim,ktop,qrs(:,i,3),den(:,i),denfac(:,i),t(:,i), & + rslope(:,3),rslopeb(:,3),rslope2(:,3),rslope3(:,3),vtg(:)) + ktop = ktopqh + call slope_hail(1,kdim,ktop,qrs(:,i,4),den(:,i),denfac(:,i),t(:,i), & + rslope(:,4),rslopeb(:,4),rslope2(:,4),rslope3(:,4),vth(:)) + ktop = ktopqc + call slope_cloud(1,kdim,ktop,qci(:,i,1),ncr(:,i,2),den(:,i),denfac(:,i), & + t(:,i),qcmin,rslopec(:),rslopec2(:),rslopec3(:)) +!=============================================================================== +! +! melting/freezing +! +!=============================================================================== + ktop = ktopmax + do k = kts, ktop + tcelci(k) = t(k,i) - t0c + if(t(k,i)t0: s->r) + if(lqs) then + ktop = ktopqs + do k = ktop, kts, -1 + if(.not.ifice(k) .and. qrs(k,i,2)>0.) then + coeres = rslope2(k,2)*sqrt(rslope(k,2)*rslopeb(k,2)) + psmlt(k) = viscod(k)/xlf0*(t(k,i)-t0c)*pi/2.*n0sfac(k) & + *(precs1*rslope2(k,2)+precs2*venfac(k)*coeres)/den(k,i) + psmlt(k) = max(min(psmlt(k)*dtcld,qrs(k,i,2)),0.) +!------------------------------------------------------------------------------- +! nsmlt: melting of snow [LH A27] +! (T>T0: ->NR) + if(qrs(k,i,2)>qrmin) then + sfac = rslope(k,2)*n0s*n0sfac(k)/qrs(k,i,2) + ncr(k,i,3) = min(ncr(k,i,3) + sfac*psmlt(k), nrmax) + endif + qrs(k,i,2) = qrs(k,i,2) - psmlt(k) + qrs(k,i,1) = qrs(k,i,1) + psmlt(k) + t(k,i) = t(k,i) - xlf0/cpm(k,i)*psmlt(k)*cldf(k) + endif + enddo + endif +!------------------------------------------------------------------------------- +! pgmlt: melting of graupel [hl a23] +! (t>t0: g->r) + if(lqg) then + ktop = ktopqg + do k = ktop, kts, -1 + if(.not.ifice(k) .and. qrs(k,i,3)>0.) then + coeres = rslope2(k,3)*sqrt(rslope(k,3)*rslopeb(k,3)) + pgmlt(k) = viscod(k)/xlf0*(t(k,i)-t0c)*(precg1*rslope2(k,3) & + + precg2*venfac(k)*coeres)/den(k,i) + pgmlt(k) = max(min(pgmlt(k)*dtcld,qrs(k,i,3)),0.) +!------------------------------------------------------------------------------- +! ngmlt: melting of graupel [lh a28] +! (t>t0: ->nr) + if(qrs(k,i,3)>qrmin) then + gfac = rslope(k,3)*n0g/qrs(k,i,3) + ncr(k,i,3) = min(ncr(k,i,3) + gfac*pgmlt(k), nrmax) + endif + qrs(k,i,3) = qrs(k,i,3) - pgmlt(k) + qrs(k,i,1) = qrs(k,i,1) + pgmlt(k) + t(k,i) = t(k,i) - xlf0/cpm(k,i)*pgmlt(k)*cldf(k) + endif + enddo + endif +!------------------------------------------------------------------------------- +! phmlt: melting of hail [bht a22] +! (t>t0: qh->qr) + if(lqh) then + ktop = ktopqh + do k = ktop, kts, -1 + if(.not.ifice(k) .and. qrs(k,i,4)>0.) then + coeres = rslope2(k,4)*sqrt(rslope(k,4)*rslopeb(k,4)) + phmlt(k) = viscod(k)/xlf0*(t(k,i)-t0c)*(prech1*rslope2(k,4) & + + prech2*venfac(k)*coeres)/den(k,i) + phmlt(k) = max(min(phmlt(k)*dtcld,qrs(k,i,4)),0.) +!------------------------------------------------------------------------------- +! nhmlt: melting of hail [lh a28] +! (t>t0: ->nr) + if(qrs(k,i,4)>qrmin) then + gfac = rslope(k,4)*n0h/qrs(k,i,4) + ncr(k,i,3) = min(ncr(k,i,3) + gfac*phmlt(k), nrmax) + endif + qrs(k,i,4) = qrs(k,i,4) - phmlt(k) + qrs(k,i,1) = qrs(k,i,1) + phmlt(k) + t(k,i) = t(k,i) - xlf0/cpm(k,i)*phmlt(k)*cldf(k) + endif + enddo + endif +!------------------------------------------------------------------------------- +! pimlt: instantaneous melting of cloud ice [hl a47] +! (t>t0: i->c) + if(lqi) then + ktop = ktopqi + do k = ktop, kts, -1 + if(.not.ifice(k) .and. qci(k,i,2)>0.) then + qci(k,i,1) = qci(k,i,1) + qci(k,i,2) + t(k,i) = t(k,i) - xlf0/cpm(k,i)*qci(k,i,2)*cldf(k) + qci(k,i,2) = 0. +!--------------------------------------------------------------- +! nimlt: instantaneous melting of cloud ice [lh a18] +! (t>t0: ->nc) + temp = (den(k,i)*max(qci(k,i,2),qcmin)) + temp = sqrt(sqrt(temp*temp*temp)) + ni(k) = min(max(5.38e7*temp,1.e3),1.e6) + ncr(k,i,2) = min(ncr(k,i,2) + ni(k),ncmax) + endif + enddo + endif +!------------------------------------------------------------------------------- +! pihmf: homogeneous freezing of cloud water below -40c [hl a45] +! (t<-40c: c->i) + if(lqc) then + ktop = ktopqc + do k = ktop, kts, -1 + if(tcelci(k)<-40. .and. qci(k,i,1)>0.) then + qci(k,i,2) = qci(k,i,2) + qci(k,i,1) + t(k,i) = t(k,i) + xlf(k,i)/cpm(k,i)*qci(k,i,1)*cldf(k) + qci(k,i,1) = 0. +!--------------------------------------------------------------- +! nihmf: homogeneous freezing of cloud water below -40c [lh a17] +! (t<-40c: nc-> ) + if(ncr(k,i,2)>0.) ncr(k,i,2) = 0. + endif +!------------------------------------------------------------------------------- +! pihtf: heterogeneous freezing of cloud water [hl a44] +! (t0>t>-40c: c->i) + if(ifice(k) .and. qci(k,i,1)>qcmin) then + hvalue = max(tcelci(k),-70.) + pfrzdtc = min(pisq*pfrz1*(exp(-pfrz2*hvalue)-1.)*denr/den(k,i) & + *ncr(k,i,2)*rslopec3(k)*rslopec3(k)/18.*dtcld & + ,qci(k,i,1)) +!--------------------------------------------------------------- +! nihtf: heterogeneous freezing of cloud water [LH A16] +! (T0>T>-40C: NC->) + if(ncr(k,i,2)>ncmin) then + nfrzdtc = min(pi*pfrz1*(exp(-pfrz2*hvalue)-1.)*ncr(k,i,2) & + *rslopec3(k)/6.*dtcld,ncr(k,i,2)) + ncr(k,i,2) = max(ncr(k,i,2) - nfrzdtc,0.) + endif + qci(k,i,1) = qci(k,i,1) - pfrzdtc + qci(k,i,2) = qci(k,i,2) + pfrzdtc + t(k,i) = t(k,i) + xlf(k,i)/cpm(k,i)*pfrzdtc*cldf(k) + endif + enddo + endif +!------------------------------------------------------------------------------- +! pgfrz: freezing of rain water [hl a20] +! (tg) + if(lqr) then + ktop = ktopqr + do k = ktop, kts, -1 + if(ifice(k) .and. qrs(k,i,1)>0.) then + hvalue = max(tcelci(k), -70.) + pfrzdtr = min(140.*pisq*pfrz1*ncr(k,i,3)*denr/den(k,i) & + *(exp(-pfrz2*hvalue)-1.)*rslope3(k,1)*rslope3(k,1) & + *dtcld,qrs(k,i,1)) +!------------------------------------------------------------------------------- +! ngfrz: freezing of rain water [lh a26] +! (T ) + if(ncr(k,i,3)>nrmin) then + nfrzdtr = min(4.*pi*pfrz1*ncr(k,i,3)*(exp(-pfrz2*hvalue)-1.) & + *rslope3(k,1)*dtcld, ncr(k,i,3)) + ncr(k,i,3) = max(ncr(k,i,3) - nfrzdtr, 0.) + endif + qrs(k,i,1) = qrs(k,i,1) - pfrzdtr + qrs(k,i,3) = qrs(k,i,3) + pfrzdtr + t(k,i) = t(k,i) + xlf(k,i)/cpm(k,i)*pfrzdtr*cldf(k) + endif + enddo + endif +!------------------------------------------------------------------------------- +! restore grid-mean variables +! + ktop = max(ktopqc,ktopqi) + do k = ktop, kts, -1 +! change in-cloud condensate variables to grid-mean variables + if(cldf(k)>0.) then + qci(k,i,1) = qci(k,i,1) * cldf(k) + qci(k,i,2) = qci(k,i,2) * cldf(k) + qrs(k,i,1) = qrs(k,i,1) * cldf(k) + qrs(k,i,2) = qrs(k,i,2) * cldf(k) + qrs(k,i,3) = qrs(k,i,3) * cldf(k) + qrs(k,i,4) = qrs(k,i,4) * cldf(k) + endif + enddo +!------------------------------------------------------------------------------- +! re-define cloud top for numerical efficiencies +! + ktop = ktopini + do k = kts, ktop + qsat_mul(k) = fsvp_water(t(k,i),p(k,i)) + qsat_mul(k) = ep2 * qsat_mul(k) / (p(k,i) - qsat_mul(k)) + qsat_mul(k) = max(qsat_mul(k),qmin) + rh_mul(k) = max(q(k,i) / qsat_mul(k),qmin) + qsat_ice(k) = fsvp(t(k,i),p(k,i)) + qsat_ice(k) = ep2 * qsat_ice(k) / (p(k,i) - qsat_ice(k)) + qsat_ice(k) = max(qsat_ice(k),qmin) + rh_ice(k) = max(q(k,i) / qsat_ice(k),qmin) + enddo +! + lqc = .false. + lqi = .false. + lqr = .false. + lqs = .false. + lqg = .false. + lqh = .false. + call find_cloud_top(1,kdim,ktopini,qci(:,i,1),zero_0,ktopqc) + call find_cloud_top(1,kdim,ktopini,qci(:,i,2),zero_0,ktopqi) + call find_cloud_top(1,kdim,ktopini,qrs(:,i,1),zero_0,ktopqr) + call find_cloud_top(1,kdim,ktopini,qrs(:,i,2),zero_0,ktopqs) + call find_cloud_top(1,kdim,ktopini,qrs(:,i,3),zero_0,ktopqg) + call find_cloud_top(1,kdim,ktopini,qrs(:,i,4),zero_0,ktopqh) + call find_cloud_top(1,kdim,ktopini,rh_ice(:), one_1,ktoprh) + if(ktopqc>0.0) lqc = .true. + if(ktopqi>0.0) lqi = .true. + if(ktopqr>0.0) lqr = .true. + if(ktopqs>0.0) lqs = .true. + if(ktopqg>0.0) lqg = .true. + if(ktopqh>0.0) lqh = .true. + ktopmax = max(ktopqc,ktopqi,ktopqr,ktopqs,ktopqg,ktopqh,ktoprh) +!------------------------------------------------------------------------------- +! update the slope parameters and microphysical parameters +! + ktop = ktopqr + call slope_rain(1,kdim,ktop,qrs(:,i,1),den(:,i),denfac(:,i),t(:,i), & + ncr(:,i,3), & + rslope(:,1),rslopeb(:,1),rslope2(:,1),rslope3(:,1),vtr(:)) + ktop = ktopqs + call slope_snow(1,kdim,ktop,qrs(:,i,2),den(:,i),denfac(:,i),t(:,i), & + rslope(:,2),rslopeb(:,2),rslope2(:,2),rslope3(:,2),vts(:)) + ktop = ktopqg + call slope_graupel(1,kdim,ktop,qrs(:,i,3),den(:,i),denfac(:,i),t(:,i), & + rslope(:,3),rslopeb(:,3),rslope2(:,3),rslope3(:,3),vtg(:)) + ktop = ktopqh + call slope_hail(1,kdim,ktop,qrs(:,i,4),den(:,i),denfac(:,i),t(:,i), & + rslope(:,4),rslopeb(:,4),rslope2(:,4),rslope3(:,4),vth(:)) + ktop = ktopqi + do k = ktop, kts, -1 + if(qci(k,i,2)>qcmin) then + temp = (den(k,i)*max(qci(k,i,2),qcmin)) + temp = sqrt(sqrt(temp*temp*temp)) + ni(k) = min(max(5.38e7*temp,1.e3),1.e6) + mi(k) = den(k,i)*qci(k,i,2)/ni(k) + di(k) = max(min(exp(log((mi(k)/cxmi))*(1./dxmi)),dimax), qmin) + vti(k) = avti*exp(log(di(k))*(bvti)) + hvalue = min(max((tcelci(k) - t2_sphere)/(t1_sphere-t2_sphere),0.),1.0) + dis(k) = max(min(exp(log((mi(k)/cxmis))*(1./dxmis)),dimax), qmin) + vtis(k)= avtis*exp(log(dis(k))*(bvtis)) + di(k) = di(k) * (1.-hvalue) + dis(k) * hvalue + vti(k) = vti(k) * (1.-hvalue) + vtis(k) * hvalue + endif + enddo +! + ktop = max(ktopqs,ktopqg,ktopqh) + do k = ktop, kts, -1 + sumice(k) = max( (qrs(k,i,2)+qrs(k,i,3)+qrs(k,i,4)), qmin) + if(sumice(k)>qmin) then + vtmean(k) = (vts(k)*qrs(k,i,2)+vtg(k)*qrs(k,i,3) & + +vth(k)*qrs(k,i,4))/sumice(k) + else + vtmean(k) = 0. + endif + enddo +!------------------------------------------------------------------------------- +! compute the mean-volume drop diameter for raindrop distribution [lh a10] +! + ktop = ktopqr + do k = ktop, kts, -1 + dr(k) = rslope(k,1)*drcoeff + enddo +!------------------------------------------------------------------------------- +! compute the mean-volume drop diameter for cloud-droplet distribution [lh a7] +! + ktop = ktopqc + call slope_cloud(1,kdim,ktop,qci(:,i,1),ncr(:,i,2),den(:,i),denfac(:,i), & + t(:,i),qcmin,rslopec(:),rslopec2(:),rslopec3(:)) + do k = ktop, kts, -1 + dc(k) = rslopec(k) + enddo +!=============================================================================== +! +! warm rain processes +! +!=============================================================================== + ktop = max(ktopqc,ktopqr) + do k = ktop, kts, -1 + qrcon(k) = 2.7e-2*den(k,i)*qci(k,i,1)*(1.e20/16.*rslopec2(k) & + *rslopec2(k)-0.4) + qrconcr(k) = max(1.2*qrcon(k), qrmin) + enddo + if(lqc) then + ktop = ktopqc + do k = ktop, kts, -1 +!------------------------------------------------------------------------------- +! praut: auto conversion rate from cloud to rain [lb2017, eqs. 15~19] +! (qc->qr, nc-> nr) + if(qci(k,i,1) > qcmin) then + L_qc = .true. + L_c = qci(k,i,1)*den(k,i) + n_c = max(min(ncr(k,i,2),1.e12),2.) + nu_c = min(nint(1.e9/n_c)+2,15) + lamc = max(min((n_c*pidnc*8.d0*ccg(nu_c)*ocg1(nu_c)/L_c)**obmr1, & + lamdacmax),lamdacmin) + else + L_qc = .false. +! qci(k,i,1) = 0. +! ncr(k,i,2) = 0. + L_c = qcmin + n_c = 2. + endif + if(L_qc.and.L_c>1.e-5) then +!----------------------------------------- +! for mass concentraion +!----------------------------------------- + gamma1(0) = 1.0d0/( lamc) + do n=1, nu_c + gamma1(n) = gamma1(n-1)*(dble(n)/( lamc)) + enddo + n0c = n_c/gamma1(nu_c) + n0csq = n0c * n0c + qc_tot = funct_aut_qc_tot(lamc,nu_c) + qc_sub = funct_aut_qc_sub(lamc,nu_c) +! + qc_aut =(qc_tot-alpha_aut*qc_sub)*(pidnc*8.0)*pi*vt0_c*kc_aut*n0csq +!----------------------------------------- +! for number concentraion +!----------------------------------------- + nc_tot = funct_aut_nc_tot(lamc,nu_c) + nc_sub = funct_aut_nc_sub(lamc,nu_c) +! + nc_aut = (2.0*nc_tot-alpha_aut*nc_sub)*pi*vt0_c*kc_aut*n0csq + nr_aut = ( nc_tot-alpha_aut*nc_sub)*pi*vt0_c*kc_aut*n0csq +! + praut(k) = max(min(real(qc_aut/den(k,i)),qci(k,i,1)*rdtcld),0.) + ncaut(k) = max(min(real(nc_aut),ncr(k,i,2)*rdtcld),0.) + nraut(k) = min(real(nr_aut),praut(k)/mrmin) + end if + enddo + endif +! + if(lqc) then + ktop = ktopqc + do k = ktop, kts, -1 +!------------------------------------------------------------------------------- +! nccol: self collection of cloud water [lh a8] [cp 24 & 25] +! (nc->) + if(dc(k)>=di100) then + nccol(k) = ncrk1*ncr(k,i,2)*ncr(k,i,2)*rslopec3(k) + else + nccol(k) = 2.*ncrk2*ncr(k,i,2)*ncr(k,i,2)*rslopec3(k)*rslopec3(k) + endif + enddo + endif +! + if(lqr) then + ktop = ktopqr + do k = ktop, kts, -1 + supsat(k) = max(q(k,i),qmin)-qsat_mul(k) + satrdt(k) = supsat(k)*rdtcld +!------------------------------------------------------------------------------- +! pracw: accretion of cloud water by rain [lh 10] [cp 22 & 23] +! (qc->qr) +! nracw: accretion of cloud water by rain [lh a9] +! (nc->) + if(qrs(k,i,1)>=qrconcr(k)) then + if(dr(k)>=di100) then + nracw(k) = min(ncrk1*ncr(k,i,2)*ncr(k,i,3)*(rslopec3(k) & + + 24.*rslope3(k,1)),ncr(k,i,2)*rdtcld) + pracw(k) = min(pi/6.*(denr/den(k,i))*ncrk1*ncr(k,i,2) & + *ncr(k,i,3)*rslopec3(k)*(2.*rslopec3(k) & + + 24.*rslope3(k,1)),qci(k,i,1)*rdtcld) + else + nracw(k) = min(ncrk2*ncr(k,i,2)*ncr(k,i,3)*(2.*rslopec3(k) & + *rslopec3(k)+5040.*rslope3(k,1) & + *rslope3(k,1)),ncr(k,i,2)*rdtcld) + pracw(k) = min(pi/6.*(denr/den(k,i))*ncrk2*ncr(k,i,2) & + *ncr(k,i,3)*rslopec3(k)*(6.*rslopec3(k) & + *rslopec3(k)+5040.*rslope3(k,1)*rslope3(k,1)) & + ,qci(k,i,1)*rdtcld) + endif + endif +!------------------------------------------------------------------------------- +! nrcol: self collection of rain-drops and break-up [lh a21] [cp 24 & 25] +! (nr->) + if(qrs(k,i,1)>=qrconcr(k)) then + if(dr(k)=di100 .and. dr(k)=di600 .and. dr(k)r or r->v) + if(qrs(k,i,1)>0.) then + coeres = rslope(k,1)*sqrt(rslope(k,1)*rslopeb(k,1)) + prevp(k) = (rh_mul(k)-1.)*ncr(k,i,3)*(precr1*rslope(k,1) & + +precr2*venfac(k)*coeres)/ab_mul(k) + if(prevp(k)<=0.) then + prevp(k) = max(prevp(k),-qrs(k,i,1)*rdtcld) + prevp(k) = max(prevp(k),satrdt(k)*.5) +!------------------------------------------------------------------------------- +! nrevp: evaporation/condensation rate of rain [lh a14] +! (nr->nccn) + if(prevp(k)==-qrs(k,i,1)*rdtcld) then + ncr(k,i,1) = min(ncr(k,i,1) + ncr(k,i,3), ccnmax) + ncr(k,i,3) = 0. + endif + else + prevp(k) = min(prevp(k),satrdt(k)*.5) + endif + endif + enddo + endif +!=============================================================================== +! +! cold rain processes +! +!=============================================================================== + ktop = ktopmax + ifice(:) = .false. + do k = ktop, kts, -1 + tcelci(k) = t(k,i) - t0c + if(t(k,i)qrmin .and. qci(k,i,2)>qcmin) then +!------------------------------------------------------------------------------- +! praci: accretion of cloud ice by rain [hl a15] [lfo 25] +! (tqr) + acrfac = 6.*rslope2(k,1)+4.*di(k)*rslope(k,1) + di(k)**2 + praci(k) = pi*qci(k,i,2)*ncr(k,i,3)*abs(vtr(k)-vti(k))*acrfac/4. +! reduce collection efficiency (suggested by B. Wilt) + praci(k) = praci(k)*min(max(0.0,qrs(k,i,1)/qci(k,i,2)),1.)**2 + praci(k) = min(praci(k),qci(k,i,2)*rdtcld) +!------------------------------------------------------------------------------- +! piacr: accretion of rain by cloud ice [hl A19] [lfo 26] +! (tqs OR qr->qg) + piacr(k) = pisq*avtr*ncr(k,i,3)*denr*ni(k)*denfac(k,i) & + *g7pbr*rslope3(k,1)*rslope2(k,1)*rslopeb(k,1) & + /24./den(k,i) +! reduce collection efficiency (suggested by B. Wilt) + piacr(k) = piacr(k)*min(max(0.0,qci(k,i,2)/qrs(k,i,1)),1.)**2 + piacr(k) = min(piacr(k),qrs(k,i,1)*rdtcld) +!------------------------------------------------------------------------------- +! niacr: accretion of rain by cloud ice [lh a25] +! (t) + if(ncr(k,i,3)>nrmin) then + niacr(k) = pi*avtr*ncr(k,i,3)*ni(k)*denfac(k,i)*g4pbr & + *rslope2(k,1)*rslopeb(k,1)/4. +! reduce collection efficiency (suggested by B. Wilt) + niacr(k) = niacr(k)*min(max(0.0,qci(k,i,2)/qrs(k,i,1)),1.)**2 + niacr(k) = min(niacr(k),ncr(k,i,3)*rdtcld) + endif + endif + endif + enddo + endif +! + if(lqs) then + ktop = ktopqs + do k = ktop, kts, -1 +! + if(ifice(k)) then + if(qrs(k,i,2)>qrmin .and. qci(k,i,2)>qcmin) then + eacrs = exp(0.09*(tcelci(k))) +!------------------------------------------------------------------------------- +! psaci: accretion of cloud ice by rain [hdc 10] +! (ts) + acrfac = 2.*rslope3(k,2) + 2.*di(k)*rslope2(k,2) & + + di(k)**2*rslope(k,2) + psaci(k) = pi*qci(k,i,2)*eacrs*n0s*n0sfac(k) & + *abs(vtmean(k)-vti(k))*acrfac/4. + psaci(k) = psaci(k)*min(max(0.0,qrs(k,i,2)/qci(k,i,2)),1.)**2 + psaci(k) = min(psaci(k),qci(k,i,2)*rdtcld) + endif + endif +!------------------------------------------------------------------------------- +! psacw: accretion of cloud water by snow [hl a7] +! (ts, and t>=t0: c->r) + if(qrs(k,i,2)>qrmin .and. qci(k,i,1)>qcmin) then + psacw(k) = min(pacrc*n0sfac(k)*rslope3(k,2)*rslopeb(k,2) & + *qci(k,i,1)*denfac(k,i),qci(k,i,1)*rdtcld) +! reduce collection efficiency (suggested by B. Wilt) + psacw(k) = psacw(k)*min(max(0.0,qrs(k,i,2)/qci(k,i,1)),1.)**2 + psacw(k) = min(psacw(k),qci(k,i,1)*rdtcld) + endif +!------------------------------------------------------------------------------- +! nsacw: accretion of cloud water by snow [lh A12] +! (NC ->) + if(qrs(k,i,2)>qrmin .and. qci(k,i,1)>qcmin .and. ncr(k,i,2)>ncmin) then + nsacw(k) = min(pacrc*n0sfac(k)*rslope3(k,2)*rslopeb(k,2) & +! reduce collection efficiency (suggested by B. Wilt) + *min(max(0.0,qrs(k,i,2)/qci(k,i,1)),1.)**2 & + *ncr(k,i,2)*denfac(k,i),ncr(k,i,2)*rdtcld) + endif + enddo + endif +! + if(lqg) then + ktop = ktopqg + do k = ktop, kts, -1 + if(ifice(k)) then +!------------------------------------------------------------------------------- +! pgaci: accretion of cloud ice by graupel [hl a17] +! (tg) + if(qrs(k,i,3)>qrmin .and. qci(k,i,2)>qcmin) then + egi = exp(0.09*(tcelci(k))) + acrfac = 2.*rslope3(k,3) + 2.*di(k)*rslope2(k,3) & + + di(k)**2*rslope(k,3) + pgaci(k) = pi*egi*qci(k,i,2)*n0g*abs(vtmean(k)-vti(k))*acrfac/4. + pgaci(k) = min(pgaci(k),qci(k,i,2)*rdtcld) + endif + endif +!------------------------------------------------------------------------------- +! pgacw: accretion of cloud water by graupel [hl a6] +! (tg, and t>=t0: c->r) + if(qrs(k,i,3)>qrmin .and. qci(k,i,1)>qcmin) then + pgacw(k) = min(pacrg*rslope3(k,3)*rslopeb(k,3) & +! reduce collection efficiency (suggested by B. Wilt) + *min(max(0.0,qrs(k,i,3)/qci(k,i,1)),1.)**2 & + *qci(k,i,1)*denfac(k,i),qci(k,i,1)*rdtcld) + endif +!------------------------------------------------------------------------------- +! ngacw: accretion of cloud water by graupel [lh a13] +! (nc-> + if(qrs(k,i,3)>qrmin .and. qci(k,i,1)>qcmin .and. ncr(k,i,2)>ncmin) then + ngacw(k) = min(pacrg*rslope3(k,3)*rslopeb(k,3)*ncr(k,i,2) & +! reduce collection efficiency (suggested by B. Wilt) + *min(max(0.0,qrs(k,i,3)/qci(k,i,1)),1.)**2 & + *denfac(k,i),ncr(k,i,2)*rdtcld) + endif + enddo + endif +!------------------------------------------------------------------------------- +! paacw: accretion of cloud water by averaged snow/graupel +! (tg or s, and t>=t0: c->r) + ktop = max(ktopqs,ktopqg) + do k = ktop, kts, -1 + if(sumice(k)>qmin) then + paacw(k) = (qrs(k,i,2)*psacw(k) + qrs(k,i,3)*pgacw(k))/sumice(k) +!------------------------------------------------------------------------------- +! naacw: Accretion of cloud water by averaged snow/graupel +! (nc->) + naacw(k) = (qrs(k,i,2)*nsacw(k) + qrs(k,i,3)*ngacw(k))/sumice(k) + endif + enddo +! + if(lqh) then + ktop = ktopqh + do k = ktop, kts, -1 + if(ifice(k)) then +!------------------------------------------------------------------------------- +! phaci: accretion of cloud ice by hail [bht] +! (th) + if(qrs(k,i,4)>qrmin .and. qci(k,i,2)>qcmin) then + ehi = exp(0.09*(tcelci(k))) + acrfac = 2.*rslope3(k,4) + 2.*di(k)*rslope2(k,4) & + + di(k)**2*rslope(k,4) + phaci(k) = pi*ehi*qci(k,i,2)*n0h*abs(vtmean(k)-vti(k))*acrfac/4. + phaci(k) = min(phaci(k),qci(k,i,2)*rdtcld) + endif + endif +!------------------------------------------------------------------------------- +! phacw: rccretion of cloud water by hail [bht a08] +! (tqh, AND t>=t0: qc->qr) + if(qrs(k,i,4)>qrmin .and. qci(k,i,1)>qcmin) then + phacw(k) = min(pacrh*rslope3(k,4)*rslopeb(k,4)*qci(k,i,1) & + *min(max(0.0,qrs(k,i,4)/qci(k,i,1)),1.)**2 & + *denfac(k,i),qci(k,i,1)*rdtcld) + endif +! +! nhacw: Accretion of cloud water by hail +! (nc->) + if(qrs(k,i,4)>qrmin .and. qci(k,i,1)>qcmin .and. ncr(k,i,2)>ncmin) then + nhacw(k) = min(pacrh*rslope3(k,4)*rslopeb(k,4)*ncr(k,i,2) & + *min(max(0.0,qrs(k,i,4)/qci(k,i,1)),1.)**2 & + *denfac(k,i),ncr(k,i,2)*rdtcld) + endif + enddo + endif +! + if(lqr) then + ktop = ktopqr + do k = kts, ktop +!------------------------------------------------------------------------------- +! pracs: accretion of snow by rain [hl a11] +! (tg) + if(qrs(k,i,2)>qrmin .and. qrs(k,i,1)>qrmin) then + if(ifice(k)) then + acrfac = 5.*rslope3(k,2)*rslope3(k,2) & + + 4.*rslope3(k,2)*rslope2(k,2)*rslope(k,1) & + + 1.5*rslope2(k,2)*rslope2(k,2)*rslope2(k,1) + pracs(k) = pisq*ncr(k,i,3)*n0s*n0sfac(k)*abs(vtr(k)-vtmean(k)) & + *(dens/den(k,i))*acrfac +! reduce collection efficiency (suggested by B. Wilt) + pracs(k) = pracs(k)*min(max(0.0,qrs(k,i,1)/qrs(k,i,2)),1.)**2 + pracs(k) = min(pracs(k),qrs(k,i,2)*rdtcld) + endif +!------------------------------------------------------------------------------- +! psacr: accretion of rain by snow [hl a10] [lfo 28] +! (tqs or qr->qg) (t>=t0: enhanced melting of snow) + acrfac = 30.*rslope3(k,1)*rslope2(k,1)*rslope(k,2) & + +10.*rslope2(k,1)*rslope2(k,1)*rslope2(k,2) & + + 2.*rslope3(k,1)*rslope3(k,2 ) + psacr(k) = pisq*ncr(k,i,3)*n0s*n0sfac(k)*abs(vtmean(k)-vtr(k)) & + *(denr/den(k,i))*acrfac +! reduce collection efficiency (suggested by B. Wilt) + psacr(k) = psacr(k)*min(max(0.0,qrs(k,i,2)/qrs(k,i,1)),1.)**2 + psacr(k) = min(psacr(k),qrs(k,i,1)*rdtcld) + endif +!------------------------------------------------------------------------------- +! nsacr: accretion of rain by snow [lh a23] +! (t) + if(qrs(k,i,2)>qrmin .and. qrs(k,i,1)>qrmin .and. ncr(k,i,3)>nrmin) then + acrfac = 1.5*rslope2(k,1)*rslope(k,2) & + + 1.0*rslope(k,1)*rslope2(k,2) + .5*rslope3(k,2) + nsacr(k) = pi*ncr(k,i,3)*n0s*n0sfac(k)*abs(vtmean(k)-vtr(k)) & + *acrfac +! reduce collection efficiency (suggested by B. Wilt) + nsacr(k) = nsacr(k)*min(max(0.0,qrs(k,i,2)/qrs(k,i,1)),1.)**2 + nsacr(k) = min(nsacr(k),ncr(k,i,3)*rdtcld) + endif +!------------------------------------------------------------------------------- +! pracg: Accretion of graupel by rain [bht a17] +! (tqh) + if(qrs(k,i,3)>qrmin .and. qrs(k,i,1)>qrmin) then + if(ifice(k)) then + acrfac = 5.*rslope3(k,3)*rslope3(k,3) & + +4.*rslope3(k,3)*rslope2(k,3)*rslope(k,1) & + +1.5*rslope2(k,3)*rslope2(k,3)*rslope2(k,1) + pracg(k) = pisq*ncr(k,i,3)*n0g*abs(vtr(k)-vtmean(k)) & + *(deng/den(k,i))*acrfac + pracg(k) = pracg(k)*min(max(0.0,qrs(k,i,1)/qrs(k,i,3)),1.)**2 + pracg(k) = min(pracg(k),qrs(k,i,3)*rdtcld) + endif + endif +!------------------------------------------------------------------------------- +! pgacr: accretion of rain by graupel [hl a12] +! (tg) (t>=t0: enhanced melting of graupel) + if(qrs(k,i,3)>qrmin .and. qrs(k,i,1)>qrmin) then +!------------------------------------------------------------------------------- +! pgacr: accretion of rain by graupel [HL A12] [LFO 42] +! (tqg) (t>=t0: enhanced melting of graupel) + acrfac = 30.*rslope3(k,1)*rslope2(k,1)*rslope(k,3) & + + 10.*rslope2(k,1)*rslope2(k,1)*rslope2(k,3) & + + 2.*rslope3(k,1)*rslope3(k,3) + pgacr(k) = pisq*ncr(k,i,3)*n0g*abs(vtmean(k)-vtr(k))*(denr/den(k,i)) & + *acrfac +! reduce collection efficiency (suggested by B. Wilt) + pgacr(k) = pgacr(k)*min(max(0.0,qrs(k,i,3)/qrs(k,i,1)),1.)**2 + pgacr(k) = min(pgacr(k),qrs(k,i,1)*rdtcld) + endif +!------------------------------------------------------------------------------- +! ngacr: accretion of rain by graupel [lh a24] +! (t) + if(qrs(k,i,3)>qrmin .and. qrs(k,i,1)>qrmin .and. ncr(k,i,3)>nrmin) then + acrfac = 1.5*rslope2(k,1)*rslope(k,3) & + +1.0*rslope(k,1)*rslope2(k,3) + .5*rslope3(k,3) + ngacr(k) = pi*ncr(k,i,3)*n0g*abs(vtmean(k)-vtr(k))*acrfac + ngacr(k) = ngacr(k)*min(max(0.0,qrs(k,i,3)/qrs(k,i,1)),1.)**2 + ngacr(k) = min(ngacr(k),ncr(k,i,3)*rdtcld) + endif + enddo + endif +! + if(lqh) then + ktop = ktopqh + do k = kts, ktop +!------------------------------------------------------------------------------- +! phacr: Accretion of rain by hail [bht a13] +! (tqh) (t>=t0: enhance melting of hail) + if(qrs(k,i,4)>qrmin.and.qrs(k,i,1)>qrmin) then + acrfac = 30.*rslope3(k,1)*rslope2(k,1)*rslope(k,4) & + +10.*rslope3(k,1)*rslope(k,1)*rslope2(k,4) & + + 2.*rslope3(k,1)*rslope3(k,4) + phacr(k) = pisq*ncr(k,i,3)*n0h*abs(vtmean(k)-vtr(k))*(denr/den(k,i)) & + *acrfac + phacr(k) = phacr(k)*min(max(0.0,qrs(k,i,4)/qrs(k,i,1)),1.)**2 + phacr(k) = min(phacr(k),qrs(k,i,1)*rdtcld) + endif +!------------------------------------------------------------------------------- +! nhacr: accretion of rain by hail +! (t) + if(qrs(k,i,4)>qrmin .and. qrs(k,i,1)>qrmin .and. ncr(k,i,3)>nrmin) then + acrfac = 1.5*rslope2(k,1)*rslope(k,4) & + + 1.0*rslope(k,1)*rslope2(k,4) + .5*rslope3(k,4) + nhacr(k) = pi*ncr(k,i,3)*n0h*abs(vtmean(k)-vtr(k))*acrfac + nhacr(k) = nhacr(k)*min(max(0.0,qrs(k,i,4)/qrs(k,i,1)),1.)**2 + nhacr(k) = min(nhacr(k),ncr(k,i,3)/dtcld) + endif +!------------------------------------------------------------------------------- +! phacs: accretion of snow by hail [bht a14] +! (tqh) + if(qrs(k,i,4)>qrmin.and.qrs(k,i,2)>qrmin) then + acrfac = 5.*rslope3(k,2)*rslope3(k,2)*rslope(k,4) & + +2.*rslope3(k,2)*rslope2(k,2)*rslope2(k,4) & + +.5*rslope2(k,2)*rslope2(k,2)*rslope3(k,4) + phacs(k) = pisq*eachs*n0s*n0sfac(k)*n0h*abs(vtmean(k)-vtmean(k)) & + *(dens/den(k,i))*acrfac + phacs(k) = min(phacs(k),qrs(k,i,2)*rdtcld) + endif +!------------------------------------------------------------------------------- +! phacg: accretion of snow by hail [bht a15] +! (tqh) + if(qrs(k,i,4)>qrmin.and.qrs(k,i,3)>qrmin) then + acrfac = 5.*rslope3(k,3)*rslope3(k,3)*rslope(k,4) & + +2.*rslope3(k,3)*rslope2(k,3)*rslope2(k,4) & + +.5*rslope2(k,3)*rslope2(k,3)*rslope3(k,4) + phacg(k) = pisq*eachg*n0g*n0h*abs(vtmean(k)-vtmean(k)) & + *(deng/den(k,i))*acrfac + phacg(k) = min(phacg(k),qrs(k,i,3)*rdtcld) + endif +!------------------------------------------------------------------------------- +! pgwet: wet growth of graupel [lfo 43] +! + if(qrs(k,i,4)>qrmin.or.qrs(k,i,3)>qrmin) then + rs0 = fsvp(t0c,p(k,i)) + rs0 = ep2*rs0/(p(k,i)-rs0) + rs0 = max(rs0,qmin) + ghw1 = den(k,i)*xlv(k,i)*diffus(k)*(rs0-q(k,i)) - viscod(k)*(tcelci(k)) + ghw2 = den(k,i)*(xlf0+cliq*(tcelci(k))) + ghw3 = venfac(k) + ghw4 = den(k,i)*(xlf0-cliq*(-tcelci(k))+cice*(-tcelci(k))) + endif + if(qrs(k,i,3)>qrmin) then + if(pgaci(k)>0.0) then + egi = exp(0.09*(tcelci(k))) + pgaci_w(k) = pgaci(k)/egi + else + pgaci_w(k) = 0.0 + endif + pgwet(k) = ghw1/ghw2*(precg1*rslope2(k,3) & + +precg3*ghw3*exp(log(rslope(k,4))*2.75) & + +ghw4*(pgaci_w(k)+pgacs(k))) + pgwet(k) = max(pgwet(k), 0.0) + if(pgacw(k)+pgacr(k)<0.95*pgwet(k)) then + pgaci(k) = 0.0 + pgacs(k) = 0.0 + endif + endif +!------------------------------------------------------------------------------- +! phwet: wet growth of hail [lfo 43] +! + if(qrs(k,i,4)>qrmin) then + if(phaci(k)>0.0) then + ehi = exp(0.09*(tcelci(k))) + phaci_w(k) = phaci(k)/ehi + else + phaci_w(k) = 0.0 + endif + phwet(k) = ghw1/ghw2*(prech1*rslope2(k,4) & + +prech3*ghw3*exp(log(rslope(k,4))*2.75) & + +ghw4*(phaci_w(k)+phacs(k))) + phwet(k) = max(phwet(k), 0.0) + if(phacw(k)+phacr(k)<0.95*phwet(k)) then + phaci(k) = 0.0 + phacs(k) = 0.0 + phacg(k) = 0.0 + endif + endif + enddo + endif +!------------------------------------------------------------------------------- +! pseml: enhanced melting of snow by accretion of water [hl a34] +! (t>=t0: s->r) + if(lqs) then + ktop = ktopqs + do k = ktop, kts, -1 + if(.not.ifice(k) .and. qrs(k,i,2)>0.) then + pseml(k) = min(max(-cliq*tcelci(k)*(paacw(k)+psacr(k))/xlf0, & + -qrs(k,i,2)*rdtcld),0.) +!------------------------------------------------------------------------------- +! nseml: enhanced melting of snow by accretion of water [lh a29] +! (t>=t0: ->nr) + if (qrs(k,i,2)>qrmin) then + sfac = rslope(k,2)*n0s*n0sfac(k)/qrs(k,i,2) + nseml(k) = -sfac*pseml(k) + endif + endif + enddo + endif +!------------------------------------------------------------------------------- +! pgeml: enhanced melting of graupel by accretion of water [hl a24] +! (t>=t0: g->r) + if(lqg) then + ktop = ktopqg + do k = ktop, kts, -1 + if(.not.ifice(k) .and. qrs(k,i,3)>0.) then + pgeml(k) = min(max(-cliq*tcelci(k)*(paacw(k)+pgacr(k))/xlf0, & + -qrs(k,i,3)*rdtcld),0.) +!------------------------------------------------------------------------------- +! ngeml: enhanced melting of graupel by accretion of water [lh a30] +! (t>=t0: -> nr) + if (qrs(k,i,3)>qrmin) then + gfac = rslope(k,3)*n0g/qrs(k,i,3) + ngeml(k) = -gfac*pgeml(k) + endif + endif + enddo + endif +!------------------------------------------------------------------------------- +! pheml: enhanced melting of hail by accretion of water [bht a23] +! (t>=t0: h->r) + if(lqh) then + ktop = ktopqh + do k = ktop, kts, -1 + if(.not.ifice(k) .and. qrs(k,i,4)>0.) then + pheml(k) = min(max(-cliq*tcelci(k)*(phacw(k)+phacr(k))/xlf0, & + -qrs(k,i,4)*rdtcld),0.) +!------------------------------------------------------------------------------- +! nheml: enhanced melting of graupel by accretion of water [lh a30] +! (t>=t0: -> nr) + if (qrs(k,i,4)>qrmin) then + gfac = rslope(k,4)*n0h/qrs(k,i,4) + nheml(k) = -gfac*pheml(k) + endif + endif + enddo + endif +! ------------------------------------------------------------------------------- +! pidep: deposition/sublimation rate of ice [hdc 9] +! (ti or i->v) + if(lqi) then + ktop = ktopqi + do k = ktop, kts, -1 + if(ifice(k)) then + if(qci(k,i,2)>0 .and. (.not.ifsat(k))) then + pidep(k) = 4.*di(k)*ni(k)*(rh_ice(k)-1.)/ab_ice(k) + supice(k) = satrdt(k) - prevp(k) + if(pidep(k)<0.) then + pidep(k) = max(max(pidep(k),satrdt(k)*.5),supice(k)) + pidep(k) = max(pidep(k),-qci(k,i,2)*rdtcld) + else + pidep(k) = min(min(pidep(k),satrdt(k)*.5),supice(k)) + endif + if(abs(prevp(k)+pidep(k))>=abs(satrdt(k))) ifsat(k) = .true. + endif + endif + enddo + endif +!------------------------------------------------------------------------------- +! psdep: deposition/sublimation rate of snow [hdc 14] +! (v->s or s->v) + if(lqs) then + ktop = ktopqs + do k = ktop, kts, -1 + if(ifice(k)) then + if(qrs(k,i,2)>0. .and. (.not.ifsat(k))) then + coeres = rslope2(k,2)*sqrt(rslope(k,2)*rslopeb(k,2)) + psdep(k) = (rh_ice(k)-1.)*n0sfac(k)*(precs1*rslope2(k,2) & + + precs2*venfac(k)*coeres)/ab_ice(k) + supice(k) = satrdt(k)-prevp(k)-pidep(k) + if(psdep(k)<0.) then + psdep(k) = max(psdep(k),-qrs(k,i,2)*rdtcld) + psdep(k) = max(max(psdep(k),satrdt(k)*.5),supice(k)) + else + psdep(k) = min(min(psdep(k),satrdt(k)*.5),supice(k)) + endif + if(abs(prevp(k)+pidep(k)+psdep(k))>=abs(satrdt(k))) & + ifsat(k) = .true. + endif + endif + enddo + endif +!------------------------------------------------------------------------------- +! pgdep: deposition/sublimation rate of graupel [hl a21] +! (tg or g->v) + if(lqg) then + ktop = ktopqg + do k = ktop, kts, -1 + if(ifice(k)) then + if(qrs(k,i,3)>0. .and. (.not.ifsat(k))) then + coeres = rslope2(k,3)*sqrt(rslope(k,3)*rslopeb(k,3)) + pgdep(k) = (rh_ice(k)-1.)*(precg1*rslope2(k,3) & + + precg2*venfac(k)*coeres)/ab_ice(k) + supice(k) = satrdt(k)-prevp(k)-pidep(k)-psdep(k) + if(pgdep(k)<0.) then + pgdep(k) = max(pgdep(k),-qrs(k,i,3)*rdtcld) + pgdep(k) = max(max(pgdep(k),satrdt(k)*.5),supice(k)) + else + pgdep(k) = min(min(pgdep(k),satrdt(k)*.5),supice(k)) + endif + if(abs(prevp(k)+pidep(k)+psdep(k)+pgdep(k))>=abs(satrdt(k))) & + ifsat(k) = .true. + endif + endif + enddo + endif +!------------------------------------------------------------------------------- +! phdep: deposition/sublimation rate of hail [bht a19] +! (th or h->v) + if(lqh) then + ktop = ktopqh + do k = ktop, kts, -1 + if(ifice(k)) then + if(qrs(k,i,4)>0. .and. (.not.ifsat(k))) then + coeres = rslope2(k,4)*sqrt(rslope(k,4)*rslopeb(k,4)) + phdep(k) = (rh_ice(k)-1.)*(prech1*rslope2(k,4) & + + prech2*venfac(k)*coeres)/ab_ice(k) + supice(k) = satrdt(k)-prevp(k)-pidep(k)-psdep(k)-pgdep(k) + if(phdep(k)<0.) then + phdep(k) = max(phdep(k),-qrs(k,i,4)*rdtcld) + phdep(k) = max(max(phdep(k),satrdt(k)*.5),supice(k)) + else + phdep(k) = min(min(phdep(k),satrdt(k)*.5),supice(k)) + endif + if(abs(prevp(k)+pidep(k)+psdep(k)+pgdep(k)+phdep(k)) & + >=abs(satrdt(k))) ifsat(k) = .true. + endif + endif + enddo + endif +!------------------------------------------------------------------------------- +! pigen: generation(nucleation) of ice from vapor [hl a50] [hdc 7-8] +! (ti) + ktop = ktoprh + do k = ktop, kts, -1 + if(ifice(k)) then + if(supsat(k)>0 .and. (.not.ifsat(k))) then + supice(k) = satrdt(k)-prevp(k)-pidep(k)-psdep(k)-pgdep(k) + if(slimsk(i)==0) then + ni0(k) = 1000.*exp(-0.2*tcelci(k)-5.) + else if(slimsk(i)==1) then + ni0(k) = 1000.*exp(-0.15*tcelci(k)-2.5) + else if(slimsk(i)==2) then + ni0(k) = 1000.*exp(-0.35*tcelci(k)-10.) + endif + ni0(k) = min(ni0(k),ni0max) + roqi0 = 4.92e-11*exp(log(ni0(k))*(1.33)) + pigen(k) = max(0.,(roqi0/den(k,i)-max(qci(k,i,2),0.))*rdtcld) + pigen(k) = min(min(pigen(k),satrdt(k)),supice(k)) + endif + endif + enddo +!------------------------------------------------------------------------------- +! psaut: conversion(aggregation) of ice to snow [hdc 12] +! (ts) + if(lqi) then + ktop = ktopqi + do k = ktop, kts, -1 + if(ifice(k)) then + if(qci(k,i,2)>0.) then + qimax = roqimax/den(k,i) + psaut(k) = max(0.,(qci(k,i,2)-qimax)*rdtcld) + endif + endif + enddo + endif +!------------------------------------------------------------------------------- +! pgaut: conversion(aggregation) of snow to graupel [hl a4] +! (tg) + if(lqs) then + ktop = ktopqs + do k = ktop, kts, -1 + if(ifice(k)) then + if(qrs(k,i,2)>0.) then + alpha2 = 1.e-3*exp(0.09*(tcelci(k))) + pgaut(k) = min(max(0.,alpha2*(qrs(k,i,2)-qs0)),qrs(k,i,2)*rdtcld) + endif + endif + enddo + endif +!------------------------------------------------------------------------------- +! phaut: conversion(aggregation) of graupel to hail [bht a18] +! (th) + if(lqh) then + ktop = ktopqh + do k = ktop, kts, -1 + if(ifice(k)) then + if(qrs(k,i,3)>0.) then + alpha2 = 1.e-3*exp(0.09*(tcelci(k))) + phaut(k) = min(max(0.,alpha2*(qrs(k,i,3)-qs0)),qrs(k,i,3)*rdtcld) + endif + endif + enddo + endif +!------------------------------------------------------------------------------- +! psevp: evaporation of melting snow [hl a35] +! (t>t0: s->v) + if(lqs) then + ktop = ktopqs + do k = ktop, kts, -1 + if(.not.ifice(k)) then + if(qrs(k,i,2)>0. .and. rh_mul(k)<1.) then + coeres = rslope2(k,2)*sqrt(rslope(k,2)*rslopeb(k,2)) + psevp(k) = (rh_mul(k)-1.)*n0sfac(k)*(precs1*rslope2(k,2) & + + precs2*venfac(k)*coeres)/ab_mul(k) + psevp(k) = min(max(psevp(k),-qrs(k,i,2)*rdtcld),0.) + endif + endif + enddo + endif +!------------------------------------------------------------------------------- +! pgevp: evaporation of melting graupel [hl a25] +! (t>=t0: g->v) + if(lqg) then + ktop = ktopqg + do k = ktop, kts, -1 + if(.not.ifice(k)) then + if(qrs(k,i,3)>0. .and. rh_mul(k)<1.) then + coeres = rslope2(k,3)*sqrt(rslope(k,3)*rslopeb(k,3)) + pgevp(k) = (rh_mul(k)-1.)*(precg1*rslope2(k,3) & + + precg2*venfac(k)*coeres)/ab_mul(k) + pgevp(k) = min(max(pgevp(k),-qrs(k,i,3)*rdtcld),0.) + endif + endif + enddo + endif +!------------------------------------------------------------------------------- +! phevp: evaporation of melting hail [bht a20] +! (t>=t0: h->v) + if(lqh) then + ktop = ktopqh + do k = ktop, kts, -1 + if(.not.ifice(k)) then + if(qrs(k,i,4)>0. .and. rh_mul(k)<1.) then + coeres = rslope2(k,4)*sqrt(rslope(k,4)*rslopeb(k,4)) + phevp(k) = (rh_mul(k)-1.)*(prech1*rslope2(k,4) & + + prech2*venfac(k)*coeres)/ab_mul(k) + phevp(k) = min(max(phevp(k),-qrs(k,i,4)*rdtcld),0.) + endif + endif + enddo + endif +!=============================================================================== +! +! check mass conservation of source/sink terms and feedback to the large scale +! +!=============================================================================== + ktop = ktopmax + do k = ktop, kts, -1 +! + delta2 = 0. + delta3 = 0. + if(qrs(k,i,1)<1.e-4 .and. qrs(k,i,2)<1.e-4) delta2 = 1. + if(qrs(k,i,1)<1.e-4) delta3 = 1. +! + if(ifice(k)) then +! +! cloud water +! + hvalue = max(qmin,qci(k,i,1)) + source = (praut(k)+pracw(k)+paacw(k)+paacw(k)+phacw(k))*dtcld + if (source>hvalue) then + factor = hvalue/source + praut(k) = praut(k) * factor + pracw(k) = pracw(k) * factor + paacw(k) = paacw(k) * factor + phacw(k) = phacw(k) * factor + endif +! +! cloud ice +! + hvalue = max(qmin,qci(k,i,2)) + source = (psaut(k)-pigen(k)-pidep(k)+praci(k)+psaci(k)+pgaci(k) & + + phaci(k))*dtcld + if (source>hvalue) then + factor = hvalue/source + psaut(k) = psaut(k) * factor + pigen(k) = pigen(k) * factor + pidep(k) = pidep(k) * factor + praci(k) = praci(k) * factor + psaci(k) = psaci(k) * factor + pgaci(k) = pgaci(k) * factor + phaci(k) = phaci(k) * factor + endif +! +! rain +! + hvalue = max(qmin,qrs(k,i,1)) + source = (-praut(k)-prevp(k)-pracw(k)+piacr(k)+psacr(k)+pgacr(k) & + + phacr(k))*dtcld + if (source>hvalue) then + factor = hvalue/source + praut(k) = praut(k) * factor + prevp(k) = prevp(k) * factor + pracw(k) = pracw(k) * factor + piacr(k) = piacr(k) * factor + psacr(k) = psacr(k) * factor + pgacr(k) = pgacr(k) * factor + phacr(k) = phacr(k) * factor + endif +! +! snow +! + hvalue = max(qmin,qrs(k,i,2)) + source = - (psdep(k)+psaut(k)-pgaut(k)+paacw(k)+piacr(k)*delta3 & + + pvapg(k)+pvaph(k) & + + praci(k)*delta3 - pracs(k)*(1.-delta2) & + + psacr(k)*delta2 + psaci(k)-pgacs(k)-phacs(k))*dtcld + if (source>hvalue) then + factor = hvalue/source + psdep(k) = psdep(k) * factor + psaut(k) = psaut(k) * factor + pgaut(k) = pgaut(k) * factor + paacw(k) = paacw(k) * factor + piacr(k) = piacr(k) * factor + praci(k) = praci(k) * factor + psaci(k) = psaci(k) * factor + pracs(k) = praCs(k) * factor + psacr(k) = psacr(k) * factor + pgacs(k) = pgacs(k) * factor + pvapg(k) = pvapg(k) * factor + pvaph(k) = pvaph(k) * factor + phacs(k) = phacs(k) * factor + endif +! +! graupel +! + hvalue = max(qmin,qrs(k,i,3)) + source = - (pgdep(k)+pgaut(k) & + + piacr(k)*(1.-delta3) + praci(k)*(1.-delta3) & + + psacr(k)*(1.-delta2) + pracs(k)*(1.-delta2) & + + pgaci(k)+paacw(k)+pgacr(k)*delta2+pgacs(k) & + - pracg(k)*(1.-delta2)-phacg(k)-phaut(k) & + - pvapg(k)+primh(k))*dtcld + if (source>hvalue) then + factor = hvalue/source + pgdep(k) = pgdep(k) * factor + pgaut(k) = pgaut(k) * factor + piacr(k) = piacr(k) * factor + praci(k) = praci(k) * factor + psacr(k) = psacr(k) * factor + pracs(k) = pracs(k) * factor + paacw(k) = paacw(k) * factor + pgaci(k) = pgaci(k) * factor + pgacr(k) = pgacr(k) * factor + pgacs(k) = pgacs(k) * factor + phaut(k) = phaut(k) * factor + pracg(k) = pracg(k) * factor + phacg(k) = phacg(k) * factor + pvapg(k) = pvapg(k) * factor + primh(k) = primh(k) * factor + endif +! +! hail +! + hvalue = max(qmin,qrs(k,i,4)) + source = -(phdep(k)+phaut(k) & + +pgacr(k)*(1.-delta2)+pracg(k)*(1.-delta2) & + +phacw(k)+phacr(k)+phaci(k)+phacs(k) & + +phacg(k)-pvaph(k)-primh(k))*dtcld + if (source>hvalue) then + factor = hvalue/source + phdep(k) = phdep(k) * factor + phaut(k) = phaut(k) * factor + pracg(k) = pracg(k) * factor + pgacr(k) = pgacr(k) * factor + phacw(k) = phacw(k) * factor + phaci(k) = phaci(k) * factor + phacr(k) = phacr(k) * factor + phacs(k) = phacs(k) * factor + phacg(k) = phacg(k) * factor + pvaph(k) = pvaph(k) * factor + primh(k) = primh(k) * factor + endif +! +! cloud +! + hvalue = max(qmin,ncr(k,i,2)) + source = (nraut(k)+nccol(k)+nracw(k)+naacw(k)+naacw(k) & + +nhacw(k))*dtcld + if (source>hvalue) then + factor = hvalue/source + nraut(k) = nraut(k) * factor + nccol(k) = nccol(k) * factor + nracw(k) = nracw(k) * factor + naacw(k) = naacw(k) * factor + nhacw(k) = nhacw(k) * factor + endif +! +! rain +! + hvalue = max(qmin,ncr(k,i,3)) + source = (-nraut(k)+nrcol(k)+niacr(k)+nsacr(k)+ngacr(k) & + +nhacr(k))*dtcld + if (source>hvalue) then + factor = hvalue/source + nraut(k) = nraut(k) * factor + nrcol(k) = nrcol(k) * factor + niacr(k) = niacr(k) * factor + nsacr(k) = nsacr(k) * factor + ngacr(k) = ngacr(k) * factor + nhacr(k) = nhacr(k) * factor + endif +! +! update +! + htotal = -(prevp(k)+psdep(k)+pgdep(k)+pigen(k)+pidep(k)+phdep(k)) + q(k,i) = q(k,i)+htotal*dtcld + qci(k,i,1) = max(qci(k,i,1) - (praut(k)+pracw(k) & + +paacw(k)+paacw(k)+phacw(k))*dtcld,0.) + qrs(k,i,1) = max(qrs(k,i,1) + (praut(k)+pracw(k) & + +prevp(k)-piacr(k)-pgacr(k)-psacr(k)-phacr(k))*dtcld,0.) + qci(k,i,2) = max(qci(k,i,2) - (psaut(k)+praci(k) & + +phaci(k) & + +psaci(k)+pgaci(k)-pigen(k)-pidep(k))*dtcld,0.) + qrs(k,i,2) = max(qrs(k,i,2) + (psdep(k)+psaut(k)+paacw(k) & + -pgaut(k)+piacr(k)*delta3 + praci(k)*delta3 & + +pvapg(k)+pvaph(k)-phacs(k) & + +psaci(k)-pgacs(k)-pracs(k)*(1.-delta2) + psacr(k)*delta2) & + *dtcld,0.) + qrs(k,i,3) = max(qrs(k,i,3) + (pgdep(k)+pgaut(k)+piacr(k)*(1.-delta3) & + +praci(k)*(1.-delta3) + psacr(k)*(1.-delta2) & + +pracs(k)*(1.-delta2) + pgaci(k)+paacw(k) & + +pgacr(k)*delta2+pgacs(k)+primh(k) & + -pracg(k)*(1.-delta2)-phacg(k)-phaut(k) & + -pvapg(k))*dtcld,0.) + qrs(k,i,4) = max(qrs(k,i,4)+(phdep(k)+phaut(k) & + +pgacr(k)*(1.-delta2)+pracg(k)*(1.-delta2) & + +phacw(k)+phacr(k)+phaci(k)+phacs(k) & + +phacg(k)-pvaph(k)-primh(k)) & + *dtcld,0.) + ncr(k,i,2) = max(ncr(k,i,2) + (-nraut(k)-nccol(k)-nracw(k) & + -naacw(k)-naacw(k)-nhacw(k))*dtcld,0.) + ncr(k,i,3) = max(ncr(k,i,3) + (nraut(k)-nrcol(k)-niacr(k) & + -nsacr(k)-ngacr(k)-nhacr(k))*dtcld,0.) + hvalue = - xls*(psdep(k)+pgdep(k)+phdep(k)+pidep(k)+pigen(k)) & + - xlv(k,i)*prevp(k) - xlf(k,i)*(piacr(k)+paacw(k)+phacw(k) & + + paacw(k)+pgacr(k)+psacr(k)+phacr(k)) + t(k,i) = t(k,i) - hvalue/cpm(k,i)*dtcld +! + else +! +! cloud water +! + hvalue = max(qmin,qci(k,i,1)) + source=(praut(k)+pracw(k)+paacw(k)+paacw(k)-phacw(k))*dtcld + if (source>hvalue) then + factor = hvalue/source + praut(k) = praut(k) * factor + pracw(k) = pracw(k) * factor + paacw(k) = paacw(k) * factor + phacw(k) = phacw(k) * factor + endif +! +! rain +! + hvalue = max(qmin,qrs(k,i,1)) + source = (-prevp(k)-praut(k)+pseml(k)+pgeml(k)+pheml(k) & + -pracw(k)-paacw(k)-paacw(k)-phacw(k))*dtcld + if (source>hvalue) then + factor = hvalue/source + praut(k) = praut(k) * factor + prevp(k) = prevp(k) * factor + pracw(k) = pracw(k) * factor + paacw(k) = paacw(k) * factor + pseml(k) = pseml(k) * factor + pgeml(k) = pgeml(k) * factor + phacw(k) = phacw(k) * factor + pheml(k) = pheml(k) * factor + endif +! +! snow +! + hvalue = max(qmin,qrs(k,i,2)) + source=(pgacs(k)+phacs(k)-pseml(k)-psevp(k))*dtcld + if (source>hvalue) then + factor = hvalue/source + pgacs(k) = pgacs(k) * factor + pseml(k) = pseml(k) * factor + psevp(k) = psevp(k) * factor + phacs(k) = phacs(k) * factor + endif +! +! graupel +! + hvalue = max(qmin,qrs(k,i,3)) + source=-(pgacs(k)+pgevp(k)+pgeml(k)-phacg(k))*dtcld + if (source>hvalue) then + factor = hvalue/source + pgacs(k) = pgacs(k) * factor + pgevp(k) = pgevp(k) * factor + pgeml(k) = pgeml(k) * factor + phacg(k) = phacg(k) * factor + endif +! +! hail +! + hvalue = max(qrmin,qrs(k,i,4)) + source=-(phacs(k)+phacg(k)+phevp(k)+pheml(k))*dtcld + if (source>hvalue) then + factor = hvalue/source + phacs(k) = phacs(k)*factor + phacg(k) = phacg(k)*factor + phevp(k) = phevp(k)*factor + pheml(k) = pheml(k)*factor + endif +! +! cloud +! + hvalue = max(qmin,ncr(k,i,2)) + source = (+nraut(k)+nccol(k)+nracw(k)+naacw(k)+naacw(k)+nhacw(k))*dtcld + if (source>hvalue) then + factor = hvalue/source + nraut(k) = nraut(k) * factor + nccol(k) = nccol(k) * factor + nracw(k) = nracw(k) * factor + naacw(k) = naacw(k) * factor + nhacw(k) = nhacw(k) * factor + endif +! +! rain +! + hvalue = max(qmin,ncr(k,i,3)) + source = (-nraut(k)+nrcol(k)-nseml(k)-ngeml(k)-nheml(k))*dtcld + if (source>hvalue) then + factor = hvalue/source + nraut(k) = nraut(k) * factor + nrcol(k) = nrcol(k) * factor + nseml(k) = nseml(k) * factor + ngeml(k) = ngeml(k) * factor + nheml(k) = nheml(k) * factor + endif +! +! update +! + htotal = -(prevp(k)+psevp(k)+pgevp(k)+phevp(k)) + q(k,i) = q(k,i) + htotal*dtcld + qci(k,i,1) = max(qci(k,i,1) - (praut(k)+pracw(k) & + +paacw(k)+paacw(k)+phacw(k))*dtcld,0.) + qrs(k,i,1) = max(qrs(k,i,1) + (praut(k)+pracw(k) & + +prevp(k)+paacw(k)+paacw(k)+phacw(k) & + -pseml(k)-pgeml(k)-pheml(k))*dtcld,0.) + qrs(k,i,2) = max(qrs(k,i,2) + (psevp(k)-pgacs(k)-phacs(k) & + +pseml(k))*dtcld,0.) + qrs(k,i,3) = max(qrs(k,i,3) + (pgacs(k)+pgevp(k) & + +pgeml(k)-phacg(k))*dtcld,0.) + qrs(k,i,4) = max(qrs(k,i,4)+(phacs(k)+phacg(k)+phevp(k) & + +pheml(k))*dtcld,0.) + ncr(k,i,2) = min(max(ncr(k,i,2) + (-nraut(k)-nccol(k)-nracw(k) & + -naacw(k)-naacw(k)-nhacw(k))*dtcld,0.),ncmax) + ncr(k,i,3) = min(max(ncr(k,i,3) + (nraut(k)-nrcol(k)+nseml(k) & + +ngeml(k)+nheml(k))*dtcld,0.),nrmax) + hvalue = -xlv(k,i)*(prevp(k)+psevp(k)+pgevp(k)+phevp(k)) & + -xlf(k,i)*(pseml(k)+pgeml(k)+pheml(k)) + t(k,i) = t(k,i) - hvalue/cpm(k,i)*dtcld + endif + enddo +!=============================================================================== +! +! ccn activaiton and condensation/evaporation of clouds +! +!=============================================================================== + call find_cloud_top(1,kdim,ktopini,qrs(:,i,1),zero_0,ktopqr) + if(ktopqr>0.0) lqr = .true. + if(lqr) then + ktop = ktopqr + call slope_rain(1,kdim,ktop,qrs(:,i,1),den(:,i),denfac(:,i),t(:,i), & + ncr(:,i,3), & + rslope(:,1),rslopeb(:,1),rslope2(:,1),rslope3(:,1),vtr(:)) + do k = ktop, kts, -1 + if(qrs(k,i,1)>0.) then + dr(k) = rslope(k,1)*drcoeff +!------------------------------------------------------------------------------- +! nrtoc: conversion from rain to cloud [lh a14] +! (nr->nc) + if(dr(k)<=di50) then + ncr(k,i,2) = min(ncr(k,i,2) + ncr(k,i,3), ncmax) + ncr(k,i,3) = 0. +!------------------------------------------------------------------------------- +! prtoc: conversion from rain to cloud [lh a15] +! (qr->qc) + qci(k,i,1) = qci(k,i,1) + qrs(k,i,1) + qrs(k,i,1) = 0. + endif + endif + enddo + endif +!------------------------------------------------------------------------------- +! pcact: qv -> qc [lh 8] [kk 14] +! ncact: nccn -> nc [lh a2] [kk 12] +! + ktop = ktopini + do k = ktop, kts, -1 + qsat_mul(k) = fsvp_water(t(k,i),p(k,i)) + qsat_mul(k) = ep2 * qsat_mul(k) / (p(k,i) - qsat_mul(k)) + qsat_mul(k) = max(qsat_mul(k),qmin) + rh_mul(k) = max(q(k,i) / qsat_mul(k),qmin) + enddo +! + call find_cloud_top(1,kdim,ktopini,rh_mul(:), one_1,ktoprh) +! + ktop = ktoprh + do k = ktop, kts, -1 + if(rh_mul(k)>1.) then + temp = ((rh_mul(k)-1.)/satmax) + temp = min(1.,exp(log(temp)*actk)) + ncact(k) = max(0.,((ncr(k,i,1)+ncr(k,i,2))*temp - ncr(k,i,2)))*rdtcld + ncact(k) =min(ncact(k),max(ncr(k,i,1),0.)*rdtcld) + pcact(k) = min(4.*pi*denr*exp(log(actr)*3)*ncact(k)/ & + (3.*den(k,i)),max(q(k,i),0.)*rdtcld) + q(k,i) = max(q(k,i) - pcact(k)*dtcld,0.) + qci(k,i,1) = max(qci(k,i,1) + pcact(k)*dtcld,0.) + ncr(k,i,1) = max(ncr(k,i,1) - ncact(k)*dtcld, ccnmin) + ncr(k,i,2) = max(ncr(k,i,2) + ncact(k)*dtcld, ncmin) + t(k,i) = t(k,i) + pcact(k)*xlv(k,i)/cpm(k,i)*dtcld + endif + enddo +!------------------------------------------------------------------------------- +! pcond: condensational/evaporational rate of cloud water [hl a46] +! (qv -> qc, qc->qv) + ktop = ktopini + do k = ktop, kts, -1 + qsat_mul(k) = fsvp_water(t(k,i),p(k,i)) + qsat_mul(k) = ep2 * qsat_mul(k) / (p(k,i) - qsat_mul(k)) + qsat_mul(k) = max(qsat_mul(k),qmin) + enddo + call find_cloud_top(1,kdim,ktopini,qci(:,i,1),zero_0,ktopqc) + call find_cloud_top(1,kdim,ktopini,rh_mul(:), one_1,ktoprh) + ktop = max(ktopqc,ktoprh) + do k = ktop, kts, -1 + hvalue = ((max(q(k,i),qmin)-(qsat_mul(k))) /(1.+(xlv(k,i))*(xlv(k,i)) & + /(rv*(cpm(k,i)))*(qsat_mul(k)) /((t(k,i))*(t(k,i))))) + pcond(k) = min(max(hvalue*rdtcld,0.),max(q(k,i),0.)*rdtcld) + if(qci(k,i,1)>0. .and. hvalue<0.) then + pcond(k) = max(hvalue,-qci(k,i,1))*rdtcld +!------------------------------------------------------------------------------- +! ncevp: evpration of cloud number concentration [lh A3] +! (nc->nccn) + if(pcond(k)==-qci(k,i,1)*rdtcld) then + ncr(k,i,1) = ncr(k,i,1) + ncr(k,i,2) + ncr(k,i,2) = 0. + endif + endif + q(k,i) = q(k,i) - pcond(k)*dtcld + qci(k,i,1) = max(qci(k,i,1)+pcond(k)*dtcld,0.) + t(k,i) = t(k,i) + pcond(k)*xlv(k,i)/cpm(k,i)*dtcld + enddo +!=============================================================================== +! +! sedimentation of hydrometeors +! +!=============================================================================== +! re-define cloud top for numerical efficiencies +! + lqc = .false. + lqi = .false. + lqr = .false. + lqs = .false. + lqg = .false. + lqh = .false. + flgcld = .false. + call find_cloud_top(1,kdim,ktopini,qci(:,i,1),zero_0,ktopqc) + call find_cloud_top(1,kdim,ktopini,qci(:,i,2),zero_0,ktopqi) + call find_cloud_top(1,kdim,ktopini,qrs(:,i,1),zero_0,ktopqr) + call find_cloud_top(1,kdim,ktopini,qrs(:,i,2),zero_0,ktopqs) + call find_cloud_top(1,kdim,ktopini,qrs(:,i,3),zero_0,ktopqg) + call find_cloud_top(1,kdim,ktopini,qrs(:,i,4),zero_0,ktopqh) + call find_cloud_top(1,kdim,ktopini,rh_ice(:), one_1,ktoprh) + if(ktopqc>0.0) lqc = .true. + if(ktopqi>0.0) lqi = .true. + if(ktopqr>0.0) lqr = .true. + if(ktopqs>0.0) lqs = .true. + if(ktopqg>0.0) lqg = .true. + if(ktopqh>0.0) lqh = .true. + ktopmax = max(ktopqc,ktopqi,ktopqr,ktopqs,ktopqg,ktopqh,ktoprh) +! +! fall out for rain +! + if(lqr) then + ktop = ktopqr + call adjust_number_concent(ktopqr,kdim,qrs(:,i,1),ncr(:,i,3),den(:,i), & + pidnr,drcoeff,qrmin,nrmin,nrmax,di1000,drmin,drmax) + call slope_rain(1,kdim,ktop,qrs(:,i,1),den(:,i),denfac(:,i),t(:,i), & + ncr(:,i,3), & + rslope(:,1),rslopeb(:,1),rslope2(:,1),rslope3(:,1),vtr(:)) + nstep = 1 + do k = ktop, kts, -1 + vtn(k) = pvtrn*rslopeb(k,1)*denfac(k,i) + hvalue = max(vtr(k),vtn(k)) + nstep = max(nstep,ceiling(dtcld/delz(k,i)*hvalue)) + enddo +! + if(ktop>2) then + do k = ktop-1, kts+1, -1 + temp = (2.*vtr(k)+vtr(k+1)+vtr(k-1))*0.25 + vtr(k) = temp + enddo + endif +! + do k = ktop, kts, -1 + if(qrs(k,i,1)>qrmin) then + diameter = drcoeff*rslope(k,1) + hvalue = fshape(diameter) + vtn(k) = vtr(k)/hvalue + else + vtn(k) = 0. + endif + enddo +! + niter = ceiling(nstep/sedi_semi_cfl) + dtcfl = dtcld/niter +! + do n = 1, niter + do k = ktop, kts, -1 + if(qrs(k,i,1)>qrmin) then + denqr(k) = dend(k,i)*qrs(k,i,1) + denqn(k) = dend(k,i)*ncr(k,i,3) + else + denqr(k) = 0.0 + denqn(k) = 0.0 + vtr(k) = 0.0 + vtn(k) = 0.0 + endif + enddo +! + call semi_lagrangian(1,kdim,max(ktop,2),dend(:,i),denfac(:,i),t(:,i), & + delz(:,i),vtr(:),denqr(:),qrpath,dtcfl,lat,i) + call semi_lagrangian(1,kdim,max(ktop,2),dend(:,i),denfac(:,i),t(:,i), & + delz(:,i),vtn(:),denqn(:),qnpath,dtcfl,lat,i) + do k = ktop, kts, -1 + if(denqr(k)>qrmin) then + qrs(k,i,1) = max(denqr(k)/dend(k,i),0.) + ncr(k,i,3) = max(denqn(k)/dend(k,i),0.) + else + qrs(k,i,1) = 0.0 + ncr(k,i,3) = 0.0 + endif + enddo +! + precip_r = qrpath/dtcld + precip_r ! [kgm-2s-1] +! + enddo + endif +!------------------------------------------------------------------------------- +! fall out for precipitating ice : mass-weighted combined sedimentation (dhl ) +! + if(lqs .or. lqg .or. lqh) then + ktop =ktopqs + call slope_snow(1,kdim,ktop,qrs(:,i,2),den(:,i),denfac(:,i),t(:,i), & + rslope(:,2),rslopeb(:,2),rslope2(:,2),rslope3(:,2),vts(:)) + ktop =ktopqg + call slope_graupel(1,kdim,ktop,qrs(:,i,3),den(:,i),denfac(:,i),t(:,i), & + rslope(:,3),rslopeb(:,3),rslope2(:,3),rslope3(:,3),vtg(:)) + ktop =ktopqh + call slope_hail(1,kdim,ktop,qrs(:,i,4),den(:,i),denfac(:,i),t(:,i), & + rslope(:,4),rslopeb(:,4),rslope2(:,4),rslope3(:,4),vth(:)) +! + ktop = max(ktopqs,ktopqg,ktopqh) + do k = ktop, kts, -1 + sumice(k) = max( (qrs(k,i,2) + qrs(k,i,3) + qrs(k,i,4)), qmin) + if(sumice(k)>qmin) then + vtmean(k) = (vts(k)*qrs(k,i,2) + vtg(k)*qrs(k,i,3) & + + vth(k)*qrs(k,i,4))/sumice(k) + else + vtmean(k) = 0. + endif + enddo + if(ktop>2) then + do k = ktop-1, kts+1, -1 + vtmean(k) = (2*vtmean(k)+vtmean(k+1)+vtmean(k-1))/4. + enddo + endif +! + nstep = max(1,ceiling(maxval(dtcld/delz(:,i)*vtmean(:)))) + niter = ceiling(nstep/sedi_semi_cfl) + dtcfl = dtcld/niter +! + do n = 1, niter +! + ktop =ktopqs + do k = ktop, kts, -1 + denqs(k) = dend(k,i)*qrs(k,i,2) + enddo + call semi_lagrangian(1,kdim,max(ktop,2),dend(:,i),denfac(:,i),t(:,i), & + delz(:,i),vtmean(:),denqs(:),qspath,dtcfl,lat,i) + do k = kts, ktop + qrs(k,i,2) = max(denqs(k)/dend(k,i),0.) + enddo + ktop =ktopqg + do k = ktop, kts, -1 + denqg(k) = dend(k,i)*qrs(k,i,3) + enddo + call semi_lagrangian(1,kdim,max(ktop,2),dend(:,i),denfac(:,i),t(:,i), & + delz(:,i),vtmean(:),denqg(:),qgpath,dtcfl,lat,i) + do k = kts, ktop + qrs(k,i,3) = max(denqg(k)/dend(k,i),0.) + enddo + ktop =ktopqh + do k = ktop, kts, -1 + denqh(k) = dend(k,i)*qrs(k,i,4) + enddo + call semi_lagrangian(1,kdim,max(ktop,2),dend(:,i),denfac(:,i),t(:,i), & + delz(:,i),vtmean(:),denqh(:),qhpath,dtcfl,lat,i) + do k = kts, ktop + qrs(k,i,4) = max(denqh(k)/dend(k,i),0.) + enddo +! + precip_s = qspath/dtcld + precip_s ! [kgm-2s-1] + precip_g = qgpath/dtcld + precip_g ! [kgm-2s-1] + precip_h = qhpath/dtcld + precip_h ! [kgm-2s-1] + enddo + endif +!------------------------------------------------------------------------------- +! fall out for cloud ice +! + if(lqi) then + ktop = ktopqi + do k = ktop, kts, -1 + temp = (den(k,i)*max(qci(k,i,2),qcmin)) + temp = exp(log(temp)*0.75) + ni(k) = min(max(5.38e7*temp,1.e3),1.e6) + if(qci(k,i,2)<=0.0) then + vti(k) = 0. + else + mi(k) = den(k,i)*qci(k,i,2)/ni(k) + di(k) = max(min(exp(log((mi(k)/cxmi))*(1./dxmi)),dimax), qmin) + vti(k) = avti*exp(log(di(k))*(bvti)) + hvalue = min(max((tcelci(k) - t2_sphere)/(t1_sphere-t2_sphere),0.),1.0) + dis(k) = max(min(exp(log((mi(k)/cxmis))*(1./dxmis)),dimax), qmin) + vtis(k)= avtis*exp(log(dis(k))*(bvtis)) + di(k) = di(k) * (1.-hvalue) + dis(k) * hvalue + vti(k) = vti(k) * (1.-hvalue) + vtis(k) * hvalue + endif + enddo + if(ktop>2) then + do k = ktop-1, kts+1, -1 + vti(k) = (2*vti(k)+vti(k+1)+vti(k-1))/4. + enddo + endif +! + nstep = max(1,ceiling(maxval(dtcld/delz(:,i)*vti(:)))) + niter = ceiling(nstep/sedi_semi_cfl) + dtcfl = dtcld/niter +! + do n = 1, niter + do k = ktop, kts, -1 + denqi(k) = dend(k,i)*qci(k,i,2) + enddo +! + call semi_lagrangian(1,kdim,max(ktop,2),dend(:,i),denfac(:,i),t(:,i), & + delz(:,i),vti(:),denqi(:),qipath,dtcfl,lat,i) + do k = kts, ktop + qci(k,i,2) = max(denqi(k)/dend(k,i),0.) + enddo +! + precip_i = qipath/dtcld + precip_i ! [kgm-2s-1] + enddo + endif +!=============================================================================== +! +! precip (den*qrsi*dz/dt) : [kgm-2s-1] ==> rain ( precip/denr*dt*1000 ) : [mm ] +! for wrf unit is mm, whereas it is m for ufs +! +!=============================================================================== + temp = 1000. + precip_sum = precip_r + precip_s + precip_i + precip_g + precip_h + precip_ice = precip_s + precip_i + precip_h +! + if(precip_sum>0.) then + hvalue = precip_sum/denr*dtcld*temp + rainncv(i) = hvalue + rainncv(i) + rain(i) = hvalue + rain(i) + endif +! + if(precip_ice>0.) then + hvalue = precip_ice/denr*dtcld*temp + tstepsnow = hvalue + tstepsnow + if ( present (snowncv) .and. present (snow)) then + snowncv(i) = hvalue + snowncv(i) + snow(i) = hvalue + snow(i) + endif + endif +! + if(precip_g>0.) then + hvalue = precip_g/denr*dtcld*temp + tstepgraupel = hvalue + tstepgraupel + if ( present (graupelncv) .and. present (graupel)) then + graupelncv(i) = hvalue + graupelncv(i) + graupel(i) = hvalue + graupel(i) + endif + endif +! + if(precip_h>0.) then + hvalue = precip_h/denr*dtcld*temp + tstephail = hvalue + tstephail + if ( present (hailncv) .and. present (hail)) then + hailncv(i) = hvalue + hailncv(i) + hail(i) = hvalue + hail(i) + endif + endif +! + if ( present (snow) ) then + if(precip_sum>0.) sr(i) = snowncv(i)/(rainncv(i) + qmin) + else + if(precip_sum>0.) sr(i) = tstepsnow/(rainncv(i) + qmin) + endif +!------------------------------------------------------------------------------- +! + enddo i_loop ! i-loops +! +!=============================================================================== +! + enddo inner_loop ! dtcldcr- loops +! +!=============================================================================== +! +!------------------------------------------------------------------------------- +! assign local to passing variables +! + ktop = kte + do k = kts, ktop + do i = its, ite + t1(i,k) = t(k,i) + q1(i,k) = q(k,i) + ncr1(i,k,1) = ncr(k,i,1) + ncr1(i,k,2) = ncr(k,i,2) + ncr1(i,k,3) = ncr(k,i,3) + enddo + enddo +! + do k = kts, ktop + do i = its, ite + qci1(i,k,1) = qci(k,i,1) + qrs1(i,k,1) = qrs(k,i,1) + qci1(i,k,2) = qci(k,i,2) + qrs1(i,k,2) = qrs(k,i,2) + qrs1(i,k,3) = qrs(k,i,3) + qrs1(i,k,4) = qrs(k,i,4) + enddo + enddo +! +! +end subroutine udm2d +!------------------------------------------------------------------------------- +! +! +!------------------------------------------------------------------------------- + subroutine slope_rain(idim, kdim, ktop, qrs, den, denfac, t, & + ncr, & + rslope, rslopeb, rslope2, rslope3, vt) +!------------------------------------------------------------------------------- + implicit none +! + integer :: idim, kdim, ktop + real, dimension( idim , kdim), & + intent(in ) :: & + qrs, & + ncr, & + den, & + denfac, & + t + real, dimension( idim, kdim), & + intent(inout ) :: & + rslope, & + rslopeb, & + rslope2, & + rslope3, & + vt + real :: lamda, lamdar1m, lamdar2m, x, y, z, hvalue + integer :: i, j, k +!------------------------------------------------------------------------------- +! size distributions: (x=mixing ratio, y=air density): + lamdar2m(x,y,z)= exp(log(((pidnr*z)/(x*y)))*((.33333333))) + lamdar1m(x,y)= exp(log(pidn0r/(x*y))*(0.25)) ! (pidn0r/(x*y))**.25 +! + do i = 1,idim + do k = 1,ktop + if(qrs(i,k)<=qrmin .or. ncr(i,k)<=nrmin ) then + rslope(i,k) = rslopermax + rslopeb(i,k) = rsloperbmax + rslope2(i,k) = rsloper2max + rslope3(i,k) = rsloper3max + else + lamda = min(max(lamdar2m(qrs(i,k),den(i,k),ncr(i,k)),lamdarmin), & + lamdarmax) + if(qrs(i,k)<=0.1e-3)then + hvalue = lamdar1m(qrs(i,k),den(i,k)) + lamda = max(lamda,hvalue) + endif + rslope(i,k) = 1./lamda + rslopeb(i,k) = exp(log(rslope(i,k))*(bvtr)) + rslope2(i,k) = rslope(i,k)*rslope(i,k) + rslope3(i,k) = rslope2(i,k)*rslope(i,k) + endif + vt(i,k) = pvtr*rslopeb(i,k)*denfac(i,k) + if(qrs(i,k)<=0.0) vt(i,k) = 0.0 + enddo + enddo +end subroutine slope_rain +!------------------------------------------------------------------------------- +! +! +!------------------------------------------------------------------------------- + subroutine slope_graupel(idim, kdim, ktop, qrs, den, denfac, t, rslope, & + rslopeb, rslope2, rslope3, vt) +!------------------------------------------------------------------------------- + implicit none +!------------------------------------------------------------------------------- +! + integer :: idim, kdim, ktop + real, dimension( idim , kdim), & + intent(in ) :: & + qrs, & + den, & + denfac, & + t + real, dimension( idim, kdim), & + intent(inout ) :: & + rslope, & + rslopeb, & + rslope2, & + rslope3, & + vt + real :: lamda, lamdag, x, y, z, supcol + integer :: i, j, k +!---------------------------------------------------------------- +! size distributions: (x=mixing ratio, y=air density): + lamdag(x,y)= exp(log(pidn0g/(x*y))*(0.25)) ! (pidn0g/(x*y))**.25 +! + do i = 1,idim + do k = 1,ktop + if(qrs(i,k)<=qrmin)then + rslope(i,k) = rslopegmax + rslopeb(i,k) = rslopegbmax + rslope2(i,k) = rslopeg2max + rslope3(i,k) = rslopeg3max + else + lamda = min(lamdag(qrs(i,k),den(i,k)),lamdagmax) + rslope(i,k) = 1./lamda + rslopeb(i,k) = exp(log(rslope(i,k))*(bvtg)) + rslope2(i,k) = rslope(i,k)*rslope(i,k) + rslope3(i,k) = rslope2(i,k)*rslope(i,k) + endif + vt(i,k) = pvtg*rslopeb(i,k)*denfac(i,k) + if(qrs(i,k)<=0.0) vt(i,k) = 0.0 + enddo + enddo +end subroutine slope_graupel +!------------------------------------------------------------------------------- +! +! +!------------------------------------------------------------------------------- + subroutine slope_hail(idim, kdim, ktop, qrs, den, denfac, t, rslope, & + rslopeb, rslope2, rslope3, vt) +!------------------------------------------------------------------------------- + implicit none +!------------------------------------------------------------------------------- +! + integer :: idim, kdim, ktop + real, dimension( idim , kdim), & + intent(in ) :: & + qrs, & + den, & + denfac, & + t + real, dimension( idim, kdim), & + intent(inout ) :: & + rslope, & + rslopeb, & + rslope2, & + rslope3, & + vt + real :: lamda, lamdah, x, y, z, supcol + integer :: i, j, k +!------------------------------------------------------------------------------- +! size distributions: (x=mixing ratio, y=air density): + lamdah(x,y)= exp(log(pidn0h/(x*y))*(0.25)) ! (pidn0h/(x*y))**.25 +! + do i = 1,idim + do k = 1,ktop + if(qrs(i,k)<=qrmin)then + rslope(i,k) = rslopehmax + rslopeb(i,k) = rslopehbmax + rslope2(i,k) = rslopeh2max + rslope3(i,k) = rslopeh3max + else + lamda = min(lamdah(qrs(i,k),den(i,k)),lamdahmax) + rslope(i,k) = 1./lamda + rslopeb(i,k) = exp(log(rslope(i,k))*(bvth)) + rslope2(i,k) = rslope(i,k)*rslope(i,k) + rslope3(i,k) = rslope2(i,k)*rslope(i,k) + endif + vt(i,k) = pvth*rslopeb(i,k)*denfac(i,k) + if(qrs(i,k)<=0.0) vt(i,k) = 0.0 + enddo + enddo +end subroutine slope_hail +!------------------------------------------------------------------------------- +! +! +!------------------------------------------------------------------------------- + subroutine slope_cloud(idim, kdim, ktop, qrs, ncr, den, denfac, t, qmin, & + rslope, rslope2, rslope3) +!------------------------------------------------------------------------------- + implicit none +!------------------------------------------------------------------------------- + integer :: idim, kdim, ktop + real, dimension( idim , kdim), & + intent(in ) :: & + qrs, & + ncr, & + den, & + denfac, & + t + real, dimension( idim, kdim), & + intent(inout ) :: & + rslope, & + rslope2, & + rslope3 + real :: lamda, lamdac, x, y, z, supcol, qmin + integer :: i, j, k +!------------------------------------------------------------------------------- +! size distributions: (x=mixing ratio, y=air density): + lamdac(x,y,z)= exp(log(((pidnc*z)/(x*y)))*((.33333333))) +! + do i = 1,idim + do k = 1,ktop + if(qrs(i,k)<=qmin .or. ncr(i,k)<=ncmin )then + rslope(i,k) = rslopecmax + rslope2(i,k) = rslopec2max + rslope3(i,k) = rslopec3max + else + lamda = min(max(lamdac(qrs(i,k),den(i,k),ncr(i,k)),lamdacmin), & + lamdacmax) + rslope(i,k) = 1./lamda + rslope2(i,k) = rslope(i,k)*rslope(i,k) + rslope3(i,k) = rslope2(i,k)*rslope(i,k) + endif + enddo + enddo +end subroutine slope_cloud +!------------------------------------------------------------------------------- +! +! +!------------------------------------------------------------------------------- +subroutine slope_snow(idim, kdim, ktop, qrs, den, denfac, t, rslope, rslopeb, & + rslope2, rslope3, vt) +!------------------------------------------------------------------------------- + implicit none +!------------------------------------------------------------------------------- + integer :: idim, kdim, ktop + real, dimension( idim , kdim), & + intent(in ) :: & + qrs, & + den, & + denfac, & + t + real, dimension( idim , kdim), & + intent(inout ) :: & + rslope, & + rslopeb, & + rslope2, & + rslope3, & + vt + real, parameter :: t0c = 273.15 + real, dimension( idim , kdim ) :: & + n0sfac + real :: lamda, lamdas, x, y, z, supcol + integer :: i, j, k +!------------------------------------------------------------------------------- +! size distributions: (x=mixing ratio, y=air density): + lamdas(x,y,z)= exp(log((pidn0s*z)/(x*y))*(0.25)) ! (pidn0s*z/(x*y))**.25 +! + do i = 1,idim + do k = 1, ktop + supcol = t0c-t(i,k) +! +! n0s: intercept parameter for snow [m-4] [hdc 6] +! + n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) + if(qrs(i,k)<=qrmin)then + rslope(i,k) = rslopesmax + rslopeb(i,k) = rslopesbmax + rslope2(i,k) = rslopes2max + rslope3(i,k) = rslopes3max + else + lamda = min(lamdas(qrs(i,k),den(i,k),n0sfac(i,k)),lamdasmax) + rslope(i,k) = 1./lamda + rslopeb(i,k) = exp(log(rslope(i,k))*(bvts)) + rslope2(i,k) = rslope(i,k)*rslope(i,k) + rslope3(i,k) = rslope2(i,k)*rslope(i,k) + endif + vt(i,k) = pvts*rslopeb(i,k)*denfac(i,k) + if(qrs(i,k)<=0.0) vt(i,k) = 0.0 + enddo + enddo +end subroutine slope_snow +!------------------------------------------------------------------------------- +! +! +!------------------------------------------------------------------------------- + subroutine semi_lagrangian(im, km, ktop, dendl, denfacl, tkl, dzl, & + wwl, rql, precip, dt, lat, lon) +!------------------------------------------------------------------------------- +! +! this routine is a semi-lagrangain forward advection for hydrometeors +! with mass conservation and positive definite advection +! +! input : +! im, km - dimension +! dendl - dry air density +! denfacl - sqrt(den0/den) +! tkl - temperature in k +! dzl - depth of model layer in meter +! wwl - terminal velocity at model layer in m/s +! dt - time step +! ktop - top layer for computing +! +! inout : +! precip - precipitation +! rql - cloud density*mixing ratio +! +! author: hann-ming henry juang +! song-you hong +! reference: Juang and Hong, 2010: Forward semi-Lagrangian advection +! with mass conservation and positive definiteness for falling +! hydrometeors. Mon. Wea. Rev., 138, 1778-1791 +! +!------------------------------------------------------------------------------- + implicit none +!------------------------------------------------------------------------------- + integer , intent(in ) :: im, km, ktop + integer , intent(in ) :: lat, lon + real , intent(in ) :: dt + real, dimension(im,km), intent(in ) :: dzl + real, dimension(im,km), intent(in ) :: dendl + real, dimension(im,km), intent(in ) :: denfacl + real, dimension(im,km), intent(in ) :: tkl + real, dimension(km), intent(in ) :: wwl + real, dimension(km), intent(inout) :: rql + real, intent(inout) :: precip +! +! local variables +! + real, dimension(km) :: & + dz, & + ww, & + qq, & + wd, & + wa, & + den, & + denfac, & + tk, & + qn + real, dimension(km+1) :: wi, & + zi, & + qmi, & + qpi, & + dza, & + qa + real, dimension(km+2) :: za +! + integer :: i, k, n, m, kk, kb, kt, lond, latd + real :: & + tl, tl2, qql, dql, qqd ,& + th, th2, qqh, dqh ,& + zsum, qsum, dim, dip ,& + zsumt, qsumt, zsumb, qsumb ,& + allold, allnew, zz, dzamin, cflmax, decfl + real :: tmp +! + real, parameter :: & + cfac = 0.05, fa1 = 9./16., fa2 = 1./16. +! + lond = 101 + latd = 1 +! + zi(:) = 0. ; wi(:) = 0. ; qa(:) = 0. + wa(:) = 0. ; wd(:) = 0. ; dza(:) = 0. + precip = 0.0 ; tmp = 0.0 +! +!------------------------------------------------------------------------------- +! + semi_loop : do i = 1,im +! +! assign local variables + dz(:) = dzl(i,:) + den(:) = dendl(i,:) + denfac(:) = denfacl(i,:) + tk(:) = tkl(i,:) + qq(:) = rql(:) + ww(:) = wwl(:) +! +! skip for no precipitation for all layers + allold = 0.0 + do k = 1,ktop + allold = allold + qq(k) + enddo + if(allold<=0.0) then + cycle semi_loop + endif +! +! compute interface value + zi(1)=0.0 + do k = 1,ktop + zi(k+1) = zi(k)+dz(k) + enddo +! +! save departure wind + wd(:) = ww(:) + n=1 + wi(1) = ww(1) + wi(ktop+1) = ww(ktop) + do k=2,ktop + wi(k) = (ww(k)*dz(k-1)+ww(k-1)*dz(k))/(dz(k-1)+dz(k)) + enddo +! +! 3rd order interpolation to get wi + wi(1) = ww(1) + wi(2) = 0.5*(ww(2)+ww(1)) + do k=3,ktop-1 + wi(k) = fa1*(ww(k)+ww(k-1))-fa2*(ww(k+1)+ww(k-2)) + enddo + wi(ktop) = 0.5*(ww(ktop)+ww(ktop-1)) + wi(ktop+1) = ww(ktop) +! +! terminate of top of raingroup + do k=2,ktop + if( ww(k)==0.0 ) wi(k)=ww(k-1) + enddo +! +! diffusivity of wi + do k=ktop,1,-1 + decfl = (wi(k+1)-wi(k))*dt/dz(k) + if( decfl > cfac ) then + wi(k) = wi(k+1) - cfac*dz(k)/dt + endif + enddo +! +! compute arrival point + do k=1,ktop+1 + za(k) = zi(k) - wi(k)*dt + enddo + za(ktop+2) = zi(ktop+1) !hmhj +! + do k=1,ktop+1 !hmhj + dza(k) = za(k+1)-za(k) + enddo +! +! compute deformation at arrival point + do k=1,ktop + tmp = qq(k)*dz(k)/dza(k) + qa(k) = tmp + enddo + qa(ktop+1) = 0.0 +! +! estimate value at arrival cell interface with monotone + do k=2,ktop + dip=(qa(k+1)-qa(k))/(dza(k+1)+dza(k)) + dim=(qa(k)-qa(k-1))/(dza(k-1)+dza(k)) + if( dip*dim<=0.0 ) then + qmi(k)=qa(k) + qpi(k)=qa(k) + else + qpi(k)=qa(k)+0.5*(dip+dim)*dza(k) + qmi(k)=2.0*qa(k)-qpi(k) + if( qpi(k)<0.0 .or. qmi(k)<0.0 ) then + qpi(k) = qa(k) + qmi(k) = qa(k) + endif + endif + enddo + qpi(1)=qa(1) + qmi(1)=qa(1) + qmi(ktop+1)=qa(ktop+1) + qpi(ktop+1)=qa(ktop+1) +! +! interpolation to regular point + qn = 0.0 + kb=1 + kt=1 + intp : do k=1,ktop + kb=max(kb-1,1) + kt=max(kt-1,1) +! find kb and kt + if( zi(k)>=za(ktop+1) ) then + exit intp + else + find_kb : do kk=kb,ktop + if( zi(k)<=za(kk+1) ) then + kb = kk + exit find_kb + else + cycle find_kb + endif + enddo find_kb + find_kt : do kk=kt,ktop+2 !hmhj + if( zi(k+1)<=za(kk) ) then + kt = kk + exit find_kt + else + cycle find_kt + endif + enddo find_kt + kt = kt - 1 +! +! compute q with piecewise parabolic method + if( kt==kb ) then + tl=(zi(k)-za(kb))/dza(kb) + th=(zi(k+1)-za(kb))/dza(kb) + tl2=tl*tl + th2=th*th + qqd=0.5*(qpi(kb)-qmi(kb)) + qqh=qqd*th2+qmi(kb)*th + qql=qqd*tl2+qmi(kb)*tl + qn(k) = (qqh-qql)/(th-tl) + else if( kt>kb ) then + tl=(zi(k)-za(kb))/dza(kb) + tl2=tl*tl + qqd=0.5*(qpi(kb)-qmi(kb)) + qql=qqd*tl2+qmi(kb)*tl + dql = qa(kb)-qql + zsum = (1.-tl)*dza(kb) + qsum = dql*dza(kb) + if( kt-kb>1 ) then + do m=kb+1,kt-1 + zsum = zsum + dza(m) + qsum = qsum + qa(m) * dza(m) + enddo + endif + th=(zi(k+1)-za(kt))/dza(kt) + th2=th*th + qqd=0.5*(qpi(kt)-qmi(kt)) + dqh=qqd*th2+qmi(kt)*th + zsum = zsum + th*dza(kt) + qsum = qsum + dqh*dza(kt) + qn(k) = qsum/zsum + endif + cycle intp + endif +! + enddo intp +! +! rain out + sum_precip: do k=1,ktop + if( za(k)<0.0 .and. za(k+1)<=0.0 ) then !hmhj + precip = precip + qa(k)*dza(k) + cycle sum_precip + else if ( za(k)<0.0 .and. za(k+1)>0.0 ) then !hmhj + th = (0.0-za(k))/dza(k) !hmhj + th2 = th*th !hmhj + qqd = 0.5*(qpi(k)-qmi(k)) !hmhj + qqh = qqd*th2+qmi(k)*th !hmhj + precip = precip + qqh*dza(k) !hmhj + exit sum_precip + endif + exit sum_precip + enddo sum_precip +! +! replace the new values + rql(:) = qn(:) +! +! ---------------------------------- + enddo semi_loop +! +end subroutine semi_lagrangian +!------------------------------------------------------------------------------- +! +! +!------------------------------------------------------------------------------- +subroutine cldf_diag(idim, kdim, t, p, q, qc, qi, dx,cldf, ktop) +!------------------------------------------------------------------------------- + implicit none +!------------------------------------------------------------------------------- +! +! abstract: computes the cloudiness from cloud ice and cloud water. +! +! references : Park et al. (2016, m.w.r.) Park and Hong (2024, meteor.) +! + integer, intent(in ) :: idim, kdim, ktop + real, dimension(idim), intent(in ) :: dx + real, dimension(idim, kdim), intent(in ) :: t, p, q + real, dimension(idim, kdim), intent(in ) :: qc + real, dimension(idim, kdim), intent(in ) :: qi + real, dimension(idim, kdim), intent(out ) :: cldf +! local + integer :: i, k, kk + real, parameter :: cldmin = 50., cldmax = 100. + real, parameter :: clddiff = cldmax - cldmin + real, parameter :: cldf_min = 0.5 + real :: cv_w_min,cv_i_min,cvf_min + real :: cv_w_max,cv_i_max,cvf_max + real :: dxkm +! + do k = 1,ktop + do i = 1,idim + cldf(i,k) = 0. + enddo + enddo +! diagnostic method (kiaps) + do k = 1,ktop + do i = 1, idim + cv_w_min = 4.82*(max(0.,qc(i,k))*1000.)**0.94/1.04 + cv_w_max = 5.77*(max(0.,qc(i,k))*1000.)**1.07/1.04 + cv_i_min = 4.82*(max(0.,qi(i,k))*1000.)**0.94/0.96 + cv_i_max = 5.77*(max(0.,qi(i,k))*1000.)**1.07/0.96 + cvf_min = cv_i_min+cv_w_min + cvf_max = cv_i_max+cv_w_max + dxkm = dx(i)/1000. + cldf(i,k)= ((dxkm-cldmin)*(cvf_max-cvf_min)+clddiff*cvf_min)/clddiff + enddo + enddo + do k = 1,ktop + do i = 1,idim + cldf(i,k)=min(1.,max(0.,cldf(i,k))) + if(qc(i,k)+qi(i,k)<1.e-6) then + cldf(i,k) = 0. + endif + if(cldf(i,k)<0.01) cldf(i,k) = 0. + if(cldf(i,k)>0.99) cldf(i,k) = 1. + if(cldf(i,k)>=0.01 .and. cldf(i,k)qqmin) then + if(nn(k) <= nnmin) then + lamdar = drconst/di0 + nn(k) = den(k)*qq(k)*exp(log(lamdar)*3.)/piconst + endif + lamdar = exp(log(((piconst*nn(k))/(den(k)*qq(k))))*((.33333333))) + diameter = drconst/lamdar + if (diameter > dimax) then + lamdar = drconst/dimax + nn(k) = den(k)*qq(k)*exp(log(lamdar)*3.)/piconst + elseif (diameter < dimin) then + lamdar = drconst/dimin + nn(k) = den(k)*qq(k)*exp(log(lamdar)*3.)/piconst + endif + nn(k) = min(nn(k),nnmax) + else + qq(k) = 0.0 + nn(k) = 0.0 + endif + enddo +! + return +end subroutine adjust_number_concent +!------------------------------------------------------------------------------- +! +! +!------------------------------------------------------------------------------- +subroutine find_cloud_top(im,km,ktop,qq,hvalue,ktopout) +!------------------------------------------------------------------------------- + implicit none +!------------------------------------------------------------------------------- + integer , intent(in ) :: im, km, ktop + real, dimension(km) , intent(in ) :: qq + real , intent(in ) :: hvalue + integer , intent(inout) :: ktopout + integer :: i,k +! +! do i = 1,im + ktopout = 0 + find_qrtop : do k = ktop,1, -1 + if(qq(k)>hvalue) then + ktopout = k + exit find_qrtop + else + cycle find_qrtop + endif + enddo find_qrtop +! enddo + return +end subroutine find_cloud_top +!------------------------------------------------------------------------------- +! +! +!------------------------------------------------------------------------------- +subroutine udm_mp_effective_radius (t, qc, qi, qs, rho, qmin, t0c, & + nc, & + re_qc, re_qi, re_qs, kts, kte, ii, jj) +!------------------------------------------------------------------------------- +! compute radiation effective radii of cloud water, ice, and snow for +! single-moment microphysics. +! these are entirely consistent with microphysics assumptions, not +! constant or otherwise ad hoc as is internal to most radiation +! schemes. +! coded and implemented by soo ya bae, kiaps, january 2015. +!------------------------------------------------------------------------------- + implicit none +!------------------------------------------------------------------------------- +!..sub arguments + integer, intent(in) :: kts, kte, ii, jj + real, intent(in) :: qmin + real, intent(in) :: t0c + real, dimension( kts:kte ), intent(in):: t + real, dimension( kts:kte ), intent(in):: qc + real, dimension( kts:kte ), intent(in):: nc + real, dimension( kts:kte ), intent(in):: qi + real, dimension( kts:kte ), intent(in):: qs + real, dimension( kts:kte ), intent(in):: rho + real, dimension( kts:kte ), intent(inout):: re_qc + real, dimension( kts:kte ), intent(inout):: re_qi + real, dimension( kts:kte ), intent(inout):: re_qs +!..local variables + integer:: i,k + integer :: nu_c + real, dimension( kts:kte ):: ni + real, dimension( kts:kte ):: rqc + real, dimension( kts:kte ):: rnc + real, dimension( kts:kte ):: rqi + real, dimension( kts:kte ):: rni + real, dimension( kts:kte ):: rqs + real :: temp + real :: lamdac + real :: supcol, n0sfac, lamdas + real :: di ! diameter of ice in m + real :: bfactor, bfactor2, bfactor3 + double precision :: lamc + logical :: has_qc, has_qi, has_qs +!..minimum microphys values + real, parameter :: r1 = 1.e-12 + real, parameter :: r2 = 1.e-6 +!..mass power law relations: mass = am*d**bm + real, parameter :: bm_r = 3.0 + real, parameter :: obmr = 1.0/bm_r + real, parameter :: nc0 = 3.e8 + real, parameter :: rqi0 = 50.e-3 ! 50 g m-3 +!------------------------------------------------------------------------------- + has_qc = .false. + has_qi = .false. + has_qs = .false. + do k = kts, kte +! for cloud + rqc(k) = max(r1, qc(k)*rho(k)) + rnc(k) = max(R2, nc(k)*rho(k)) + if (rqc(k)>R1 .and. rnc(k)>R2) has_qc = .true. + if (rqc(k)>r1) has_qc = .true. +! for ice + rqi(k) = max(r1, qi(k)*rho(k)) + temp = (rho(k)*max(qi(k),qmin)) + temp = sqrt(sqrt(temp*temp*temp)) + ni(k) = min(max(5.38e7*temp,1.e3),1.e6) + rni(k)= max(r2, ni(k)*rho(k)) + if (rqi(k)>r1 .and. rni(k)>r2) has_qi = .true. +! for snow + rqs(k) = max(r1, qs(k)*rho(k)) + if (rqs(k)>r1) has_qs = .true. + enddo + if (has_qc) then + do k=kts,kte + if (rqc(k)<=R1 .or. rnc(k)<=R2) CYCLE + lamc = (pidnc*nc(k)/rqc(k))**obmr + re_qc(k) = max(recmin,min(0.5*(1./lamc),recmax)) + enddo + endif + if (has_qi) then + do k=kts,kte + if (rqi(k)<=r1 .or. rni(k)<=r2) cycle + temp = t0c - t(k) + bfactor = -2.0 + 1.0e-3*temp*sqrt(temp)*log10(rqi(k)/rqi0) + bfactor2 = bfactor*bfactor + bfactor3 = bfactor2*bfactor + temp = 377.4 + 203.3*bfactor+ 37.91*bfactor2 + 2.3696*bfactor3 + re_qi(k) = max(reimin,min(temp*1.e-6,reimax)) + enddo + endif + if (has_qs) then + do k=kts,kte + if (rqs(k)<=r1) cycle + supcol = t0c-t(k) + n0sfac = max(min(exp(alpha*supcol),n0smax/n0s),1.) + lamdas = sqrt(sqrt(pidn0s*n0sfac/rqs(k))) + re_qs(k) = max(resmin,min(0.5*(1./lamdas), resmax)) + enddo + endif +end subroutine udm_mp_effective_radius +!------------------------------------------------------------------------------- +! +! +!------------------------------------------------------------------------------- +subroutine udm_mp_reflectivity (qv1d, qr1d, qs1d, qg1d, & + nr1d, & + qh1d, & + t1d, p1d, dbz, kts, kte, ii, jj) +!------------------------------------------------------------------------------- + implicit none +!------------------------------------------------------------------------------- +!..sub arguments + integer, intent(in):: kts, kte, ii, jj + real, dimension(kts:kte), intent(in):: t1d, p1d + real, dimension(kts:kte), intent(in):: qv1d, qr1d, qs1d, qg1d + real, dimension(kts:kte), intent(in):: qh1d + real, dimension(kts:kte), intent(in):: nr1d + real, dimension(kts:kte), intent(inout):: dbz +!..local variables + real, dimension(kts:kte):: temp, pres, qv, rho + real, dimension(kts:kte):: rr, nr, rs, rg, rh + real:: temp_c +! + double precision, dimension(kts:kte):: ilamr, ilams, ilamg, ilamh + double precision, dimension(kts:kte):: n0_r, n0_s, n0_g, n0_h + double precision:: lamr, lams, lamg, lamh + logical, dimension(kts:kte):: l_qr, l_qs, l_qg, l_qh +! + real, dimension(kts:kte):: ze_rain, ze_snow, ze_graupel + double precision:: fmelt_s, fmelt_g + real, dimension(kts:kte):: ze_hail + double precision:: fmelt_h +! + integer:: i, k, k_0, kbot, n + logical:: melti +! + double precision:: cback, x, eta, f_d + real, parameter:: r=287. +! +!+---initialize the local variables +!+ + temp(:) = 0. ; pres(:) = 0. ; qv(:) = 0. ; rho(:) = 0. + rr(:) = 0. ; nr(:) = 0. ; rs(:) = 0. ; rg(:) = 0. ; rh(:) = 0. + temp_c = 0. +! + ilamr(:) = 0. ; ilams(:) = 0. ; ilamg(:) = 0. ; ilamh(:) = 0. + n0_r(:) = 0.; n0_s(:) = 0. ; n0_g(:) = 0. ; n0_h(:) = 0. + lamr = 0. ; lams = 0. ; lamg = 0. ; lamh = 0. + l_qr = .false. ; l_qs = .false. ; l_qg = .false. ; l_qh = .false. +! + ze_rain(:) = 0. ; ze_snow(:) = 0. ; ze_graupel(:) = 0. + fmelt_s = 0. ; fmelt_g = 0. + ze_hail(:) = 0. ; fmelt_h = 0. +! + melti = .false. +! + cback = 0. ; x = 0. ; x = 0. ; eta = 0. ; f_d = 0. +! + do k = kts, kte + dbz(k) = -35.0 + enddo +! return +!+---+-----------------------------------------------------------------+ +!..put column of data into local arrays. +!+---+-----------------------------------------------------------------+ + do k = kts, kte + temp(k) = t1d(k) + temp_c = min(-0.001, temp(k)-273.15) + qv(k) = max(1.e-10, qv1d(k)) + pres(k) = p1d(k) + rho(k) = 0.622*pres(k)/(r*temp(k)*(qv(k)+0.622)) +! + if (qr1d(k) > 1.e-9) then + rr(k) = qr1d(k)*rho(k) + nr(k) = nr1d(k)*rho(k) + lamr = (xam_r*xcrg(3)*xorg2*nr(k)/rr(k))**xobmr + N0_r(k) = nr(k)*xorg2*lamr**xcre(2) + ilamr(k) = 1./lamr + l_qr(k) = .true. + else + rr(k) = 1.e-12 + nr(k) = 1.e-12 + l_qr(k) = .false. + endif +! + if (qs1d(k) > 1.e-9) then + rs(k) = qs1d(k)*rho(k) + n0_s(k) = min(n0smax, n0s*exp(-alpha*temp_c)) + lams = (xam_s*xcsg(3)*n0_s(k)/rs(k))**(1./xcse(1)) + ilams(k) = 1./lams + l_qs(k) = .true. + else + rs(k) = 1.e-12 + l_qs(k) = .false. + endif +! + if (qg1d(k) > 1.e-9) then + rg(k) = qg1d(k)*rho(k) + n0_g(k) = n0g + lamg = (xam_g*xcgg(3)*n0_g(k)/rg(k))**(1./xcge(1)) + ilamg(k) = 1./lamg + l_qg(k) = .true. + else + rg(k) = 1.e-12 + l_qg(k) = .false. + endif + if (qh1d(k) > 1.e-9) then + rh(k) = qh1d(k)*rho(k) + n0_h(k) = n0h + lamh = (xam_h*xchg(3)*n0_h(k)/rh(k))**(1./xche(1)) + ilamh(k) = 1./lamh + l_qh(k) = .true. + else + rh(k) = 1.e-12 + l_qh(k) = .false. + endif + enddo +! +!+---+-----------------------------------------------------------------+ +!..locate k-level of start of melting (k_0 is level above). +!+---+-----------------------------------------------------------------+ + melti = .false. + k_0 = kts + do k = kte-1, kts, -1 + if ( (temp(k)>273.15) .and. L_qr(k) & + .and. (L_qs(k+1).or.L_qg(k+1).or.l_qh(k+1)) ) then + k_0 = max(k+1, k_0) + melti=.true. + goto 195 + endif + enddo + 195 continue +!+---+-----------------------------------------------------------------+ +!..assume rayleigh approximation at 10 cm wavelength. rain (all temps) +!.. and non-water-coated snow and graupel when below freezing are +!.. simple. integrations of m(d)*m(d)*n(d)*dd. +!+---+-----------------------------------------------------------------+ + do k = kts, kte + ze_rain(k) = 1.e-22 + ze_snow(k) = 1.e-22 + if (l_qr(k)) ze_rain(k) = n0_r(k)*xcrg(4)*ilamr(k)**xcre(4) + if (l_qs(k)) ze_snow(k) = (0.176/0.93) * (6.0/pi)*(6.0/pi) & + * (xam_s/900.0)*(xam_s/900.0) & + * n0_s(k)*xcsg(4)*ilams(k)**xcse(4) + ze_graupel(k) = 1.e-22 + if (L_qg(k)) ze_graupel(k) = (0.176/0.93) * (6.0/PI)*(6.0/PI) & + & * (xam_g/900.0)*(xam_g/900.0) & + & * N0_g(k)*xcgg(4)*ilamg(k)**xcge(4) + ze_hail(k) = 1.e-22 + if (L_qh(k)) ze_hail(k) = (0.176/0.93) * (6.0/PI)*(6.0/PI) & + & * (xam_h/900.0)*(xam_h/900.0) & + & * N0_h(k)*xchg(4)*ilamh(k)**xche(4) + enddo +!+---+-----------------------------------------------------------------+ +!..special case of melting ice (snow/graupel) particles. assume the +!.. ice is surrounded by the liquid water. fraction of meltwater is +!.. extremely simple based on amount found above the melting level. +!.. uses code from uli blahak (rayleigh_soak_wetgraupel and supporting +!.. routines). +!+---+-----------------------------------------------------------------+ + if (melti .and. k_0>=kts+1) then + do k = k_0-1, kts, -1 +!..reflectivity contributed by melting snow + if (l_qs(k) .and. l_qs(k_0) ) then + fmelt_s = max(0.005d0, min(1.0d0-rs(k)/rs(k_0), 0.99d0)) + eta = 0.d0 + lams = 1./ilams(k) + do n = 1, nrbins + x = xam_s * xxds(n)**xbm_s + call rayleigh_soak_wetgraupel (x,dble(xocms),dble(xobms), & + fmelt_s, melt_outside_s, m_w_0, m_i_0, lamda_radar, & + cback, mixingrulestring_s, matrixstring_s, & + inclusionstring_s, hoststring_s, & + hostmatrixstring_s, hostinclusionstring_s) + f_d = n0_s(k)*xxds(n)**xmu_s * dexp(-lams*xxds(n)) + eta = eta + f_d * cback * simpson(n) * xdts(n) + enddo + ze_snow(k) = sngl(lamda4 / (pi5 * k_w) * eta) + endif +!..Reflectivity contributed by melting graupel + if (L_qg(k) .and. L_qg(k_0) ) then + fmelt_g = MAX(0.05d0, MIN(1.0d0-rg(k)/rg(k_0), 0.99d0)) + eta = 0.d0 + lamg = 1./ilamg(k) + do n = 1, nrbins + x = xam_g * xxDg(n)**xbm_g + call rayleigh_soak_wetgraupel (x, DBLE(xocmg), DBLE(xobmg), & + & fmelt_g, melt_outside_g, m_w_0, m_i_0, lamda_radar, & + & CBACK, mixingrulestring_g, matrixstring_g, & + & inclusionstring_g, hoststring_g, & + & hostmatrixstring_g, hostinclusionstring_g) + f_d = N0_g(k)*xxDg(n)**xmu_g * DEXP(-lamg*xxDg(n)) + eta = eta + f_d * CBACK * simpson(n) * xdtg(n) + enddo + ze_graupel(k) = SNGL(lamda4 / (pi5 * K_w) * eta) + endif +!..Reflectivity contributed by melting hail + if (L_qh(k) .and. L_qh(k_0) ) then + fmelt_h = MAX(0.05d0, MIN(1.0d0-rh(k)/rh(k_0), 0.99d0)) + eta = 0.d0 + lamh = 1./ilamh(k) + do n = 1, nrbins + x = xam_h * xxDh(n)**xbm_h + call rayleigh_soak_wetgraupel (x, DBLE(xocmh), DBLE(xobmh), & + & fmelt_h, melt_outside_h, m_w_0, m_i_0, lamda_radar, & + & CBACK, mixingrulestring_h, matrixstring_h, & + & inclusionstring_h, hoststring_h, & + & hostmatrixstring_h, hostinclusionstring_h) + f_d = N0_h(k)*xxDh(n)**xmu_h * DEXP(-lamh*xxDh(n)) + eta = eta + f_d * CBACK * simpson(n) * xdth(n) + enddo + ze_hail(k) = SNGL(lamda4 / (pi5 * K_w) * eta) + endif + enddo + endif + do k = kte, kts, -1 + dbz(k) = 10.*log10((ze_rain(k)+ze_snow(k)+ze_graupel(k)+ze_hail(k))*1.d18) + enddo +end subroutine udm_mp_reflectivity +!------------------------------------------------------------------------------- +! +! +!------------------------------------------------------------------------------- + subroutine udm_funct_shape_setup +!------------------------------------------------------------------------------- +! +! abstract: computes the ratio of fall velocity for mass over number +! concentations, vm/vn, as a function of variable shape parameter. +! the shape paramter is a diagnosed with respect to diamater of +! drops. exact shape dependent ratio is calculated in subprogram +! fshapex. the current implementation computes a table with a length +! of 9991 for diameter ranging from 10 micro to 10 mm. +! +! usage : call udm_funct_shape_setup +! +! history : first development songyou hong 2023-11-27 +! +! subprograms called : +! (fshapex) - inlinable function to compute velocity ratio +! +!------------------------------------------------------------------------------- + implicit none +! + real , parameter :: xmin = 10.e-6, xmax = 10.e-3 + integer :: jx + real :: xinc,x,d +! + xinc = (xmax-xmin)/(nxshape-1) + c1xshape = 1.-xmin/xinc + c2xshape = 1./xinc +! + do jx = 1,nxshape + x = xmin+(jx-1)*xinc + d = x + tbshape(jx) = fshapex(d) + enddo +! + return + end subroutine udm_funct_shape_setup +!------------------------------------------------------------------------------- + real function fshapex(d) +!------------------------------------------------------------------------------- +! +! abstract : exactly compute velocity ratio from diameter. +! vratio = gamma(1+myu)*gamma(4+bvtr+myu)/gamma(1+bvtr+myu)/gamma(4+myu) +! where bvtr is the power parameter in terminal velocity, and myu is +! the dignosed shape parameter,which is a function of drop size. +! myu = 11.8*[1000D**(1/3)-0.7)**2 + 2, from Milbrandt and +! Mctaggart-Cowan (JAS, 2010). D is the unit in meters. +! this function should be expanded inline in the calling routine. +! +! usage : shape=fshapex(d) +! +! input : +! d - real diameter in meters +! +! output : +! fshapex - real velocity ratio, Vm/Vn +! +!------------------------------------------------------------------------------- +! + implicit none +! +! passing variable +! + real , intent(in ) :: d +! +! local variable +! + real :: shape_rain +! + shape_rain = min(11.8*(1000.*d-0.7)**2 + 2.,10.) + fshapex = max(rgmma(4.+shape_rain+bvtr)*rgmma(1.+shape_rain) & + /rgmma(1.+shape_rain+bvtr)/rgmma(4.+shape_rain),1.) +! + return + end function fshapex +!------------------------------------------------------------------------------- + real function fshape(d) +!------------------------------------------------------------------------------- +! +! abstract : compute velocity ratio from the diameter of drops. +! a linear interpolation is done between values in a lookup table +! computed in funct_shape_setup. +! input values outside table range are reset to table extrema. +! +! usage : shape=fshape(d) +! +! input : +! d - real diameter in meters +! +! output : +! fshape - real velocity ratio +! +!------------------------------------------------------------------------------- + implicit none +! + real , intent(in ) :: d +! + integer :: jx + real :: xj +! + xj = min(max(c1xshape+c2xshape*d,1.),real(nxshape)) + jx = min(xj,nxshape-1.) + fshape = tbshape(jx)+(xj-jx)*(tbshape(jx+1)-tbshape(jx)) +! + return + end function fshape +!------------------------------------------------------------------------------- +! +! +!------------------------------------------------------------------------------- + subroutine udm_funct_lb2017_setup +!------------------------------------------------------------------------------- +! +! abstract: computes the production of qc to qr and nc to nr in the +! lb207 autoconversion physics in terms of lamda_r, slope parameter of rain. +! the current implementation computes a table with a length of 100 for +! diameter ranging from 1 micro [10**6 m-1] to 100 micro [10**4 m-1]. +! +! usage : udm_call funct_lb2017_setup +! +! history : first development songyou hong 2024-11-27 +! +! subprograms called : +! (funct_qc_totx) - inlinable function to compute qc_total +! (funct_qc_subx) - inlinable function to compute qc_sub +! (funct_nc_totx) - inlinable function to compute nc_total +! (funct_nc_subx) - inlinable function to compute nc_sub +! +!------------------------------------------------------------------------------- + implicit none +! + real , parameter :: xmin = 1.e+4, xmax = 1.e+7 + integer :: jx, nu + real :: xinc,x,d +! + double precision :: funct_aut_qc_totx,funct_aut_qc_subx + double precision :: funct_aut_nc_totx,funct_aut_nc_subx +! + funct_aut_qc_totx = 0. ; funct_aut_qc_subx = 0. + funct_aut_nc_totx = 0. ; funct_aut_nc_subx = 0. + tbaut_qc_tot(:,:) = 0. ; tbaut_qc_sub(:,:) = 0. + tbaut_nc_tot(:,:) = 0. ; tbaut_nc_sub(:,:) = 0. +! + xinc = (xmax-xmin)/(nxaut-1) + c1xaut = 1.-xmin/xinc + c2xaut = 1./xinc +! + do nu = 1,numax + do jx = 1,nxaut + x = xmin+(jx-1)*xinc + d = x + call comp_aut_table(d,nu,funct_aut_qc_totx,funct_aut_qc_subx, & + funct_aut_nc_totx,funct_aut_nc_subx) + tbaut_qc_tot(jx,nu) = funct_aut_qc_totx + tbaut_qc_sub(jx,nu) = funct_aut_qc_subx + tbaut_nc_tot(jx,nu) = funct_aut_nc_totx + tbaut_nc_sub(jx,nu) = funct_aut_nc_subx + enddo + enddo +! + return + end subroutine udm_funct_lb2017_setup +!------------------------------------------------------------------------------- + subroutine comp_aut_table(lamc,nu_c,qc_tot,qc_sub,nc_tot,nc_sub) +!------------------------------------------------------------------------------- +! +! abstract : exactly compute conversoin rate for qc to qr, and nc and nr. +! this function should be expanded inline in the calling routine. +! see equations 15~19 of Lee and Baik (2017) +! +! usage : call comp_aut_table +! +! input : +! lamc - slope parameter for rain +! +! output : +! qc_tot, qc_sub, nc_tot, nc_sub +! +!------------------------------------------------------------------------------- +! + implicit none +! +! passing variable +! + real , intent(in ) :: lamc + double precision, intent(inout ) :: qc_tot,qc_sub,nc_tot,nc_sub + double precision, parameter :: & + r_star = 50.0d-6, & !< from 40 micro-m in lb2017 + a_aut = 0.21421d0, & + b_aut = -1.11347d4 + integer,parameter :: n_gamma = 42 + double precision, dimension(0:n_gamma) :: gamma1, gamma2, & + exp1, exp2, exp3, err1, err2 + double precision :: term, temp11, temp12, temp21, temp22 + double precision, dimension(10), parameter :: ak1 = & + (/a_aut, 1+a_aut, 1-2*a_aut, -2+a_aut, -1+2*a_aut, & + 2-a_aut, -1-2*a_aut, -2+a_aut, 1+a_aut, 1.0d0 /) + double precision, dimension( 7), parameter :: ak2 = & + (/a_aut, 1+a_aut, 1-2*a_aut, -2-2*a_aut, -2+a_aut, 1+a_aut,1.0d0/) + integer :: n, nn, nu_c +! + gamma1(:) = 0. ; gamma2(:) = 0. + exp1(:) = 0. ; exp2(:) = 0. ; exp3(:) = 0. ; err1(:) = 0.; err2(:) = 0. + term = 0. ; temp11 = 0.0 ; temp12 = 0. ; temp21 = 0. ; temp22 = 0. +! + gamma1(0) = 1.0d0/(lamc) + gamma2(0) = 1.0d0/(2.0d0*lamc) + exp1(0) = 1.0d0 + err1(0) = 1.0d0 + exp2(0) = 1.0d0 + err2(0) = 1.0d0 +! + do n = 1, n_gamma + gamma1(n) = gamma1(n-1)*(dble(n)/(lamc)) + gamma2(n) = gamma2(n-1)*(dble(n)/(2.0d0*lamc)) + exp1(n) = exp1(n-1) *(( lamc*r_star)/dble(n)) + exp2(n) = exp2(n-1) *((2.0d0*lamc*r_star)/dble(n)) + end do +! + exp3 = 1.0d0/(lamc*gamma1) +! + do n = 1, n_gamma + err1(n) = 0.0d0 + err2(n) = 0.0d0 + do nn = 0, n + err1(n) = err1(n) + exp1(nn) + err2(n) = err2(n) + exp2(nn) + end do + err1(n) = 1.0d0 - exp(- lamc*r_star)*err1(n) + err2(n) = 1.0d0 - exp(-2.0d0*lamc*r_star)*err2(n) + end do +!----------------------------------------- +! for mass concentraion +!----------------------------------------- + qc_tot = 0.0d0 + qc_sub = 0.0d0 +! + do n = 1, 10 + temp11 = 0.0d0 + temp12 = 0.0d0 + do nn = 0, nu_c+n + term = exp3(nn)*gamma2(nu_c+10-n+nn) + temp11 = temp11 + term + temp12 = temp12 + term*err2(nu_c+10-n+nn) + end do + temp21 = 0.0d0 + temp22 = 0.0d0 + do nn = 0, nu_c+n + term = exp3(nn)*gamma2(nu_c+11-n+nn) + temp21 = temp21 + term + temp22 = temp22 + term*err2(nu_c+11-n+nn) + end do +! + qc_tot = qc_tot + ak1(n)*gamma1(nu_c+n)*(gamma1(nu_c+10-n) & + - temp11 + b_aut*(gamma1(nu_c+11-n) -temp21)) + qc_sub = qc_sub + ak1(n)*gamma1(nu_c+n)*(gamma1(nu_c+10-n) & + *err1(nu_c+10-n)-temp12 +b_aut*(gamma1(nu_c+11-n) & + *err1(nu_c+11-n)-temp22)) + end do +!----------------------------------------- +! for number concentraion +!----------------------------------------- + nc_tot = 0.0d0 + nc_sub = 0.0d0 +! + do n = 1, 7 + temp11 = 0.0d0 + temp12 = 0.0d0 + do nn=0, nu_c+n + term = exp3(nn)*gamma2(nu_c+7-n+nn) + temp11 = temp11 + term + temp12 = temp12 + term*err2(nu_c+7-n+nn) + end do + temp21 = 0.0d0 + temp22 = 0.0d0 + do nn = 0, nu_c+n + term = exp3(nn)*gamma2(nu_c+8-n+nn) + temp21 = temp21 + term + temp22 = temp22 + term*err2(nu_c+8-n+nn) + end do +! + nc_tot = nc_tot + ak2(n)*gamma1(nu_c+n)*(gamma1(nu_c+7-n) & + - temp11 + b_aut*(gamma1(nu_c+8-n) - temp21)) + nc_sub = nc_sub + ak2(n)*gamma1(nu_c+n)*(gamma1(nu_c+7-n) & + *err1(nu_c+7-n)-temp12 +b_aut*(gamma1(nu_c+8-n) & + *err1(nu_c+8-n)-temp22)) + end do +! + return + end subroutine comp_aut_table +!------------------------------------------------------------------------------- + double precision function funct_aut_qc_tot(d,nu) +!------------------------------------------------------------------------------- +! +! abstract : +! a linear interpolation is done between values in a lookup table +! computed in funct_lb2017_setup. +! input values outside table range are reset to table extrema. +! +! usage : funct_aut_qc_tot(d) +! +! input : +! d - slope parameter +! +! output : +! qc_tot - real total conversion rate of qc +! +!------------------------------------------------------------------------------- + implicit none +! + double precision , intent(in ) :: d + integer , intent(in ) :: nu +! + integer :: jx + real :: xj +! + xj = min(max(c1xaut+c2xaut*d,1.d0),real(nxaut)) + jx = min(xj,nxaut-1.d0) + funct_aut_qc_tot = tbaut_qc_tot(jx,nu)+(xj-jx)*(tbaut_qc_tot(jx+1,nu) & + -tbaut_qc_tot(jx,nu)) +! + return + end function funct_aut_qc_tot +!------------------------------------------------------------------------------- + double precision function funct_aut_qc_sub(d,nu) +!------------------------------------------------------------------------------- +! +! abstract : +! a linear interpolation is done between values in a lookup table +! computed in funct_lb2017_setup. +! input values outside table range are reset to table extrema. +! +! usage : funct_aut_qc_sub(d) +! +! input : +! d - slope parameter +! +! output : +! qc_tot - real sub conversion rate of qc +! +!------------------------------------------------------------------------------- + implicit none +! + double precision , intent(in ) :: d + integer , intent(in ) :: nu +! + integer :: jx + real :: xj +! + xj = min(max(c1xaut+c2xaut*d,1.d0),real(nxaut)) + jx = min(xj,nxaut-1.d0) + funct_aut_qc_sub = tbaut_qc_sub(jx,nu)+(xj-jx)*(tbaut_qc_sub(jx+1,nu) & + -tbaut_qc_sub(jx,nu)) +! + return + end function funct_aut_qc_sub +!------------------------------------------------------------------------------- + double precision function funct_aut_nc_tot(d,nu) +!------------------------------------------------------------------------------- +! +! abstract : +! a linear interpolation is done between values in a lookup table +! computed in funct_lb2017_setup. +! input values outside table range are reset to table extrema. +! +! usage : funct_aut_nc_tot(d) +! +! input : +! d - slope parameter +! +! output : +! qc_tot - real sub conversion rate of nc +! +!------------------------------------------------------------------------------- + implicit none +! + double precision , intent(in ) :: d + integer , intent(in ) :: nu +! + integer :: jx + real :: xj +! + xj = min(max(c1xaut+c2xaut*d,1.d0),real(nxaut)) + jx = min(xj,nxaut-1.d0) + funct_aut_nc_tot = tbaut_nc_tot(jx,nu)+(xj-jx)*(tbaut_nc_tot(jx+1,nu) & + -tbaut_nc_tot(jx,nu)) +! + return + end function funct_aut_nc_tot +!------------------------------------------------------------------------------- + double precision function funct_aut_nc_sub(d,nu) +!------------------------------------------------------------------------------- +! +! abstract : +! a linear interpolation is done between values in a lookup table +! computed in funct_lb2017_setup. +! input values outside table range are reset to table extrema. +! +! usage : funct_aut_nc_sub(d) +! +! input : +! d - slope parameter +! +! output : +! nc_sub - real sub conversion rate of nc +! +!------------------------------------------------------------------------------- + implicit none +! + double precision , intent(in ) :: d + integer , intent(in ) :: nu +! + integer :: jx + real :: xj +! + xj = min(max(c1xaut+c2xaut*d,1.d0),real(nxaut)) + jx = min(xj,nxaut-1.d0) + funct_aut_nc_sub = tbaut_nc_sub(jx,nu)+(xj-jx)*(tbaut_nc_sub(jx+1,nu) & + -tbaut_nc_sub(jx,nu)) +! + return + end function funct_aut_nc_sub +!------------------------------------------------------------------------------- +! +! +!------------------------------------------------------------------------------- + subroutine udm_funct_svp_setup +!------------------------------------------------------------------------------- +! +! abstract: compute saturation vapor pressure table for the table lookup +! function fsvp.exact saturation vapor pressures are calculated in +! subprogram fsvpx. +! the current implementation computes a table with a length +! of 7501 for temperatures ranging from 180. to 330. kelvin. +! +! history log: +! 1991-05-07 iredell made into inlinable function +! 1996-02-19 song-you hong ice effect & increased range and accuracy +! 2009-10-01 jung-eun kim f90 format with standard physics modules +! 2010-07-01 myung-seo koo dimension allocatable with namelist input +! 2023-11-27 song-you hong clean-up and implemented on ufs model +! +! usage : call funct_svp_setup +! +! subprograms called : +! (fsvpx) - inlinable function to compute saturation vapor pressure +! +!------------------------------------------------------------------------------- + implicit none +! + real , parameter :: xmin = 180.0, & + xmax = 330.0 + integer :: jx + real :: xinc,x,t +! + xinc = (xmax-xmin)/(nxsvp-1) + c1xsvp = 1.-xmin/xinc + c2xsvp = 1./xinc + c1xsvpw = c1xsvp + c2xsvpw = c2xsvp +! + do jx = 1,nxsvp + x = xmin+(jx-1)*xinc + t = x + tbsvp(jx) = fsvpx(t) + tbsvpw(jx) = fsvpxw(t) + enddo +! + return + end subroutine udm_funct_svp_setup +!------------------------------------------------------------------------------- + real function fsvpx(t) +!------------------------------------------------------------------------------- +! +! abstract : exactly compute saturation vapor pressure from temperature. +! the clausius-clapeyron equation is integrated from the triple point +! to get the formula +! svp=psatk*(tr**xa)*exp(xb*(1.-tr)) +! where tr is ttp/t and other values are physical constants +! this function should be expanded inline in the calling routine. +! +! usage : svp=fsvpx(t) +! +! input : +! t - real temperature in kelvin +! +! output : +! fsvpx - real saturation vapor pressure in pascale (pa) +! +!------------------------------------------------------------------------------- + implicit none +! +! passing variable +! + real , intent(in ) :: t +! +! local variable +! + real :: tr +! + tr = ttp_/t + if (t >= ttp_) then + fsvpx = psatk*(tr**xa)*exp(xb*(1.-tr)) + else + fsvpx = psatk*(tr**xai)*exp(xbi*(1.-tr)) + endif +! + return + end function fsvpx +!------------------------------------------------------------------------------- + real function fsvpxw(t) +!------------------------------------------------------------------------------- +! +! abstract : same to fxvps but water only +! +!------------------------------------------------------------------------------- + implicit none +! + real , intent(in ) :: t + real :: tr +! + tr = ttp_/t + fsvpxw = psatk*(tr**xa)*exp(xb*(1.-tr)) +! + return + end function fsvpxw +!------------------------------------------------------------------------------- + real function fsvp(t,p) +!------------------------------------------------------------------------------- +! +! abstract : compute saturation vapor pressure from the temperature. +! a linear interpolation is done between values in a lookup table +! computed in funct_svp_setup. +! +! usage : svp=fsvp(t) +! +! input : +! t - real temperature in kelvin +! p - real pressure in pa (optional) +! +! output : +! fsvp - real saturation vapor pressure in pascals (pa) +! +!------------------------------------------------------------------------------- + implicit none +! + real , intent(in ) :: t + real , intent(in ), optional :: p +! + integer :: jx + real :: xj +! + xj = min(max(c1xsvp+c2xsvp*t,1.),real(nxsvp)) + jx = min(xj,nxsvp-1.) + fsvp = tbsvp(jx)+(xj-jx)*(tbsvp(jx+1)-tbsvp(jx)) +! + if (present(p)) fsvp = min(fsvp,0.99*p) +! + return + end function fsvp +!------------------------------------------------------------------------------- + real function fsvp_water(t,p) +!------------------------------------------------------------------------------- +! +! abstract : same to fsvp but water only +! +!------------------------------------------------------------------------------- + implicit none +! + real , intent(in ) :: t + real , intent(in ), optional :: p +! + integer :: jx1 + real :: xj1 +! + xj1 = min(max(c1xsvpw+c2xsvpw*t,1.),real(nxsvpw)) + jx1 = min(xj1,nxsvpw-1.) + fsvp_water = tbsvpw(jx1)+(xj1-jx1)*(tbsvpw(jx1+1)-tbsvpw(jx1)) +! + if (present(p)) fsvp_water = min(fsvp_water,0.99*p) +! + return + end function fsvp_water +!------------------------------------------------------------------------------- +! +end module module_mp_udm +! +!------------------------------------------------------------------------------- +!------------------------------------------------------------------------------- diff --git a/phys/module_mp_wdm5.F b/phys/module_mp_wdm5.F index 6e69b082e2..0e67a665c6 100644 --- a/phys/module_mp_wdm5.F +++ b/phys/module_mp_wdm5.F @@ -1,4 +1,4 @@ -#if ( RWORDSIZE == 4 ) +#ifndef DOUBLE_PRECISION # define VREC vsrec # define VSQRT vssqrt #else diff --git a/phys/module_mp_wdm6.F b/phys/module_mp_wdm6.F index 4509fff847..e30ec5ade9 100644 --- a/phys/module_mp_wdm6.F +++ b/phys/module_mp_wdm6.F @@ -1,4 +1,4 @@ -#if ( RWORDSIZE == 4 ) +#ifndef DOUBLE_PRECISION # define VREC vsrec # define VSQRT vssqrt #else diff --git a/phys/module_mp_wdm7.F b/phys/module_mp_wdm7.F index d29374481c..9096c997e5 100644 --- a/phys/module_mp_wdm7.F +++ b/phys/module_mp_wdm7.F @@ -1,4 +1,4 @@ -#if ( RWORDSIZE == 4 ) +#ifndef DOUBLE_PRECISION # define VREC vsrec # define VSQRT vssqrt #else diff --git a/phys/module_mp_wsm3.F b/phys/module_mp_wsm3.F index a71d3cbfa6..0081a4817e 100644 --- a/phys/module_mp_wsm3.F +++ b/phys/module_mp_wsm3.F @@ -1,7 +1,7 @@ #ifdef _ACCEL # include "module_mp_wsm3_accel.F" #else -#if ( RWORDSIZE == 4 ) +#ifndef DOUBLE_PRECISION # define VREC vsrec # define VSQRT vssqrt #else diff --git a/phys/module_mp_wsm3_accel.F b/phys/module_mp_wsm3_accel.F index bacec9bfad..21c7a7e00e 100644 --- a/phys/module_mp_wsm3_accel.F +++ b/phys/module_mp_wsm3_accel.F @@ -1,4 +1,4 @@ -#if ( RWORDSIZE == 4 ) +#ifndef DOUBLE_PRECISION # define VREC vsrec # define VSQRT vssqrt #else diff --git a/phys/module_mp_wsm5.F b/phys/module_mp_wsm5.F index e081a7b6e4..c80978e702 100644 --- a/phys/module_mp_wsm5.F +++ b/phys/module_mp_wsm5.F @@ -1,7 +1,7 @@ #ifdef _ACCEL # include "module_mp_wsm5_accel.F" #else -#if ( RWORDSIZE == 4 ) +#ifndef DOUBLE_PRECISION # define VREC vsrec # define VSQRT vssqrt #else diff --git a/phys/module_mp_wsm5_accel.F b/phys/module_mp_wsm5_accel.F index 085ef2f441..286e6a14cd 100644 --- a/phys/module_mp_wsm5_accel.F +++ b/phys/module_mp_wsm5_accel.F @@ -1,4 +1,4 @@ -#if ( RWORDSIZE == 4 ) +#ifndef DOUBLE_PRECISION # define VREC vsrec # define VSQRT vssqrt #else diff --git a/phys/module_mp_wsm7.F b/phys/module_mp_wsm7.F index 8f757f08c5..9b0c777d47 100644 --- a/phys/module_mp_wsm7.F +++ b/phys/module_mp_wsm7.F @@ -1,4 +1,4 @@ -#if ( RWORDSIZE == 4 ) +#ifndef DOUBLE_PRECISION # define VREC vsrec # define VSQRT vssqrt #else diff --git a/phys/module_pbl_driver.F b/phys/module_pbl_driver.F index f703071765..24c2174556 100644 --- a/phys/module_pbl_driver.F +++ b/phys/module_pbl_driver.F @@ -54,7 +54,7 @@ SUBROUTINE pbl_driver( & ,sub_thl3D,sub_sqv3D & ,det_thl3D,det_sqv3D & ,vdfg & - ,maxwidth,maxMF,ztop_plume,ktop_plume & + ,maxwidth,maxMF,ztop_plume & ,spp_pbl,pattern_spp_pbl & ! EEPS ,pek,pep,pek_adv,pep_adv & @@ -199,7 +199,7 @@ SUBROUTINE pbl_driver( & USE module_bl_mfshconvpbl USE module_bl_gbmpbl #if (EM_CORE==1) - USE module_bl_mynn_wrapper + USE module_bl_mynnedmf_driver USE module_bl_eeps USE module_bl_keps USE module_bl_fogdes @@ -595,8 +595,6 @@ SUBROUTINE pbl_driver( & REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL, & & INTENT(INOUT):: vdfg - INTEGER, OPTIONAL, DIMENSION( ims:ime , jms:jme ), & - & INTENT(OUT) :: ktop_plume REAL, OPTIONAL, DIMENSION( ims:ime , jms:jme ), & & INTENT(OUT) :: maxwidth,maxMF,ztop_plume @@ -1634,7 +1632,7 @@ SUBROUTINE pbl_driver( & PRESENT( rqniblten ) .AND. PRESENT( qni_curr ) .AND.& PRESENT(qke) .AND. PRESENT(tsq) .AND. & PRESENT(qsq) .AND. PRESENT(cov) .AND. & - PRESENT(rmol) .AND. PRESENT(ch) .AND. & + PRESENT(ch) .AND. & PRESENT(tke_budget) .AND. PRESENT(qke_adv) .AND. & PRESENT(bl_mynn_tkeadvect) ) THEN @@ -1657,7 +1655,7 @@ SUBROUTINE pbl_driver( & ims, ime, jms, jme, kms, kme, kts, kte) end if - CALL mynnedmf_wrapper_run( & + CALL mynnedmf_driver( & &initflag=initflag,restart=restart,cycling=cycling, & &delt=dtbl,dz=dz8w,dxc=dx,znt=znt, & &u=u_phy,v=v_phy,w=w,th=th_phy,qv=qv_curr, & @@ -1667,7 +1665,7 @@ SUBROUTINE pbl_driver( & ! &ozone=ozone, & &p=p_phy,exner=pi_phy,rho=rho,T3D=t_phy, & &xland=xland,ts=tsk,qsfc=qsfc,ps=psfc, & - &ust=ust,ch=ch,hfx=hfx,qfx=qfx,rmol=rmol,wspd=wspd, & + &ust=ust,ch=ch,hfx=hfx,qfx=qfx,wspd=wspd, & &uoce=uoce,voce=voce, & !Ocean currents &Qke=qke,qke_adv=qke_adv,Sh3d=Sh3d,Sm3d=Sm3d, & #if (WRF_CHEM == 1) @@ -1696,7 +1694,7 @@ SUBROUTINE pbl_driver( & &sub_thl3D=sub_thl3D,sub_sqv3D=sub_sqv3D, & &det_thl3D=det_thl3D,det_sqv3D=det_sqv3D, & &maxwidth=maxwidth,maxMF=maxMF, & - &ztop_plume=ztop_plume,ktop_plume=ktop_plume, & + &ztop_plume=ztop_plume, & &RTHRATEN=RTHRATEN, & &bl_mynn_tkeadvect=bl_mynn_tkeadvect, & &tke_budget=tke_budget, & @@ -1731,7 +1729,7 @@ SUBROUTINE pbl_driver( & deallocate (qke_tmp) end if ELSE - WRITE ( message , FMT = '(A,17(L1,1X))' ) & + WRITE ( message , FMT = '(A,16(L1,1X))' ) & 'present: '// & 'qv_curr, '// & 'qc_curr, '// & @@ -1745,7 +1743,6 @@ SUBROUTINE pbl_driver( & 'tsq, '// & 'qsq, '// & 'cov, '// & - 'rmol, '// & 'ch, '// & 'tke_budget, '// & 'qke_adv, '// & @@ -1762,7 +1759,6 @@ SUBROUTINE pbl_driver( & PRESENT( tsq ) , & PRESENT( qsq ) , & PRESENT( cov ) , & - PRESENT( rmol ) , & PRESENT( ch ) , & PRESENT( tke_budget) , & PRESENT( qke_adv ) , & @@ -1899,7 +1895,7 @@ SUBROUTINE pbl_driver( & ,B_E_BEP=b_e_bep & ,SF_BEP=sf_bep,VL_BEP=vl_bep & ,BR=br,ZNT=znt & - ,PSIM=psim,PSIH=psih & + ,PSIM=fm,PSIH=fhh & ,IDS=ids,IDE=ide,JDS=jds,JDE=jde,KDS=kds,KDE=kde & ,IMS=ims,IME=ime,JMS=jms,JME=jme,KMS=kms,KME=kme & ,ITS=its,ITE=ite,JTS=jts,JTE=jte,KTS=kts,KTE=kte ) diff --git a/phys/module_physics_addtendc.F b/phys/module_physics_addtendc.F index 5e15a32b83..a0a360deda 100644 --- a/phys/module_physics_addtendc.F +++ b/phys/module_physics_addtendc.F @@ -38,6 +38,10 @@ SUBROUTINE update_phy_ten(rph_tendf,rt_tendf,ru_tendf,rv_tendf,moist_tendf, & RUNDGDTEN,RVNDGDTEN,RTHNDGDTEN,RPHNDGDTEN, & RQVNDGDTEN,RMUNDGDTEN, & rthfrten,rqvfrten, & !fire + ruiauten,rviauten,rthiauten, & + rqviauten,rqciauten,rqriauten, & + rqiiauten,rqsiauten,rqgiauten, & + rphiauten,rmuiauten, & n_moist,n_scalar,config_flags,rk_step,adv_moist_cond, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -103,9 +107,20 @@ SUBROUTINE update_phy_ten(rph_tendf,rt_tendf,ru_tendf,rv_tendf,moist_tendf, & RPHNDGDTEN, & RQVNDGDTEN, & RUNDGDTEN, & - RVNDGDTEN - - REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN ) :: RMUNDGDTEN + RVNDGDTEN, & + RUIAUTEN, & + RVIAUTEN, & + RPHIAUTEN, & + RTHIAUTEN, & + RQVIAUTEN, & + RQCIAUTEN, & + RQRIAUTEN, & + RQIIAUTEN, & + RQSIAUTEN, & + RQGIAUTEN + + REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN ) :: RMUNDGDTEN, & + RMUIAUTEN REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN ) :: & ! fire rthfrten, & @@ -164,6 +179,18 @@ SUBROUTINE update_phy_ten(rph_tendf,rt_tendf,ru_tendf,rv_tendf,moist_tendf, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) + if (config_flags%iau .gt. 0) & + CALL phy_iau_ten(config_flags,rk_step,n_moist, & + rph_tendf,rt_tendf,ru_tendf,rv_tendf, & + mu_tendf, moist_tendf, & + RUIAUTEN,RVIAUTEN,RTHIAUTEN, & + RPHIAUTEN,RMUIAUTEN, & + RQVIAUTEN,RQCIAUTEN,RQRIAUTEN, & + RQIIAUTEN,RQSIAUTEN,RQGIAUTEN, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + if (config_flags%ifire .gt. 0) & ! fire CALL phy_fr_ten(config_flags,rk_step,n_moist, & rt_tendf,ru_tendf,rv_tendf, & @@ -1992,6 +2019,129 @@ SUBROUTINE phy_fg_ten(config_flags,rk_step,n_moist, & END SUBROUTINE phy_fg_ten +!================================================================= +SUBROUTINE phy_iau_ten(config_flags,rk_step,n_moist, & + rph_tendf,rt_tendf,ru_tendf,rv_tendf, & + mu_tendf, moist_tendf, & + RUIAUTEN,RVIAUTEN,RTHIAUTEN, & + RPHIAUTEN,RMUIAUTEN, & + RQVIAUTEN,RQCIAUTEN,RQRIAUTEN, & + RQIIAUTEN,RQSIAUTEN,RQGIAUTEN, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) +!----------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------- + TYPE(grid_config_rec_type) , INTENT(IN ) :: config_flags + + INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte, & + n_moist, rk_step + + REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_moist), & + INTENT(INOUT) :: moist_tendf + + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN ) :: & + RPHIAUTEN, & + RTHIAUTEN, & + RUIAUTEN, & + RVIAUTEN, & + RQVIAUTEN + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN ) :: & + RQCIAUTEN, & + RQRIAUTEN, & + RQIIAUTEN, & + RQSIAUTEN, & + RQGIAUTEN + + REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN ) :: RMUIAUTEN + + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: & + rph_tendf,& + rt_tendf, & + ru_tendf, & + rv_tendf + + REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT):: mu_tendf + +! LOCAL VARS + + INTEGER :: i,j,k,IBGN,IEND,JBGN,JEND + +!----------------------------------------------------------------- + + CALL add_a2a(rt_tendf,RTHIAUTEN,config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CALL add_a2a_ph(rph_tendf,RPHIAUTEN,config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + +! note fdda u and v tendencies are staggered + CALL add_c2c_u(ru_tendf,RUIAUTEN,config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CALL add_c2c_v(rv_tendf,RVIAUTEN,config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CALL add_a2a(mu_tendf,RMUIAUTEN,config_flags, & + ids,ide, jds, jde, kds, kds, & + ims, ime, jms, jme, kms, kms, & + its, ite, jts, jte, kts, kts ) + + if (P_QV .ge. PARAM_FIRST_SCALAR) & + CALL add_a2a(moist_tendf(ims,kms,jms,P_QV),RQVIAUTEN, & + config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + if (P_QC .ge. PARAM_FIRST_SCALAR) & + CALL add_a2a(moist_tendf(ims,kms,jms,P_QC),RQCIAUTEN, & + config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + if (P_QR .ge. PARAM_FIRST_SCALAR) & + CALL add_a2a(moist_tendf(ims,kms,jms,P_QR),RQRIAUTEN, & + config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + if (P_QI .ge. PARAM_FIRST_SCALAR) & + CALL add_a2a(moist_tendf(ims,kms,jms,P_QI),RQIIAUTEN, & + config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + if (P_QS .ge. PARAM_FIRST_SCALAR) & + CALL add_a2a(moist_tendf(ims,kms,jms,P_QS),RQSIAUTEN, & + config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + if (P_QG .ge. PARAM_FIRST_SCALAR) & + CALL add_a2a(moist_tendf(ims,kms,jms,P_QG),RQGIAUTEN, & + config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + +END SUBROUTINE phy_iau_ten + !================================================================= SUBROUTINE phy_fr_ten(config_flags,rk_step,n_moist, & rt_tendf,ru_tendf,rv_tendf, & diff --git a/phys/module_physics_init.F b/phys/module_physics_init.F index 9d419edf7d..8f94e171e2 100644 --- a/phys/module_physics_init.F +++ b/phys/module_physics_init.F @@ -1004,6 +1004,7 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf, & (config_flags%ra_sw_physics .eq. goddardswscheme ) ) .and. & (config_flags%mp_physics .eq. THOMPSON .or. & config_flags%mp_physics .eq. THOMPSONAERO .or. & + config_flags%mp_physics .eq. RCON_MP_SCHEME .or. & (config_flags%mp_physics .eq. NSSL_2MOM .and. config_flags%nssl_2moment_on == 1) .or. & config_flags%mp_physics .eq. WSM3SCHEME .or. & config_flags%mp_physics .eq. WSM5SCHEME .or. & @@ -1037,6 +1038,7 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf, & IF ( config_flags%swint_opt .eq. 2 ) THEN IF (( config_flags%mp_physics == THOMPSON .OR. & + config_flags%mp_physics == RCON_MP_SCHEME .OR. & config_flags%mp_physics == THOMPSONAERO .OR. & config_flags%mp_physics == WSM3SCHEME .OR. & config_flags%mp_physics == WSM5SCHEME .OR. & @@ -2660,7 +2662,7 @@ SUBROUTINE bl_init(STEPBL,BLDT,DT,RUBLTEN,RVBLTEN,RTHBLTEN, & USE module_bl_mfshconvpbl USE module_bl_gbmpbl #if ( EM_CORE == 1 ) - USE module_bl_mynn_wrapper + USE module_bl_mynnedmf_driver USE module_bl_eeps USE module_bl_temf #if ( WRFPLUS == 1 ) @@ -3840,7 +3842,7 @@ SUBROUTINE bl_init(STEPBL,BLDT,DT,RUBLTEN,RVBLTEN,RTHBLTEN, & IF ((SF_URBAN_PHYSICS.eq.2).OR.(SF_URBAN_PHYSICS.EQ.3)) CALL wrf_error_fatal & ( 'module_physics_init: use ysu (option1), myj (option 2), or boulac (option 8) with BEP/BEM urban scheme' ) - CALL mynnedmf_wrapper_init( & + CALL mynnedmf_init( & &RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN,RQCBLTEN, & &RQIBLTEN,QKE, & &restart,allowed_to_read, & @@ -4379,6 +4381,7 @@ SUBROUTINE mp_init(RAINNC,SNOWNC,GRAUPELNC,config_flags,restart,warm_rain, ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) !------------------------------------------------------------------ + USE module_mp_rcon USE module_mp_wsm3 USE module_mp_wsm5 USE mp_wsm6 @@ -4401,6 +4404,7 @@ SUBROUTINE mp_init(RAINNC,SNOWNC,GRAUPELNC,config_flags,restart,warm_rain, USE module_mp_wdm5 USE module_mp_wdm6 USE module_mp_wdm7 + USE module_mp_udm #if (WRFPLUS != 1) & !defined( VAR4D ) USE module_mp_nssl_2mom, only: nssl_2mom_init #endif @@ -4537,6 +4541,23 @@ SUBROUTINE mp_init(RAINNC,SNOWNC,GRAUPELNC,config_flags,restart,warm_rain, IMS=ims, IME=ime, JMS=jms, JME=jme, KMS=kms, KME=kme, & ITS=its, ITE=ite, JTS=jts, JTE=jte, KTS=kts, KTE=kte) + CASE (RCON_MP_SCHEME) + IF(start_of_simulation.or.restart.or.config_flags%cycling) & + CALL rcon_init(HGT=z_at_q, & + ORHO=inv_dens, & + NWFA2D=qnwfa2d, NBCA2D=qnbca2d, & + NWFA=scalar(ims,kms,jms,P_QNWFA), & + NIFA=scalar(ims,kms,jms,P_QNIFA), & + NBCA=scalar(ims,kms,jms,P_QNBCA), & + wif_input_opt=config_flags%wif_input_opt, & + FRC_URB2D=frc_urb2d, & + DX=DX, DY=DY, & + is_start=start_of_simulation, & + IDS=ids, IDE=ide, JDS=jds, JDE=jde, KDS=kds, KDE=kde, & + IMS=ims, IME=ime, JMS=jms, JME=jme, KMS=kms, KME=kme, & + ITS=its, ITE=ite, JTS=jts, JTE=jte, KTS=kts, KTE=kte) + + CASE (THOMPSONGH) ! Cycling the WRF forecast with moving nests will cause this initialization to be ! called for each nest move. This is potentially very computationally expensive. @@ -4584,6 +4605,11 @@ SUBROUTINE mp_init(RAINNC,SNOWNC,GRAUPELNC,config_flags,restart,warm_rain, config_flags%hail_opt, allowed_to_read ) CASE (WDM7SCHEME) CALL wdm7init(rhoair0,rhowater,rhosnow,cliq,cpv,ccn_conc, allowed_to_read ) + CASE (UDMSCHEME) + CALL udminit(rhoair0,rhowater,rhosnow,cliq,cpv,ccn_conc, allowed_to_read ) + call udm_funct_shape_setup + call udm_funct_svp_setup + call udm_funct_lb2017_setup #if (EM_CORE==1) CASE (NTU) CALL ntu_init(PHB,PH,P,PB,inv_dens,QV,QDCN,QTCN,QCCN,QRCN, & @@ -4644,11 +4670,12 @@ SUBROUTINE mp_init(RAINNC,SNOWNC,GRAUPELNC,config_flags,restart,warm_rain, ccn_conc = config_flags%nssl_cccn/1.225 ! set this to have correct boundary conditions ENDIF CALL nssl_2mom_init(nssl_params=nssl_params,ipctmp=nssl_ipconc,mixphase=0, & - nssl_density_on=(config_flags%nssl_density_on > 0), & - nssl_hail_on=config_flags%nssl_hail_on > 0, & - nssl_ccn_on=(config_flags%nssl_ccn_on > 0), & - nssl_icdx=config_flags%nssl_icdx, & - nssl_icdxhl=config_flags%nssl_icdxhl,ccn_is_ccna=config_flags%nssl_ccn_is_ccna) + nssl_density_on=(config_flags%nssl_density_on > 0), & + nssl_hail_on=config_flags%nssl_hail_on > 0, & + nssl_ccn_on=( config_flags%nssl_ccn_on > 0 ), & + nssl_icdx=config_flags%nssl_icdx, & + nssl_icdxhl=config_flags%nssl_icdxhl, & + ccn_is_ccna=config_flags%nssl_ccn_is_ccna) #endif #if (EM_CORE==1) CASE (CAMMGMPSCHEME) ! CAM5's microphysics diff --git a/phys/module_ra_cam_support.F b/phys/module_ra_cam_support.F index 4e71f21dcd..86c1ffd501 100644 --- a/phys/module_ra_cam_support.F +++ b/phys/module_ra_cam_support.F @@ -3517,7 +3517,7 @@ subroutine oznini(ozmixm,pin,levsiz,num_months,XLAT, & #if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) endif if_master call wrf_debug(1,"Broadcast ozone to other ranks.") -# if ( RWORDSIZE == DWORDSIZE ) +# ifdef DOUBLE_PRECISION call MPI_Bcast(ozmixin,size(ozmixin),MPI_DOUBLE_PRECISION,0,local_communicator,ierr) call MPI_Bcast(pin,size(pin),MPI_DOUBLE_PRECISION,0,local_communicator,ierr) plev=pin diff --git a/phys/module_ra_goddard.F b/phys/module_ra_goddard.F index f9387c1a92..402491dc1a 100644 --- a/phys/module_ra_goddard.F +++ b/phys/module_ra_goddard.F @@ -2062,14 +2062,14 @@ subroutine goddardrad( sw_or_lw, dx & ENDDO -#if (RWORDSIZE == 4) +#ifndef DOUBLE_PRECISION call swrad ( np=dk_half, icb=icb, ict=ict, fcld=dble(fcld1d), & pl=dble(p8w1d), ta=dble(t1d), wa=dble(sh1d), oa=dble(o31d), & taucl=dble(taucl_sw), ssacl=dble(ssacl_sw), asycl=dble(asycl_sw), & taual=dble(taual_sw), ssaal=dble(ssaal_sw), asyal=dble(asyal_sw), & cosz=dble(cosz), rsuvbm=dble(rsuvbm), rsuvdf=dble(rsuvdf), rsirbm=dble(rsirbm), rsirdf=dble(rsirdf),& flx_out=flx, flxd_out=flxd,flxu_out=flxu, flxd_surf = flxd_surf, lmask=lmask, irestrict=min(CHUNK,ite-ii+1) ) -#elif (RWORDSIZE == 8) +#else call swrad ( np=dk_half, icb=icb, ict=ict, fcld=fcld1d, & pl=p8w1d, ta=t1d, wa=sh1d, oa=o31d, & taucl=taucl_sw, ssacl=ssacl_sw, asycl=asycl_sw, & @@ -2312,14 +2312,14 @@ subroutine goddardrad( sw_or_lw, dx & ! 1-dimension driver of longwave radiative transfer scheme ! -#if (RWORDSIZE == 4) +#ifndef DOUBLE_PRECISION call lwrad ( np=dk_half, tb=dble(tsfc), ts=dble(tskin), ict=ict, icb=icb,& pl=dble(p8w1d), ta=dble(t1d), wa=dble(sh1d), oa=dble(o31d), & emiss=dble(emis1d), fcld=dble(fcld1d), & taucl=dble(taucl_lw), ssacl=dble(ssacl_lw), asycl=dble(asycl_lw), & taual=dble(taual_lw), ssaal=dble(ssaal_lw), asyal=dble(asyal_lw), & flx_out=flx, acflxd_out=flxd, acflxu_out=flxu, irestrict=min(CHUNK,ite-ii+1) ) -#elif (RWORDSIZE == 8) +#else call lwrad ( np=dk_half, tb=tsfc, ts=tskin, ict=ict, icb=icb,& pl=p8w1d, ta=t1d, wa=sh1d, oa=o31d, & emiss=emis1d, fcld=fcld1d, & diff --git a/phys/module_ra_rrtmg_aero_optical_util_cmaq.F b/phys/module_ra_rrtmg_aero_optical_util_cmaq.F index 7ec0864a4e..48ba55d893 100644 --- a/phys/module_ra_rrtmg_aero_optical_util_cmaq.F +++ b/phys/module_ra_rrtmg_aero_optical_util_cmaq.F @@ -1687,7 +1687,7 @@ SUBROUTINE BHCOAT (XX, YY, RRFRL1, RRFRL2, QQEXT, QQSCA, QBACK, GGSCA, SUCCESS) SUCCESS = .TRUE. -#if ( RWORDSIZE == 8 ) +#ifdef DOUBLE_PRECISION II = c_set(0.0, 1.0) #else II = c_set(0.0D0, 1.0D0) @@ -1733,13 +1733,13 @@ SUBROUTINE BHCOAT (XX, YY, RRFRL1, RRFRL2, QQEXT, QQSCA, QBACK, GGSCA, SUCCESS) xi0y = c_sub(psi0y, c_mul(chi0y, II)) xi1y = c_sub(psi1y, c_mul(chi1y, II)) -#if ( RWORDSIZE == 8 ) +#ifdef DOUBLE_PRECISION chi0y2 = c_mul(-1.0, c_SIN(y2)) #else chi0y2 = c_mul(-1.0d0, c_SIN(y2)) #endif chi1y2 = c_COS(y2) -#if ( RWORDSIZE == 8 ) +#ifdef DOUBLE_PRECISION chi0x2 = c_mul(-1.0, c_SIN(x2)) #else chi0x2 = c_mul(-1.0d0, c_SIN(x2)) @@ -1748,7 +1748,7 @@ SUBROUTINE BHCOAT (XX, YY, RRFRL1, RRFRL2, QQEXT, QQSCA, QBACK, GGSCA, SUCCESS) qsca = 0.0d0 qext = 0.0d0 GSCA = 0.0d0 -#if ( RWORDSIZE == 8 ) +#ifdef DOUBLE_PRECISION xback = c_set(0.0, 0.0) #else xback = c_set(0.0d0, 0.0d0) @@ -1806,7 +1806,7 @@ SUBROUTINE BHCOAT (XX, YY, RRFRL1, RRFRL2, QQEXT, QQSCA, QBACK, GGSCA, SUCCESS) (c_ABS(amess3) .LE. del*c_ABS(d1y2)) .AND. & (c_ABS(amess4) .LE. del) ) THEN ! convergence for inner sphere -#if ( RWORDSIZE == 8 ) +#ifdef DOUBLE_PRECISION brack = c_set(0.0,0.0) crack = c_set(0.0,0.0) #else diff --git a/phys/module_ra_rrtmg_lw.F b/phys/module_ra_rrtmg_lw.F index 6b5dc2d342..fd04a0370c 100644 --- a/phys/module_ra_rrtmg_lw.F +++ b/phys/module_ra_rrtmg_lw.F @@ -32,10 +32,10 @@ module parkind #if 0 ! Modified for WRF: -#if (RWORDSIZE == 8) +#ifdef DOUBLE_PRECISION integer, parameter :: kind_rb = selected_real_kind(12) ! 8 byte real #endif -#if (RWORDSIZE == 4) +#ifndef DOUBLE_PRECISION integer, parameter :: kind_rb = selected_real_kind(6) ! 4 byte real #endif #else diff --git a/phys/module_sf_bep_bem.F b/phys/module_sf_bep_bem.F index f249700a08..656fa1bc90 100644 --- a/phys/module_sf_bep_bem.F +++ b/phys/module_sf_bep_bem.F @@ -1597,7 +1597,7 @@ subroutine BEP1D(itimestep,ix,iy,iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, - do iz=1,nz_um !Compute the outdoor temperature + do iz=1,nzu !Compute the outdoor temperature tmp_u(iz)=pt_u(iz)*(pr_u(iz)/p0)**(rcp_u) end do diff --git a/phys/module_sf_fogdes.F b/phys/module_sf_fogdes.F index 9d2a3d6fae..afa6ddfe69 100644 --- a/phys/module_sf_fogdes.F +++ b/phys/module_sf_fogdes.F @@ -13,7 +13,7 @@ MODULE module_sf_fogdes SUBROUTINE sf_fogdes(& vdfg,fgdp,dfgdp,ivgtyp,lai,wspd,qc_curr, & - dtbl,rho,dz8w,grav_settling,nlcat, & + dtbl,rho,dz8w,grav_settling,nlcat,mminlu, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte & @@ -81,7 +81,7 @@ SUBROUTINE sf_fogdes(& ,ids,ide,jds,jde,kds,kde INTEGER, INTENT(IN) :: grav_settling,nlcat - + CHARACTER (LEN=*), INTENT(IN):: mminlu INTEGER,DIMENSION( ims:ime , jms:jme ),INTENT(INOUT) :: ivgtyp REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & @@ -105,18 +105,20 @@ SUBROUTINE sf_fogdes(& !JOE-end ! Local variables + CHARACTER*512 :: message INTEGER :: i,j REAL :: lad, spcfct, vegh, ftmp1, ftmp2, dp_fog, lwc CHARACTER (LEN=25) :: land_use_type, lu_fogdes !------------------------------------------------------------------ - IF ((nlcat .eq. 20).or.(nlcat .eq. 21)) THEN ! includes lake category + IF (mminlu .eq. 'MODIFIED_IGBP_MODIS_NOAH') THEN ! includes lake category land_use_type = 'MODIS' - ELSEIF ((nlcat .eq. 24).or.(nlcat .eq. 28)) THEN ! includes lake category + ELSEIF (mminlu .eq. 'USGS') THEN ! includes lake category land_use_type = 'USGS' ELSE - PRINT *, 'Unknown landuse category (sf_fogdes.F): num_land_cat=',nlcat + write ( message, * ) "Unknown land category for grav_settling (sf_fogdes.F) Landuse type = ",mminlu," and number of land categories= ",nlcat + CALL wrf_error_fatal ( message ) STOP END IF diff --git a/phys/module_surface_driver.F b/phys/module_surface_driver.F index 650dd4fe87..036c006446 100644 --- a/phys/module_surface_driver.F +++ b/phys/module_surface_driver.F @@ -363,6 +363,7 @@ SUBROUTINE surface_driver( & USE module_sf_gfs USE module_sf_noahdrv ! danli mosaic, the " ,only : lsm " needs to be deleted USE module_sf_noahlsm, only : LCZ_1,LCZ_2,LCZ_3,LCZ_4,LCZ_5,LCZ_6,LCZ_7,LCZ_8,LCZ_9,LCZ_10,LCZ_11 + USE noahmp_tables, only : LCZ_1_TABLE,LCZ_2_TABLE,LCZ_3_TABLE,LCZ_4_TABLE,LCZ_5_TABLE,LCZ_6_TABLE,LCZ_7_TABLE,LCZ_8_TABLE,LCZ_9_TABLE,LCZ_10_TABLE,LCZ_11_TABLE USE module_sf_noahmpdrv, only : noahmplsm, noahmp_urban USE module_sf_noahmp_groundwater USE module_sf_noah_seaice_drv @@ -2509,7 +2510,7 @@ SUBROUTINE surface_driver( & CALL sf_fogdes( & vdfg,fgdp,dfgdp,ivgtyp,lai,wspd,qc_curr, & - dtbl,rho,dz8w,grav_settling,nlcat, & + dtbl,rho,dz8w,grav_settling,nlcat,mminlu, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & i_start(ij),i_end(ij), & @@ -3354,10 +3355,10 @@ SUBROUTINE surface_driver( & ENDIF TH2(I,J) = T2(I,J)*(1.E5/PSFC(I,J))**RCP ! ELSEIF (IVGTYP(I,J) == ISURBAN .OR. IVGTYP(I,J) == ISICE .OR. FVEGXY(I,J) == 0.0 ) THEN - ELSEIF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LCZ_1 .or. IVGTYP(I,J) == LCZ_2 .or. & - IVGTYP(I,J) == LCZ_3 .or. IVGTYP(I,J) == LCZ_4 .or. IVGTYP(I,J) == LCZ_5 .or. & - IVGTYP(I,J) == LCZ_6 .or. IVGTYP(I,J) == LCZ_7 .or. IVGTYP(I,J) == LCZ_8 .or. & - IVGTYP(I,J) == LCZ_9 .or. IVGTYP(I,J) == LCZ_10 .or. IVGTYP(I,J) == LCZ_11 .or. & + ELSEIF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LCZ_1_TABLE .or. IVGTYP(I,J) == LCZ_2_TABLE .or. & + IVGTYP(I,J) == LCZ_3_TABLE .or. IVGTYP(I,J) == LCZ_4_TABLE .or. IVGTYP(I,J) == LCZ_5_TABLE .or. & + IVGTYP(I,J) == LCZ_6_TABLE .or. IVGTYP(I,J) == LCZ_7_TABLE .or. IVGTYP(I,J) == LCZ_8_TABLE .or. & + IVGTYP(I,J) == LCZ_9_TABLE .or. IVGTYP(I,J) == LCZ_10_TABLE .or. IVGTYP(I,J) == LCZ_11_TABLE .or. & (IVGTYP(I,J) == ISICE .AND. XICE(I,J) .LT. XICE_THRESHOLD)) THEN Q2(I,J) = Q2MBXY(I,J) @@ -3382,10 +3383,10 @@ SUBROUTINE surface_driver( & IF(SF_URBAN_PHYSICS.eq.1) THEN DO j=j_start(ij),j_end(ij) !urban DO i=i_start(ij),i_end(ij) !urban - IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LCZ_1 .or. IVGTYP(I,J) == LCZ_2 .or. & - IVGTYP(I,J) == LCZ_3 .or. IVGTYP(I,J) == LCZ_4 .or. IVGTYP(I,J) == LCZ_5 .or. & - IVGTYP(I,J) == LCZ_6 .or. IVGTYP(I,J) == LCZ_7 .or. IVGTYP(I,J) == LCZ_8 .or. & - IVGTYP(I,J) == LCZ_9 .or. IVGTYP(I,J) == LCZ_10 .or. IVGTYP(I,J) == LCZ_11 )THEN + IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LCZ_1_TABLE .or. IVGTYP(I,J) == LCZ_2_TABLE .or. & + IVGTYP(I,J) == LCZ_3_TABLE .or. IVGTYP(I,J) == LCZ_4_TABLE .or. IVGTYP(I,J) == LCZ_5_TABLE .or. & + IVGTYP(I,J) == LCZ_6_TABLE .or. IVGTYP(I,J) == LCZ_7_TABLE .or. IVGTYP(I,J) == LCZ_8_TABLE .or. & + IVGTYP(I,J) == LCZ_9_TABLE .or. IVGTYP(I,J) == LCZ_10_TABLE .or. IVGTYP(I,J) == LCZ_11_TABLE )THEN Q2(I,J) = (FVEGXY(I,J)*Q2MVXY(I,J) + (1.-FVEGXY(I,J))*Q2MBXY(I,J))*(1.-FRC_URB2D(I,J)) + & Q2_URB2D(I,J)*FRC_URB2D(I,J) T2(I,J) = (FVEGXY(I,J)*T2MVXY(I,J) + (1.-FVEGXY(I,J))*T2MBXY(I,J))*(1.-FRC_URB2D(I,J)) + & @@ -3406,10 +3407,10 @@ SUBROUTINE surface_driver( & IF((SF_URBAN_PHYSICS.eq.2).OR.(SF_URBAN_PHYSICS.eq.3)) THEN DO j=j_start(ij),j_end(ij) !urban DO i=i_start(ij),i_end(ij) !urban - IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LCZ_1 .or. IVGTYP(I,J) == LCZ_2 .or. & - IVGTYP(I,J) == LCZ_3 .or. IVGTYP(I,J) == LCZ_4 .or. IVGTYP(I,J) == LCZ_5 .or. & - IVGTYP(I,J) == LCZ_6 .or. IVGTYP(I,J) == LCZ_7 .or. IVGTYP(I,J) == LCZ_8 .or. & - IVGTYP(I,J) == LCZ_9 .or. IVGTYP(I,J) == LCZ_10 .or. IVGTYP(I,J) == LCZ_11 )THEN + IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LCZ_1_TABLE .or. IVGTYP(I,J) == LCZ_2_TABLE .or. & + IVGTYP(I,J) == LCZ_3_TABLE .or. IVGTYP(I,J) == LCZ_4_TABLE .or. IVGTYP(I,J) == LCZ_5_TABLE .or. & + IVGTYP(I,J) == LCZ_6_TABLE .or. IVGTYP(I,J) == LCZ_7_TABLE .or. IVGTYP(I,J) == LCZ_8_TABLE .or. & + IVGTYP(I,J) == LCZ_9_TABLE .or. IVGTYP(I,J) == LCZ_10_TABLE .or. IVGTYP(I,J) == LCZ_11_TABLE )THEN T2(I,J) = TH_PHY(i,1,j)/((1.E5/PSFC(I,J))**RCP) !urban TH2(I,J) = TH_PHY(i,1,j) !urban Q2(I,J) = qv_curr(i,1,j) !urban diff --git a/phys/noahmp b/phys/noahmp index 848f54ad3d..e5c0859874 160000 --- a/phys/noahmp +++ b/phys/noahmp @@ -1 +1 @@ -Subproject commit 848f54ad3d28c4303151fe5ad83724e232694422 +Subproject commit e5c0859874407859936739e8be8741f9aed369ee diff --git a/phys/physics_mmm/bl_gwdo.F90 b/phys/physics_mmm/bl_gwdo.F90 deleted file mode 100644 index b314634539..0000000000 --- a/phys/physics_mmm/bl_gwdo.F90 +++ /dev/null @@ -1,649 +0,0 @@ -!================================================================================================================= - module bl_gwdo - use ccpp_kind_types,only: kind_phys - - implicit none - private - public:: bl_gwdo_run, & - bl_gwdo_init, & - bl_gwdo_finalize - - - contains - - -!================================================================================================================= -!>\section arg_table_bl_gwdo_init -!!\html\include bl_gwdo_init.html -!! - subroutine bl_gwdo_init(errmsg,errflg) -!================================================================================================================= - -!--- output arguments: - character(len=*),intent(out):: errmsg - integer,intent(out):: errflg - -!----------------------------------------------------------------------------------------------------------------- - - errmsg = 'bl_gwdo_init OK' - errflg = 0 - - end subroutine bl_gwdo_init - -!================================================================================================================= -!>\section arg_table_bl_gwdo_finalize -!!\html\include bl_gwdo_finalize.html -!! - subroutine bl_gwdo_finalize(errmsg,errflg) -!================================================================================================================= - -!--- output arguments: - character(len=*),intent(out):: errmsg - integer,intent(out):: errflg - -!----------------------------------------------------------------------------------------------------------------- - - errmsg = 'bl_gwdo_finalize OK' - errflg = 0 - - end subroutine bl_gwdo_finalize - -!================================================================================================================= -!>\section arg_table_bl_gwdo_run -!!\html\include bl_gwdo_run.html -!! - subroutine bl_gwdo_run(sina, cosa, & - rublten,rvblten, & - dtaux3d,dtauy3d, & - dusfcg,dvsfcg, & - uproj, vproj, & - t1, q1, & - prsi, prsl, prslk, zl, & - var, oc1, & - oa2d1, oa2d2, & - oa2d3, oa2d4, & - ol2d1, ol2d2, & - ol2d3, ol2d4, & - g_, cp_, rd_, rv_, fv_, pi_, & - dxmeter, deltim, & - its, ite, kte, kme, & - errmsg, errflg ) -!------------------------------------------------------------------------------- -! -! abstract : -! this code handles the time tendencies of u v due to the effect of -! mountain induced gravity wave drag from sub-grid scale orography. -! this routine not only treats the traditional upper-level wave breaking due -! to mountain variance (alpert 1988), but also the enhanced -! lower-tropospheric wave breaking due to mountain convexity and asymmetry -! (kim and arakawa 1995). thus, in addition to the terrain height data -! in a model grid gox, additional 10-2d topographic statistics files are -! needed, including orographic standard deviation (var), convexity (oc1), -! asymmetry (oa4) and ol (ol4). these data sets are prepared based on the -! 30 sec usgs orography (hong 1999). the current scheme was implmented as in -! choi and hong (2015), which names kim gwdo since it was developed by -! kiaps staffs for kiaps integrated model system (kim). the scheme -! additionally includes the effects of orographic anisotropy and -! flow-blocking drag. -! coded by song-you hong and young-joon kim and implemented by song-you hong -! -! history log : -! 2015-07-01 hyun-joo choi add flow-blocking drag and orographic anisotropy -! -! references : -! choi and hong (2015), j. geophys. res. -! hong et al. (2008), wea. forecasting -! kim and doyle (2005), q. j. r. meteor. soc. -! kim and arakawa (1995), j. atmos. sci. -! alpet et al. (1988), NWP conference -! hong (1999), NCEP office note 424 -! -! input : -! dudt, dvdt - non-lin tendency for u and v wind component -! uproj, vproj - projection-relative U and V m/sec -! u1, v1 - zonal and meridional wind m/sec at t0-dt -! t1 - temperature deg k at t0-dt -! q1 - mixing ratio at t0-dt -! deltim - time step (s) -! del - positive increment of pressure across layer (pa) -! prslk, zl, prsl, prsi - pressure and height variables -! oa4, ol4, omax, var, oc1 - orographic statistics -! -! output : -! dudt, dvdt - wind tendency due to gwdo -! dtaux2d, dtauy2d - diagnoised orographic gwd -! dusfc, dvsfc - gw stress -! -!------------------------------------------------------------------------------- - implicit none -! - integer, parameter :: kts = 1 - integer , intent(in ) :: its, ite, kte, kme - real(kind=kind_phys) , intent(in ) :: g_, pi_, rd_, rv_, fv_,& - cp_, deltim - real(kind=kind_phys), dimension(its:) , intent(in ) :: dxmeter - real(kind=kind_phys), dimension(its:,:) , intent(inout) :: rublten, rvblten - real(kind=kind_phys), dimension(its:,:) , intent( out) :: dtaux3d, dtauy3d - real(kind=kind_phys), dimension(its:) , intent( out) :: dusfcg, dvsfcg - real(kind=kind_phys), dimension(its:) , intent(in ) :: sina, cosa - real(kind=kind_phys), dimension(its:,:) , intent(in ) :: uproj, vproj - real(kind=kind_phys), dimension(its:,:) , intent(in ) :: t1, q1, prslk, zl -! - real(kind=kind_phys), dimension(its:,:) , intent(in ) :: prsl - real(kind=kind_phys), dimension(its:,:) , intent(in ) :: prsi -! - real(kind=kind_phys), dimension(its:) , intent(in ) :: var, oc1, & - oa2d1, oa2d2, oa2d3, oa2d4, & - ol2d1, ol2d2, ol2d3, ol2d4 - character(len=*) , intent( out) :: errmsg - integer , intent( out) :: errflg -! - real(kind=kind_phys), parameter :: ric = 0.25 ! critical richardson number - real(kind=kind_phys), parameter :: dw2min = 1. - real(kind=kind_phys), parameter :: rimin = -100. - real(kind=kind_phys), parameter :: bnv2min = 1.0e-5 - real(kind=kind_phys), parameter :: efmin = 0.0 - real(kind=kind_phys), parameter :: efmax = 10.0 - real(kind=kind_phys), parameter :: xl = 4.0e4 - real(kind=kind_phys), parameter :: critac = 1.0e-5 - real(kind=kind_phys), parameter :: gmax = 1. - real(kind=kind_phys), parameter :: veleps = 1.0 - real(kind=kind_phys), parameter :: frc = 1.0 - real(kind=kind_phys), parameter :: ce = 0.8 - real(kind=kind_phys), parameter :: cg = 0.5 - integer,parameter :: kpblmin = 2 -! -! local variables -! - integer :: kpblmax - integer :: latd,lond - integer :: i,k,lcap,lcapp1,nwd,idir, & - klcap,kp1,ikount,kk -! - real(kind=kind_phys) :: fdir,cs,rcsks, & - wdir,ti,rdz,temp,tem2,dw2,shr2,bvf2,rdelks, & - wtkbj,tem,gfobnv,hd,fro,rim,temc,tem1,efact, & - temv,dtaux,dtauy -! - real(kind=kind_phys), dimension(its:ite,kts:kte) :: dudt, dvdt - real(kind=kind_phys), dimension(its:ite,kts:kte) :: dtaux2d, dtauy2d - real(kind=kind_phys), dimension(its:ite) :: dusfc, dvsfc - logical, dimension(its:ite) :: ldrag, icrilv, flag,kloop1 - real(kind=kind_phys), dimension(its:ite) :: coefm -! - real(kind=kind_phys), dimension(its:ite) :: taub, xn, yn, ubar, vbar, fr, & - ulow, rulow, bnv, oa, ol, rhobar, & - dtfac, brvf, xlinv, delks,delks1, & - zlowtop,cleff - real(kind=kind_phys), dimension(its:ite,kts:kte+1) :: taup - real(kind=kind_phys), dimension(its:ite,kts:kte-1) :: velco - real(kind=kind_phys), dimension(its:ite,kts:kte) :: bnv2, usqj, taud, rho, vtk, vtj - real(kind=kind_phys), dimension(its:ite,kts:kte) :: del - real(kind=kind_phys), dimension(its:ite,kts:kte) :: u1, v1 - real(kind=kind_phys), dimension(its:ite,4) :: oa4, ol4 -! - integer, dimension(its:ite) :: kbl, klowtop - integer, parameter :: mdir=8 - integer, dimension(mdir) :: nwdir - data nwdir/6,7,5,8,2,3,1,4/ -! -! variables for flow-blocking drag -! - real(kind=kind_phys), parameter :: frmax = 10. - real(kind=kind_phys), parameter :: olmin = 1.0e-5 - real(kind=kind_phys), parameter :: odmin = 0.1 - real(kind=kind_phys), parameter :: odmax = 10. -! - real(kind=kind_phys) :: fbdcd - real(kind=kind_phys) :: zblk, tautem - real(kind=kind_phys) :: fbdpe, fbdke - real(kind=kind_phys), dimension(its:ite) :: delx, dely - real(kind=kind_phys), dimension(its:ite,4) :: dxy4, dxy4p - real(kind=kind_phys), dimension(4) :: ol4p - real(kind=kind_phys), dimension(its:ite) :: dxy, dxyp, olp, od - real(kind=kind_phys), dimension(its:ite,kts:kte+1) :: taufb -! - integer, dimension(its:ite) :: komax - integer :: kblk -!------------------------------------------------------------------------------- -! -! constants -! - lcap = kte - lcapp1 = lcap + 1 - fdir = mdir / (2.0*pi_) -! -! initialize CCPP error flag and message -! - errmsg = '' - errflg = 0 -! -! calculate length of grid for flow-blocking drag -! - delx(its:ite) = dxmeter(its:ite) - dely(its:ite) = dxmeter(its:ite) - dxy4(its:ite,1) = delx(its:ite) - dxy4(its:ite,2) = dely(its:ite) - dxy4(its:ite,3) = sqrt(delx(its:ite)**2. + dely(its:ite)**2.) - dxy4(its:ite,4) = dxy4(its:ite,3) - dxy4p(its:ite,1) = dxy4(its:ite,2) - dxy4p(its:ite,2) = dxy4(its:ite,1) - dxy4p(its:ite,3) = dxy4(its:ite,4) - dxy4p(its:ite,4) = dxy4(its:ite,3) -! - cleff(its:ite) = dxmeter(its:ite) -! -! initialize arrays, array syntax is OK for OpenMP since these are local -! - ldrag = .false. ; icrilv = .false. ; flag = .true. -! - klowtop = 0 ; kbl = 0 -! - dtaux = 0. ; dtauy = 0. ; xn = 0. ; yn = 0. - ubar = 0. ; vbar = 0. ; rhobar = 0. ; ulow = 0. - oa = 0. ; ol = 0. ; taub = 0. -! - usqj = 0. ; bnv2 = 0. ; vtj = 0. ; vtk = 0. - taup = 0. ; taud = 0. ; dtaux2d = 0. ; dtauy2d = 0. -! - dtfac = 1.0 ; xlinv = 1.0/xl -! - komax = 0 - taufb = 0.0 -! - do k = kts,kte - do i = its,ite - vtj(i,k) = t1(i,k) * (1.+fv_*q1(i,k)) - vtk(i,k) = vtj(i,k) / prslk(i,k) - - ! Density (kg/m^3) - - rho(i,k) = 1./rd_ * prsl(i,k) / vtj(i,k) - - ! Delta p (positive) between interfaces levels (Pa) - - del(i,k) = prsi(i,k) - prsi(i,k+1) - - ! Earth-relative zonal and meridional winds (m/s) - - u1(i,k) = uproj(i,k)*cosa(i) - vproj(i,k)*sina(i) - v1(i,k) = uproj(i,k)*sina(i) + vproj(i,k)*cosa(i) - - enddo - enddo - -! - do i = its,ite - zlowtop(i) = 2. * var(i) - enddo -! - do i = its,ite - kloop1(i) = .true. - enddo -! - do k = kts+1,kte - do i = its,ite - if(zlowtop(i) .gt. 0.) then - if (kloop1(i).and.zl(i,k)-zl(i,1).ge.zlowtop(i)) then - klowtop(i) = k+1 - kloop1(i) = .false. - endif - endif - enddo - enddo -! - kpblmax = kte - do i = its,ite - kbl(i) = klowtop(i) - kbl(i) = max(min(kbl(i),kpblmax),kpblmin) - enddo -! -! determine the level of maximum orographic height -! - komax(:) = kbl(:) -! - do i = its,ite - delks(i) = 1.0 / (prsi(i,1) - prsi(i,kbl(i))) - delks1(i) = 1.0 / (prsl(i,1) - prsl(i,kbl(i))) - enddo -! -! compute low level averages within pbl -! - do k = kts,kpblmax - do i = its,ite - if (k.lt.kbl(i)) then - rcsks = del(i,k) * delks(i) - rdelks = del(i,k) * delks(i) - ubar(i) = ubar(i) + rcsks * u1(i,k) ! pbl u mean - vbar(i) = vbar(i) + rcsks * v1(i,k) ! pbl v mean - rhobar(i) = rhobar(i) + rdelks * rho(i,k) ! pbl rho mean - endif - enddo - enddo -! -! figure out low-level horizontal wind direction -! -! nwd 1 2 3 4 5 6 7 8 -! wd w s sw nw e n ne se -! - do i = its,ite - oa4(i,1) = oa2d1(i) - oa4(i,2) = oa2d2(i) - oa4(i,3) = oa2d3(i) - oa4(i,4) = oa2d4(i) - ol4(i,1) = ol2d1(i) - ol4(i,2) = ol2d2(i) - ol4(i,3) = ol2d3(i) - ol4(i,4) = ol2d4(i) - wdir = atan2(ubar(i),vbar(i)) + pi_ - idir = mod(nint(fdir*wdir),mdir) + 1 - nwd = nwdir(idir) - oa(i) = (1-2*int( (nwd-1)/4 )) * oa4(i,mod(nwd-1,4)+1) - ol(i) = ol4(i,mod(nwd-1,4)+1) -! -! compute orographic width along (ol) and perpendicular (olp) the wind direction -! - ol4p(1) = ol4(i,2) - ol4p(2) = ol4(i,1) - ol4p(3) = ol4(i,4) - ol4p(4) = ol4(i,3) - olp(i) = ol4p(mod(nwd-1,4)+1) -! -! compute orographic direction (horizontal orographic aspect ratio) -! - od(i) = olp(i)/max(ol(i),olmin) - od(i) = min(od(i),odmax) - od(i) = max(od(i),odmin) -! -! compute length of grid in the along(dxy) and cross(dxyp) wind directions -! - dxy(i) = dxy4(i,MOD(nwd-1,4)+1) - dxyp(i) = dxy4p(i,MOD(nwd-1,4)+1) - enddo -! -! saving richardson number in usqj for migwdi -! - do k = kts,kte-1 - do i = its,ite - ti = 2.0 / (t1(i,k)+t1(i,k+1)) - rdz = 1./(zl(i,k+1) - zl(i,k)) - tem1 = u1(i,k) - u1(i,k+1) - tem2 = v1(i,k) - v1(i,k+1) - dw2 = tem1*tem1 + tem2*tem2 - shr2 = max(dw2,dw2min) * rdz * rdz - bvf2 = g_*(g_/cp_+rdz*(vtj(i,k+1)-vtj(i,k))) * ti - usqj(i,k) = max(bvf2/shr2,rimin) - bnv2(i,k) = 2.0*g_*rdz*(vtk(i,k+1)-vtk(i,k))/(vtk(i,k+1)+vtk(i,k)) - enddo - enddo -! -! compute the "low level" or 1/3 wind magnitude (m/s) -! - do i = its,ite - ulow(i) = max(sqrt(ubar(i)*ubar(i) + vbar(i)*vbar(i)), 1.0) - rulow(i) = 1./ulow(i) - enddo -! - do k = kts,kte-1 - do i = its,ite - velco(i,k) = 0.5 * ((u1(i,k)+u1(i,k+1)) * ubar(i) & - + (v1(i,k)+v1(i,k+1)) * vbar(i)) - velco(i,k) = velco(i,k) * rulow(i) - if ((velco(i,k).lt.veleps) .and. (velco(i,k).gt.0.)) then - velco(i,k) = veleps - endif - enddo - enddo -! -! no drag when critical level in the base layer -! - do i = its,ite - ldrag(i) = velco(i,1).le.0. - enddo -! -! no drag when velco.lt.0 -! - do k = kpblmin,kpblmax - do i = its,ite - if (k .lt. kbl(i)) ldrag(i) = ldrag(i).or. velco(i,k).le.0. - enddo - enddo -! -! the low level weighted average ri is stored in usqj(1,1; im) -! the low level weighted average n**2 is stored in bnv2(1,1; im) -! this is called bnvl2 in phy_gwd_alpert_sub not bnv2 -! rdelks (del(k)/delks) vert ave factor so we can * instead of / -! - do i = its,ite - wtkbj = (prsl(i,1)-prsl(i,2)) * delks1(i) - bnv2(i,1) = wtkbj * bnv2(i,1) - usqj(i,1) = wtkbj * usqj(i,1) - enddo -! - do k = kpblmin,kpblmax - do i = its,ite - if (k .lt. kbl(i)) then - rdelks = (prsl(i,k)-prsl(i,k+1)) * delks1(i) - bnv2(i,1) = bnv2(i,1) + bnv2(i,k) * rdelks - usqj(i,1) = usqj(i,1) + usqj(i,k) * rdelks - endif - enddo - enddo -! - do i = its,ite - ldrag(i) = ldrag(i) .or. bnv2(i,1).le.0.0 - ldrag(i) = ldrag(i) .or. ulow(i).eq.1.0 - ldrag(i) = ldrag(i) .or. var(i) .le. 0.0 - enddo -! -! set all ri low level values to the low level value -! - do k = kpblmin,kpblmax - do i = its,ite - if (k .lt. kbl(i)) usqj(i,k) = usqj(i,1) - enddo - enddo -! - do i = its,ite - if (.not.ldrag(i)) then - bnv(i) = sqrt( bnv2(i,1) ) - fr(i) = bnv(i) * rulow(i) * var(i) * od(i) - fr(i) = min(fr(i),frmax) - xn(i) = ubar(i) * rulow(i) - yn(i) = vbar(i) * rulow(i) - endif - enddo -! -! compute the base level stress and store it in taub -! calculate enhancement factor, number of mountains & aspect -! ratio const. use simplified relationship between standard -! deviation & critical hgt -! - do i = its,ite - if (.not. ldrag(i)) then - efact = (oa(i) + 2.) ** (ce*fr(i)/frc) - efact = min( max(efact,efmin), efmax ) - coefm(i) = (1. + ol(i)) ** (oa(i)+1.) - xlinv(i) = coefm(i) / cleff(i) - tem = fr(i) * fr(i) * oc1(i) - gfobnv = gmax * tem / ((tem + cg)*bnv(i)) - taub(i) = xlinv(i) * rhobar(i) * ulow(i) * ulow(i) & - * ulow(i) * gfobnv * efact - else - taub(i) = 0.0 - xn(i) = 0.0 - yn(i) = 0.0 - endif - enddo -! -! now compute vertical structure of the stress. -! - do k = kts,kpblmax - do i = its,ite - if (k .le. kbl(i)) taup(i,k) = taub(i) - enddo - enddo -! - do k = kpblmin, kte-1 ! vertical level k loop! - kp1 = k + 1 - do i = its,ite -! -! unstablelayer if ri < ric -! unstable layer if upper air vel comp along surf vel <=0 (crit lay) -! at (u-c)=0. crit layer exists and bit vector should be set (.le.) -! - if (k .ge. kbl(i)) then - icrilv(i) = icrilv(i) .or. ( usqj(i,k) .lt. ric) & - .or. (velco(i,k) .le. 0.0) - brvf(i) = max(bnv2(i,k),bnv2min) ! brunt-vaisala frequency squared - brvf(i) = sqrt(brvf(i)) ! brunt-vaisala frequency - endif - enddo -! - do i = its,ite - if (k .ge. kbl(i) .and. (.not. ldrag(i))) then - if (.not.icrilv(i) .and. taup(i,k) .gt. 0.0 ) then - temv = 1.0 / velco(i,k) - tem1 = coefm(i)/dxy(i)*(rho(i,kp1)+rho(i,k))*brvf(i)*velco(i,k)*0.5 - hd = sqrt(taup(i,k) / tem1) - fro = brvf(i) * hd * temv -! -! rim is the minimum-richardson number by shutts (1985) -! - tem2 = sqrt(usqj(i,k)) - tem = 1. + tem2 * fro - rim = usqj(i,k) * (1.-fro) / (tem * tem) -! -! check stability to employ the 'saturation hypothesis' -! of lindzen (1981) except at tropospheric downstream regions -! - if (rim .le. ric) then ! saturation hypothesis! - if ((oa(i) .le. 0.).or.(kp1 .ge. kpblmin )) then - temc = 2.0 + 1.0 / tem2 - hd = velco(i,k) * (2.*sqrt(temc)-temc) / brvf(i) - taup(i,kp1) = tem1 * hd * hd - endif - else ! no wavebreaking! - taup(i,kp1) = taup(i,k) - endif - endif - endif - enddo - enddo -! - if (lcap.lt.kte) then - do klcap = lcapp1,kte - do i = its,ite - taup(i,klcap) = prsi(i,klcap) / prsi(i,lcap) * taup(i,lcap) - enddo - enddo - endif - do i = its,ite - if (.not.ldrag(i)) then -! -! determine the height of flow-blocking layer -! - kblk = 0 - fbdpe = 0.0 - fbdke = 0.0 - do k = kte, kpblmin, -1 - if (kblk.eq.0 .and. k.le.kbl(i)) then - fbdpe = fbdpe + bnv2(i,k)*(zl(i,kbl(i))-zl(i,k)) & - *del(i,k)/g_/rho(i,k) - fbdke = 0.5*(u1(i,k)**2.+v1(i,k)**2.) -! -! apply flow-blocking drag when fbdpe >= fbdke -! - if (fbdpe.ge.fbdke) then - kblk = k - kblk = min(kblk,kbl(i)) - zblk = zl(i,kblk)-zl(i,kts) - endif - endif - enddo - if (kblk.ne.0) then -! -! compute flow-blocking stress -! - fbdcd = max(2.0-1.0/od(i),0.0) - taufb(i,kts) = 0.5*rhobar(i)*coefm(i)/dxmeter(i)**2*fbdcd*dxyp(i) & - *olp(i)*zblk*ulow(i)**2 - tautem = taufb(i,kts)/real(kblk-kts) - do k = kts+1, kblk - taufb(i,k) = taufb(i,k-1) - tautem - enddo -! -! sum orographic GW stress and flow-blocking stress -! - taup(i,:) = taup(i,:) + taufb(i,:) - endif - endif - enddo -! -! calculate - (g)*d(tau)/d(pressure) and deceleration terms dtaux, dtauy -! - do k = kts,kte - do i = its,ite - taud(i,k) = 1. * (taup(i,k+1) - taup(i,k)) * g_ / del(i,k) - enddo - enddo -! -! if the gravity wave drag would force a critical line -! in the lower ksmm1 layers during the next deltim timestep, -! then only apply drag until that critical line is reached. -! - do k = kts,kpblmax-1 - do i = its,ite - if (k .le. kbl(i)) then - if (taud(i,k).ne.0.) & - dtfac(i) = min(dtfac(i),abs(velco(i,k)/(deltim*taud(i,k)))) - endif - enddo - enddo -! - do i = its,ite - dusfc(i) = 0. - dvsfc(i) = 0. - enddo -! - do k = kts,kte - do i = its,ite - taud(i,k) = taud(i,k) * dtfac(i) - dtaux = taud(i,k) * xn(i) - dtauy = taud(i,k) * yn(i) - dtaux2d(i,k) = dtaux - dtauy2d(i,k) = dtauy - dudt(i,k) = dtaux - dvdt(i,k) = dtauy - dusfc(i) = dusfc(i) + dtaux * del(i,k) - dvsfc(i) = dvsfc(i) + dtauy * del(i,k) - enddo - enddo -! - do i = its,ite - dusfc(i) = (-1./g_) * dusfc(i) - dvsfc(i) = (-1./g_) * dvsfc(i) - enddo -! -! rotate tendencies from zonal/meridional back to model grid -! - do k = kts,kte - do i = its,ite - rublten(i,k) = rublten(i,k)+dudt(i,k)*cosa(i) + dvdt(i,k)*sina(i) - rvblten(i,k) = rvblten(i,k)-dudt(i,k)*sina(i) + dvdt(i,k)*cosa(i) - dtaux3d(i,k) = dtaux2d(i,k)*cosa(i) + dtauy2d(i,k)*sina(i) - dtauy3d(i,k) =-dtaux2d(i,k)*sina(i) + dtauy2d(i,k)*cosa(i) - enddo - enddo - do i = its,ite - dusfcg(i) = dusfc(i)*cosa(i) + dvsfc(i)*sina(i) - dvsfcg(i) =-dusfc(i)*sina(i) + dvsfc(i)*cosa(i) - enddo - return - end subroutine bl_gwdo_run - - -!================================================================================================================= - end module bl_gwdo -!================================================================================================================= - diff --git a/phys/physics_mmm/bl_ysu.F90 b/phys/physics_mmm/bl_ysu.F90 deleted file mode 100644 index 710fa65cf9..0000000000 --- a/phys/physics_mmm/bl_ysu.F90 +++ /dev/null @@ -1,1696 +0,0 @@ -#define NEED_B4B_DURING_CCPP_TESTING 1 -!================================================================================================================= - module bl_ysu - use ccpp_kind_types,only: kind_phys - - implicit none - private - public:: bl_ysu_run, & - bl_ysu_init, & - bl_ysu_finalize - - - contains - - -!================================================================================================================= -!>\section arg_table_bl_ysu_init -!!\html\include bl_ysu_init.html -!! - subroutine bl_ysu_init(errmsg,errflg) -!================================================================================================================= - -!--- output arguments: - character(len=*),intent(out):: errmsg - integer,intent(out):: errflg - -!----------------------------------------------------------------------------------------------------------------- - - errmsg = 'bl_ysu_init OK' - errflg = 0 - - end subroutine bl_ysu_init - -!================================================================================================================= -!>\section arg_table_bl_ysu_finalize -!!\html\include bl_ysu_finalize.html -!! - subroutine bl_ysu_finalize(errmsg,errflg) -!================================================================================================================= - -!--- output arguments: - character(len=*),intent(out):: errmsg - integer,intent(out):: errflg - -!----------------------------------------------------------------------------------------------------------------- - - errmsg = 'bl_ysu_finalize OK' - errflg = 0 - - end subroutine bl_ysu_finalize - -!================================================================================================================= -!>\section arg_table_bl_ysu_run -!!\html\include bl_ysu_run.html -!! - subroutine bl_ysu_run(ux,vx,tx,qvx,qcx,qix,nmix,qmix,p2d,p2di,pi2d, & - f_qc,f_qi, & - utnp,vtnp,ttnp,qvtnp,qctnp,qitnp,qmixtnp, & - cp,g,rovcp,rd,rovg,ep1,ep2,karman,xlv,rv, & - dz8w2d,psfcpa, & - znt,ust,hpbl,dusfc,dvsfc,dtsfc,dqsfc,psim,psih, & - xland,hfx,qfx,wspd,br, & - dt,kpbl1d, & - exch_hx,exch_mx, & - wstar,delta, & - u10,v10, & - uox,vox, & - rthraten, & - ysu_topdown_pblmix, & - ctopo,ctopo2, & - a_u,a_v,a_t,a_q,a_e, & - b_u,b_v,b_t,b_q,b_e, & - sfk,vlk,dlu,dlg,frcurb, & - flag_bep, & - its,ite,kte,kme, & - errmsg,errflg & - ) -!------------------------------------------------------------------------------- - implicit none -!------------------------------------------------------------------------------- -! -! this code is a revised vertical diffusion package ("ysupbl") -! with a nonlocal turbulent mixing in the pbl after "mrfpbl". -! the ysupbl (hong et al. 2006) is based on the study of noh -! et al.(2003) and accumulated realism of the behavior of the -! troen and mahrt (1986) concept implemented by hong and pan(1996). -! the major ingredient of the ysupbl is the inclusion of an explicit -! treatment of the entrainment processes at the entrainment layer. -! this routine uses an implicit approach for vertical flux -! divergence and does not require "miter" timesteps. -! it includes vertical diffusion in the stable atmosphere -! and moist vertical diffusion in clouds. -! -! mrfpbl: -! coded by song-you hong (ncep), implemented by jimy dudhia (ncar) -! fall 1996 -! -! ysupbl: -! coded by song-you hong (yonsei university) and implemented by -! song-you hong (yonsei university) and jimy dudhia (ncar) -! summer 2002 -! -! further modifications : -! an enhanced stable layer mixing, april 2008 -! ==> increase pbl height when sfc is stable (hong 2010) -! pressure-level diffusion, april 2009 -! ==> negligible differences -! implicit forcing for momentum with clean up, july 2009 -! ==> prevents model blowup when sfc layer is too low -! incresea of lamda, maximum (30, 0.1 x del z) feb 2010 -! ==> prevents model blowup when delz is extremely large -! revised prandtl number at surface, peggy lemone, feb 2010 -! ==> increase kh, decrease mixing due to counter-gradient term -! revised thermal, shin et al. mon. wea. rev. , songyou hong, aug 2011 -! ==> reduce the thermal strength when z1 < 0.1 h -! revised prandtl number for free convection, dudhia, mar 2012 -! ==> pr0 = 1 + bke (=0.272) when neutral, kh is reduced -! minimum kzo = 0.01, lo = min (30m,delz), hong, mar 2012 -! ==> weaker mixing when stable, and les resolution in vertical -! gz1oz0 is removed, and psim psih are ln(z1/z0)-psim,h, hong, mar 2012 -! ==> consider thermal z0 when differs from mechanical z0 -! a bug fix in wscale computation in stable bl, sukanta basu, jun 2012 -! ==> wscale becomes small with height, and less mixing in stable bl -! revision in background diffusion (kzo), jan 2016 -! ==> kzo = 0.1 for momentum and = 0.01 for mass to account for -! internal wave mixing of large et al. (1994), songyou hong, feb 2016 -! ==> alleviate superious excessive mixing when delz is large -! add multilayer urban canopy models of BEP and BEP+BEM, jan 2021 -! -! references: -! -! hendricks, knievel, and wang (2020), j. appl. meteor. clim. -! hong (2010) quart. j. roy. met. soc -! hong, noh, and dudhia (2006), mon. wea. rev. -! hong and pan (1996), mon. wea. rev. -! noh, chun, hong, and raasch (2003), boundary layer met. -! troen and mahrt (1986), boundary layer met. -! -!------------------------------------------------------------------------------- -! - 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 - integer,parameter :: imvdif = 1 - real(kind=kind_phys),parameter :: rcl = 1.0 - integer,parameter :: kts=1, kms=1 -! - integer, intent(in ) :: its,ite,kte,kme - - logical, intent(in) :: ysu_topdown_pblmix -! - integer, intent(in) :: nmix -! - real(kind=kind_phys), intent(in ) :: dt,cp,g,rovcp,rovg,rd,xlv,rv -! - real(kind=kind_phys), intent(in ) :: ep1,ep2,karman -! - logical, intent(in ) :: f_qc, f_qi -! - real(kind=kind_phys), dimension( its:,: ) , & - intent(in) :: dz8w2d, & - pi2d -! - real(kind=kind_phys), dimension( its:,: ) , & - intent(in ) :: tx, & - qvx, & - qcx, & - qix -! - real(kind=kind_phys), dimension( its:,:,: ) , & - intent(in ) :: qmix -! - real(kind=kind_phys), dimension( its:,: ) , & - intent(out ) :: utnp, & - vtnp, & - ttnp, & - qvtnp, & - qctnp, & - qitnp -! - real(kind=kind_phys), dimension( its:,:,: ) , & - intent(out ) :: qmixtnp -! - real(kind=kind_phys), dimension( its:,: ) , & - intent(in ) :: p2di -! - real(kind=kind_phys), dimension( its:,: ) , & - intent(in ) :: p2d -! - real(kind=kind_phys), dimension( its: ) , & - intent(out ) :: hpbl -! - real(kind=kind_phys), dimension( its: ) , & - intent(out ), optional :: dusfc, & - dvsfc, & - dtsfc, & - dqsfc -! - real(kind=kind_phys), dimension( its: ) , & - intent(in ) :: ust, & - znt - real(kind=kind_phys), dimension( its: ) , & - intent(in ) :: xland, & - hfx, & - qfx -! - real(kind=kind_phys), dimension( its: ), intent(in ) :: wspd - real(kind=kind_phys), dimension( its: ), intent(in ) :: br -! - real(kind=kind_phys), dimension( its: ), intent(in ) :: psim, & - psih -! - real(kind=kind_phys), dimension( its: ), intent(in ) :: psfcpa - integer, dimension( its: ), intent(out ) :: kpbl1d -! - real(kind=kind_phys), dimension( its:,: ) , & - intent(in ) :: ux, & - vx, & - rthraten - real(kind=kind_phys), dimension( its: ) , & - optional , & - intent(in ) :: ctopo, & - ctopo2 -! - logical, intent(in ) :: flag_bep - real(kind=kind_phys), dimension( its:,: ) , & - optional , & - intent(in ) :: a_u, & - a_v, & - a_t, & - a_q, & - a_e, & - b_u, & - b_v, & - b_t, & - b_q, & - b_e, & - sfk, & - vlk, & - dlu, & - dlg - real(kind=kind_phys), dimension( its: ) , & - optional , & - intent(in ) :: frcurb -! - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - -! -! local vars -! - real(kind=kind_phys), dimension( its:ite ) :: hol - real(kind=kind_phys), dimension( its:ite, kms:kme ) :: zq -! - real(kind=kind_phys), dimension( its:ite, kts:kte ) :: & - thx,thvx,thlix, & - del, & - dza, & - dzq, & - xkzom, & - xkzoh, & - za -! - real(kind=kind_phys), dimension( its:ite ) :: & - rhox, & - govrth, & - zl1,thermal, & - wscale, & - hgamt,hgamq, & - brdn,brup, & - phim,phih, & - prpbl, & - wspd1,thermalli -! - real(kind=kind_phys), dimension( its:ite, kts:kte ) :: xkzh,xkzm,xkzq, & - f1,f2, & - r1,r2, & - ad,au, & - cu, & - al, & - zfac, & - rhox2, & - hgamt2, & - ad1,adm,adv -! -!jdf added exch_hx -! - real(kind=kind_phys), dimension( its:ite, kts:kte ) , & - intent(out ) :: exch_hx, & - exch_mx -! - real(kind=kind_phys), dimension( its:ite ) , & - intent(inout) :: u10, & - v10 - real(kind=kind_phys), dimension( its:ite ), optional , & - intent(in ) :: uox, & - vox - real(kind=kind_phys), dimension( its:ite ) :: uoxl, & - voxl - real(kind=kind_phys), dimension( its:ite ) :: & - brcr, & - sflux, & - zol1, & - brcr_sbro -! - real(kind=kind_phys), dimension( its:ite, kts:kte) :: r3,f3 - integer, dimension( its:ite ) :: kpbl,kpblold -! - logical, dimension( its:ite ) :: pblflg, & - sfcflg, & - stable, & - cloudflg - - logical :: definebrup -! - integer :: n,i,k,l,ic,is,kk - integer :: klpbl -! -! - 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 -! - - real(kind=kind_phys), dimension( its:ite, kts:kte ) :: wscalek,wscalek2 - real(kind=kind_phys), dimension( its:ite ), intent(out) :: wstar, & - delta - real(kind=kind_phys), dimension( its:ite, kts:kte ) :: xkzml,xkzhl, & - zfacent,entfac - real(kind=kind_phys), dimension( its:ite, kts:kte ) :: qcxl, & - qixl - real(kind=kind_phys), dimension( its:ite ) :: 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,vconvlim,vconvnew,fluxc,vconvc,vconv -!topo-corr - real(kind=kind_phys), dimension( its:ite, kts:kte ) :: fric, & - tke_ysu,& - el_ysu,& - shear_ysu,& - buoy_ysu - real(kind=kind_phys), dimension( its:ite) :: pblh_ysu,& - vconvfx -! - real(kind=kind_phys) :: bepswitch - - real(kind=kind_phys), dimension( its:ite, kts:kte ) :: & - a_u2d,a_v2d,a_t2d,a_q2d,a_e2d,b_u2d,b_v2d,b_t2d,b_q2d,b_e2d, & - sfk2d,vlk2d,dlu2d,dlg2d - real(kind=kind_phys), dimension( its:ite ) :: & - frc_urb1d - - real(kind=kind_phys), dimension( kts:kte ) :: thvx_1d,tke_1d,dzq_1d - real(kind=kind_phys), dimension( kts:kte+1) :: zq_1d - -! -!------------------------------------------------------------------------------- -! - klpbl = kte -! - cont=cp/g - conq=xlv/g - conw=1./g - conwrc = conw*sqrt(rcl) - conpr = bfac*karman*sfcfrac -! -! k-start index for tracer diffusion -! - if(f_qc) then - do k = kts,kte - do i = its,ite - qcxl(i,k) = qcx(i,k) - enddo - enddo - else - do k = kts,kte - do i = its,ite - qcxl(i,k) = 0. - enddo - enddo - endif -! - if(f_qi) then - do k = kts,kte - do i = its,ite - qixl(i,k) = qix(i,k) - enddo - enddo - else - do k = kts,kte - do i = its,ite - qixl(i,k) = 0. - enddo - enddo - endif -! - do k = kts,kte - do i = its,ite - thx(i,k) = tx(i,k)/pi2d(i,k) - thlix(i,k) = (tx(i,k)-xlv*qcxl(i,k)/cp-2.834E6*qixl(i,k)/cp)/pi2d(i,k) - enddo - enddo -! - do k = kts,kte - do i = its,ite - tvcon = (1.+ep1*qvx(i,k)) - thvx(i,k) = thx(i,k)*tvcon - enddo - enddo -! - if ( present(uox) .and. present(vox) ) then - do i =its,ite - uoxl(i) = uox(i) - voxl(i) = vox(i) - enddo - else - do i =its,ite - uoxl(i) = 0 - voxl(i) = 0 - enddo - endif -! - do i = its,ite - tvcon = (1.+ep1*qvx(i,1)) - rhox(i) = psfcpa(i)/(rd*tx(i,1)*tvcon) - govrth(i) = g/thx(i,1) - enddo -! - if(present(a_u) .and. present(a_v) .and. present(a_t) .and. & - present(a_q) .and. present(a_t) .and. present(a_e) .and. & - present(b_u) .and. present(b_v) .and. present(b_t) .and. & - present(b_q) .and. present(b_e) .and. present(dlg) .and. & - present(dlu) .and. present(sfk) .and. present(vlk) .and. & - present(frcurb) .and. flag_bep) then - - bepswitch=1.0 - do k = kts, kte - do i = its,ite - a_u2d(i,k) = a_u(i,k) - a_v2d(i,k) = a_v(i,k) - a_t2d(i,k) = a_t(i,k) - a_q2d(i,k) = a_q(i,k) - a_e2d(i,k) = a_e(i,k) - b_u2d(i,k) = b_u(i,k) - b_v2d(i,k) = b_v(i,k) - b_t2d(i,k) = b_t(i,k) - b_q2d(i,k) = b_q(i,k) - b_e2d(i,k) = b_e(i,k) - dlg2d(i,k) = dlg(i,k) - dlu2d(i,k) = dlu(i,k) - vlk2d(i,k) = vlk(i,k) - sfk2d(i,k) = sfk(i,k) - enddo - enddo - do i = its, ite - frc_urb1d(i) = frcurb(i) - enddo - else - bepswitch=0.0 - do k = kts, kte - do i = its,ite - a_u2d(i,k) = 0.0 - a_v2d(i,k) = 0.0 - a_t2d(i,k) = 0.0 - a_q2d(i,k) = 0.0 - a_e2d(i,k) = 0.0 - b_u2d(i,k) = 0.0 - b_v2d(i,k) = 0.0 - b_t2d(i,k) = 0.0 - b_q2d(i,k) = 0.0 - b_e2d(i,k) = 0.0 - dlg2d(i,k) = 0.0 - dlu2d(i,k) = 0.0 - vlk2d(i,k) = 1.0 - sfk2d(i,k) = 1.0 - enddo - enddo - do i = its, ite - frc_urb1d(i) = 0.0 - enddo - endif -! -!-----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) = dz8w2d(i,k)+zq(i,k) - tvcon = (1.+ep1*qvx(i,k)) - rhox2(i,k) = p2d(i,k)/(rd*tx(i,k)*tvcon) - enddo - enddo -! - do k = kts,kte - do i = its,ite - za(i,k) = 0.5*(zq(i,k)+zq(i,k+1)) - dzq(i,k) = zq(i,k+1)-zq(i,k) - del(i,k) = p2di(i,k)-p2di(i,k+1) - 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 -! -!-----initialize output and local exchange coefficents: - do k = kts,kte - do i = its,ite - exch_hx(i,k) = 0. - exch_mx(i,k) = 0. - xkzh(i,k) = 0. - xkzhl(i,k) = 0. - xkzm(i,k) = 0. - xkzml(i,k) = 0. - xkzq(i,k) = 0. - enddo - enddo -! - do i = its,ite - wspd1(i) = sqrt( (ux(i,1)-uoxl(i))*(ux(i,1)-uoxl(i)) + (vx(i,1)-voxl(i))*(vx(i,1)-voxl(i)) )+1.e-9 - enddo -! -!---- 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 - wstar3_2(i) = 0.0 - enddo -! - do k = kts,klpbl - do i = its,ite - wscalek(i,k) = 0.0 - wscalek2(i,k) = 0.0 - enddo - enddo -! - do k = kts,klpbl - do i = its,ite - zfac(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 - if(present(dusfc)) dusfc(i) = 0. - if(present(dvsfc)) dvsfc(i) = 0. - if(present(dtsfc)) dtsfc(i) = 0. - if(present(dqsfc)) 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) - 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 = 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 - 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) - 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 = 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 -! -! enhance pbl by theta-li -! - if (ysu_topdown_pblmix)then - do i = its,ite - kpblold(i) = kpbl(i) - definebrup=.false. - do k = kpblold(i), kte-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 = 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. - endif - enddo -! -! stable boundary layer -! - do i = its,ite - 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 -! -! estimate the entrainment parameters -! - do i = its,ite - 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((qcxl(i,k)+qixl(i,k)).gt.0.01e-3.and.ysu_topdown_pblmix)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 + ((qvx(i,k)+qcxl(i,k))-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((qvx(i,k)+qcxl(i,k))-rvls,0.) - !entrainment efficiency - dthvx(i) = (thlix(i,k+2)+thx(i,k+2)*ep1*(qvx(i,k+2)+qcxl(i,k+2))) & - - (thlix(i,k) + thx(i,k) *ep1*(qvx(i,k) +qcxl(i,k))) - 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=rthraten(i,kk)*pi2d(i,kk) !converts theta/s to 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(qvx(i,k+1)-qvx(i,k),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 = kts,klpbl - do i = its,ite - 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 = 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 - 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 = 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)) - if(imvdif.eq.1)then - if((qcxl(i,k)+qixl(i,k)).gt.0.01e-3.and. & - (qcxl(i,k+1)+qixl(i,k+1)).gt.0.01e-3)then -! in cloud - qmean = 0.5*(qvx(i,k)+qvx(i,k+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 = 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.+(1.0-bepswitch)*hfx(i)/cont/del(i,1)*dt2 - enddo -! - do k = kts,kte-1 - do i = its,ite - dtodsd = sfk2d(i,k)*dt2/del(i,k) - dtodsu = sfk2d(i,k)*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/vlk2d(i,k) - al(i,k) = -dtodsu*dsdz2/vlk2d(i,k) - ad(i,k) = ad(i,k)-au(i,k) - ad(i,k+1) = 1.-al(i,k) - exch_hx(i,k+1) = xkzh(i,k) - enddo - enddo -! -! add bep/bep+bem forcing for heat if flag_bep=.true. -! - do k = kts,kte - do i = its,ite - ad(i,k) = ad(i,k) - a_t2d(i,k)*dt2 - f1(i,k) = f1(i,k) + b_t2d(i,k)*dt2 - 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 -#if (NEED_B4B_DURING_CCPP_TESTING == 1) - ttend = (f1(i,k)-thx(i,k)+300.)*rdt*pi2d(i,k) - ttnp(i,k) = ttend - if(present(dtsfc)) dtsfc(i) = dtsfc(i)+ttend*cont*del(i,k)/pi2d(i,k) -#elif (NEED_B4B_DURING_CCPP_TESTING != 1) - ttend = (f1(i,k)-thx(i,k)+300.)*rdt - ttnp(i,k) = ttend - if(present(dtsfc)) dtsfc(i) = dtsfc(i)+ttend*cont*del(i,k) -#endif - enddo - enddo -! - -!--- compute tridiagonal matrix elements for water vapor, cloud water, and cloud ice: - !--- initialization of k-coefficient above the PBL. - do i = its,ite - do k = kts,kte-1 - if(k .ge. kpbl(i)) xkzq(i,k) = xkzh(i,k) - enddo - enddo - - !--- water vapor: - do i = its,ite - do k = kts,kte - au(i,k) = 0. - al(i,k) = 0. - ad(i,k) = 0. - f1(i,k) = 0. - r1(i,k) = 0. - enddo - - k = 1 - ad(i,1) = 1. - f1(i,1) = qvx(i,1)+(1.0-bepswitch)*qfx(i)*g/del(i,1)*dt2 - - do k = kts,kte-1 - dtodsd = sfk2d(i,k)*dt2/del(i,k) - dtodsu = sfk2d(i,k)*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)) - f1(i,k) = f1(i,k)+dtodsd*dsdzq - f1(i,k+1) = qvx(i,k+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) - f1(i,k+1) = qvx(i,k+1) - else - f1(i,k+1) = qvx(i,k+1) - endif - tem1 = dsig*xkzq(i,k)*rdz - dsdz2 = tem1*rdz - au(i,k) = -dtodsd*dsdz2/vlk2d(i,k) - al(i,k) = -dtodsu*dsdz2/vlk2d(i,k) - ad(i,k) = ad(i,k)-au(i,k) - ad(i,k+1) = 1.-al(i,k) - enddo -! -! add bep/bep+bem forcing for water vapor if flag_bep=.true. -! - do k = kts,kte - adv(i,k) = ad(i,k) - a_q2d(i,k)*dt2 - f1(i,k) = f1(i,k) + b_q2d(i,k)*dt2 - enddo - - do k = kts,kte - cu(i,k) = au(i,k) - r1(i,k) = f1(i,k) - enddo - enddo - call tridin_ysu(al,adv,cu,r1,au,f1,its,ite,kts,kte,1) - - do i = its,ite - do k = kte,kts,-1 - qtend = (f1(i,k)-qvx(i,k))*rdt - qvtnp(i,k) = qtend - if(present(dqsfc)) dqsfc(i) = dqsfc(i)+qtend*conq*del(i,k) - enddo - enddo - - !--- cloud water: - if(f_qc) then - do i = its,ite - do k = kts,kte - f1(i,k) = qcxl(i,k) - r1(i,k) = f1(i,k) - enddo - enddo - call tridin_ysu(al,ad,cu,r1,au,f1,its,ite,kts,kte,1) - - do i = its,ite - do k = kte,kts,-1 - qtend = (f1(i,k)-qcxl(i,k))*rdt - qctnp(i,k) = qtend - enddo - enddo - endif - - !--- cloud ice: - if(f_qi) then - do i = its,ite - do k = kts,kte - f1(i,k) = qixl(i,k) - r1(i,k) = f1(i,k) - enddo - enddo - call tridin_ysu(al,ad,cu,r1,au,f1,its,ite,kts,kte,1) - - do i = its,ite - do k = kte,kts,-1 - qtend = (f1(i,k)-qixl(i,k))*rdt - qitnp(i,k) = qtend - enddo - enddo - endif - - !--- chemical species and/or passive tracers, meaning all variables that we want to - ! be vertically-mixed, if nmix=0 (number of tracers) then the loop is skipped - do n = 1, nmix - do i = its,ite - do k = kts,kte - f1(i,k) = qmix(i,k,n) - r1(i,k) = f1(i,k) - enddo - enddo - call tridin_ysu(al,ad,cu,r1,au,f1,its,ite,kts,kte,1) - - do i = its,ite - do k = kte,kts,-1 - qtend = (f1(i,k)-qmix(i,k,n))*rdt - qmixtnp(i,k,n) = qtend - enddo - enddo - enddo - -! -! 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 -! -! paj: ctopo=1 if topo_wind=0 (default) -!raquel---paj tke code (could be replaced with shin-hong tke in future - do i = its,ite - do k= kts, kte-1 - shear_ysu(i,k)=xkzm(i,k)*((-hgamu(i)/hpbl(i)+(ux(i,k+1)-ux(i,k))/dza(i,k+1))*(ux(i,k+1)-ux(i,k))/dza(i,k+1) & - + (-hgamv(i)/hpbl(i)+(vx(i,k+1)-vx(i,k))/dza(i,k+1))*(vx(i,k+1)-vx(i,k))/dza(i,k+1)) - buoy_ysu(i,k)=xkzh(i,k)*g*(1.0/thx(i,k))*(-hgamt(i)/hpbl(i)+(thx(i,k+1)-thx(i,k))/dza(i,k+1)) - - zk = karman*zq(i,k+1) - !over pbl - if (k.ge.kpbl(i)) then - rlamdz = min(max(0.1*dza(i,k+1),rlam),300.) - rlamdz = min(dza(i,k+1),rlamdz) - else - !in pbl - rlamdz = 150.0 - endif - el_ysu(i,k) = zk*rlamdz/(rlamdz+zk) - tke_ysu(i,k)=16.6*el_ysu(i,k)*(shear_ysu(i,k)-buoy_ysu(i,k)) - !q2 when q3 positive - if(tke_ysu(i,k).le.0) then - tke_ysu(i,k)=0.0 - else - tke_ysu(i,k)=(tke_ysu(i,k))**0.66 - endif - enddo - !Hybrid pblh of MYNN - !tke is q2 -! CALL GET_PBLH(KTS,KTE,pblh_ysu(i),thvx(i,kts:kte),& -! & tke_ysu(i,kts:kte),zq(i,kts:kte+1),dzq(i,kts:kte),xland(i)) - do k = kts,kte - thvx_1d(k) = thvx(i,k) - tke_1d(k) = tke_ysu(i,k) - zq_1d(k) = zq(i,k) - dzq_1d(k) = dzq(i,k) - enddo - zq_1d(kte+1) = zq(i,kte+1) - call get_pblh(kts,kte,pblh_ysu(i),thvx_1d,tke_1d,zq_1d,dzq_1d,xland(i)) - -!--- end of paj tke -! compute vconv -! Use Beljaars over land - if (xland(i).lt.1.5) then - fluxc = max(sflux(i),0.0) - vconvc=1. - VCONV = vconvc*(g/thvx(i,1)*pblh_ysu(i)*fluxc)**.33 - else -! for water there is no topo effect so vconv not needed - VCONV = 0. - endif - vconvfx(i) = vconv -!raquel -!ctopo stability correction - fric(i,1)=ust(i)**2/wspd1(i)*rhox(i)*g/del(i,1)*dt2 & - *(wspd1(i)/wspd(i))**2 - if(present(ctopo)) then - vconvnew=0.9*vconvfx(i)+1.5*(max((pblh_ysu(i)-500)/1000.0,0.0)) - vconvlim = min(vconvnew,1.0) - ad(i,1) = 1.+fric(i,1)*vconvlim+ctopo(i)*fric(i,1)*(1-vconvlim) - ad(i,1) = ad(i,1) - bepswitch*frc_urb1d(i)* & - (fric(i,1)*vconvlim+ctopo(i)*fric(i,1)*(1-vconvlim)) -! ad(i,1) = 1.+(1.-bepswitch*frc_urb1d(i))* & -! (fric(i,1)*vconvlim+ctopo(i)*fric(i,1)*(1-vconvlim)) - else - ad(i,1) = 1.+fric(i,1) - endif - f1(i,1) = ux(i,1)+uoxl(i)*ust(i)**2*rhox(i)*g/del(i,1)*dt2/wspd1(i)*(wspd1(i)/wspd(i))**2 - f2(i,1) = vx(i,1)+voxl(i)*ust(i)**2*rhox(i)*g/del(i,1)*dt2/wspd1(i)*(wspd1(i)/wspd(i))**2 - enddo -! - do k = kts,kte-1 - do i = its,ite - dtodsd = sfk2d(i,k)*dt2/del(i,k) - dtodsu = sfk2d(i,k)*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/vlk2d(i,k) - al(i,k) = -dtodsu*dsdz2/vlk2d(i,k) - ad(i,k) = ad(i,k)-au(i,k) - ad(i,k+1) = 1.-al(i,k) - exch_mx(i,k+1) = xkzm(i,k) - enddo - enddo -! -! add bep/bep+bem forcing for momentum if flag_bep=.true. -! - do k = kts,kte - do i = its,ite - ad1(i,k) = ad(i,k) - end do - end do - do k = kts,kte - do i = its,ite - ad(i,k) = ad(i,k) - a_u2d(i,k)*dt2 - ad1(i,k) = ad1(i,k) - a_v2d(i,k)*dt2 - f1(i,k) = f1(i,k) + b_u2d(i,k)*dt2 - f2(i,k) = f2(i,k) + b_v2d(i,k)*dt2 - 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 tridi2n(al,ad,ad1,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) = utend - vtnp(i,k) = vtend - if(present(dusfc)) dusfc(i) = dusfc(i) + utend*conwrc*del(i,k) - if(present(dvsfc)) dvsfc(i) = dvsfc(i) + vtend*conwrc*del(i,k) - enddo - enddo -! -! paj: ctopo2=1 if topo_wind=0 (default) -! - do i = its,ite - if(present(ctopo).and.present(ctopo2)) then ! mchen for NMM - u10(i) = ctopo2(i)*u10(i)+(1-ctopo2(i))*ux(i,1) - v10(i) = ctopo2(i)*v10(i)+(1-ctopo2(i))*vx(i,1) - endif !mchen - enddo -! -!---- end of vertical diffusion -! - do i = its,ite - kpbl1d(i) = kpbl(i) - enddo -! - errmsg = 'bl_ysu_run OK' - errflg = 0 -! - end subroutine bl_ysu_run - -!================================================================================================================= - subroutine tridi2n(cl,cm,cm1,cu,r1,r2,au,f1,f2,its,ite,kts,kte,nt) -!------------------------------------------------------------------------------- - 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, & - cm1, & - 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./cm1(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./(cm1(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./(cm1(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 tridi2n -!------------------------------------------------------------------------------- -! -!------------------------------------------------------------------------------- - subroutine tridin_ysu(cl,cm,cu,r2,au,f2,its,ite,kts,kte,nt) -!------------------------------------------------------------------------------- - 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 ) :: au, & - cm, & - cu - real(kind=kind_phys), dimension( its:ite, kts:kte,nt ) , & - intent(in ) :: r2 - - real(kind=kind_phys), dimension( its:ite, kts:kte,nt ) , & - intent(inout) :: f2 -! - real(kind=kind_phys) :: fk - real(kind=kind_phys), dimension( its:ite, kts:kte ) :: aul - integer :: i,k,l,n,it -! -!------------------------------------------------------------------------------- -! - l = ite - n = kte -! - do i = its,ite - do k = kts,kte - aul(i,k) = 0. - enddo - enddo -! - do it = 1,nt - do i = its,l - fk = 1./cm(i,1) - aul(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)*aul(i,k-1)) - aul(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)*aul(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)-aul(i,k)*f2(i,k+1,it) - enddo - enddo - enddo -! - end subroutine tridin_ysu - -!================================================================================================================= - subroutine get_pblh(kts,kte,zi,thetav1d,qke1d,zw1d,dz1d,landsea) -! Copied from MYNN PBL - - !--------------------------------------------------------------- - ! NOTES ON THE PBLH FORMULATION - ! - !The 1.5-theta-increase method defines PBL heights as the level at - !which the potential temperature first exceeds the minimum potential - !temperature within the boundary layer by 1.5 K. When applied to - !observed temperatures, this method has been shown to produce PBL- - !height estimates that are unbiased relative to profiler-based - !estimates (Nielsen-Gammon et al. 2008). However, their study did not - !include LLJs. Banta and Pichugina (2008) show that a TKE-based - !threshold is a good estimate of the PBL height in LLJs. Therefore, - !a hybrid definition is implemented that uses both methods, weighting - !the TKE-method more during stable conditions (PBLH < 400 m). - !A variable tke threshold (TKEeps) is used since no hard-wired - !value could be found to work best in all conditions. - !--------------------------------------------------------------- - - integer,intent(in) :: kts,kte - real(kind=kind_phys), intent(out) :: zi - real(kind=kind_phys), intent(in) :: landsea - real(kind=kind_phys), dimension(kts:kte), intent(in) :: thetav1d, qke1d, dz1d - real(kind=kind_phys), dimension(kts:kte+1), intent(in) :: zw1d - !local vars - real(kind=kind_phys) :: pblh_tke,qtke,qtkem1,wt,maxqke,tkeeps,minthv - real(kind=kind_phys) :: delt_thv !delta theta-v; dependent on land/sea point - real(kind=kind_phys), parameter :: sbl_lim = 200. !theta-v pbl lower limit of trust (m). - real(kind=kind_phys), parameter :: sbl_damp = 400. !damping range for averaging with tke-based pblh (m). - integer :: i,j,k,kthv,ktke - - !find max tke and min thetav in the lowest 500 m - k = kts+1 - kthv = 1 - ktke = 1 - maxqke = 0. - minthv = 9.e9 - - do while (zw1d(k) .le. 500.) - qtke =max(qke1d(k),0.) ! maximum qke - if (maxqke < qtke) then - maxqke = qtke - ktke = k - endif - if (minthv > thetav1d(k)) then - minthv = thetav1d(k) - kthv = k - endif - k = k+1 - enddo - !tkeeps = maxtke/20. = maxqke/40. - tkeeps = maxqke/40. - tkeeps = max(tkeeps,0.025) - tkeeps = min(tkeeps,0.25) - - !find thetav-based pblh (best for daytime). - zi=0. - k = kthv+1 - if((landsea-1.5).ge.0)then - ! water - delt_thv = 0.75 - else - ! land - delt_thv = 1.5 - endif - - zi=0. - k = kthv+1 - do while (zi .eq. 0.) - if (thetav1d(k) .ge. (minthv + delt_thv))then - zi = zw1d(k) - dz1d(k-1)* & - & min((thetav1d(k)-(minthv + delt_thv))/max(thetav1d(k)-thetav1d(k-1),1e-6),1.0) - endif - k = k+1 - if (k .eq. kte-1) zi = zw1d(kts+1) !exit safeguard - enddo - - !print*,"in get_pblh:",thsfc,zi - !for stable boundary layers, use tke method to complement the - !thetav-based definition (when the theta-v based pblh is below ~0.5 km). - !the tanh weighting function will make the tke-based definition negligible - !when the theta-v-based definition is above ~1 km. - !find tke-based pblh (best for nocturnal/stable conditions). - - pblh_tke=0. - k = ktke+1 - do while (pblh_tke .eq. 0.) - !qke can be negative (if ckmod == 0)... make tke non-negative. - qtke =max(qke1d(k)/2.,0.) ! maximum tke - qtkem1=max(qke1d(k-1)/2.,0.) - if (qtke .le. tkeeps) then - pblh_tke = zw1d(k) - dz1d(k-1)* & - & min((tkeeps-qtke)/max(qtkem1-qtke, 1e-6), 1.0) - !in case of near zero tke, set pblh = lowest level. - pblh_tke = max(pblh_tke,zw1d(kts+1)) - !print *,"pblh_tke:",i,j,pblh_tke, qke1d(k)/2., zw1d(kts+1) - endif - k = k+1 - if (k .eq. kte-1) pblh_tke = zw1d(kts+1) !exit safeguard - enddo - - !blend the two pblh types here: - - wt=.5*tanh((zi - sbl_lim)/sbl_damp) + .5 - zi=pblh_tke*(1.-wt) + zi*wt - - end subroutine get_pblh - -!================================================================================================================= - end module bl_ysu -!================================================================================================================= diff --git a/phys/physics_mmm/cu_ntiedtke.F90 b/phys/physics_mmm/cu_ntiedtke.F90 deleted file mode 100644 index e1d266d06f..0000000000 --- a/phys/physics_mmm/cu_ntiedtke.F90 +++ /dev/null @@ -1,3594 +0,0 @@ -!================================================================================================================= - module cu_ntiedtke_common - use ccpp_kind_types,only: kind_phys - - - implicit none - save - - real(kind=kind_phys):: alf - real(kind=kind_phys):: als - real(kind=kind_phys):: alv - real(kind=kind_phys):: cpd - real(kind=kind_phys):: g - real(kind=kind_phys):: rd - real(kind=kind_phys):: rv - - real(kind=kind_phys),parameter:: t13 = 1.0/3.0 - real(kind=kind_phys),parameter:: tmelt = 273.16 - real(kind=kind_phys),parameter:: c1es = 610.78 - real(kind=kind_phys),parameter:: c3les = 17.2693882 - real(kind=kind_phys),parameter:: c3ies = 21.875 - real(kind=kind_phys),parameter:: c4les = 35.86 - real(kind=kind_phys),parameter:: c4ies = 7.66 - - real(kind=kind_phys),parameter:: rtwat = tmelt - real(kind=kind_phys),parameter:: rtber = tmelt-5. - real(kind=kind_phys),parameter:: rtice = tmelt-23. - - integer,parameter:: momtrans = 2 - real(kind=kind_phys),parameter:: entrdd = 2.0e-4 - real(kind=kind_phys),parameter:: cmfcmax = 1.0 - real(kind=kind_phys),parameter:: cmfcmin = 1.e-10 - real(kind=kind_phys),parameter:: cmfdeps = 0.30 - real(kind=kind_phys),parameter:: zdnoprc = 2.0e4 - real(kind=kind_phys),parameter:: cprcon = 1.4e-3 - real(kind=kind_phys),parameter:: pgcoef = 0.7 - - real(kind=kind_phys):: rcpd - real(kind=kind_phys):: c2es - real(kind=kind_phys):: c5les - real(kind=kind_phys):: c5ies - real(kind=kind_phys):: r5alvcp - real(kind=kind_phys):: r5alscp - real(kind=kind_phys):: ralvdcp - real(kind=kind_phys):: ralsdcp - real(kind=kind_phys):: ralfdcp - real(kind=kind_phys):: vtmpc1 - real(kind=kind_phys):: zrg - - logical,parameter:: nonequil = .true. - logical,parameter:: lmfpen = .true. - logical,parameter:: lmfmid = .true. - logical,parameter:: lmfscv = .true. - logical,parameter:: lmfdd = .true. - logical,parameter:: lmfdudv = .true. - - -!================================================================================================================= - end module cu_ntiedtke_common -!================================================================================================================= - - module cu_ntiedtke - use ccpp_kind_types,only: kind_phys - use cu_ntiedtke_common - - - implicit none - private - public:: cu_ntiedtke_run, & - cu_ntiedtke_init, & - cu_ntiedtke_finalize - - - contains - - -!================================================================================================================= -!>\section arg_table_cu_ntiedtke_init -!!\html\include cu_ntiedtke_init.html -!! - subroutine cu_ntiedtke_init(con_cp,con_rd,con_rv,con_xlv,con_xls,con_xlf,con_grav,errmsg,errflg) -!================================================================================================================= - -!input arguments: - real(kind=kind_phys),intent(in):: & - con_cp, & - con_rd, & - con_rv, & - con_xlv, & - con_xls, & - con_xlf, & - con_grav - -!--- output arguments: - character(len=*),intent(out):: errmsg - integer,intent(out):: errflg - -!----------------------------------------------------------------------------------------------------------------- - - alf = con_xlf - als = con_xls - alv = con_xlv - cpd = con_cp - g = con_grav - rd = con_rd - rv = con_rv - - rcpd = 1.0/con_cp - c2es = c1es*con_rd/con_rv - c5les = c3les*(tmelt-c4les) - c5ies = c3ies*(tmelt-c4ies) - r5alvcp = c5les*con_xlv*rcpd - r5alscp = c5ies*con_xls*rcpd - ralvdcp = con_xlv*rcpd - ralsdcp = con_xls*rcpd - ralfdcp = con_xlf*rcpd - vtmpc1 = con_rv/con_rd-1.0 - zrg = 1.0/con_grav - - errmsg = 'cu_ntiedtke_init OK' - errflg = 0 - - end subroutine cu_ntiedtke_init - -!================================================================================================================= -!>\section arg_table_cu_ntiedtke_finalize -!!\html\include cu_ntiedtke_finalize.html -!! - subroutine cu_ntiedtke_finalize(errmsg,errflg) -!================================================================================================================= - -!--- output arguments: - character(len=*),intent(out):: errmsg - integer,intent(out):: errflg - -!----------------------------------------------------------------------------------------------------------------- - - errmsg = 'cu_ntiedtke_finalize OK' - errflg = 0 - - end subroutine cu_ntiedtke_finalize - -!================================================================================================================= -!>\section arg_table_cu_ntiedtke_run -!!\html\include cu_ntiedtke_run.html -!! -! level 1 subroutine 'cu_ntiedkte_run' - subroutine cu_ntiedtke_run(pu,pv,pt,pqv,pqc,pqi,pqvf,ptf,poz,pzz,pomg, & - & pap,paph,evap,hfx,zprecc,lndj,lq,km,km1,dt,dx,errmsg,errflg) -!================================================================================================================= -! this is the interface between the model and the mass flux convection module -! m.tiedtke e.c.m.w.f. 1989 -! j.morcrette 1992 -!-------------------------------------------- -! modifications -! C. zhang & Yuqing Wang 2011-2017 -! -! modified from IPRC IRAM - yuqing wang, university of hawaii (ICTP REGCM4.4). -! -! The current version is stable. There are many updates to the old Tiedtke scheme (cu_physics=6) -! update notes: -! the new Tiedtke scheme is similar to the Tiedtke scheme used in REGCM4 and ECMWF cy40r1. -! the major differences to the old Tiedtke (cu_physics=6) scheme are, -! (a) New trigger functions for deep and shallow convections (Jakob and Siebesma 2003; -! Bechtold et al. 2004, 2008, 2014). -! (b) Non-equilibrium situations are considered in the closure for deep convection -! (Bechtold et al. 2014). -! (c) New convection time scale for the deep convection closure (Bechtold et al. 2008). -! (d) New entrainment and detrainment rates for all convection types (Bechtold et al. 2008). -! (e) New formula for the conversion from cloud water/ice to rain/snow (Sundqvist 1978). -! (f) Different way to include cloud scale pressure gradients (Gregory et al. 1997; -! Wu and Yanai 1994) -! -! other reference: tiedtke (1989, mwr, 117, 1779-1800) -! IFS documentation - cy33r1, cy37r2, cy38r1, cy40r1 -! -! Note for climate simulation of Tropical Cyclones -! This version of Tiedtke scheme was tested with YSU PBL scheme, RRTMG radation -! schemes, and WSM6 microphysics schemes, at horizontal resolution around 20 km -! Set: momtrans = 2. -! pgcoef = 0.7 to 1.0 is good depends on the basin -! nonequil = .false. - -! Note for the diurnal simulation of precipitaton -! When nonequil = .true., the CAPE is relaxed toward to a value from PBL -! It can improve the diurnal precipitation over land. - -!--- input arguments: - integer,intent(in):: lq,km,km1 - integer,intent(in),dimension(:):: lndj - - real(kind=kind_phys),intent(in):: dt - real(kind=kind_phys),intent(in),dimension(:):: dx - real(kind=kind_phys),intent(in),dimension(:):: evap,hfx - real(kind=kind_phys),intent(in),dimension(:,:):: pqvf,ptf - real(kind=kind_phys),intent(in),dimension(:,:):: poz,pomg,pap - real(kind=kind_phys),intent(in),dimension(:,:):: pzz,paph - -!--- inout arguments: - real(kind=kind_phys),intent(inout),dimension(:):: zprecc - real(kind=kind_phys),intent(inout),dimension(:,:):: pu,pv,pt,pqv,pqc,pqi - -!--- output arguments: - character(len=*),intent(out):: errmsg - integer,intent(out):: errflg - -!--- local variables and arrays: - logical,dimension(lq):: locum - integer:: i,j,k - integer,dimension(lq):: icbot,ictop,ktype - - real(kind=kind_phys):: ztmst,fliq,fice,ztc,zalf,tt - real(kind=kind_phys):: ztpp1,zew,zqs,zcor - real(kind=kind_phys):: dxref - - real(kind=kind_phys),dimension(lq):: pqhfl,prsfc,pssfc,phhfl,zrain - real(kind=kind_phys),dimension(lq):: scale_fac,scale_fac2 - - real(kind=kind_phys),dimension(lq,km):: pum1,pvm1,ztt,ptte,pqte,pvom,pvol,pverv,pgeo - real(kind=kind_phys),dimension(lq,km):: zqq,pcte - real(kind=kind_phys),dimension(lq,km):: ztp1,zqp1,ztu,zqu,zlu,zlude,zmfu,zmfd,zqsat - real(kind=kind_phys),dimension(lq,km1):: pgeoh - -!----------------------------------------------------------------------------------------------------------------- -! - ztmst=dt -! -! set scale-dependency factor when dx is < 15 km -! - dxref = 15000. - do j=1,lq - if (dx(j).lt.dxref) then - scale_fac(j) = (1.06133+log(dxref/dx(j)))**3 - scale_fac2(j) = scale_fac(j)**0.5 - else - scale_fac(j) = 1.+1.33e-5*dx(j) - scale_fac2(j) = 1. - end if - end do -! -! 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)=g*pzz(j,km1) - end do -! -! convert model variables for mflux scheme -! - do k=1,km - do j=1,lq - pcte(j,k)=0.0 - pvom(j,k)=0.0 - pvol(j,k)=0.0 - ztp1(j,k)=pt(j,k) - zqp1(j,k)=pqv(j,k)/(1.0+pqv(j,k)) - pum1(j,k)=pu(j,k) - pvm1(j,k)=pv(j,k) - pverv(j,k)=pomg(j,k) - pgeo(j,k)=g*poz(j,k) - pgeoh(j,k)=g*pzz(j,k) - tt=ztp1(j,k) - zew = foeewm(tt) - zqs = zew/pap(j,k) - zqs = min(0.5,zqs) - zcor = 1./(1.-vtmpc1*zqs) - zqsat(j,k)=zqs*zcor - pqte(j,k)=pqvf(j,k) - zqq(j,k) =pqte(j,k) - ptte(j,k)=ptf(j,k) - ztt(j,k) =ptte(j,k) - end do - end do -! -!----------------------------------------------------------------------- -!* 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, & - & ktype, icbot, ictop, ztu, zqu, & - & zlu, zlude, zmfu, zmfd, zrain, & - & pcte, phhfl, lndj, pgeoh, dx, & - & scale_fac, scale_fac2) -! -! to include the cloud water and cloud ice detrained from convection -! - do k=1,km - do j=1,lq - if(pcte(j,k).gt.0.) then - fliq=foealfa(ztp1(j,k)) - fice=1.0-fliq - pqc(j,k)=pqc(j,k)+fliq*pcte(j,k)*ztmst - pqi(j,k)=pqi(j,k)+fice*pcte(j,k)*ztmst - endif - end do - end do -! - do k=1,km - do j=1,lq - pt(j,k)= ztp1(j,k)+(ptte(j,k)-ztt(j,k))*ztmst - zqp1(j,k)=zqp1(j,k)+(pqte(j,k)-zqq(j,k))*ztmst - pqv(j,k)=zqp1(j,k)/(1.0-zqp1(j,k)) - end do - end do - - do j=1,lq - zprecc(j)=amax1(0.0,(prsfc(j)+pssfc(j))*ztmst) - end do - - if (lmfdudv) then - do k=1,km - do j=1,lq - pu(j,k)=pu(j,k)+pvom(j,k)*ztmst - pv(j,k)=pv(j,k)+pvol(j,k)*ztmst - end do - end do - endif -! - errmsg = 'cu_ntiedtke_run OK' - errflg = 0 -! - 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, & - & ktype, kcbot, kctop, ptu, pqu, & - & plu, plude, pmfu, pmfd, prain, & - & pcte, phhfl, lndj, zgeoh, dx, & - & scale_fac, scale_fac2) - 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) -!----------------------------------------------------------------- - -!--- input arguments: - integer,intent(in):: klev,klon,klevp1,klevm1 - integer,intent(in),dimension(klon):: lndj - - real(kind=kind_phys),intent(in):: ztmst - real(kind=kind_phys),intent(in),dimension(klon):: dx - real(kind=kind_phys),intent(in),dimension(klon):: pqhfl,phhfl - real(kind=kind_phys),intent(in),dimension(klon):: scale_fac,scale_fac2 - real(kind=kind_phys),intent(in),dimension(klon,klev):: pten,pqen,puen,pven,pverv - real(kind=kind_phys),intent(in),dimension(klon,klev):: pap,pgeo - real(kind=kind_phys),intent(in),dimension(klon,klevp1):: paph,zgeoh - -!--- inout arguments: - integer,intent(inout),dimension(klon):: ktype,kcbot,kctop - logical,intent(inout),dimension(klon):: ldcum - - real(kind=kind_phys),intent(inout),dimension(klon):: pqsen - real(kind=kind_phys),intent(inout),dimension(klon):: prsfc,pssfc,prain - real(kind=kind_phys),intent(inout),dimension(klon,klev):: pcte,ptte,pqte,pvom,pvol - real(kind=kind_phys),intent(inout),dimension(klon,klev):: ptu,pqu,plu,plude,pmfu,pmfd - -!--- local variables and arrays: - logical:: llo1 - logical,dimension(klon):: loddraf,llo2 - - integer:: jl,jk,ik - integer:: ikb,ikt,icum,itopm2 - integer,dimension(klon):: kdpl,idtop,ictop0,ilwmin - integer,dimension(klon,klev):: ilab - - 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 - real(kind=kind_phys):: zduten,zdvten,ztdis,pgf_u,pgf_v - real(kind=kind_phys):: zlon - real(kind=kind_phys):: ztau,zerate,zderate,zmfa - real(kind=kind_phys),dimension(klon):: zmfs - real(kind=kind_phys),dimension(klon):: zsfl,zcape,zcape1,zcape2,ztauc,ztaubl,zheat - real(kind=kind_phys),dimension(klon):: wup,zdqcv - real(kind=kind_phys),dimension(klon):: wbase,zmfuub - real(kind=kind_phys),dimension(klon):: upbl - real(kind=kind_phys),dimension(klon):: zhcbase,zmfub,zmfub1,zdhpbl - real(kind=kind_phys),dimension(klon):: zmfuvb,zsum12,zsum22 - real(kind=kind_phys),dimension(klon):: zrfl - real(kind=kind_phys),dimension(klev):: pmean - real(kind=kind_phys),dimension(klon,klev):: pmfude_rate,pmfdde_rate - real(kind=kind_phys),dimension(klon,klev):: zdpmel - real(kind=kind_phys),dimension(klon,klev):: zmfuus,zmfdus,zuv2,ztenu,ztenv - real(kind=kind_phys),dimension(klon,klev):: ztenh,zqenh,zqsenh,ztd,zqd - real(kind=kind_phys),dimension(klon,klev):: zmfus,zmfds,zmfuq,zmfdq,zdmfup,zdmfdp,zmful - real(kind=kind_phys),dimension(klon,klev):: zuu,zvu,zud,zvd,zlglac - real(kind=kind_phys),dimension(klon,klevp1):: pmflxr,pmflxs - -!------------------------------------------- -! 1. specify constants and parameters -!------------------------------------------- - zcons=1./(g*ztmst) - zcons2=3./(g*ztmst) - -!-------------------------------------------------------------- -!* 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) - ztauc(jl) = max(ztmst,ztauc(jl)) - ztauc(jl) = max(360.,ztauc(jl)) - ztauc(jl) = min(10800.,ztauc(jl)) - ztau = ztauc(jl) * scale_fac(jl) - if(nonequil) 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) = zmfub1(jl)/scale_fac2(jl) - 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 -!---------------------------------------------------------- -!* 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 - pgf_u = -pgcoef*0.5*(pmfu(jl,ik)*(puen(jl,ik)-puen(jl,jk))+& - pmfu(jl,jk)*(puen(jl,jk)-puen(jl,jk-1))) - pgf_v = -pgcoef*0.5*(pmfu(jl,ik)*(pven(jl,ik)-pven(jl,jk))+& - pmfu(jl,jk)*(pven(jl,jk)-pven(jl,jk-1))) - 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 - - 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 -! ---------------------------------------------------------------- - -!--- input arguments: - integer,intent(in):: klon,klev,klevp1,klevm1 - - real(kind=kind_phys),intent(in),dimension(klon,klev):: pten,pqen,pqsen,puen,pven - real(kind=kind_phys),intent(in),dimension(klon,klev):: pgeo,pverv - real(kind=kind_phys),intent(in),dimension(klon,klev+1):: paph,pgeoh - -!--- output arguments: - integer,intent(out),dimension(klon):: klwmin - integer,intent(out),dimension(klon,klev):: klab - - real(kind=kind_phys),intent(out),dimension(klon,klev):: ptenh,pqenh,pqsenh - real(kind=kind_phys),intent(out),dimension(klon,klev):: ptu,ptd,pqu,pqd,plu - real(kind=kind_phys),intent(out),dimension(klon,klev):: puu,pud,pvu,pvd - -!--- inout arguments: - real(kind=kind_phys),intent(inout),dimension(klon,klev):: pmfu,pmfd,pmfus,pmfds,pmfuq,pmfdq - real(kind=kind_phys),intent(inout),dimension(klon,klev):: pdmfup,pdmfdp,plude,pdpmel - -!--- local variables and arrays: - logical,dimension(klon):: loflag - integer:: jl,jk - integer:: icall,ik - real(kind=kind_phys):: zzs - real(kind=kind_phys),dimension(klon):: zph,zwmax - -!------------------------------------------------------------ -!* 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 subroutines -!-------------------------------------------------------- - 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 -!------------------------------------------------------------------- - -!--- input arguments: - integer,intent(in):: klon,klev,klevp1,klevm1 - integer,intent(in),dimension(klon):: lndj - - real(kind=kind_phys),intent(in),dimension(klon):: qfx,hfx - real(kind=kind_phys),intent(in),dimension(klon,klev):: pap,pgeo - real(kind=kind_phys),intent(in),dimension(klon,klev):: pten,pqen,pqsen - real(kind=kind_phys),intent(in),dimension(klon,klev):: ptenh,pqenh,pqsenh - real(kind=kind_phys),intent(in),dimension(klon,klevp1):: paph,pgeoh - -!--- output arguments: - logical,intent(out),dimension(klon):: ldcum - - integer,intent(out),dimension(klon):: ktype - integer,intent(out),dimension(klon):: cubot,cutop,kdpl - integer,intent(out),dimension(klon,klev):: culab - - real(kind=kind_phys),intent(out),dimension(klon):: wbase - real(kind=kind_phys),intent(out),dimension(klon,klev):: cutu,cuqu,culu - -!--- local variables and arrays: - logical:: needreset - logical,dimension(klon):: lldcum - logical,dimension(klon):: loflag,deepflag,resetflag - - integer:: jl,jk,ik,icall,levels - integer:: nk,is,ikb,ikt - integer,dimension(klon):: kctop,kcbot - integer,dimension(klon):: zcbase,itoppacel - integer,dimension(klon,klev):: klab - - real(kind=kind_phys):: rho,part1,part2,root,conw,deltt,deltq - 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 - real(kind=kind_phys):: zqsu,zcor,zdp,zesdp,zalfaw,zfacw,zfaci,zfac,zdsdp,zdqsdt,zdtdp - real(kind=kind_phys):: zpdifftop, zpdiffbot - - real(kind=kind_phys),dimension(klon):: eta,dz,coef,zqold,zph - real(kind=kind_phys),dimension(klon,klev):: dh,dhen,kup,vptu,vten - real(kind=kind_phys),dimension(klon,klev):: ptu,pqu,plu - real(kind=kind_phys),dimension(klon,klev):: zbuo,abuoy,plude - -!-------------------------------------------------------------- - 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)))) - 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.8/(pgeo(jl,jk)*zrg)+2.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,klev/2+1,-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 - -!--- input arguments: - integer,intent(in):: klev,klon,klevp1,klevm1 - integer,intent(in),dimension(klon):: lndj - integer,intent(in),dimension(klon):: klwmin - integer,intent(in),dimension(klon):: kdpl - - real(kind=kind_phys),intent(in):: ztmst - real(kind=kind_phys),intent(in),dimension(klon):: wbase - real(kind=kind_phys),intent(in),dimension(klon,klev):: pten,pqen,pqsen,puen,pven,pqte,pverv - real(kind=kind_phys),intent(in),dimension(klon,klev):: pap,pgeo - real(kind=kind_phys),intent(in),dimension(klon,klevp1):: paph,pgeoh - -!--- inout arguments: - logical,intent(inout),dimension(klon):: ldcum - - integer,intent(inout):: kcum - integer,intent(inout),dimension(klon):: kcbot,kctop,kctop0 - integer,intent(inout),dimension(klon,klev):: klab - - real(kind=kind_phys),intent(inout),dimension(klon):: phcbase - real(kind=kind_phys),intent(inout),dimension(klon):: pmfub - real(kind=kind_phys),intent(inout),dimension(klon,klev):: ptenh,pqenh,pqsenh - real(kind=kind_phys),intent(inout),dimension(klon,klev):: ptu,pqu,plu,puu,pvu - real(kind=kind_phys),intent(inout),dimension(klon,klev):: pmfu,pmfus,pmfuq,pmful,plude,pdmfup - -!--- output arguments: - integer,intent(out),dimension(klon):: ktype - - real(kind=kind_phys),intent(out),dimension(klon):: wup - real(kind=kind_phys),intent(out),dimension(klon,klev):: plglac,pmfude_rate - -!--- local variables and arrays: - logical:: llo2,llo3 - logical,dimension(klon):: loflag,llo1 - - integer:: jl,jk - integer::ikb,icum,itopm2,ik,icall,is,jlm,jll - integer,dimension(klon):: jlx - - real(kind=kind_phys):: 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 - - real(kind=kind_phys),dimension(klon):: eta,dz,zoentr,zdpmean - real(kind=kind_phys),dimension(klon):: zph,zdmfen,zdmfde,zmfuu,zmfuv,zpbase,zqold,zluold,zprecip - real(kind=kind_phys),dimension(klon,klev):: zlrain,zbuo,kup,zodetr,pdmfen - -!-------------------------------- -!* 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) - 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 - 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): - -! *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): - -! *prfl* precipitation rate kg/(m2*s) - -! output parameters (real): - -! *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 - -!--- input arguments: - integer,intent(in):: klon - logical,intent(in),dimension(klon):: ldcum - - integer,intent(in):: klev - integer,intent(in),dimension(klon):: lndj - integer,intent(in),dimension(klon):: kcbot,kctop - - real(kind=kind_phys),intent(in),dimension(klon):: pmfub - real(kind=kind_phys),intent(in),dimension(klon,klev):: pten,pqsen,pgeo,puen,pven - real(kind=kind_phys),intent(in),dimension(klon,klev):: ptenh,pqenh - real(kind=kind_phys),intent(in),dimension(klon,klev):: ptu,pqu,puu,pvu,plu - real(kind=kind_phys),intent(in),dimension(klon,klev+1):: pgeoh,paph - -!--- inout arguments: - real(kind=kind_phys),intent(inout),dimension(klon):: prfl - real(kind=kind_phys),intent(inout),dimension(klon,klev):: pud,pvd - -!--- output arguments: - logical,intent(out),dimension(klon):: lddraf - integer,intent(out),dimension(klon):: kdtop - - real(kind=kind_phys),intent(out),dimension(klon,klev):: ptd,pqd,pmfd,pmfds,pmfdq,pdmfdp - -!--- local variables and arrays: - logical,dimension(klon):: llo2 - integer:: jl,jk - integer:: is,ik,icall,ike - integer,dimension(klon):: ikhsmin - - real(kind=kind_phys):: zhsk,zttest,zqtest,zbuo,zmftop - real(kind=kind_phys),dimension(klon):: zcond,zph,zhsmin - real(kind=kind_phys),dimension(klon,klev):: ztenwb,zqenwb - -!---------------------------------------------------------------------- - -! 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): - -! *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 -! *paph* provisional pressure on half levels pa -! *pmfu* massflux updrafts kg/(m2*s) - -! updated parameters (real): - -! *prfl* precipitation rate kg/(m2*s) - -! output parameters (real): - -! *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 - -!--- input arguments: - integer,intent(in)::klon - logical,intent(in),dimension(klon):: lddraf - - integer,intent(in)::klev - - real(kind=kind_phys),intent(in),dimension(klon,klev):: ptenh,pqenh,puen,pven - real(kind=kind_phys),intent(in),dimension(klon,klev):: pgeo,pmfu - real(kind=kind_phys),intent(in),dimension(klon,klev+1):: pgeoh,paph - -!--- inout arguments: - real(kind=kind_phys),intent(inout),dimension(klon):: prfl - real(kind=kind_phys),intent(inout),dimension(klon,klev):: ptd,pqd,pud,pvd - real(kind=kind_phys),intent(inout),dimension(klon,klev):: pmfd,pmfds,pmfdq,pdmfdp - -!--- output arguments: - real(kind=kind_phys),intent(inout),dimension(klon,klev):: pmfdde_rate - -!--- local variables and arrays: - logical:: llo1 - logical,dimension(klon):: llo2 - - integer:: jl,jk - integer:: is,ik,icall,ike - integer,dimension(klon):: itopde - - real(kind=kind_phys):: zentr,zdz,zzentr,zseen,zqeen,zsdde,zqdde,zdmfdp - real(kind=kind_phys):: zmfdsk,zmfdqk,zbuo,zrain,zbuoyz,zmfduk,zmfdvk - real(kind=kind_phys),dimension(klon):: zdmfen,zdmfde,zcond,zoentr,zbuoy,zph - -!---------------------------------------------------------------------- -! 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): - -! *ptsphy* 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 subroutines -!-------------------------------------------------------- - 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 - -!--- input arguments: - integer,intent(in):: klon - logical,intent(in),dimension(klon):: ldcum,lddraf - - integer,intent(in):: klev,ktopm2 - integer,intent(in),dimension(klon):: kctop,kdtop - - real(kind=kind_phys),intent(in):: ztmst - real(kind=kind_phys),intent(in),dimension(klon,klev):: pgeo - real(kind=kind_phys),intent(in),dimension(klon,klev):: pten - real(kind=kind_phys),intent(in),dimension(klon,klev):: pmfu,pmfus,pmfd,pmfds - real(kind=kind_phys),intent(in),dimension(klon,klev):: pmfuq,pmfdq,pmful - real(kind=kind_phys),intent(in),dimension(klon,klev):: plglac,plude,pdpmel - real(kind=kind_phys),intent(in),dimension(klon,klev):: pdmfup,pdmfdp - real(kind=kind_phys),intent(in),dimension(klon,klev):: pqen, ptenh,pqenh,pqsen - real(kind=kind_phys),intent(in),dimension(klon,klev+1):: paph,pgeoh - -!--- inout arguments: - real(kind=kind_phys),intent(inout),dimension(klon,klev):: ptent,ptenq,pcte - -!--- local variables and arrays: - integer:: jk ,ik ,jl - real(kind=kind_phys):: zalv ,zzp - real(kind=kind_phys),dimension(klon,klev):: zdtdt,zdqdt,zdp - - !* 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 subroutines -!-------------------------------------------------------- - subroutine cududvn(klon,klev,ktopm2,ktype,kcbot,kctop,ldcum, & - ztmst,paph,puen,pven,pmfu,pmfd,puu,pud,pvu,pvd,ptenu, & - ptenv) - implicit none - -!--- input arguments: - integer,intent(in):: klon - logical,intent(in),dimension(klon):: ldcum - integer,intent(in):: klev,ktopm2 - integer,intent(in),dimension(klon):: ktype,kcbot,kctop - - real(kind=kind_phys),intent(in):: ztmst - real(kind=kind_phys),intent(in),dimension(klon,klev):: pmfu,pmfd,puen,pven - real(kind=kind_phys),intent(in),dimension(klon,klev):: puu,pud,pvu,pvd - real(kind=kind_phys),intent(in),dimension(klon,klev+1):: paph - -!--- inout arguments: - real(kind=kind_phys),intent(inout),dimension(klon,klev):: ptenu,ptenv - -!--- local variables and arrays: - integer:: ik,ikb,jk,jl - - real(kind=kind_phys):: zzp,zdtdt - real(kind=kind_Phys),dimension(klon,klev):: zdudt,zdvdt,zdp - real(kind=kind_phys),dimension(klon,klev):: zuen,zven,zmfuu,zmfdu,zmfuv,zmfdv - -! - 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 subroutines -!-------------------------------------------------------- - 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): - -! *psp* pressure pa - -! updated parameters (real): - -! *pt* temperature k -! *pq* specific humidity kg/kg -! externals -! --------- -! for condensation calculations. -! the tables are initialised in *suphec*. - -!---------------------------------------------------------------------- - - implicit none - -!--- input arguments: - integer,intent(in):: klon - logical,intent(in),dimension(klon):: ldflag - integer,intent(in):: kcall,kk,klev - - real(kind=kind_phys),intent(in),dimension(klon):: psp - -!--- inout arguments: - real(kind=kind_phys),intent(inout),dimension(klon,klev):: pt,pq - -!--- local variables and arrays: - integer:: jl,jk - integer:: isum - - 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 subroutines -!-------------------------------------------------------- - 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 -! ---------------------------------------------------------------- - -!--- input arguments: - integer,intent(in):: klon - logical,intent(in),dimension(klon):: ldcum - integer,intent(in):: kk,klev,klevm1 - - real(kind=kind_phys),intent(in),dimension(klon,klev):: pten,pqen,pqsen,pgeo,pverv - real(kind=kind_phys),intent(in),dimension(klon,klev):: puen,pven ! not used. - real(kind=kind_phys),intent(in),dimension(klon,klev):: puu,pvu ! not used. - real(kind=kind_phys),intent(in),dimension(klon,klev+1):: pgeoh - -!--- output arguments: - integer,intent(out),dimension(klon):: ktype,kcbot - integer,intent(out),dimension(klon,klev):: klab - - real(kind=kind_phys),intent(out),dimension(klon):: pmfub - real(kind=kind_phys),intent(out),dimension(klon,klev):: plrain - real(kind=kind_phys),intent(out),dimension(klon,klev):: ptu,pqu,plu - real(kind=kind_phys),intent(out),dimension(klon,klev):: pmfu,pmfus,pmfuq,pmful - real(kind=kind_phys),intent(out),dimension(klon,klev):: pdmfup - -!--- local variables and arrays: - integer:: jl,klevp1 - 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 subroutines -!--------------------------------------------------------- - subroutine cuentrn(klon,klev,kk,kcbot,ldcum,ldwork, & - pgeoh,pmfu,pdmfen,pdmfde) - implicit none - -!--- input arguments: - logical,intent(in):: ldwork - integer,intent(in):: klon - logical,intent(in),dimension(klon):: ldcum - - integer,intent(in):: klev,kk - integer,intent(in),dimension(klon):: kcbot - - real(kind=kind_phys),intent(in),dimension(klon,klev):: pmfu - real(kind=kind_phys),intent(in),dimension(klon,klev+1):: pgeoh - -!--- output arguments: - real(kind=kind_phys),intent(out),dimension(klon):: pdmfen - real(kind=kind_phys),intent(out),dimension(klon):: pdmfde - -!--- local variables and arrays: - logical:: llo1 - integer:: jl - real(kind=kind_phys):: zdz ,zmf - real(kind=kind_phys),dimension(klon):: zentr - - ! - !* 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),intent(in):: 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),intent(in):: 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),intent(in):: 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),intent(in):: 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),intent(in):: tt - foeldcpm = foealfa(tt)*ralvdcp+ & - & (1.-foealfa(tt))*ralsdcp - return - end function foeldcpm - -!================================================================================================================= - end module cu_ntiedtke -!================================================================================================================= - diff --git a/phys/physics_mmm/module_libmassv.F90 b/phys/physics_mmm/module_libmassv.F90 deleted file mode 100644 index 60ff9fa022..0000000000 --- a/phys/physics_mmm/module_libmassv.F90 +++ /dev/null @@ -1,91 +0,0 @@ -!================================================================================================================= - module module_libmassv - - implicit none - - - interface vrec - module procedure vrec_d - module procedure vrec_s - end interface - - interface vsqrt - module procedure vsqrt_d - module procedure vsqrt_s - end interface - - integer, parameter, private :: R4KIND = selected_real_kind(6) - integer, parameter, private :: R8KIND = selected_real_kind(12) - - contains - - -!================================================================================================================= - subroutine vrec_d(y,x,n) -!================================================================================================================= - integer,intent(in):: n - real(kind=R8KIND),dimension(*),intent(in):: x - real(kind=R8KIND),dimension(*),intent(out):: y - - integer:: j -!----------------------------------------------------------------------------------------------------------------- - - do j=1,n - y(j)=real(1.0,kind=R8KIND)/x(j) - enddo - - end subroutine vrec_d - -!================================================================================================================= - subroutine vrec_s(y,x,n) -!================================================================================================================= - integer,intent(in):: n - real(kind=R4KIND),dimension(*),intent(in):: x - real(kind=R4KIND),dimension(*),intent(out):: y - - integer:: j -!----------------------------------------------------------------------------------------------------------------- - - do j=1,n - y(j)=real(1.0,kind=R4KIND)/x(j) - enddo - - end subroutine vrec_s - -!================================================================================================================= - subroutine vsqrt_d(y,x,n) -!================================================================================================================= - integer,intent(in):: n - real(kind=R8KIND),dimension(*),intent(in):: x - real(kind=R8KIND),dimension(*),intent(out):: y - - integer:: j -!----------------------------------------------------------------------------------------------------------------- - - do j=1,n - y(j)=sqrt(x(j)) - enddo - - end subroutine vsqrt_d - -!================================================================================================================= - subroutine vsqrt_s(y,x,n) -!================================================================================================================= - - integer,intent(in):: n - real(kind=R4KIND),dimension(*),intent(in):: x - real(kind=R4KIND),dimension(*),intent(out):: y - - integer:: j - -!----------------------------------------------------------------------------------------------------------------- - - do j=1,n - y(j)=sqrt(x(j)) - enddo - - end subroutine vsqrt_s - -!================================================================================================================= - end module module_libmassv -!================================================================================================================= diff --git a/phys/physics_mmm/mp_radar.F90 b/phys/physics_mmm/mp_radar.F90 deleted file mode 100644 index 851e5d3f69..0000000000 --- a/phys/physics_mmm/mp_radar.F90 +++ /dev/null @@ -1,677 +0,0 @@ -!================================================================================================================= - module mp_radar - use ccpp_kind_types,only: kind_phys - - implicit none - private - public:: radar_init, & - rayleigh_soak_wetgraupel - -!+---+-----------------------------------------------------------------+ -!..This set of routines facilitates computing radar reflectivity. -!.. This module is more library code whereas the individual microphysics -!.. schemes contains specific details needed for the final computation, -!.. so refer to location within each schemes calling the routine named -!.. rayleigh_soak_wetgraupel. -!.. The bulk of this code originated from Ulrich Blahak (Germany) and -!.. was adapted to WRF by G. Thompson. This version of code is only -!.. intended for use when Rayleigh scattering principles dominate and -!.. is not intended for wavelengths in which Mie scattering is a -!.. significant portion. Therefore, it is well-suited to use with -!.. 5 or 10 cm wavelength like USA NEXRAD radars. -!.. This code makes some rather simple assumptions about water -!.. coating on outside of frozen species (snow/graupel). Fraction of -!.. meltwater is simply the ratio of mixing ratio below melting level -!.. divided by mixing ratio at level just above highest T>0C. Also, -!.. immediately 90% of the melted water exists on the ice's surface -!.. and 10% is embedded within ice. No water is "shed" at all in these -!.. assumptions. The code is quite slow because it does the reflectivity -!.. calculations based on 50 individual size bins of the distributions. -!+---+-----------------------------------------------------------------+ - - integer, parameter, private :: R4KIND = selected_real_kind(6) - integer, parameter, private :: R8KIND = selected_real_kind(12) - - integer,parameter,public:: nrbins = 50 - integer,parameter,public:: slen = 20 - character(len=slen), public:: & - mixingrulestring_s, matrixstring_s, inclusionstring_s, & - hoststring_s, hostmatrixstring_s, hostinclusionstring_s, & - mixingrulestring_g, matrixstring_g, inclusionstring_g, & - hoststring_g, hostmatrixstring_g, hostinclusionstring_g - - complex(kind=R8KIND),public:: m_w_0, m_i_0 - - double precision,dimension(nrbins+1),public:: xxdx - double precision,dimension(nrbins),public:: xxds,xdts,xxdg,xdtg - double precision,parameter,public:: lamda_radar = 0.10 ! in meters - double precision,public:: k_w,pi5,lamda4 - - double precision, dimension(nrbins+1), public:: simpson - double precision, dimension(3), parameter, public:: basis = & - (/1.d0/3.d0, 4.d0/3.d0, 1.d0/3.d0/) - - real(kind=kind_phys),public,dimension(4):: xcre,xcse,xcge,xcrg,xcsg,xcgg - real(kind=kind_phys),public:: xam_r,xbm_r,xmu_r,xobmr - real(kind=kind_phys),public:: xam_s,xbm_s,xmu_s,xoams,xobms,xocms - real(kind=kind_phys),public:: xam_g,xbm_g,xmu_g,xoamg,xobmg,xocmg - real(kind=kind_phys),public:: xorg2,xosg2,xogg2 - - -!..Single melting snow/graupel particle 90% meltwater on external sfc - character(len=256):: radar_debug - - double precision,parameter,public:: melt_outside_s = 0.9d0 - double precision,parameter,public:: melt_outside_g = 0.9d0 - - - contains - - -!================================================================================================================= - subroutine radar_init - implicit none -!================================================================================================================= - - integer:: n - -!----------------------------------------------------------------------------------------------------------------- - - pi5 = 3.14159*3.14159*3.14159*3.14159*3.14159 - lamda4 = lamda_radar*lamda_radar*lamda_radar*lamda_radar - m_w_0 = m_complex_water_ray (lamda_radar, 0.0d0) - m_i_0 = m_complex_ice_maetzler (lamda_radar, 0.0d0) - k_w = (abs( (m_w_0*m_w_0 - 1.0) /(m_w_0*m_w_0 + 2.0) ))**2 - - do n = 1, nrbins+1 - simpson(n) = 0.0d0 - enddo - do n = 1, nrbins-1, 2 - simpson(n) = simpson(n) + basis(1) - simpson(n+1) = simpson(n+1) + basis(2) - simpson(n+2) = simpson(n+2) + basis(3) - enddo - - do n = 1, slen - mixingrulestring_s(n:n) = char(0) - matrixstring_s(n:n) = char(0) - inclusionstring_s(n:n) = char(0) - hoststring_s(n:n) = char(0) - hostmatrixstring_s(n:n) = char(0) - hostinclusionstring_s(n:n) = char(0) - mixingrulestring_g(n:n) = char(0) - matrixstring_g(n:n) = char(0) - inclusionstring_g(n:n) = char(0) - hoststring_g(n:n) = char(0) - hostmatrixstring_g(n:n) = char(0) - hostinclusionstring_g(n:n) = char(0) - enddo - - mixingrulestring_s = 'maxwellgarnett' - hoststring_s = 'air' - matrixstring_s = 'water' - inclusionstring_s = 'spheroidal' - hostmatrixstring_s = 'icewater' - hostinclusionstring_s = 'spheroidal' - - mixingrulestring_g = 'maxwellgarnett' - hoststring_g = 'air' - matrixstring_g = 'water' - inclusionstring_g = 'spheroidal' - hostmatrixstring_g = 'icewater' - hostinclusionstring_g = 'spheroidal' - -!..Create bins of snow (from 100 microns up to 2 cm). - xxdx(1) = 100.d-6 - xxdx(nrbins+1) = 0.02d0 - do n = 2, nrbins - xxdx(n) = dexp(real(n-1,kind=R8KIND)/real(nrbins,kind=R8KIND) & - * dlog(xxdx(nrbins+1)/xxdx(1)) +dlog(xxdx(1))) - enddo - do n = 1, nrbins - xxds(n) = dsqrt(xxdx(n)*xxdx(n+1)) - xdts(n) = xxdx(n+1) - xxdx(n) - enddo - -!..create bins of graupel (from 100 microns up to 5 cm). - xxdx(1) = 100.d-6 - xxdx(nrbins+1) = 0.05d0 - do n = 2, nrbins - xxdx(n) = dexp(real(n-1,kind=R8KIND)/real(nrbins,kind=R8KIND) & - * dlog(xxdx(nrbins+1)/xxdx(1)) +dlog(xxdx(1))) - enddo - do n = 1, nrbins - xxdg(n) = dsqrt(xxdx(n)*xxdx(n+1)) - xdtg(n) = xxdx(n+1) - xxdx(n) - enddo - - -!.. The calling program must set the m(D) relations and gamma shape -!.. parameter mu for rain, snow, and graupel. Easily add other types -!.. based on the template here. For majority of schemes with simpler -!.. exponential number distribution, mu=0. - - xcre(1) = 1. + xbm_r - xcre(2) = 1. + xmu_r - xcre(3) = 4. + xmu_r - xcre(4) = 7. + xmu_r - do n = 1, 4 - xcrg(n) = wgamma(xcre(n)) - enddo - xorg2 = 1./xcrg(2) - - xcse(1) = 1. + xbm_s - xcse(2) = 1. + xmu_s - xcse(3) = 4. + xmu_s - xcse(4) = 7. + xmu_s - do n = 1, 4 - xcsg(n) = wgamma(xcse(n)) - enddo - xosg2 = 1./xcsg(2) - - xcge(1) = 1. + xbm_g - xcge(2) = 1. + xmu_g - xcge(3) = 4. + xmu_g - xcge(4) = 7. + xmu_g - do n = 1, 4 - xcgg(n) = wgamma(xcge(n)) - enddo - xogg2 = 1./xcgg(2) - - xobmr = 1./xbm_r - xoams = 1./xam_s - xobms = 1./xbm_s - xocms = xoams**xobms - xoamg = 1./xam_g - xobmg = 1./xbm_g - xocmg = xoamg**xobmg - - end subroutine radar_init - -!================================================================================================================= - subroutine rayleigh_soak_wetgraupel(x_g,a_geo,b_geo,fmelt,meltratio_outside,m_w,m_i,lambda,c_back, & - mixingrule,matrix,inclusion,host,hostmatrix,hostinclusion) - implicit none -!================================================================================================================= - -!--- input arguments: - character(len=*), intent(in):: mixingrule, matrix, inclusion, & - host, hostmatrix, hostinclusion - - complex(kind=R8KIND),intent(in):: m_w, m_i - - double precision, intent(in):: x_g, a_geo, b_geo, fmelt, lambda, meltratio_outside - -!--- output arguments: - double precision,intent(out):: c_back - -!--- local variables: - integer:: error - - complex(kind=R8KIND):: m_core, m_air - - double precision, parameter:: pix=3.1415926535897932384626434d0 - double precision:: d_large, d_g, rhog, x_w, xw_a, fm, fmgrenz, & - volg, vg, volair, volice, volwater, & - meltratio_outside_grenz, mra - -!----------------------------------------------------------------------------------------------------------------- - -!refractive index of air: - m_air = (1.0d0,0.0d0) - -!Limiting the degree of melting --- for safety: - fm = dmax1(dmin1(fmelt, 1.0d0), 0.0d0) -!Limiting the ratio of (melting on outside)/(melting on inside): - mra = dmax1(dmin1(meltratio_outside, 1.0d0), 0.0d0) - -!The relative portion of meltwater melting at outside should increase -!from the given input value (between 0 and 1) -!to 1 as the degree of melting approaches 1, -!so that the melting particle "converges" to a water drop. -!Simplest assumption is linear: - mra = mra + (1.0d0-mra)*fm - - x_w = x_g * fm - - d_g = a_geo * x_g**b_geo - - if(D_g .ge. 1d-12) then - - vg = PIx/6. * D_g**3 - rhog = DMAX1(DMIN1(x_g / vg, 900.0d0), 10.0d0) - vg = x_g / rhog - - meltratio_outside_grenz = 1.0d0 - rhog / 1000. - - if (mra .le. meltratio_outside_grenz) then - !..In this case, it cannot happen that, during melting, all the - !.. air inclusions within the ice particle get filled with - !.. meltwater. This only happens at the end of all melting. - volg = vg * (1.0d0 - mra * fm) - - else - !..In this case, at some melting degree fm, all the air - !.. inclusions get filled with meltwater. - fmgrenz=(900.0-rhog)/(mra*900.0-rhog+900.0*rhog/1000.) - - if (fm .le. fmgrenz) then - !.. not all air pockets are filled: - volg = (1.0 - mra * fm) * vg - else - !..all air pockets are filled with meltwater, now the - !.. entire ice sceleton melts homogeneously: - volg = (x_g - x_w) / 900.0 + x_w / 1000. - endif - - endif - - d_large = (6.0 / pix * volg) ** (1./3.) - volice = (x_g - x_w) / (volg * 900.0) - volwater = x_w / (1000. * volg) - volair = 1.0 - volice - volwater - - !..complex index of refraction for the ice-air-water mixture - !.. of the particle: - m_core = get_m_mix_nested (m_air, m_i, m_w, volair, volice, & - volwater, mixingrule, host, matrix, inclusion, & - hostmatrix, hostinclusion, error) - if (error .ne. 0) then - c_back = 0.0d0 - return - endif - - !..rayleigh-backscattering coefficient of melting particle: - c_back = (abs((m_core**2-1.0d0)/(m_core**2+2.0d0)))**2 & - * pi5 * d_large**6 / lamda4 - - else - c_back = 0.0d0 - endif - - end subroutine rayleigh_soak_wetgraupel - -!================================================================================================================= - real(kind=kind_phys) function wgamma(y) - implicit none -!================================================================================================================= - -!--- input arguments: - real(kind=kind_phys),intent(in):: y - -!----------------------------------------------------------------------------------------------------------------- - - wgamma = exp(gammln(y)) - - end function wgamma - -!================================================================================================================= - real(kind=kind_phys) function gammln(xx) - implicit none -!(C) Copr. 1986-92 Numerical Recipes Software 2.02 -!================================================================================================================= - -!--- inout arguments: - real(kind=kind_phys),intent(in):: xx - -!--- local variables: - integer:: j - - double precision,parameter:: stp = 2.5066282746310005d0 - double precision,dimension(6), parameter:: & - cof = (/76.18009172947146d0, -86.50532032941677d0, & - 24.01409824083091d0, -1.231739572450155d0, & - .1208650973866179d-2, -.5395239384953d-5/) - double precision:: ser,tmp,x,y - -!----------------------------------------------------------------------------------------------------------------- - -!--- returns the value ln(gamma(xx)) for xx > 0. - x = xx - y = x - tmp = x+5.5d0 - tmp = (x+0.5d0)*log(tmp)-tmp - ser = 1.000000000190015d0 - do j = 1,6 - y=y+1.d0 - ser=ser+cof(j)/y - enddo - - gammln=tmp+log(stp*ser/x) - - end function gammln - -!================================================================================================================= - complex(kind=R8KIND) function get_m_mix_nested (m_a, m_i, m_w, volair, & - volice, volwater, mixingrule, host, matrix, & - inclusion, hostmatrix, hostinclusion, cumulerror) - implicit none -!================================================================================================================= - -!--- input arguments: - character(len=*),intent(in):: mixingrule, host, matrix, & - inclusion, hostmatrix, hostinclusion - - complex(kind=R8KIND),intent(in):: m_a, m_i, m_w - - double precision,intent(in):: volice, volair, volwater - -!--- output arguments: - integer,intent(out):: cumulerror - -!--- local variables: - integer:: error - - complex(kind=R8KIND):: mtmp - - double precision:: vol1, vol2 - -!----------------------------------------------------------------------------------------------------------------- - -!..Folded: ( (m1 + m2) + m3), where m1,m2,m3 could each be air, ice, or water - cumulerror = 0 - get_m_mix_nested = cmplx(1.0d0,0.0d0) - - if (host .eq. 'air') then - if (matrix .eq. 'air') then - write(radar_debug,*) 'GET_M_MIX_NESTED: bad matrix: ', matrix -! call physics_message(radar_debug) - cumulerror = cumulerror + 1 - else - vol1 = volice / MAX(volice+volwater,1d-10) - vol2 = 1.0d0 - vol1 - mtmp = get_m_mix (m_a, m_i, m_w, 0.0d0, vol1, vol2, & - mixingrule, matrix, inclusion, error) - cumulerror = cumulerror + error - - if (hostmatrix .eq. 'air') then - get_m_mix_nested = get_m_mix (m_a, mtmp, 2.0*m_a, & - volair, (1.0d0-volair), 0.0d0, mixingrule, & - hostmatrix, hostinclusion, error) - cumulerror = cumulerror + error - elseif (hostmatrix .eq. 'icewater') then - get_m_mix_nested = get_m_mix (m_a, mtmp, 2.0*m_a, & - volair, (1.0d0-volair), 0.0d0, mixingrule, & - 'ice', hostinclusion, error) - cumulerror = cumulerror + error - else - write(radar_debug,*) 'GET_M_MIX_NESTED: bad hostmatrix: ', hostmatrix -! call physics_message(radar_debug) - cumulerror = cumulerror + 1 - endif - endif - - elseif (host .eq. 'ice') then - - if (matrix .eq. 'ice') then - write(radar_debug,*) 'GET_M_MIX_NESTED: bad matrix: ', matrix -! call physics_message(radar_debug) - cumulerror = cumulerror + 1 - else - vol1 = volair / MAX(volair+volwater,1d-10) - vol2 = 1.0d0 - vol1 - mtmp = get_m_mix (m_a, m_i, m_w, vol1, 0.0d0, vol2, & - mixingrule, matrix, inclusion, error) - cumulerror = cumulerror + error - - if (hostmatrix .eq. 'ice') then - get_m_mix_nested = get_m_mix (mtmp, m_i, 2.0*m_a, & - (1.0d0-volice), volice, 0.0d0, mixingrule, & - hostmatrix, hostinclusion, error) - cumulerror = cumulerror + error - elseif (hostmatrix .eq. 'airwater') then - get_m_mix_nested = get_m_mix (mtmp, m_i, 2.0*m_a, & - (1.0d0-volice), volice, 0.0d0, mixingrule, & - 'air', hostinclusion, error) - cumulerror = cumulerror + error - else - write(radar_debug,*) 'GET_M_MIX_NESTED: bad hostmatrix: ', hostmatrix -! call physics_message(radar_debug) - cumulerror = cumulerror + 1 - endif - endif - - elseif (host .eq. 'water') then - - if (matrix .eq. 'water') then - write(radar_debug,*) 'GET_M_MIX_NESTED: bad matrix: ', matrix -! call physics_message(radar_debug) - cumulerror = cumulerror + 1 - else - vol1 = volair / MAX(volice+volair,1d-10) - vol2 = 1.0d0 - vol1 - mtmp = get_m_mix (m_a, m_i, m_w, vol1, vol2, 0.0d0, & - mixingrule, matrix, inclusion, error) - cumulerror = cumulerror + error - - if (hostmatrix .eq. 'water') then - get_m_mix_nested = get_m_mix (2*m_a, mtmp, m_w, & - 0.0d0, (1.0d0-volwater), volwater, mixingrule, & - hostmatrix, hostinclusion, error) - cumulerror = cumulerror + error - elseif (hostmatrix .eq. 'airice') then - get_m_mix_nested = get_m_mix (2*m_a, mtmp, m_w, & - 0.0d0, (1.0d0-volwater), volwater, mixingrule, & - 'ice', hostinclusion, error) - cumulerror = cumulerror + error - else - write(radar_debug,*) 'GET_M_MIX_NESTED: bad hostmatrix: ', hostmatrix -! call physics_message(radar_debug) - cumulerror = cumulerror + 1 - endif - endif - - elseif (host .eq. 'none') then - - get_m_mix_nested = get_m_mix (m_a, m_i, m_w, & - volair, volice, volwater, mixingrule, & - matrix, inclusion, error) - cumulerror = cumulerror + error - - else - write(radar_debug,*) 'GET_M_MIX_NESTED: unknown matrix: ', host -! call physics_message(radar_debug) - cumulerror = cumulerror + 1 - endif - - if (cumulerror .ne. 0) then - write(radar_debug,*) 'get_m_mix_nested: error encountered' -! call physics_message(radar_debug) - get_m_mix_nested = cmplx(1.0d0,0.0d0) - endif - - end function get_m_mix_nested - -!================================================================================================================= - complex(kind=R8KIND) function get_m_mix (m_a, m_i, m_w, volair, volice, & - volwater, mixingrule, matrix, inclusion, & - error) - implicit none -!================================================================================================================= - -!--- input arguments: - character(len=*),intent(in):: mixingrule, matrix, inclusion - - complex(kind=R8KIND), intent(in):: m_a, m_i, m_w - - double precision, intent(in):: volice, volair, volwater - -!--- output arguments: - integer,intent(out):: error - -!----------------------------------------------------------------------------------------------------------------- - error = 0 - get_m_mix = cmplx(1.0d0,0.0d0) - - if (mixingrule .eq. 'maxwellgarnett') then - if (matrix .eq. 'ice') then - get_m_mix = m_complex_maxwellgarnett(volice, volair, volwater, & - m_i, m_a, m_w, inclusion, error) - elseif (matrix .eq. 'water') then - get_m_mix = m_complex_maxwellgarnett(volwater, volair, volice, & - m_w, m_a, m_i, inclusion, error) - elseif (matrix .eq. 'air') then - get_m_mix = m_complex_maxwellgarnett(volair, volwater, volice, & - m_a, m_w, m_i, inclusion, error) - else - write(radar_debug,*) 'GET_M_MIX: unknown matrix: ', matrix -! call physics_message(radar_debug) - error = 1 - endif - - else - write(radar_debug,*) 'GET_M_MIX: unknown mixingrule: ', mixingrule -! call physics_message(radar_debug) - error = 2 - endif - - if (error .ne. 0) then - write(radar_debug,*) 'GET_M_MIX: error encountered' -! call physics_message(radar_debug) - endif - - end function get_m_mix - -!================================================================================================================= - complex(kind=R8KIND) function m_complex_maxwellgarnett(vol1, vol2, vol3, & - m1, m2, m3, inclusion, error) - implicit none -!================================================================================================================= - -!--- input arguments: - character(len=*),intent(in):: inclusion - - complex(kind=R8KIND),intent(in):: m1,m2,m3 - - double precision,intent(in):: vol1,vol2,vol3 - - -!--- output arguments: - integer,intent(out):: error - -!--- local variables: - complex(kind=R8KIND) :: beta2, beta3, m1t, m2t, m3t - -!----------------------------------------------------------------------------------------------------------------- - - error = 0 - - if (dabs(vol1+vol2+vol3-1.0d0) .gt. 1d-6) then - write(radar_debug,*) 'M_COMPLEX_MAXWELLGARNETT: sum of the ', & - 'partial volume fractions is not 1...ERROR' -! call physics_message(radar_debug) - m_complex_maxwellgarnett = CMPLX(-999.99d0,-999.99d0) - error = 1 - return - endif - - m1t = m1**2 - m2t = m2**2 - m3t = m3**2 - - if (inclusion .eq. 'spherical') then - beta2 = 3.0d0*m1t/(m2t+2.0d0*m1t) - beta3 = 3.0d0*m1t/(m3t+2.0d0*m1t) - elseif (inclusion .eq. 'spheroidal') then - beta2 = 2.0d0*m1t/(m2t-m1t) * (m2t/(m2t-m1t)*LOG(m2t/m1t)-1.0d0) - beta3 = 2.0d0*m1t/(m3t-m1t) * (m3t/(m3t-m1t)*LOG(m3t/m1t)-1.0d0) - else - write(radar_debug,*) 'M_COMPLEX_MAXWELLGARNETT: ', 'unknown inclusion: ', inclusion -! call physics_message(radar_debug) - m_complex_maxwellgarnett=cmplx(-999.99d0,-999.99d0,kind=R8KIND) - error = 1 - return - endif - - m_complex_maxwellgarnett = sqrt(((1.0d0-vol2-vol3)*m1t + vol2*beta2*m2t + vol3*beta3*m3t) / & - (1.0d0-vol2-vol3+vol2*beta2+vol3*beta3)) - - end function m_complex_maxwellgarnett - -!================================================================================================================= - complex(kind=R8KIND) function m_complex_water_ray(lambda,t) - implicit none -!================================================================================================================= - -!complex refractive Index of Water as function of Temperature T -![deg C] and radar wavelength lambda [m]; valid for -!lambda in [0.001,1.0] m; T in [-10.0,30.0] deg C -!after Ray (1972) - -!--- input arguments: - double precision,intent(in):: t,lambda - -!--- local variables: - double precision,parameter:: pix=3.1415926535897932384626434d0 - double precision:: epsinf,epss,epsr,epsi - double precision:: alpha,lambdas,sigma,nenner - complex(kind=R8KIND),parameter:: i = (0d0,1d0) - -!----------------------------------------------------------------------------------------------------------------- - - epsinf = 5.27137d0 + 0.02164740d0 * T - 0.00131198d0 * T*T - epss = 78.54d+0 * (1.0 - 4.579d-3 * (T - 25.0) & - + 1.190d-5 * (T - 25.0)*(T - 25.0) & - - 2.800d-8 * (T - 25.0)*(T - 25.0)*(T - 25.0)) - alpha = -16.8129d0/(T+273.16) + 0.0609265d0 - lambdas = 0.00033836d0 * exp(2513.98d0/(T+273.16)) * 1e-2 - - nenner = 1.d0+2.d0*(lambdas/lambda)**(1d0-alpha)*sin(alpha*PIx*0.5) & - + (lambdas/lambda)**(2d0-2d0*alpha) - epsr = epsinf + ((epss-epsinf) * ((lambdas/lambda)**(1d0-alpha) & - * sin(alpha*PIx*0.5)+1d0)) / nenner - epsi = ((epss-epsinf) * ((lambdas/lambda)**(1d0-alpha) & - * cos(alpha*PIx*0.5)+0d0)) / nenner & - + lambda*1.25664/1.88496 - - m_complex_water_ray = sqrt(cmplx(epsr,-epsi)) - - end function m_complex_water_ray - -!================================================================================================================= - complex(kind=R8KIND) function m_complex_ice_maetzler(lambda,t) - implicit none -!================================================================================================================= - -!complex refractive index of ice as function of Temperature T -![deg C] and radar wavelength lambda [m]; valid for -!lambda in [0.0001,30] m; T in [-250.0,0.0] C -!Original comment from the Matlab-routine of Prof. Maetzler: -!Function for calculating the relative permittivity of pure ice in -!the microwave region, according to C. Maetzler, "Microwave -!properties of ice and snow", in B. Schmitt et al. (eds.) Solar -!System Ices, Astrophys. and Space Sci. Library, Vol. 227, Kluwer -!Academic Publishers, Dordrecht, pp. 241-257 (1998). Input: -!TK = temperature (K), range 20 to 273.15 -!f = frequency in GHz, range 0.01 to 3000 - -!--- input arguments: - double precision,intent(in):: t,lambda - -!--- local variables: - double precision:: f,c,tk,b1,b2,b,deltabeta,betam,beta,theta,alfa - -!----------------------------------------------------------------------------------------------------------------- - - c = 2.99d8 - tk = t + 273.16 - f = c / lambda * 1d-9 - - b1 = 0.0207 - b2 = 1.16d-11 - b = 335.0d0 - deltabeta = exp(-10.02 + 0.0364*(tk-273.16)) - betam = (b1/tk) * ( exp(b/tk) / ((exp(b/tk)-1)**2) ) + b2*f*f - beta = betam + deltabeta - theta = 300. / tk - 1. - alfa = (0.00504d0 + 0.0062d0*theta) * exp(-22.1d0*theta) - m_complex_ice_maetzler = 3.1884 + 9.1e-4*(tk-273.16) - m_complex_ice_maetzler = m_complex_ice_maetzler & - + cmplx(0.0d0, (alfa/f + beta*f)) - m_complex_ice_maetzler = sqrt(conjg(m_complex_ice_maetzler)) - - end function m_complex_ice_maetzler - -!================================================================================================================= - end module mp_radar -!================================================================================================================= diff --git a/phys/physics_mmm/mp_wsm6.F90 b/phys/physics_mmm/mp_wsm6.F90 deleted file mode 100644 index ec2d1dca3c..0000000000 --- a/phys/physics_mmm/mp_wsm6.F90 +++ /dev/null @@ -1,2449 +0,0 @@ -!================================================================================================================= - module mp_wsm6 - use ccpp_kind_types,only: kind_phys - use module_libmassv,only: vrec,vsqrt - - use mp_radar - - implicit none - private - public:: mp_wsm6_run, & - mp_wsm6_init, & - mp_wsm6_finalize, & - refl10cm_wsm6 - - real(kind=kind_phys),parameter,private:: dtcldcr = 120. ! maximum time step for minor loops - real(kind=kind_phys),parameter,private:: n0r = 8.e6 ! intercept parameter rain -!real(kind=kind_phys),parameter,private:: n0g = 4.e6 ! intercept parameter graupel - real(kind=kind_phys),parameter,private:: avtr = 841.9 ! a constant for terminal velocity of rain - real(kind=kind_phys),parameter,private:: bvtr = 0.8 ! a constant for terminal velocity of rain - real(kind=kind_phys),parameter,private:: r0 = .8e-5 ! 8 microm in contrast to 10 micro m - real(kind=kind_phys),parameter,private:: peaut = .55 ! collection efficiency - real(kind=kind_phys),parameter,private:: xncr = 3.e8 ! maritime cloud in contrast to 3.e8 in tc80 - real(kind=kind_phys),parameter,private:: xmyu = 1.718e-5 ! the dynamic viscosity kgm-1s-1 - real(kind=kind_phys),parameter,private:: avts = 11.72 ! a constant for terminal velocity of snow - real(kind=kind_phys),parameter,private:: bvts = .41 ! a constant for terminal velocity of snow -!real(kind=kind_phys),parameter,private:: avtg = 330. ! a constant for terminal velocity of graupel -!real(kind=kind_phys),parameter,private:: bvtg = 0.8 ! a constant for terminal velocity of graupel -!real(kind=kind_phys),parameter,private:: deng = 500. ! density of graupel ! set later with hail_opt - real(kind=kind_phys),parameter,private:: lamdarmax = 8.e4 ! limited maximum value for slope parameter of rain - real(kind=kind_phys),parameter,private:: lamdasmax = 1.e5 ! limited maximum value for slope parameter of snow -!real(kind=kind_phys),parameter,private:: lamdagmax = 6.e4 ! limited maximum value for slope parameter of graupel - real(kind=kind_phys),parameter,private:: dicon = 11.9 ! constant for the cloud-ice diamter - real(kind=kind_phys),parameter,private:: dimax = 500.e-6 ! limited maximum value for the cloud-ice diamter - real(kind=kind_phys),parameter,private:: pfrz1 = 100. ! constant in Biggs freezing - real(kind=kind_phys),parameter,private:: pfrz2 = 0.66 ! constant in Biggs freezing - real(kind=kind_phys),parameter,private:: qcrmin = 1.e-9 ! minimun values for qr, qs, and qg - real(kind=kind_phys),parameter,private:: eacrc = 1.0 ! Snow/cloud-water collection efficiency - real(kind=kind_phys),parameter,private:: dens = 100.0 ! Density of snow - real(kind=kind_phys),parameter,private:: qs0 = 6.e-4 ! threshold amount for aggretion to occur - - real(kind=kind_phys),parameter,public :: n0smax = 1.e11 ! maximum n0s (t=-90C unlimited) - real(kind=kind_phys),parameter,public :: n0s = 2.e6 ! temperature dependent intercept parameter snow - real(kind=kind_phys),parameter,public :: alpha = .12 ! .122 exponen factor for n0s - - real(kind=kind_phys),save:: & - qc0,qck1, & - bvtr1,bvtr2,bvtr3,bvtr4,g1pbr, & - g3pbr,g4pbr,g5pbro2,pvtr,eacrr,pacrr, & - bvtr6,g6pbr, & - precr1,precr2,roqimax,bvts1, & - bvts2,bvts3,bvts4,g1pbs,g3pbs,g4pbs, & - n0g,avtg,bvtg,deng,lamdagmax, & !RAS13.3 - set these in wsm6init - g5pbso2,pvts,pacrs,precs1,precs2,pidn0r, & - xlv1,pacrc,pi, & - bvtg1,bvtg2,bvtg3,bvtg4,g1pbg, & - g3pbg,g4pbg,g5pbgo2,pvtg,pacrg, & - precg1,precg2,pidn0g, & - rslopermax,rslopesmax,rslopegmax, & - rsloperbmax,rslopesbmax,rslopegbmax, & - rsloper2max,rslopes2max,rslopeg2max, & - rsloper3max,rslopes3max,rslopeg3max - - real(kind=kind_phys),public,save:: pidn0s,pidnc - - - contains - - -!================================================================================================================= -!>\section arg_table_mp_wsm6_init -!!\html\include mp_wsm6_init.html -!! - subroutine mp_wsm6_init(den0,denr,dens,cl,cpv,hail_opt,errmsg,errflg) -!================================================================================================================= - -!input arguments: - integer,intent(in):: hail_opt ! RAS - real(kind=kind_phys),intent(in):: den0,denr,dens,cl,cpv - -!output arguments: - character(len=*),intent(out):: errmsg - integer,intent(out):: errflg - -!----------------------------------------------------------------------------------------------------------------- - -! RAS13.1 define graupel parameters as graupel-like or hail-like, -! depending on namelist option - if(hail_opt .eq. 1) then !Hail! - n0g = 4.e4 - deng = 700. - avtg = 285.0 - bvtg = 0.8 - lamdagmax = 2.e4 - else !Graupel! - n0g = 4.e6 - deng = 500 - avtg = 330.0 - bvtg = 0.8 - lamdagmax = 6.e4 - endif -! - pi = 4.*atan(1.) - xlv1 = cl-cpv -! - qc0 = 4./3.*pi*denr*r0**3*xncr/den0 ! 0.419e-3 -- .61e-3 - qck1 = .104*9.8*peaut/(xncr*denr)**(1./3.)/xmyu*den0**(4./3.) ! 7.03 - pidnc = pi*denr/6. ! syb -! - bvtr1 = 1.+bvtr - bvtr2 = 2.5+.5*bvtr - bvtr3 = 3.+bvtr - bvtr4 = 4.+bvtr - bvtr6 = 6.+bvtr - g1pbr = rgmma(bvtr1) - g3pbr = rgmma(bvtr3) - g4pbr = rgmma(bvtr4) ! 17.837825 - g6pbr = rgmma(bvtr6) - g5pbro2 = rgmma(bvtr2) ! 1.8273 - pvtr = avtr*g4pbr/6. - eacrr = 1.0 - pacrr = pi*n0r*avtr*g3pbr*.25*eacrr - precr1 = 2.*pi*n0r*.78 - precr2 = 2.*pi*n0r*.31*avtr**.5*g5pbro2 - roqimax = 2.08e22*dimax**8 -! - bvts1 = 1.+bvts - bvts2 = 2.5+.5*bvts - bvts3 = 3.+bvts - bvts4 = 4.+bvts - g1pbs = rgmma(bvts1) !.8875 - g3pbs = rgmma(bvts3) - g4pbs = rgmma(bvts4) ! 12.0786 - g5pbso2 = rgmma(bvts2) - pvts = avts*g4pbs/6. - pacrs = pi*n0s*avts*g3pbs*.25 - precs1 = 4.*n0s*.65 - precs2 = 4.*n0s*.44*avts**.5*g5pbso2 - pidn0r = pi*denr*n0r - pidn0s = pi*dens*n0s -! - pacrc = pi*n0s*avts*g3pbs*.25*eacrc -! - bvtg1 = 1.+bvtg - bvtg2 = 2.5+.5*bvtg - bvtg3 = 3.+bvtg - bvtg4 = 4.+bvtg - g1pbg = rgmma(bvtg1) - g3pbg = rgmma(bvtg3) - g4pbg = rgmma(bvtg4) - pacrg = pi*n0g*avtg*g3pbg*.25 - g5pbgo2 = rgmma(bvtg2) - pvtg = avtg*g4pbg/6. - precg1 = 2.*pi*n0g*.78 - precg2 = 2.*pi*n0g*.31*avtg**.5*g5pbgo2 - pidn0g = pi*deng*n0g -! - rslopermax = 1./lamdarmax - rslopesmax = 1./lamdasmax - rslopegmax = 1./lamdagmax - rsloperbmax = rslopermax ** bvtr - rslopesbmax = rslopesmax ** bvts - rslopegbmax = rslopegmax ** bvtg - rsloper2max = rslopermax * rslopermax - rslopes2max = rslopesmax * rslopesmax - rslopeg2max = rslopegmax * rslopegmax - rsloper3max = rsloper2max * rslopermax - rslopes3max = rslopes2max * rslopesmax - rslopeg3max = rslopeg2max * rslopegmax - -!+---+-----------------------------------------------------------------+ -!.. Set these variables needed for computing radar reflectivity. These -!.. get used within radar_init to create other variables used in the -!.. radar module. - xam_r = PI*denr/6. - xbm_r = 3. - xmu_r = 0. - xam_s = PI*dens/6. - xbm_s = 3. - xmu_s = 0. - xam_g = PI*deng/6. - xbm_g = 3. - xmu_g = 0. - - call radar_init - - errmsg = 'mp_wsm6_init OK' - errflg = 0 - - end subroutine mp_wsm6_init - -!================================================================================================================= -!>\section arg_table_mp_wsm6_finalize -!!\html\include mp_wsm6_finalize.html -!! - subroutine mp_wsm6_finalize(errmsg,errflg) -!================================================================================================================= - -!--- output arguments: - character(len=*),intent(out):: errmsg - integer,intent(out):: errflg - -!----------------------------------------------------------------------------------------------------------------- - - errmsg = 'mp_wsm6_finalize OK' - errflg = 0 - - end subroutine mp_wsm6_finalize - -!================================================================================================================= -!>\section arg_table_mp_wsm6_run -!!\html\include mp_wsm6_run.html -!! - subroutine mp_wsm6_run(t,q,qc,qi,qr,qs,qg,den,p,delz,delt, & - g,cpd,cpv,rd,rv,t0c,ep1,ep2,qmin,xls, & - xlv0,xlf0,den0,denr,cliq,cice,psat, & - rain,rainncv,sr,snow,snowncv,graupel, & - graupelncv,rainprod2d,evapprod2d, & - its,ite,kts,kte,errmsg,errflg & - ) -!=================================================================================================================! -! This code is a 6-class GRAUPEL phase microphyiscs scheme (WSM6) of the -! Single-Moment MicroPhyiscs (WSMMP). The WSMMP assumes that ice nuclei -! number concentration is a function of temperature, and seperate assumption -! is developed, in which ice crystal number concentration is a function -! of ice amount. A theoretical background of the ice-microphysics and related -! processes in the WSMMPs are described in Hong et al. (2004). -! All production terms in the WSM6 scheme are described in Hong and Lim (2006). -! All units are in m.k.s. and source/sink terms in kgkg-1s-1. -! -! WSM6 cloud scheme -! -! Coded by Song-You Hong and Jeong-Ock Jade Lim (Yonsei Univ.) -! Summer 2003 -! -! Implemented by Song-You Hong (Yonsei Univ.) and Jimy Dudhia (NCAR) -! Summer 2004 -! -! further modifications : -! semi-lagrangian sedimentation (JH,2010),hong, aug 2009 -! ==> higher accuracy and efficient at lower resolutions -! reflectivity computation from greg thompson, lim, jun 2011 -! ==> only diagnostic, but with removal of too large drops -! add hail option from afwa, aug 2014 -! ==> switch graupel or hail by changing no, den, fall vel. -! effective radius of hydrometeors, bae from kiaps, jan 2015 -! ==> consistency in solar insolation of rrtmg radiation -! bug fix in melting terms, bae from kiaps, nov 2015 -! ==> density of air is divided, which has not been -! -! Reference) Hong, Dudhia, Chen (HDC, 2004) Mon. Wea. Rev. -! Hong and Lim (HL, 2006) J. Korean Meteor. Soc. -! Dudhia, Hong and Lim (DHL, 2008) J. Meteor. Soc. Japan -! Lin, Farley, Orville (LFO, 1983) J. Appl. Meteor. -! Rutledge, Hobbs (RH83, 1983) J. Atmos. Sci. -! Rutledge, Hobbs (RH84, 1984) J. Atmos. Sci. -! Juang and Hong (JH, 2010) Mon. Wea. Rev. -! - -!input arguments: - integer,intent(in):: its,ite,kts,kte - - real(kind=kind_phys),intent(in),dimension(its:,:):: & - den, & - p, & - delz - real(kind=kind_phys),intent(in):: & - delt, & - g, & - cpd, & - cpv, & - t0c, & - den0, & - rd, & - rv, & - ep1, & - ep2, & - qmin, & - xls, & - xlv0, & - xlf0, & - cliq, & - cice, & - psat, & - denr - -!inout arguments: - real(kind=kind_phys),intent(inout),dimension(its:,:):: & - t - real(kind=kind_phys),intent(inout),dimension(its:,:):: & - q, & - qc, & - qi, & - qr, & - qs, & - qg - real(kind=kind_phys),intent(inout),dimension(its:):: & - rain, & - rainncv, & - sr - - real(kind=kind_phys),intent(inout),dimension(its:),optional:: & - snow, & - snowncv - - real(kind=kind_phys),intent(inout),dimension(its:),optional:: & - graupel, & - graupelncv - - real(kind=kind_phys),intent(inout),dimension(its:,:),optional:: & - rainprod2d, & - evapprod2d - -!output arguments: - character(len=*),intent(out):: errmsg - integer,intent(out):: errflg - -!local variables and arrays: - real(kind=kind_phys),dimension(its:ite,kts:kte,3):: & - rh, & - qsat, & - rslope, & - rslope2, & - rslope3, & - rslopeb, & - qrs_tmp, & - falk, & - fall, & - work1 - real(kind=kind_phys),dimension(its:ite,kts:kte):: & - fallc, & - falkc, & - work1c, & - work2c, & - workr, & - worka - real(kind=kind_phys),dimension(its:ite,kts:kte):: & - den_tmp, & - delz_tmp - real(kind=kind_phys),dimension(its:ite,kts:kte):: & - pigen, & - pidep, & - pcond, & - prevp, & - psevp, & - pgevp, & - psdep, & - pgdep, & - praut, & - psaut, & - pgaut, & - piacr, & - pracw, & - praci, & - pracs, & - psacw, & - psaci, & - psacr, & - pgacw, & - pgaci, & - pgacr, & - pgacs, & - paacw, & - psmlt, & - pgmlt, & - pseml, & - pgeml - real(kind=kind_phys),dimension(its:ite,kts:kte):: & - qsum, & - xl, & - cpm, & - work2, & - denfac, & - xni, & - denqrs1, & - denqrs2, & - denqrs3, & - denqci, & - n0sfac - real(kind=kind_phys),dimension(its:ite):: & - delqrs1, & - delqrs2, & - delqrs3, & - delqi - real(kind=kind_phys),dimension(its:ite):: & - tstepsnow, & - tstepgraup - integer,dimension(its:ite):: & - mstep, & - numdt - logical,dimension(its:ite):: flgcld - real(kind=kind_phys):: & - cpmcal, xlcal, diffus, & - viscos, xka, venfac, conden, diffac, & - x, y, z, a, b, c, d, e, & - qdt, holdrr, holdrs, holdrg, supcol, supcolt, pvt, & - coeres, supsat, dtcld, xmi, eacrs, satdt, & - qimax, diameter, xni0, roqi0, & - fallsum, fallsum_qsi, fallsum_qg, & - vt2i,vt2r,vt2s,vt2g,acrfac,egs,egi, & - xlwork2, factor, source, value, & - xlf, pfrzdtc, pfrzdtr, supice, alpha2, delta2, delta3 - real(kind=kind_phys):: vt2ave - real(kind=kind_phys):: holdc, holdci - integer:: i, j, k, mstepmax, & - iprt, latd, lond, loop, loops, ifsat, n, idim, kdim - -!Temporaries used for inlining fpvs function - real(kind=kind_phys):: dldti, xb, xai, tr, xbi, xa, hvap, cvap, hsub, dldt, ttp - -! variables for optimization - real(kind=kind_phys),dimension(its:ite):: dvec1,tvec1 - real(kind=kind_phys):: temp - -!----------------------------------------------------------------------------------------------------------------- - -! compute internal functions -! - cpmcal(x) = cpd*(1.-max(x,qmin))+max(x,qmin)*cpv - xlcal(x) = xlv0-xlv1*(x-t0c) -!---------------------------------------------------------------- -! diffus: diffusion coefficient of the water vapor -! viscos: kinematic viscosity(m2s-1) -! Optimizatin : A**B => exp(log(A)*(B)) -! - diffus(x,y) = 8.794e-5 * exp(log(x)*(1.81)) / y ! 8.794e-5*x**1.81/y - viscos(x,y) = 1.496e-6 * (x*sqrt(x)) /(x+120.)/y ! 1.496e-6*x**1.5/(x+120.)/y - xka(x,y) = 1.414e3*viscos(x,y)*y - diffac(a,b,c,d,e) = d*a*a/(xka(c,d)*rv*c*c)+1./(e*diffus(c,b)) - venfac(a,b,c) = exp(log((viscos(b,c)/diffus(b,a)))*((.3333333))) & - /sqrt(viscos(b,c))*sqrt(sqrt(den0/c)) - conden(a,b,c,d,e) = (max(b,qmin)-c)/(1.+d*d/(rv*e)*c/(a*a)) -! -! - idim = ite-its+1 - kdim = kte-kts+1 -! -!---------------------------------------------------------------- -! paddint 0 for negative values generated by dynamics -! - do k = kts, kte - do i = its, ite - qc(i,k) = max(qc(i,k),0.0) - qr(i,k) = max(qr(i,k),0.0) - qi(i,k) = max(qi(i,k),0.0) - qs(i,k) = max(qs(i,k),0.0) - qg(i,k) = max(qg(i,k),0.0) - enddo - enddo -! -!---------------------------------------------------------------- -! latent heat for phase changes and heat capacity. neglect the -! changes during microphysical process calculation emanuel(1994) -! - do k = kts, kte - do i = its, ite - cpm(i,k) = cpmcal(q(i,k)) - xl(i,k) = xlcal(t(i,k)) - enddo - enddo - do k = kts, kte - do i = its, ite - delz_tmp(i,k) = delz(i,k) - den_tmp(i,k) = den(i,k) - enddo - enddo -! -!---------------------------------------------------------------- -! initialize the surface rain, snow, graupel -! - do i = its, ite - rainncv(i) = 0. - if(present(snowncv) .and. present(snow)) snowncv(i) = 0. - if(present(graupelncv) .and. present(graupel)) graupelncv(i) = 0. - sr(i) = 0. -! new local array to catch step snow and graupel - tstepsnow(i) = 0. - tstepgraup(i) = 0. - enddo -! -!---------------------------------------------------------------- -! compute the minor time steps. -! - loops = max(nint(delt/dtcldcr),1) - dtcld = delt/loops - if(delt.le.dtcldcr) dtcld = delt -! - do loop = 1,loops -! -!---------------------------------------------------------------- -! initialize the large scale variables -! - do i = its, ite - mstep(i) = 1 - flgcld(i) = .true. - enddo -! -! do k = kts, kte -! do i = its, ite -! denfac(i,k) = sqrt(den0/den(i,k)) -! enddo -! enddo - do k = kts, kte - do i = its,ite - dvec1(i) = den(i,k) - enddo - call vrec(tvec1,dvec1,ite-its+1) - do i = its, ite - tvec1(i) = tvec1(i)*den0 - enddo - call vsqrt(dvec1,tvec1,ite-its+1) - do i = its,ite - denfac(i,k) = dvec1(i) - enddo - enddo -! -! Inline expansion for fpvs -! qsat(i,k,1) = fpvs(t(i,k),0,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) -! qsat(i,k,2) = fpvs(t(i,k),1,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) - hsub = xls - hvap = xlv0 - cvap = cpv - ttp=t0c+0.01 - dldt=cvap-cliq - xa=-dldt/rv - xb=xa+hvap/(rv*ttp) - dldti=cvap-cice - xai=-dldti/rv - xbi=xai+hsub/(rv*ttp) - do k = kts, kte - do i = its, ite - tr=ttp/t(i,k) - qsat(i,k,1)=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr)) - qsat(i,k,1) = min(qsat(i,k,1),0.99*p(i,k)) - qsat(i,k,1) = ep2 * qsat(i,k,1) / (p(i,k) - qsat(i,k,1)) - qsat(i,k,1) = max(qsat(i,k,1),qmin) - rh(i,k,1) = max(q(i,k) / qsat(i,k,1),qmin) - tr=ttp/t(i,k) - if(t(i,k).lt.ttp) then - qsat(i,k,2)=psat*exp(log(tr)*(xai))*exp(xbi*(1.-tr)) - else - qsat(i,k,2)=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr)) - endif - qsat(i,k,2) = min(qsat(i,k,2),0.99*p(i,k)) - qsat(i,k,2) = ep2 * qsat(i,k,2) / (p(i,k) - qsat(i,k,2)) - qsat(i,k,2) = max(qsat(i,k,2),qmin) - rh(i,k,2) = max(q(i,k) / qsat(i,k,2),qmin) - enddo - enddo -! -!---------------------------------------------------------------- -! initialize the variables for microphysical physics -! -! - do k = kts, kte - do i = its, ite - prevp(i,k) = 0. - psdep(i,k) = 0. - pgdep(i,k) = 0. - praut(i,k) = 0. - psaut(i,k) = 0. - pgaut(i,k) = 0. - pracw(i,k) = 0. - praci(i,k) = 0. - piacr(i,k) = 0. - psaci(i,k) = 0. - psacw(i,k) = 0. - pracs(i,k) = 0. - psacr(i,k) = 0. - pgacw(i,k) = 0. - paacw(i,k) = 0. - pgaci(i,k) = 0. - pgacr(i,k) = 0. - pgacs(i,k) = 0. - pigen(i,k) = 0. - pidep(i,k) = 0. - pcond(i,k) = 0. - psmlt(i,k) = 0. - pgmlt(i,k) = 0. - pseml(i,k) = 0. - pgeml(i,k) = 0. - psevp(i,k) = 0. - pgevp(i,k) = 0. - falk(i,k,1) = 0. - falk(i,k,2) = 0. - falk(i,k,3) = 0. - fall(i,k,1) = 0. - fall(i,k,2) = 0. - fall(i,k,3) = 0. - fallc(i,k) = 0. - falkc(i,k) = 0. - xni(i,k) = 1.e3 - enddo - enddo -!------------------------------------------------------------- -! Ni: ice crystal number concentraiton [HDC 5c] -!------------------------------------------------------------- - do k = kts, kte - do i = its, ite - temp = (den(i,k)*max(qi(i,k),qmin)) - temp = sqrt(sqrt(temp*temp*temp)) - xni(i,k) = min(max(5.38e7*temp,1.e3),1.e6) - enddo - enddo -! -!---------------------------------------------------------------- -! compute the fallout term: -! first, vertical terminal velosity for minor loops -!---------------------------------------------------------------- - do k = kts, kte - do i = its, ite - qrs_tmp(i,k,1) = qr(i,k) - qrs_tmp(i,k,2) = qs(i,k) - qrs_tmp(i,k,3) = qg(i,k) - enddo - enddo - call slope_wsm6(qrs_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2,rslope3, & - work1,its,ite,kts,kte) -! - do k = kte, kts, -1 - do i = its, ite - workr(i,k) = work1(i,k,1) - qsum(i,k) = max( (qs(i,k)+qg(i,k)), 1.E-15) - if( qsum(i,k) .gt. 1.e-15 ) then - worka(i,k) = (work1(i,k,2)*qs(i,k) + work1(i,k,3)*qg(i,k)) & - / qsum(i,k) - else - worka(i,k) = 0. - endif - denqrs1(i,k) = den(i,k)*qr(i,k) - denqrs2(i,k) = den(i,k)*qs(i,k) - denqrs3(i,k) = den(i,k)*qg(i,k) - if(qr(i,k).le.0.0) workr(i,k) = 0.0 - enddo - enddo - call nislfv_rain_plm(idim,kdim,den_tmp,denfac,t,delz_tmp,workr,denqrs1, & - delqrs1,dtcld,1,1) - call nislfv_rain_plm6(idim,kdim,den_tmp,denfac,t,delz_tmp,worka, & - denqrs2,denqrs3,delqrs2,delqrs3,dtcld,1,1) - do k = kts, kte - do i = its, ite - qr(i,k) = max(denqrs1(i,k)/den(i,k),0.) - qs(i,k) = max(denqrs2(i,k)/den(i,k),0.) - qg(i,k) = max(denqrs3(i,k)/den(i,k),0.) - fall(i,k,1) = denqrs1(i,k)*workr(i,k)/delz(i,k) - fall(i,k,2) = denqrs2(i,k)*worka(i,k)/delz(i,k) - fall(i,k,3) = denqrs3(i,k)*worka(i,k)/delz(i,k) - enddo - enddo - do i = its, ite - fall(i,1,1) = delqrs1(i)/delz(i,1)/dtcld - fall(i,1,2) = delqrs2(i)/delz(i,1)/dtcld - fall(i,1,3) = delqrs3(i)/delz(i,1)/dtcld - enddo - do k = kts, kte - do i = its, ite - qrs_tmp(i,k,1) = qr(i,k) - qrs_tmp(i,k,2) = qs(i,k) - qrs_tmp(i,k,3) = qg(i,k) - enddo - enddo - call slope_wsm6(qrs_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2,rslope3, & - work1,its,ite,kts,kte) -! - do k = kte, kts, -1 - do i = its, ite - supcol = t0c-t(i,k) - n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) - if(t(i,k).gt.t0c) then -!--------------------------------------------------------------- -! psmlt: melting of snow [HL A33] [RH83 A25] -! (T>T0: S->R) -!--------------------------------------------------------------- - xlf = xlf0 - work2(i,k) = venfac(p(i,k),t(i,k),den(i,k)) - if(qs(i,k).gt.0.) then - coeres = rslope2(i,k,2)*sqrt(rslope(i,k,2)*rslopeb(i,k,2)) - psmlt(i,k) = xka(t(i,k),den(i,k))/xlf*(t0c-t(i,k))*pi/2. & - *n0sfac(i,k)*(precs1*rslope2(i,k,2) & - +precs2*work2(i,k)*coeres)/den(i,k) - psmlt(i,k) = min(max(psmlt(i,k)*dtcld/mstep(i), & - -qs(i,k)/mstep(i)),0.) - qs(i,k) = qs(i,k) + psmlt(i,k) - qr(i,k) = qr(i,k) - psmlt(i,k) - t(i,k) = t(i,k) + xlf/cpm(i,k)*psmlt(i,k) - endif -!--------------------------------------------------------------- -! pgmlt: melting of graupel [HL A23] [LFO 47] -! (T>T0: G->R) -!--------------------------------------------------------------- - if(qg(i,k).gt.0.) then - coeres = rslope2(i,k,3)*sqrt(rslope(i,k,3)*rslopeb(i,k,3)) - pgmlt(i,k) = xka(t(i,k),den(i,k))/xlf & - *(t0c-t(i,k))*(precg1*rslope2(i,k,3) & - +precg2*work2(i,k)*coeres)/den(i,k) - pgmlt(i,k) = min(max(pgmlt(i,k)*dtcld/mstep(i), & - -qg(i,k)/mstep(i)),0.) - qg(i,k) = qg(i,k) + pgmlt(i,k) - qr(i,k) = qr(i,k) - pgmlt(i,k) - t(i,k) = t(i,k) + xlf/cpm(i,k)*pgmlt(i,k) - endif - endif - enddo - enddo -!--------------------------------------------------------------- -! Vice [ms-1] : fallout of ice crystal [HDC 5a] -!--------------------------------------------------------------- - do k = kte, kts, -1 - do i = its, ite - if(qi(i,k).le.0.) then - work1c(i,k) = 0. - else - xmi = den(i,k)*qi(i,k)/xni(i,k) - diameter = max(min(dicon * sqrt(xmi),dimax), 1.e-25) - work1c(i,k) = 1.49e4*exp(log(diameter)*(1.31)) - endif - enddo - enddo -! -! forward semi-laglangian scheme (JH), PCM (piecewise constant), (linear) -! - do k = kte, kts, -1 - do i = its, ite - denqci(i,k) = den(i,k)*qi(i,k) - enddo - enddo - call nislfv_rain_plm(idim,kdim,den_tmp,denfac,t,delz_tmp,work1c,denqci, & - delqi,dtcld,1,0) - do k = kts, kte - do i = its, ite - qi(i,k) = max(denqci(i,k)/den(i,k),0.) - enddo - enddo - do i = its, ite - fallc(i,1) = delqi(i)/delz(i,1)/dtcld - enddo -! -!---------------------------------------------------------------- -! rain (unit is mm/sec;kgm-2s-1: /1000*delt ===> m)==> mm for wrf -! - do i = its, ite - fallsum = fall(i,kts,1)+fall(i,kts,2)+fall(i,kts,3)+fallc(i,kts) - fallsum_qsi = fall(i,kts,2)+fallc(i,kts) - fallsum_qg = fall(i,kts,3) - if(fallsum.gt.0.) then - rainncv(i) = fallsum*delz(i,kts)/denr*dtcld*1000. + rainncv(i) - rain(i) = fallsum*delz(i,kts)/denr*dtcld*1000. + rain(i) - endif - if(fallsum_qsi.gt.0.) then - tstepsnow(i) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000. & - + tstepsnow(i) - if(present(snowncv) .and. present(snow)) then - snowncv(i) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000. & - + snowncv(i) - snow(i) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000. + snow(i) - endif - endif - if(fallsum_qg.gt.0.) then - tstepgraup(i) = fallsum_qg*delz(i,kts)/denr*dtcld*1000. & - + tstepgraup(i) - if(present (graupelncv) .and. present (graupel)) then - graupelncv(i) = fallsum_qg*delz(i,kts)/denr*dtcld*1000. & - + graupelncv(i) - graupel(i) = fallsum_qg*delz(i,kts)/denr*dtcld*1000. + graupel(i) - endif - endif - if(present (snowncv)) then - if(fallsum.gt.0.)sr(i)=(snowncv(i) + graupelncv(i))/(rainncv(i)+1.e-12) - else - if(fallsum.gt.0.)sr(i)=(tstepsnow(i) + tstepgraup(i))/(rainncv(i)+1.e-12) - endif - enddo -! -!--------------------------------------------------------------- -! pimlt: instantaneous melting of cloud ice [HL A47] [RH83 A28] -! (T>T0: I->C) -!--------------------------------------------------------------- - do k = kts, kte - do i = its, ite - supcol = t0c-t(i,k) - xlf = xls-xl(i,k) - if(supcol.lt.0.) xlf = xlf0 - if(supcol.lt.0.and.qi(i,k).gt.0.) then - qc(i,k) = qc(i,k) + qi(i,k) - t(i,k) = t(i,k) - xlf/cpm(i,k)*qi(i,k) - qi(i,k) = 0. - endif -!--------------------------------------------------------------- -! pihmf: homogeneous freezing of cloud water below -40c [HL A45] -! (T<-40C: C->I) -!--------------------------------------------------------------- - if(supcol.gt.40..and.qc(i,k).gt.0.) then - qi(i,k) = qi(i,k) + qc(i,k) - t(i,k) = t(i,k) + xlf/cpm(i,k)*qc(i,k) - qc(i,k) = 0. - endif -!--------------------------------------------------------------- -! pihtf: heterogeneous freezing of cloud water [HL A44] -! (T0>T>-40C: C->I) -!--------------------------------------------------------------- - if(supcol.gt.0..and.qc(i,k).gt.qmin) then -! pfrzdtc = min(pfrz1*(exp(pfrz2*supcol)-1.) & -! * den(i,k)/denr/xncr*qc(i,k)**2*dtcld,qc(i,k)) - supcolt=min(supcol,50.) - pfrzdtc = min(pfrz1*(exp(pfrz2*supcolt)-1.) & - * den(i,k)/denr/xncr*qc(i,k)*qc(i,k)*dtcld,qc(i,k)) - qi(i,k) = qi(i,k) + pfrzdtc - t(i,k) = t(i,k) + xlf/cpm(i,k)*pfrzdtc - qc(i,k) = qc(i,k)-pfrzdtc - endif -!--------------------------------------------------------------- -! pgfrz: freezing of rain water [HL A20] [LFO 45] -! (TG) -!--------------------------------------------------------------- - if(supcol.gt.0..and.qr(i,k).gt.0.) then -! pfrzdtr = min(20.*pi**2*pfrz1*n0r*denr/den(i,k) & -! * (exp(pfrz2*supcol)-1.)*rslope3(i,k,1)**2 & -! * rslope(i,k,1)*dtcld,qr(i,k)) - temp = rslope3(i,k,1) - temp = temp*temp*rslope(i,k,1) - supcolt=min(supcol,50.) - pfrzdtr = min(20.*(pi*pi)*pfrz1*n0r*denr/den(i,k) & - *(exp(pfrz2*supcolt)-1.)*temp*dtcld, & - qr(i,k)) - qg(i,k) = qg(i,k) + pfrzdtr - t(i,k) = t(i,k) + xlf/cpm(i,k)*pfrzdtr - qr(i,k) = qr(i,k)-pfrzdtr - endif - enddo - enddo -! -! -!---------------------------------------------------------------- -! update the slope parameters for microphysics computation -! - do k = kts, kte - do i = its, ite - qrs_tmp(i,k,1) = qr(i,k) - qrs_tmp(i,k,2) = qs(i,k) - qrs_tmp(i,k,3) = qg(i,k) - enddo - enddo - call slope_wsm6(qrs_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2,rslope3, & - work1,its,ite,kts,kte) -!------------------------------------------------------------------ -! work1: the thermodynamic term in the denominator associated with -! heat conduction and vapor diffusion -! (ry88, y93, h85) -! work2: parameter associated with the ventilation effects(y93) -! - do k = kts, kte - do i = its, ite - work1(i,k,1) = diffac(xl(i,k),p(i,k),t(i,k),den(i,k),qsat(i,k,1)) - work1(i,k,2) = diffac(xls,p(i,k),t(i,k),den(i,k),qsat(i,k,2)) - work2(i,k) = venfac(p(i,k),t(i,k),den(i,k)) - enddo - enddo -! -!=============================================================== -! -! warm rain processes -! -! - follows the processes in RH83 and LFO except for autoconcersion -! -!=============================================================== -! - do k = kts, kte - do i = its, ite - supsat = max(q(i,k),qmin)-qsat(i,k,1) - satdt = supsat/dtcld -!--------------------------------------------------------------- -! praut: auto conversion rate from cloud to rain [HDC 16] -! (C->R) -!--------------------------------------------------------------- - if(qc(i,k).gt.qc0) then - praut(i,k) = qck1*qc(i,k)**(7./3.) - praut(i,k) = min(praut(i,k),qc(i,k)/dtcld) - endif -!--------------------------------------------------------------- -! pracw: accretion of cloud water by rain [HL A40] [LFO 51] -! (C->R) -!--------------------------------------------------------------- - if(qr(i,k).gt.qcrmin.and.qc(i,k).gt.qmin) then - pracw(i,k) = min(pacrr*rslope3(i,k,1)*rslopeb(i,k,1) & - * qc(i,k)*denfac(i,k),qc(i,k)/dtcld) - endif -!--------------------------------------------------------------- -! prevp: evaporation/condensation rate of rain [HDC 14] -! (V->R or R->V) -!--------------------------------------------------------------- - if(qr(i,k).gt.0.) then - coeres = rslope2(i,k,1)*sqrt(rslope(i,k,1)*rslopeb(i,k,1)) - prevp(i,k) = (rh(i,k,1)-1.)*(precr1*rslope2(i,k,1) & - + precr2*work2(i,k)*coeres)/work1(i,k,1) - if(prevp(i,k).lt.0.) then - prevp(i,k) = max(prevp(i,k),-qr(i,k)/dtcld) - prevp(i,k) = max(prevp(i,k),satdt/2) - else - prevp(i,k) = min(prevp(i,k),satdt/2) - endif - endif - enddo - enddo -! -!=============================================================== -! -! cold rain processes -! -! - follows the revised ice microphysics processes in HDC -! - the processes same as in RH83 and RH84 and LFO behave -! following ice crystal hapits defined in HDC, inclduing -! intercept parameter for snow (n0s), ice crystal number -! concentration (ni), ice nuclei number concentration -! (n0i), ice diameter (d) -! -!=============================================================== -! - do k = kts, kte - do i = its, ite - supcol = t0c-t(i,k) - n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) - supsat = max(q(i,k),qmin)-qsat(i,k,2) - satdt = supsat/dtcld - ifsat = 0 -!------------------------------------------------------------- -! Ni: ice crystal number concentraiton [HDC 5c] -!------------------------------------------------------------- -! xni(i,k) = min(max(5.38e7*(den(i,k) & -! * max(qi(i,k),qmin))**0.75,1.e3),1.e6) - temp = (den(i,k)*max(qi(i,k),qmin)) - temp = sqrt(sqrt(temp*temp*temp)) - xni(i,k) = min(max(5.38e7*temp,1.e3),1.e6) - eacrs = exp(0.07*(-supcol)) -! - xmi = den(i,k)*qi(i,k)/xni(i,k) - diameter = min(dicon * sqrt(xmi),dimax) - vt2i = 1.49e4*diameter**1.31 - vt2r=pvtr*rslopeb(i,k,1)*denfac(i,k) - vt2s=pvts*rslopeb(i,k,2)*denfac(i,k) - vt2g=pvtg*rslopeb(i,k,3)*denfac(i,k) - qsum(i,k) = max( (qs(i,k)+qg(i,k)), 1.E-15) - if(qsum(i,k) .gt. 1.e-15) then - vt2ave=(vt2s*qs(i,k)+vt2g*qg(i,k))/(qsum(i,k)) - else - vt2ave=0. - endif - if(supcol.gt.0.and.qi(i,k).gt.qmin) then - if(qr(i,k).gt.qcrmin) then -!------------------------------------------------------------- -! praci: accretion of cloud ice by rain [HL A15] [LFO 25] -! (TR) -!------------------------------------------------------------- - acrfac = 2.*rslope3(i,k,1)+2.*diameter*rslope2(i,k,1) & - + diameter**2*rslope(i,k,1) - praci(i,k) = pi*qi(i,k)*n0r*abs(vt2r-vt2i)*acrfac/4. -! reduce collection efficiency (suggested by B. Wilt) - praci(i,k) = praci(i,k)*min(max(0.0,qr(i,k)/qi(i,k)),1.)**2 - praci(i,k) = min(praci(i,k),qi(i,k)/dtcld) -!------------------------------------------------------------- -! piacr: accretion of rain by cloud ice [HL A19] [LFO 26] -! (TS or R->G) -!------------------------------------------------------------- - piacr(i,k) = pi**2*avtr*n0r*denr*xni(i,k)*denfac(i,k) & - * g6pbr*rslope3(i,k,1)*rslope3(i,k,1) & - * rslopeb(i,k,1)/24./den(i,k) -! reduce collection efficiency (suggested by B. Wilt) - piacr(i,k) = piacr(i,k)*min(max(0.0,qi(i,k)/qr(i,k)),1.)**2 - piacr(i,k) = min(piacr(i,k),qr(i,k)/dtcld) - endif -!------------------------------------------------------------- -! psaci: accretion of cloud ice by snow [HDC 10] -! (TS) -!------------------------------------------------------------- - if(qs(i,k).gt.qcrmin) then - acrfac = 2.*rslope3(i,k,2)+2.*diameter*rslope2(i,k,2) & - + diameter**2*rslope(i,k,2) - psaci(i,k) = pi*qi(i,k)*eacrs*n0s*n0sfac(i,k) & - * abs(vt2ave-vt2i)*acrfac/4. - psaci(i,k) = min(psaci(i,k),qi(i,k)/dtcld) - endif -!------------------------------------------------------------- -! pgaci: accretion of cloud ice by graupel [HL A17] [LFO 41] -! (TG) -!------------------------------------------------------------- - if(qg(i,k).gt.qcrmin) then - egi = exp(0.07*(-supcol)) - acrfac = 2.*rslope3(i,k,3)+2.*diameter*rslope2(i,k,3) & - + diameter**2*rslope(i,k,3) - pgaci(i,k) = pi*egi*qi(i,k)*n0g*abs(vt2ave-vt2i)*acrfac/4. - pgaci(i,k) = min(pgaci(i,k),qi(i,k)/dtcld) - endif - endif -!------------------------------------------------------------- -! psacw: accretion of cloud water by snow [HL A7] [LFO 24] -! (TS, and T>=T0: C->R) -!------------------------------------------------------------- - if(qs(i,k).gt.qcrmin.and.qc(i,k).gt.qmin) then - psacw(i,k) = min(pacrc*n0sfac(i,k)*rslope3(i,k,2)*rslopeb(i,k,2) & -! reduce collection efficiency (suggested by B. Wilt) - * min(max(0.0,qs(i,k)/qc(i,k)),1.)**2 & - * qc(i,k)*denfac(i,k),qc(i,k)/dtcld) - endif -!------------------------------------------------------------- -! pgacw: accretion of cloud water by graupel [HL A6] [LFO 40] -! (TG, and T>=T0: C->R) -!------------------------------------------------------------- - if(qg(i,k).gt.qcrmin.and.qc(i,k).gt.qmin) then - pgacw(i,k) = min(pacrg*rslope3(i,k,3)*rslopeb(i,k,3) & -! reduce collection efficiency (suggested by B. Wilt) - * min(max(0.0,qg(i,k)/qc(i,k)),1.)**2 & - * qc(i,k)*denfac(i,k),qc(i,k)/dtcld) - endif -!------------------------------------------------------------- -! paacw: accretion of cloud water by averaged snow/graupel -! (TG or S, and T>=T0: C->R) -!------------------------------------------------------------- - if(qsum(i,k) .gt. 1.e-15) then - paacw(i,k) = (qs(i,k)*psacw(i,k)+qg(i,k)*pgacw(i,k)) & - /(qsum(i,k)) - endif -!------------------------------------------------------------- -! pracs: accretion of snow by rain [HL A11] [LFO 27] -! (TG) -!------------------------------------------------------------- - if(qs(i,k).gt.qcrmin.and.qr(i,k).gt.qcrmin) then - if(supcol.gt.0) then - acrfac = 5.*rslope3(i,k,2)*rslope3(i,k,2)*rslope(i,k,1) & - + 2.*rslope3(i,k,2)*rslope2(i,k,2)*rslope2(i,k,1) & - + .5*rslope2(i,k,2)*rslope2(i,k,2)*rslope3(i,k,1) - pracs(i,k) = pi**2*n0r*n0s*n0sfac(i,k)*abs(vt2r-vt2ave) & - * (dens/den(i,k))*acrfac -! reduce collection efficiency (suggested by B. Wilt) - pracs(i,k) = pracs(i,k)*min(max(0.0,qr(i,k)/qs(i,k)),1.)**2 - pracs(i,k) = min(pracs(i,k),qs(i,k)/dtcld) - endif -!------------------------------------------------------------- -! psacr: accretion of rain by snow [HL A10] [LFO 28] -! (TS or R->G) (T>=T0: enhance melting of snow) -!------------------------------------------------------------- - acrfac = 5.*rslope3(i,k,1)*rslope3(i,k,1)*rslope(i,k,2) & - + 2.*rslope3(i,k,1)*rslope2(i,k,1)*rslope2(i,k,2) & - +.5*rslope2(i,k,1)*rslope2(i,k,1)*rslope3(i,k,2) - psacr(i,k) = pi**2*n0r*n0s*n0sfac(i,k)*abs(vt2ave-vt2r) & - * (denr/den(i,k))*acrfac -! reduce collection efficiency (suggested by B. Wilt) - psacr(i,k) = psacr(i,k)*min(max(0.0,qs(i,k)/qr(i,k)),1.)**2 - psacr(i,k) = min(psacr(i,k),qr(i,k)/dtcld) - endif -!------------------------------------------------------------- -! pgacr: accretion of rain by graupel [HL A12] [LFO 42] -! (TG) (T>=T0: enhance melting of graupel) -!------------------------------------------------------------- - if(qg(i,k).gt.qcrmin.and.qr(i,k).gt.qcrmin) then - acrfac = 5.*rslope3(i,k,1)*rslope3(i,k,1)*rslope(i,k,3) & - + 2.*rslope3(i,k,1)*rslope2(i,k,1)*rslope2(i,k,3) & - + .5*rslope2(i,k,1)*rslope2(i,k,1)*rslope3(i,k,3) - pgacr(i,k) = pi**2*n0r*n0g*abs(vt2ave-vt2r)*(denr/den(i,k)) & - * acrfac -! reduce collection efficiency (suggested by B. Wilt) - pgacr(i,k) = pgacr(i,k)*min(max(0.0,qg(i,k)/qr(i,k)),1.)**2 - pgacr(i,k) = min(pgacr(i,k),qr(i,k)/dtcld) - endif -! -!------------------------------------------------------------- -! pgacs: accretion of snow by graupel [HL A13] [LFO 29] -! (S->G): This process is eliminated in V3.0 with the -! new combined snow/graupel fall speeds -!------------------------------------------------------------- - if(qg(i,k).gt.qcrmin.and.qs(i,k).gt.qcrmin) then - pgacs(i,k) = 0. - endif - if(supcol.le.0) then - xlf = xlf0 -!------------------------------------------------------------- -! pseml: enhanced melting of snow by accretion of water [HL A34] -! (T>=T0: S->R) -!------------------------------------------------------------- - if(qs(i,k).gt.0.) & - pseml(i,k) = min(max(cliq*supcol*(paacw(i,k)+psacr(i,k)) & - / xlf,-qs(i,k)/dtcld),0.) -!------------------------------------------------------------- -! pgeml: enhanced melting of graupel by accretion of water [HL A24] [RH84 A21-A22] -! (T>=T0: G->R) -!------------------------------------------------------------- - if(qg(i,k).gt.0.) & - pgeml(i,k) = min(max(cliq*supcol*(paacw(i,k)+pgacr(i,k)) & - / xlf,-qg(i,k)/dtcld),0.) - endif - if(supcol.gt.0) then -!------------------------------------------------------------- -! pidep: deposition/Sublimation rate of ice [HDC 9] -! (TI or I->V) -!------------------------------------------------------------- - if(qi(i,k).gt.0.and.ifsat.ne.1) then - pidep(i,k) = 4.*diameter*xni(i,k)*(rh(i,k,2)-1.)/work1(i,k,2) - supice = satdt-prevp(i,k) - if(pidep(i,k).lt.0.) then - pidep(i,k) = max(max(pidep(i,k),satdt/2),supice) - pidep(i,k) = max(pidep(i,k),-qi(i,k)/dtcld) - else - pidep(i,k) = min(min(pidep(i,k),satdt/2),supice) - endif - if(abs(prevp(i,k)+pidep(i,k)).ge.abs(satdt)) ifsat = 1 - endif -!------------------------------------------------------------- -! psdep: deposition/sublimation rate of snow [HDC 14] -! (TS or S->V) -!------------------------------------------------------------- - if(qs(i,k).gt.0..and.ifsat.ne.1) then - coeres = rslope2(i,k,2)*sqrt(rslope(i,k,2)*rslopeb(i,k,2)) - psdep(i,k) = (rh(i,k,2)-1.)*n0sfac(i,k)*(precs1*rslope2(i,k,2) & - + precs2*work2(i,k)*coeres)/work1(i,k,2) - supice = satdt-prevp(i,k)-pidep(i,k) - if(psdep(i,k).lt.0.) then - psdep(i,k) = max(psdep(i,k),-qs(i,k)/dtcld) - psdep(i,k) = max(max(psdep(i,k),satdt/2),supice) - else - psdep(i,k) = min(min(psdep(i,k),satdt/2),supice) - endif - if(abs(prevp(i,k)+pidep(i,k)+psdep(i,k)).ge.abs(satdt)) & - ifsat = 1 - endif -!------------------------------------------------------------- -! pgdep: deposition/sublimation rate of graupel [HL A21] [LFO 46] -! (TG or G->V) -!------------------------------------------------------------- - if(qg(i,k).gt.0..and.ifsat.ne.1) then - coeres = rslope2(i,k,3)*sqrt(rslope(i,k,3)*rslopeb(i,k,3)) - pgdep(i,k) = (rh(i,k,2)-1.)*(precg1*rslope2(i,k,3) & - + precg2*work2(i,k)*coeres)/work1(i,k,2) - supice = satdt-prevp(i,k)-pidep(i,k)-psdep(i,k) - if(pgdep(i,k).lt.0.) then - pgdep(i,k) = max(pgdep(i,k),-qg(i,k)/dtcld) - pgdep(i,k) = max(max(pgdep(i,k),satdt/2),supice) - else - pgdep(i,k) = min(min(pgdep(i,k),satdt/2),supice) - endif - if(abs(prevp(i,k)+pidep(i,k)+psdep(i,k)+pgdep(i,k)).ge. & - abs(satdt)) ifsat = 1 - endif -!------------------------------------------------------------- -! pigen: generation(nucleation) of ice from vapor [HL 50] [HDC 7-8] -! (TI) -!------------------------------------------------------------- - if(supsat.gt.0.and.ifsat.ne.1) then - supice = satdt-prevp(i,k)-pidep(i,k)-psdep(i,k)-pgdep(i,k) - xni0 = 1.e3*exp(0.1*supcol) - roqi0 = 4.92e-11*xni0**1.33 - pigen(i,k) = max(0.,(roqi0/den(i,k)-max(qi(i,k),0.))/dtcld) - pigen(i,k) = min(min(pigen(i,k),satdt),supice) - endif -! -!------------------------------------------------------------- -! psaut: conversion(aggregation) of ice to snow [HDC 12] -! (TS) -!------------------------------------------------------------- - if(qi(i,k).gt.0.) then - qimax = roqimax/den(i,k) - psaut(i,k) = max(0.,(qi(i,k)-qimax)/dtcld) - endif -! -!------------------------------------------------------------- -! pgaut: conversion(aggregation) of snow to graupel [HL A4] [LFO 37] -! (TG) -!------------------------------------------------------------- - if(qs(i,k).gt.0.) then - alpha2 = 1.e-3*exp(0.09*(-supcol)) - pgaut(i,k) = min(max(0.,alpha2*(qs(i,k)-qs0)),qs(i,k)/dtcld) - endif - endif -! -!------------------------------------------------------------- -! psevp: evaporation of melting snow [HL A35] [RH83 A27] -! (T>=T0: S->V) -!------------------------------------------------------------- - if(supcol.lt.0.) then - if(qs(i,k).gt.0..and.rh(i,k,1).lt.1.) then - coeres = rslope2(i,k,2)*sqrt(rslope(i,k,2)*rslopeb(i,k,2)) - psevp(i,k) = (rh(i,k,1)-1.)*n0sfac(i,k)*(precs1 & - * rslope2(i,k,2)+precs2*work2(i,k) & - * coeres)/work1(i,k,1) - psevp(i,k) = min(max(psevp(i,k),-qs(i,k)/dtcld),0.) - endif -!------------------------------------------------------------- -! pgevp: evaporation of melting graupel [HL A25] [RH84 A19] -! (T>=T0: G->V) -!------------------------------------------------------------- - if(qg(i,k).gt.0..and.rh(i,k,1).lt.1.) then - coeres = rslope2(i,k,3)*sqrt(rslope(i,k,3)*rslopeb(i,k,3)) - pgevp(i,k) = (rh(i,k,1)-1.)*(precg1*rslope2(i,k,3) & - + precg2*work2(i,k)*coeres)/work1(i,k,1) - pgevp(i,k) = min(max(pgevp(i,k),-qg(i,k)/dtcld),0.) - endif - endif - enddo - enddo -! -! -!---------------------------------------------------------------- -! check mass conservation of generation terms and feedback to the -! large scale -! - do k = kts, kte - do i = its, ite -! - delta2=0. - delta3=0. - if(qr(i,k).lt.1.e-4.and.qs(i,k).lt.1.e-4) delta2=1. - if(qr(i,k).lt.1.e-4) delta3=1. - if(t(i,k).le.t0c) then -! -! cloud water -! - value = max(qmin,qc(i,k)) - source = (praut(i,k)+pracw(i,k)+paacw(i,k)+paacw(i,k))*dtcld - if (source.gt.value) then - factor = value/source - praut(i,k) = praut(i,k)*factor - pracw(i,k) = pracw(i,k)*factor - paacw(i,k) = paacw(i,k)*factor - endif -! -! cloud ice -! - value = max(qmin,qi(i,k)) - source = (psaut(i,k)-pigen(i,k)-pidep(i,k)+praci(i,k)+psaci(i,k) & - + pgaci(i,k))*dtcld - if (source.gt.value) then - factor = value/source - psaut(i,k) = psaut(i,k)*factor - pigen(i,k) = pigen(i,k)*factor - pidep(i,k) = pidep(i,k)*factor - praci(i,k) = praci(i,k)*factor - psaci(i,k) = psaci(i,k)*factor - pgaci(i,k) = pgaci(i,k)*factor - endif -! -! rain -! - value = max(qmin,qr(i,k)) - source = (-praut(i,k)-prevp(i,k)-pracw(i,k)+piacr(i,k)+psacr(i,k) & - + pgacr(i,k))*dtcld - if (source.gt.value) then - factor = value/source - praut(i,k) = praut(i,k)*factor - prevp(i,k) = prevp(i,k)*factor - pracw(i,k) = pracw(i,k)*factor - piacr(i,k) = piacr(i,k)*factor - psacr(i,k) = psacr(i,k)*factor - pgacr(i,k) = pgacr(i,k)*factor - endif -! -! snow -! - value = max(qmin,qs(i,k)) - source = -(psdep(i,k)+psaut(i,k)-pgaut(i,k)+paacw(i,k)+piacr(i,k) & - * delta3+praci(i,k)*delta3-pracs(i,k)*(1.-delta2) & - + psacr(i,k)*delta2+psaci(i,k)-pgacs(i,k) )*dtcld - if (source.gt.value) then - factor = value/source - psdep(i,k) = psdep(i,k)*factor - psaut(i,k) = psaut(i,k)*factor - pgaut(i,k) = pgaut(i,k)*factor - paacw(i,k) = paacw(i,k)*factor - piacr(i,k) = piacr(i,k)*factor - praci(i,k) = praci(i,k)*factor - psaci(i,k) = psaci(i,k)*factor - pracs(i,k) = pracs(i,k)*factor - psacr(i,k) = psacr(i,k)*factor - pgacs(i,k) = pgacs(i,k)*factor - endif -! -! graupel -! - value = max(qmin,qg(i,k)) - source = -(pgdep(i,k)+pgaut(i,k) & - + piacr(i,k)*(1.-delta3)+praci(i,k)*(1.-delta3) & - + psacr(i,k)*(1.-delta2)+pracs(i,k)*(1.-delta2) & - + pgaci(i,k)+paacw(i,k)+pgacr(i,k)+pgacs(i,k))*dtcld - if (source.gt.value) then - factor = value/source - pgdep(i,k) = pgdep(i,k)*factor - pgaut(i,k) = pgaut(i,k)*factor - piacr(i,k) = piacr(i,k)*factor - praci(i,k) = praci(i,k)*factor - psacr(i,k) = psacr(i,k)*factor - pracs(i,k) = pracs(i,k)*factor - paacw(i,k) = paacw(i,k)*factor - pgaci(i,k) = pgaci(i,k)*factor - pgacr(i,k) = pgacr(i,k)*factor - pgacs(i,k) = pgacs(i,k)*factor - endif -! - work2(i,k)=-(prevp(i,k)+psdep(i,k)+pgdep(i,k)+pigen(i,k)+pidep(i,k)) -! update - q(i,k) = q(i,k)+work2(i,k)*dtcld - qc(i,k) = max(qc(i,k)-(praut(i,k)+pracw(i,k) & - + paacw(i,k)+paacw(i,k))*dtcld,0.) - qr(i,k) = max(qr(i,k)+(praut(i,k)+pracw(i,k) & - + prevp(i,k)-piacr(i,k)-pgacr(i,k) & - - psacr(i,k))*dtcld,0.) - qi(i,k) = max(qi(i,k)-(psaut(i,k)+praci(i,k) & - + psaci(i,k)+pgaci(i,k)-pigen(i,k)-pidep(i,k)) & - * dtcld,0.) - qs(i,k) = max(qs(i,k)+(psdep(i,k)+psaut(i,k)+paacw(i,k) & - - pgaut(i,k)+piacr(i,k)*delta3 & - + praci(i,k)*delta3+psaci(i,k)-pgacs(i,k) & - - pracs(i,k)*(1.-delta2)+psacr(i,k)*delta2) & - * dtcld,0.) - qg(i,k) = max(qg(i,k)+(pgdep(i,k)+pgaut(i,k) & - + piacr(i,k)*(1.-delta3) & - + praci(i,k)*(1.-delta3)+psacr(i,k)*(1.-delta2) & - + pracs(i,k)*(1.-delta2)+pgaci(i,k)+paacw(i,k) & - + pgacr(i,k)+pgacs(i,k))*dtcld,0.) - xlf = xls-xl(i,k) - xlwork2 = -xls*(psdep(i,k)+pgdep(i,k)+pidep(i,k)+pigen(i,k)) & - -xl(i,k)*prevp(i,k)-xlf*(piacr(i,k)+paacw(i,k) & - +paacw(i,k)+pgacr(i,k)+psacr(i,k)) - t(i,k) = t(i,k)-xlwork2/cpm(i,k)*dtcld - else -! -! cloud water -! - value = max(qmin,qc(i,k)) - source=(praut(i,k)+pracw(i,k)+paacw(i,k)+paacw(i,k))*dtcld - if (source.gt.value) then - factor = value/source - praut(i,k) = praut(i,k)*factor - pracw(i,k) = pracw(i,k)*factor - paacw(i,k) = paacw(i,k)*factor - endif -! -! rain -! - value = max(qmin,qr(i,k)) - source = (-paacw(i,k)-praut(i,k)+pseml(i,k)+pgeml(i,k)-pracw(i,k) & - -paacw(i,k)-prevp(i,k))*dtcld - if (source.gt.value) then - factor = value/source - praut(i,k) = praut(i,k)*factor - prevp(i,k) = prevp(i,k)*factor - pracw(i,k) = pracw(i,k)*factor - paacw(i,k) = paacw(i,k)*factor - pseml(i,k) = pseml(i,k)*factor - pgeml(i,k) = pgeml(i,k)*factor - endif -! -! snow -! - value = max(qcrmin,qs(i,k)) - source=(pgacs(i,k)-pseml(i,k)-psevp(i,k))*dtcld - if (source.gt.value) then - factor = value/source - pgacs(i,k) = pgacs(i,k)*factor - psevp(i,k) = psevp(i,k)*factor - pseml(i,k) = pseml(i,k)*factor - endif -! -! graupel -! - value = max(qcrmin,qg(i,k)) - source=-(pgacs(i,k)+pgevp(i,k)+pgeml(i,k))*dtcld - if (source.gt.value) then - factor = value/source - pgacs(i,k) = pgacs(i,k)*factor - pgevp(i,k) = pgevp(i,k)*factor - pgeml(i,k) = pgeml(i,k)*factor - endif -! - work2(i,k)=-(prevp(i,k)+psevp(i,k)+pgevp(i,k)) -! update - q(i,k) = q(i,k)+work2(i,k)*dtcld - qc(i,k) = max(qc(i,k)-(praut(i,k)+pracw(i,k) & - + paacw(i,k)+paacw(i,k))*dtcld,0.) - qr(i,k) = max(qr(i,k)+(praut(i,k)+pracw(i,k) & - + prevp(i,k)+paacw(i,k)+paacw(i,k)-pseml(i,k) & - - pgeml(i,k))*dtcld,0.) - qs(i,k) = max(qs(i,k)+(psevp(i,k)-pgacs(i,k) & - + pseml(i,k))*dtcld,0.) - qg(i,k) = max(qg(i,k)+(pgacs(i,k)+pgevp(i,k) & - + pgeml(i,k))*dtcld,0.) - xlf = xls-xl(i,k) - xlwork2 = -xl(i,k)*(prevp(i,k)+psevp(i,k)+pgevp(i,k)) & - -xlf*(pseml(i,k)+pgeml(i,k)) - t(i,k) = t(i,k)-xlwork2/cpm(i,k)*dtcld - endif - enddo - enddo -! -! Inline expansion for fpvs -! qsat(i,k,1) = fpvs(t(i,k),0,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) -! qsat(i,k,2) = fpvs(t(i,k),1,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) - hsub = xls - hvap = xlv0 - cvap = cpv - ttp=t0c+0.01 - dldt=cvap-cliq - xa=-dldt/rv - xb=xa+hvap/(rv*ttp) - dldti=cvap-cice - xai=-dldti/rv - xbi=xai+hsub/(rv*ttp) - do k = kts, kte - do i = its, ite - tr=ttp/t(i,k) - qsat(i,k,1)=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr)) - qsat(i,k,1) = min(qsat(i,k,1),0.99*p(i,k)) - qsat(i,k,1) = ep2 * qsat(i,k,1) / (p(i,k) - qsat(i,k,1)) - qsat(i,k,1) = max(qsat(i,k,1),qmin) - tr=ttp/t(i,k) - if(t(i,k).lt.ttp) then - qsat(i,k,2)=psat*exp(log(tr)*(xai))*exp(xbi*(1.-tr)) - else - qsat(i,k,2)=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr)) - endif - qsat(i,k,2) = min(qsat(i,k,2),0.99*p(i,k)) - qsat(i,k,2) = ep2 * qsat(i,k,2) / (p(i,k) - qsat(i,k,2)) - qsat(i,k,2) = max(qsat(i,k,2),qmin) - enddo - enddo -! -!---------------------------------------------------------------- -! pcond: condensational/evaporational rate of cloud water [HL A46] [RH83 A6] -! if there exists additional water vapor condensated/if -! evaporation of cloud water is not enough to remove subsaturation -! - do k = kts, kte - do i = its, ite - work1(i,k,1) = conden(t(i,k),q(i,k),qsat(i,k,1),xl(i,k),cpm(i,k)) - work2(i,k) = qc(i,k)+work1(i,k,1) - pcond(i,k) = min(max(work1(i,k,1)/dtcld,0.),max(q(i,k),0.)/dtcld) - if(qc(i,k).gt.0..and.work1(i,k,1).lt.0.) & - pcond(i,k) = max(work1(i,k,1),-qc(i,k))/dtcld - q(i,k) = q(i,k)-pcond(i,k)*dtcld - qc(i,k) = max(qc(i,k)+pcond(i,k)*dtcld,0.) - t(i,k) = t(i,k)+pcond(i,k)*xl(i,k)/cpm(i,k)*dtcld - enddo - enddo -! -! -!---------------------------------------------------------------- -! padding for small values -! - do k = kts, kte - do i = its, ite - if(qc(i,k).le.qmin) qc(i,k) = 0.0 - if(qi(i,k).le.qmin) qi(i,k) = 0.0 - enddo - enddo - enddo ! big loops - - if(present(rainprod2d) .and. present(evapprod2d)) then - do k = kts, kte - do i = its,ite - rainprod2d(i,k) = praut(i,k)+pracw(i,k)+praci(i,k)+psaci(i,k)+pgaci(i,k) & - + psacw(i,k)+pgacw(i,k)+paacw(i,k)+psaut(i,k) - evapprod2d(i,k) = -(prevp(i,k)+psevp(i,k)+pgevp(i,k)+psdep(i,k)+pgdep(i,k)) - enddo - enddo - endif -! -!---------------------------------------------------------------- -! CCPP checks: -! - - errmsg = 'mp_wsm6_run OK' - errflg = 0 - - end subroutine mp_wsm6_run - -!================================================================================================================= - real(kind=kind_phys) function rgmma(x) -!================================================================================================================= -!rgmma function: use infinite product form - - real(kind=kind_phys),intent(in):: x - - integer:: i - real(kind=kind_phys),parameter:: euler=0.577215664901532 - real(kind=kind_phys):: y - -!----------------------------------------------------------------------------------------------------------------- - - if(x.eq.1.)then - rgmma=0. - else - rgmma=x*exp(euler*x) - do i = 1,10000 - y = float(i) - rgmma=rgmma*(1.000+x/y)*exp(-x/y) - enddo - rgmma=1./rgmma - endif - - end function rgmma - -!================================================================================================================= - real(kind=kind_phys) function fpvs(t,ice,rd,rv,cvap,cliq,cice,hvap,hsub,psat,t0c) -!================================================================================================================= - - integer,intent(in):: ice - real(kind=kind_phys),intent(in):: cice,cliq,cvap,hsub,hvap,psat,rd,rv,t0c - real(kind=kind_phys),intent(in):: t - - real(kind=kind_phys):: tr,ttp,dldt,dldti,xa,xb,xai,xbi - -!----------------------------------------------------------------------------------------------------------------- - - ttp=t0c+0.01 - dldt=cvap-cliq - xa=-dldt/rv - xb=xa+hvap/(rv*ttp) - dldti=cvap-cice - xai=-dldti/rv - xbi=xai+hsub/(rv*ttp) - tr=ttp/t - if(t.lt.ttp.and.ice.eq.1) then - fpvs=psat*(tr**xai)*exp(xbi*(1.-tr)) - else - fpvs=psat*(tr**xa)*exp(xb*(1.-tr)) - endif - - end function fpvs - -!================================================================================================================= - subroutine slope_wsm6(qrs,den,denfac,t,rslope,rslopeb,rslope2,rslope3,vt,its,ite,kts,kte) -!================================================================================================================= - -!--- input arguments: - integer:: its,ite,kts,kte - - real(kind=kind_phys),intent(in),dimension(its:ite,kts:kte):: den,denfac,t - real(kind=kind_phys),intent(in),dimension(its:ite,kts:kte,3):: qrs - -!--- inout arguments: - real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte,3):: & - rslope,rslopeb,rslope2,rslope3,vt - -!--- local variables and arrays: - integer:: i,k - - real(kind=kind_phys),parameter:: t0c = 273.15 - real(kind=kind_phys):: lamdar,lamdas,lamdag,x,y,z,supcol - real(kind=kind_phys),dimension(its:ite,kts:kte):: n0sfac - -!----------------------------------------------------------------------------------------------------------------- - -!size distributions: (x=mixing ratio, y=air density): -!valid for mixing ratio > 1.e-9 kg/kg. - lamdar(x,y)= sqrt(sqrt(pidn0r/(x*y))) ! (pidn0r/(x*y))**.25 - lamdas(x,y,z)= sqrt(sqrt(pidn0s*z/(x*y))) ! (pidn0s*z/(x*y))**.25 - lamdag(x,y)= sqrt(sqrt(pidn0g/(x*y))) ! (pidn0g/(x*y))**.25 - - do k = kts, kte - do i = its, ite - supcol = t0c-t(i,k) -!--------------------------------------------------------------- -! n0s: Intercept parameter for snow [m-4] [HDC 6] -!--------------------------------------------------------------- - n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) - if(qrs(i,k,1).le.qcrmin)then - rslope(i,k,1) = rslopermax - rslopeb(i,k,1) = rsloperbmax - rslope2(i,k,1) = rsloper2max - rslope3(i,k,1) = rsloper3max - else - rslope(i,k,1) = 1./lamdar(qrs(i,k,1),den(i,k)) - rslopeb(i,k,1) = rslope(i,k,1)**bvtr - rslope2(i,k,1) = rslope(i,k,1)*rslope(i,k,1) - rslope3(i,k,1) = rslope2(i,k,1)*rslope(i,k,1) - endif - if(qrs(i,k,2).le.qcrmin)then - rslope(i,k,2) = rslopesmax - rslopeb(i,k,2) = rslopesbmax - rslope2(i,k,2) = rslopes2max - rslope3(i,k,2) = rslopes3max - else - rslope(i,k,2) = 1./lamdas(qrs(i,k,2),den(i,k),n0sfac(i,k)) - rslopeb(i,k,2) = rslope(i,k,2)**bvts - rslope2(i,k,2) = rslope(i,k,2)*rslope(i,k,2) - rslope3(i,k,2) = rslope2(i,k,2)*rslope(i,k,2) - endif - if(qrs(i,k,3).le.qcrmin)then - rslope(i,k,3) = rslopegmax - rslopeb(i,k,3) = rslopegbmax - rslope2(i,k,3) = rslopeg2max - rslope3(i,k,3) = rslopeg3max - else - rslope(i,k,3) = 1./lamdag(qrs(i,k,3),den(i,k)) - rslopeb(i,k,3) = rslope(i,k,3)**bvtg - rslope2(i,k,3) = rslope(i,k,3)*rslope(i,k,3) - rslope3(i,k,3) = rslope2(i,k,3)*rslope(i,k,3) - endif - vt(i,k,1) = pvtr*rslopeb(i,k,1)*denfac(i,k) - vt(i,k,2) = pvts*rslopeb(i,k,2)*denfac(i,k) - vt(i,k,3) = pvtg*rslopeb(i,k,3)*denfac(i,k) - if(qrs(i,k,1).le.0.0) vt(i,k,1) = 0.0 - if(qrs(i,k,2).le.0.0) vt(i,k,2) = 0.0 - if(qrs(i,k,3).le.0.0) vt(i,k,3) = 0.0 - enddo - enddo - - end subroutine slope_wsm6 - -!================================================================================================================= - subroutine slope_rain(qrs,den,denfac,t,rslope,rslopeb,rslope2,rslope3,vt,its,ite,kts,kte) -!================================================================================================================= - -!--- input arguments: - integer:: its,ite,kts,kte - - real(kind=kind_phys),intent(in),dimension(its:ite,kts:kte):: qrs,den,denfac,t - -!--- inout arguments: - real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte):: & - rslope,rslopeb,rslope2,rslope3,vt - -!--- local variables and arrays: - integer:: i,k - - real(kind=kind_phys),parameter:: t0c = 273.15 - real(kind=kind_phys):: lamdar,x,y - real(kind=kind_phys),dimension(its:ite,kts:kte):: n0sfac - -!----------------------------------------------------------------------------------------------------------------- - -!size distributions: (x=mixing ratio, y=air density): -!valid for mixing ratio > 1.e-9 kg/kg. - lamdar(x,y)= sqrt(sqrt(pidn0r/(x*y))) ! (pidn0r/(x*y))**.25 - - do k = kts, kte - do i = its, ite - if(qrs(i,k).le.qcrmin)then - rslope(i,k) = rslopermax - rslopeb(i,k) = rsloperbmax - rslope2(i,k) = rsloper2max - rslope3(i,k) = rsloper3max - else - rslope(i,k) = 1./lamdar(qrs(i,k),den(i,k)) - rslopeb(i,k) = rslope(i,k)**bvtr - rslope2(i,k) = rslope(i,k)*rslope(i,k) - rslope3(i,k) = rslope2(i,k)*rslope(i,k) - endif - vt(i,k) = pvtr*rslopeb(i,k)*denfac(i,k) - if(qrs(i,k).le.0.0) vt(i,k) = 0.0 - enddo - enddo - - end subroutine slope_rain - -!================================================================================================================= - subroutine slope_snow(qrs,den,denfac,t,rslope,rslopeb,rslope2,rslope3,vt,its,ite,kts,kte) -!================================================================================================================= - -!--- input arguments: - integer:: its,ite,kts,kte - - real(kind=kind_phys),intent(in),dimension(its:ite,kts:kte):: qrs,den,denfac,t - -!--- inout arguments: - real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte):: & - rslope,rslopeb,rslope2,rslope3,vt - -!--- local variables and arrays: - integer:: i,k - - real(kind=kind_phys),parameter:: t0c = 273.15 - real(kind=kind_phys):: lamdas,x,y,z,supcol - real(kind=kind_phys),dimension(its:ite,kts:kte):: n0sfac - -!----------------------------------------------------------------------------------------------------------------- - -!size distributions: (x=mixing ratio, y=air density): -!valid for mixing ratio > 1.e-9 kg/kg. - lamdas(x,y,z)= sqrt(sqrt(pidn0s*z/(x*y))) ! (pidn0s*z/(x*y))**.25 -! - do k = kts, kte - do i = its, ite - supcol = t0c-t(i,k) -!--------------------------------------------------------------- -! n0s: Intercept parameter for snow [m-4] [HDC 6] -!--------------------------------------------------------------- - n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) - if(qrs(i,k).le.qcrmin)then - rslope(i,k) = rslopesmax - rslopeb(i,k) = rslopesbmax - rslope2(i,k) = rslopes2max - rslope3(i,k) = rslopes3max - else - rslope(i,k) = 1./lamdas(qrs(i,k),den(i,k),n0sfac(i,k)) - rslopeb(i,k) = rslope(i,k)**bvts - rslope2(i,k) = rslope(i,k)*rslope(i,k) - rslope3(i,k) = rslope2(i,k)*rslope(i,k) - endif - vt(i,k) = pvts*rslopeb(i,k)*denfac(i,k) - if(qrs(i,k).le.0.0) vt(i,k) = 0.0 - enddo - enddo - - end subroutine slope_snow - -!================================================================================================================= - subroutine slope_graup(qrs,den,denfac,t,rslope,rslopeb,rslope2,rslope3,vt,its,ite,kts,kte) -!================================================================================================================= - -!--- input arguments: - integer:: its,ite,kts,kte - - real(kind=kind_phys),intent(in),dimension(its:ite,kts:kte):: qrs,den,denfac,t - -!--- inout arguments: - real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte):: & - rslope,rslopeb,rslope2,rslope3,vt - -!--- local variables and arrays: - integer:: i,k - - real(kind=kind_phys),parameter:: t0c = 273.15 - real(kind=kind_phys):: lamdag,x,y - real(kind=kind_phys),dimension(its:ite,kts:kte):: n0sfac - -!----------------------------------------------------------------------------------------------------------------- - -!size distributions: (x=mixing ratio, y=air density): -!valid for mixing ratio > 1.e-9 kg/kg. - lamdag(x,y)= sqrt(sqrt(pidn0g/(x*y))) ! (pidn0g/(x*y))**.25 - - do k = kts, kte - do i = its, ite -!--------------------------------------------------------------- -! n0s: Intercept parameter for snow [m-4] [HDC 6] -!--------------------------------------------------------------- - if(qrs(i,k).le.qcrmin)then - rslope(i,k) = rslopegmax - rslopeb(i,k) = rslopegbmax - rslope2(i,k) = rslopeg2max - rslope3(i,k) = rslopeg3max - else - rslope(i,k) = 1./lamdag(qrs(i,k),den(i,k)) - rslopeb(i,k) = rslope(i,k)**bvtg - rslope2(i,k) = rslope(i,k)*rslope(i,k) - rslope3(i,k) = rslope2(i,k)*rslope(i,k) - endif - vt(i,k) = pvtg*rslopeb(i,k)*denfac(i,k) - if(qrs(i,k).le.0.0) vt(i,k) = 0.0 - enddo - enddo - - end subroutine slope_graup - -!================================================================================================================= - subroutine nislfv_rain_plm(im,km,denl,denfacl,tkl,dzl,wwl,rql,precip,dt,id,iter) -!================================================================================================================= -! -! for non-iteration semi-Lagrangain forward advection for cloud -! with mass conservation and positive definite advection -! 2nd order interpolation with monotonic piecewise linear method -! this routine is under assumption of decfl < 1 for semi_Lagrangian -! -! dzl depth of model layer in meter -! wwl terminal velocity at model layer m/s -! rql cloud density*mixing ration -! precip precipitation -! dt time step -! id kind of precip: 0 test case; 1 raindrop -! iter how many time to guess mean terminal velocity: 0 pure forward. -! 0 : use departure wind for advection -! 1 : use mean wind for advection -! > 1 : use mean wind after iter-1 iterations -! -! author: hann-ming henry juang -! implemented by song-you hong -! - -!--- input arguments: - integer,intent(in):: im,km,id,iter - - real(kind=kind_phys),intent(in):: dt - real(kind=kind_phys),intent(in),dimension(im,km):: dzl,denl,denfacl,tkl - -!--- inout arguments: - real(kind=kind_phys),intent(inout),dimension(im):: precip - real(kind=kind_phys),intent(inout),dimension(im,km):: rql,wwl - -!---- local variables and arrays: - integer:: i,k,n,m,kk,kb,kt - real(kind=kind_phys):: tl,tl2,qql,dql,qqd - real(kind=kind_phys):: th,th2,qqh,dqh - real(kind=kind_phys):: zsum,qsum,dim,dip,c1,con1,fa1,fa2 - real(kind=kind_phys):: allold,allnew,zz,dzamin,cflmax,decfl - real(kind=kind_phys),dimension(km):: dz,ww,qq,wd,wa,was - real(kind=kind_phys),dimension(km):: den,denfac,tk - real(kind=kind_phys),dimension(km):: qn,qr,tmp,tmp1,tmp2,tmp3 - real(kind=kind_phys),dimension(km+1):: wi,zi,za - real(kind=kind_phys),dimension(km+1):: dza,qa,qmi,qpi - -!----------------------------------------------------------------------------------------------------------------- - - precip(:) = 0.0 - - i_loop: do i=1,im - dz(:) = dzl(i,:) - qq(:) = rql(i,:) - ww(:) = wwl(i,:) - den(:) = denl(i,:) - denfac(:) = denfacl(i,:) - tk(:) = tkl(i,:) -! skip for no precipitation for all layers - allold = 0.0 - do k=1,km - allold = allold + qq(k) - enddo - if(allold.le.0.0) then - cycle i_loop - endif -! -! compute interface values - zi(1)=0.0 - do k=1,km - zi(k+1) = zi(k)+dz(k) - enddo -! -! save departure wind - wd(:) = ww(:) - n=1 - 100 continue -! plm is 2nd order, we can use 2nd order wi or 3rd order wi -! 2nd order interpolation to get wi - wi(1) = ww(1) - wi(km+1) = ww(km) - do k=2,km - wi(k) = (ww(k)*dz(k-1)+ww(k-1)*dz(k))/(dz(k-1)+dz(k)) - enddo -! 3rd order interpolation to get wi - fa1 = 9./16. - fa2 = 1./16. - wi(1) = ww(1) - wi(2) = 0.5*(ww(2)+ww(1)) - do k=3,km-1 - wi(k) = fa1*(ww(k)+ww(k-1))-fa2*(ww(k+1)+ww(k-2)) - enddo - wi(km) = 0.5*(ww(km)+ww(km-1)) - wi(km+1) = ww(km) -! -! terminate of top of raingroup - do k=2,km - if( ww(k).eq.0.0 ) wi(k)=ww(k-1) - enddo -! -! diffusivity of wi - con1 = 0.05 - do k=km,1,-1 - decfl = (wi(k+1)-wi(k))*dt/dz(k) - if( decfl .gt. con1 ) then - wi(k) = wi(k+1) - con1*dz(k)/dt - endif - enddo -! compute arrival point - do k=1,km+1 - za(k) = zi(k) - wi(k)*dt - enddo -! - do k=1,km - dza(k) = za(k+1)-za(k) - enddo - dza(km+1) = zi(km+1) - za(km+1) -! -! computer deformation at arrival point - do k=1,km - qa(k) = qq(k)*dz(k)/dza(k) - qr(k) = qa(k)/den(k) - enddo - qa(km+1) = 0.0 -! call maxmin(km,1,qa,' arrival points ') -! -! compute arrival terminal velocity, and estimate mean terminal velocity -! then back to use mean terminal velocity - if( n.le.iter ) then - call slope_rain(qr,den,denfac,tk,tmp,tmp1,tmp2,tmp3,wa,1,1,1,km) - if( n.ge.2 ) wa(1:km)=0.5*(wa(1:km)+was(1:km)) - do k=1,km -!#ifdef DEBUG -! print*,' slope_wsm3 ',qr(k)*1000.,den(k),denfac(k),tk(k),tmp(k),tmp1(k),tmp2(k),ww(k),wa(k) -!#endif -! mean wind is average of departure and new arrival winds - ww(k) = 0.5* ( wd(k)+wa(k) ) - enddo - was(:) = wa(:) - n=n+1 - go to 100 - endif -! -! estimate values at arrival cell interface with monotone - do k=2,km - dip=(qa(k+1)-qa(k))/(dza(k+1)+dza(k)) - dim=(qa(k)-qa(k-1))/(dza(k-1)+dza(k)) - if( dip*dim.le.0.0 ) then - qmi(k)=qa(k) - qpi(k)=qa(k) - else - qpi(k)=qa(k)+0.5*(dip+dim)*dza(k) - qmi(k)=2.0*qa(k)-qpi(k) - if( qpi(k).lt.0.0 .or. qmi(k).lt.0.0 ) then - qpi(k) = qa(k) - qmi(k) = qa(k) - endif - endif - enddo - qpi(1)=qa(1) - qmi(1)=qa(1) - qmi(km+1)=qa(km+1) - qpi(km+1)=qa(km+1) -! -! interpolation to regular point - qn = 0.0 - kb=1 - kt=1 - intp : do k=1,km - kb=max(kb-1,1) - kt=max(kt-1,1) -! find kb and kt - if( zi(k).ge.za(km+1) ) then - exit intp - else - find_kb : do kk=kb,km - if( zi(k).le.za(kk+1) ) then - kb = kk - exit find_kb - else - cycle find_kb - endif - enddo find_kb - find_kt : do kk=kt,km - if( zi(k+1).le.za(kk) ) then - kt = kk - exit find_kt - else - cycle find_kt - endif - enddo find_kt - kt = kt - 1 -! compute q with piecewise constant method - if( kt.eq.kb ) then - tl=(zi(k)-za(kb))/dza(kb) - th=(zi(k+1)-za(kb))/dza(kb) - tl2=tl*tl - th2=th*th - qqd=0.5*(qpi(kb)-qmi(kb)) - qqh=qqd*th2+qmi(kb)*th - qql=qqd*tl2+qmi(kb)*tl - qn(k) = (qqh-qql)/(th-tl) - else if( kt.gt.kb ) then - tl=(zi(k)-za(kb))/dza(kb) - tl2=tl*tl - qqd=0.5*(qpi(kb)-qmi(kb)) - qql=qqd*tl2+qmi(kb)*tl - dql = qa(kb)-qql - zsum = (1.-tl)*dza(kb) - qsum = dql*dza(kb) - if( kt-kb.gt.1 ) then - do m=kb+1,kt-1 - zsum = zsum + dza(m) - qsum = qsum + qa(m) * dza(m) - enddo - endif - th=(zi(k+1)-za(kt))/dza(kt) - th2=th*th - qqd=0.5*(qpi(kt)-qmi(kt)) - dqh=qqd*th2+qmi(kt)*th - zsum = zsum + th*dza(kt) - qsum = qsum + dqh*dza(kt) - qn(k) = qsum/zsum - endif - cycle intp - endif -! - enddo intp -! -! rain out - sum_precip: do k=1,km - if( za(k).lt.0.0 .and. za(k+1).lt.0.0 ) then - precip(i) = precip(i) + qa(k)*dza(k) - cycle sum_precip - else if ( za(k).lt.0.0 .and. za(k+1).ge.0.0 ) then - precip(i) = precip(i) + qa(k)*(0.0-za(k)) - exit sum_precip - endif - exit sum_precip - enddo sum_precip -! -! replace the new values - rql(i,:) = qn(:) - enddo i_loop - - end subroutine nislfv_rain_plm - -!================================================================================================================= - subroutine nislfv_rain_plm6(im,km,denl,denfacl,tkl,dzl,wwl,rql,rql2,precip1,precip2,dt,id,iter) -!================================================================================================================= -! -! for non-iteration semi-Lagrangain forward advection for cloud -! with mass conservation and positive definite advection -! 2nd order interpolation with monotonic piecewise linear method -! this routine is under assumption of decfl < 1 for semi_Lagrangian -! -! dzl depth of model layer in meter -! wwl terminal velocity at model layer m/s -! rql cloud density*mixing ration -! precip precipitation -! dt time step -! id kind of precip: 0 test case; 1 raindrop -! iter how many time to guess mean terminal velocity: 0 pure forward. -! 0 : use departure wind for advection -! 1 : use mean wind for advection -! > 1 : use mean wind after iter-1 iterations -! -! author: hann-ming henry juang -! implemented by song-you hong -! - -!--- input arguments: - integer,intent(in):: im,km,id,iter - - real(kind=kind_phys),intent(in):: dt - real(kind=kind_phys),intent(in),dimension(im,km):: dzl,denl,denfacl,tkl - -!--- inout arguments: - real(kind=kind_phys),intent(inout),dimension(im):: precip1,precip2 - real(kind=kind_phys),intent(inout),dimension(im,km):: rql,rql2,wwl - -!---- local variables and arrays: - integer:: i,ist,k,n,m,kk,kb,kt - real(kind=kind_phys):: tl,tl2,qql,dql,qqd - real(kind=kind_phys):: th,th2,qqh,dqh - real(kind=kind_phys):: zsum,qsum,dim,dip,c1,con1,fa1,fa2 - real(kind=kind_phys):: allold,allnew,zz,dzamin,cflmax,decfl - real(kind=kind_phys),dimension(km):: dz,ww,qq,qq2,wd,wa,wa2,was - real(kind=kind_phys),dimension(km):: den,denfac,tk - real(kind=kind_phys),dimension(km):: qn,qr,qr2,tmp,tmp1,tmp2,tmp3 - real(kind=kind_phys),dimension(km+1):: wi,zi,za - real(kind=kind_phys),dimension(km+1):: dza,qa,qa2,qmi,qpi - real(kind=kind_phys),dimension(im):: precip - -!----------------------------------------------------------------------------------------------------------------- - - precip(:) = 0.0 - precip1(:) = 0.0 - precip2(:) = 0.0 - - i_loop: do i=1,im - dz(:) = dzl(i,:) - qq(:) = rql(i,:) - qq2(:) = rql2(i,:) - ww(:) = wwl(i,:) - den(:) = denl(i,:) - denfac(:) = denfacl(i,:) - tk(:) = tkl(i,:) -! skip for no precipitation for all layers - allold = 0.0 - do k=1,km - allold = allold + qq(k) + qq2(k) - enddo - if(allold.le.0.0) then - cycle i_loop - endif -! -! compute interface values - zi(1)=0.0 - do k=1,km - zi(k+1) = zi(k)+dz(k) - enddo -! -! save departure wind - wd(:) = ww(:) - n=1 - 100 continue -! plm is 2nd order, we can use 2nd order wi or 3rd order wi -! 2nd order interpolation to get wi - wi(1) = ww(1) - wi(km+1) = ww(km) - do k=2,km - wi(k) = (ww(k)*dz(k-1)+ww(k-1)*dz(k))/(dz(k-1)+dz(k)) - enddo -! 3rd order interpolation to get wi - fa1 = 9./16. - fa2 = 1./16. - wi(1) = ww(1) - wi(2) = 0.5*(ww(2)+ww(1)) - do k=3,km-1 - wi(k) = fa1*(ww(k)+ww(k-1))-fa2*(ww(k+1)+ww(k-2)) - enddo - wi(km) = 0.5*(ww(km)+ww(km-1)) - wi(km+1) = ww(km) -! -! terminate of top of raingroup - do k=2,km - if( ww(k).eq.0.0 ) wi(k)=ww(k-1) - enddo -! -! diffusivity of wi - con1 = 0.05 - do k=km,1,-1 - decfl = (wi(k+1)-wi(k))*dt/dz(k) - if( decfl .gt. con1 ) then - wi(k) = wi(k+1) - con1*dz(k)/dt - endif - enddo -! compute arrival point - do k=1,km+1 - za(k) = zi(k) - wi(k)*dt - enddo -! - do k=1,km - dza(k) = za(k+1)-za(k) - enddo - dza(km+1) = zi(km+1) - za(km+1) -! -! computer deformation at arrival point - do k=1,km - qa(k) = qq(k)*dz(k)/dza(k) - qa2(k) = qq2(k)*dz(k)/dza(k) - qr(k) = qa(k)/den(k) - qr2(k) = qa2(k)/den(k) - enddo - qa(km+1) = 0.0 - qa2(km+1) = 0.0 -! call maxmin(km,1,qa,' arrival points ') -! -! compute arrival terminal velocity, and estimate mean terminal velocity -! then back to use mean terminal velocity - if( n.le.iter ) then - call slope_snow(qr,den,denfac,tk,tmp,tmp1,tmp2,tmp3,wa,1,1,1,km) - call slope_graup(qr2,den,denfac,tk,tmp,tmp1,tmp2,tmp3,wa2,1,1,1,km) - do k = 1, km - tmp(k) = max((qr(k)+qr2(k)), 1.E-15) - if( tmp(k) .gt. 1.e-15 ) then - wa(k) = (wa(k)*qr(k) + wa2(k)*qr2(k))/tmp(k) - else - wa(k) = 0. - endif - enddo - if( n.ge.2 ) wa(1:km)=0.5*(wa(1:km)+was(1:km)) - do k=1,km -!#ifdef DEBUG -! print*,' slope_wsm3 ',qr(k)*1000.,den(k),denfac(k),tk(k),tmp(k),tmp1(k),tmp2(k), & -! ww(k),wa(k) -!#endif -! mean wind is average of departure and new arrival winds - ww(k) = 0.5* ( wd(k)+wa(k) ) - enddo - was(:) = wa(:) - n=n+1 - go to 100 - endif - - ist_loop : do ist = 1, 2 - if (ist.eq.2) then - qa(:) = qa2(:) - endif -! - precip(i) = 0. -! -! estimate values at arrival cell interface with monotone - do k=2,km - dip=(qa(k+1)-qa(k))/(dza(k+1)+dza(k)) - dim=(qa(k)-qa(k-1))/(dza(k-1)+dza(k)) - if( dip*dim.le.0.0 ) then - qmi(k)=qa(k) - qpi(k)=qa(k) - else - qpi(k)=qa(k)+0.5*(dip+dim)*dza(k) - qmi(k)=2.0*qa(k)-qpi(k) - if( qpi(k).lt.0.0 .or. qmi(k).lt.0.0 ) then - qpi(k) = qa(k) - qmi(k) = qa(k) - endif - endif - enddo - qpi(1)=qa(1) - qmi(1)=qa(1) - qmi(km+1)=qa(km+1) - qpi(km+1)=qa(km+1) -! -! interpolation to regular point - qn = 0.0 - kb=1 - kt=1 - intp : do k=1,km - kb=max(kb-1,1) - kt=max(kt-1,1) -! find kb and kt - if( zi(k).ge.za(km+1) ) then - exit intp - else - find_kb : do kk=kb,km - if( zi(k).le.za(kk+1) ) then - kb = kk - exit find_kb - else - cycle find_kb - endif - enddo find_kb - find_kt : do kk=kt,km - if( zi(k+1).le.za(kk) ) then - kt = kk - exit find_kt - else - cycle find_kt - endif - enddo find_kt - kt = kt - 1 -! compute q with piecewise constant method - if( kt.eq.kb ) then - tl=(zi(k)-za(kb))/dza(kb) - th=(zi(k+1)-za(kb))/dza(kb) - tl2=tl*tl - th2=th*th - qqd=0.5*(qpi(kb)-qmi(kb)) - qqh=qqd*th2+qmi(kb)*th - qql=qqd*tl2+qmi(kb)*tl - qn(k) = (qqh-qql)/(th-tl) - else if( kt.gt.kb ) then - tl=(zi(k)-za(kb))/dza(kb) - tl2=tl*tl - qqd=0.5*(qpi(kb)-qmi(kb)) - qql=qqd*tl2+qmi(kb)*tl - dql = qa(kb)-qql - zsum = (1.-tl)*dza(kb) - qsum = dql*dza(kb) - if( kt-kb.gt.1 ) then - do m=kb+1,kt-1 - zsum = zsum + dza(m) - qsum = qsum + qa(m) * dza(m) - enddo - endif - th=(zi(k+1)-za(kt))/dza(kt) - th2=th*th - qqd=0.5*(qpi(kt)-qmi(kt)) - dqh=qqd*th2+qmi(kt)*th - zsum = zsum + th*dza(kt) - qsum = qsum + dqh*dza(kt) - qn(k) = qsum/zsum - endif - cycle intp - endif -! - enddo intp -! -! rain out - sum_precip: do k=1,km - if( za(k).lt.0.0 .and. za(k+1).lt.0.0 ) then - precip(i) = precip(i) + qa(k)*dza(k) - cycle sum_precip - else if ( za(k).lt.0.0 .and. za(k+1).ge.0.0 ) then - precip(i) = precip(i) + qa(k)*(0.0-za(k)) - exit sum_precip - endif - exit sum_precip - enddo sum_precip -! -! replace the new values - if(ist.eq.1) then - rql(i,:) = qn(:) - precip1(i) = precip(i) - else - rql2(i,:) = qn(:) - precip2(i) = precip(i) - endif - enddo ist_loop - - enddo i_loop - - end subroutine nislfv_rain_plm6 - -!================================================================================================================= - subroutine refl10cm_wsm6(qv1d,qr1d,qs1d,qg1d,t1d,p1d,dBZ,kts,kte) - implicit none -!================================================================================================================= - -!..Sub arguments - integer,intent(in):: kts,kte - real(kind=kind_phys),intent(in),dimension(kts:kte):: qv1d,qr1d,qs1d,qg1d,t1d,p1d - real(kind=kind_phys),intent(inout),dimension(kts:kte):: dBz - -!..Local variables - logical:: melti - logical,dimension(kts:kte):: l_qr,l_qs,l_qg - - INTEGER:: i,k,k_0,kbot,n - - real(kind=kind_phys),parameter:: R=287. - real(kind=kind_phys):: temp_c - real(kind=kind_phys),dimension(kts:kte):: temp,pres,qv,rho - real(kind=kind_phys),dimension(kts:kte):: rr,rs,rg - real(kind=kind_phys),dimension(kts:kte):: ze_rain,ze_snow,ze_graupel - - double precision:: fmelt_s,fmelt_g - double precision:: cback,x,eta,f_d - double precision,dimension(kts:kte):: ilamr,ilams,ilamg - double precision,dimension(kts:kte):: n0_r, n0_s, n0_g - double precision:: lamr,lams,lamg - -!----------------------------------------------------------------------------------------------------------------- - - do k = kts, kte - dBZ(k) = -35.0 - enddo - -!+---+-----------------------------------------------------------------+ -!..Put column of data into local arrays. -!+---+-----------------------------------------------------------------+ - do k = kts, kte - temp(k) = t1d(k) - temp_c = min(-0.001, temp(k)-273.15) - qv(k) = max(1.e-10, qv1d(k)) - pres(k) = p1d(k) - rho(k) = 0.622*pres(k)/(R*temp(k)*(qv(k)+0.622)) - - if (qr1d(k) .gt. 1.e-9) then - rr(k) = qr1d(k)*rho(k) - n0_r(k) = n0r - lamr = (xam_r*xcrg(3)*n0_r(k)/rr(k))**(1./xcre(1)) - ilamr(k) = 1./lamr - l_qr(k) = .true. - else - rr(k) = 1.e-12 - l_qr(k) = .false. - endif - - if (qs1d(k) .gt. 1.e-9) then - rs(k) = qs1d(k)*rho(k) - n0_s(k) = min(n0smax, n0s*exp(-alpha*temp_c)) - lams = (xam_s*xcsg(3)*n0_s(k)/rs(k))**(1./xcse(1)) - ilams(k) = 1./lams - l_qs(k) = .true. - else - rs(k) = 1.e-12 - l_qs(k) = .false. - endif - - if (qg1d(k) .gt. 1.e-9) then - rg(k) = qg1d(k)*rho(k) - n0_g(k) = n0g - lamg = (xam_g*xcgg(3)*n0_g(k)/rg(k))**(1./xcge(1)) - ilamg(k) = 1./lamg - l_qg(k) = .true. - else - rg(k) = 1.e-12 - l_qg(k) = .false. - endif - enddo - -!+---+-----------------------------------------------------------------+ -!..Locate K-level of start of melting (k_0 is level above). -!+---+-----------------------------------------------------------------+ - melti = .false. - k_0 = kts - do k = kte-1, kts, -1 - if ( (temp(k).gt.273.15) .and. L_qr(k) & - .and. (L_qs(k+1).or.L_qg(k+1)) ) then - k_0 = MAX(k+1, k_0) - melti=.true. - goto 195 - endif - enddo - 195 continue - -!+---+-----------------------------------------------------------------+ -!..Assume Rayleigh approximation at 10 cm wavelength. Rain (all temps) -!.. and non-water-coated snow and graupel when below freezing are -!.. simple. Integrations of m(D)*m(D)*N(D)*dD. -!+---+-----------------------------------------------------------------+ - - do k = kts, kte - ze_rain(k) = 1.e-22 - ze_snow(k) = 1.e-22 - ze_graupel(k) = 1.e-22 - if (l_qr(k)) ze_rain(k) = n0_r(k)*xcrg(4)*ilamr(k)**xcre(4) - if (l_qs(k)) ze_snow(k) = (0.176/0.93) * (6.0/pi)*(6.0/pi) & - * (xam_s/900.0)*(xam_s/900.0) & - * n0_s(k)*xcsg(4)*ilams(k)**xcse(4) - if (l_qg(k)) ze_graupel(k) = (0.176/0.93) * (6.0/pi)*(6.0/pi) & - * (xam_g/900.0)*(xam_g/900.0) & - * n0_g(k)*xcgg(4)*ilamg(k)**xcge(4) - enddo - - -!+---+-----------------------------------------------------------------+ -!..Special case of melting ice (snow/graupel) particles. Assume the -!.. ice is surrounded by the liquid water. Fraction of meltwater is -!.. extremely simple based on amount found above the melting level. -!.. Uses code from Uli Blahak (rayleigh_soak_wetgraupel and supporting -!.. routines). -!+---+-----------------------------------------------------------------+ - - if (melti .and. k_0.ge.kts+1) then - do k = k_0-1, kts, -1 - -!..Reflectivity contributed by melting snow - if (L_qs(k) .and. L_qs(k_0) ) then - fmelt_s = MAX(0.005d0, MIN(1.0d0-rs(k)/rs(k_0), 0.99d0)) - eta = 0.d0 - lams = 1./ilams(k) - do n = 1, nrbins - x = xam_s * xxDs(n)**xbm_s - call rayleigh_soak_wetgraupel (x,dble(xocms),dble(xobms), & - fmelt_s, melt_outside_s, m_w_0, m_i_0, lamda_radar, & - cback, mixingrulestring_s, matrixstring_s, & - inclusionstring_s, hoststring_s, & - hostmatrixstring_s, hostinclusionstring_s) - f_d = n0_s(k)*xxds(n)**xmu_s * dexp(-lams*xxds(n)) - eta = eta + f_d * cback * simpson(n) * xdts(n) - enddo - ze_snow(k) = sngl(lamda4 / (pi5 * k_w) * eta) - endif - - -!..Reflectivity contributed by melting graupel - - if (l_qg(k) .and. l_qg(k_0) ) then - fmelt_g = max(0.005d0, min(1.0d0-rg(k)/rg(k_0), 0.99d0)) - eta = 0.d0 - lamg = 1./ilamg(k) - do n = 1, nrbins - x = xam_g * xxdg(n)**xbm_g - call rayleigh_soak_wetgraupel (x,dble(xocmg),dble(xobmg), & - fmelt_g, melt_outside_g, m_w_0, m_i_0, lamda_radar, & - cback, mixingrulestring_g, matrixstring_g, & - inclusionstring_g, hoststring_g, & - hostmatrixstring_g, hostinclusionstring_g) - f_d = n0_g(k)*xxdg(n)**xmu_g * dexp(-lamg*xxdg(n)) - eta = eta + f_d * cback * simpson(n) * xdtg(n) - enddo - ze_graupel(k) = sngl(lamda4 / (pi5 * k_w) * eta) - endif - - enddo - endif - - do k = kte, kts, -1 - dBZ(k) = 10.*log10((ze_rain(k)+ze_snow(k)+ze_graupel(k))*1.d18) - enddo - - - end subroutine refl10cm_wsm6 - - -!================================================================================================================= - end module mp_wsm6 -!================================================================================================================= diff --git a/phys/physics_mmm/mp_wsm6_effectRad.F90 b/phys/physics_mmm/mp_wsm6_effectRad.F90 deleted file mode 100644 index 458bbda34a..0000000000 --- a/phys/physics_mmm/mp_wsm6_effectRad.F90 +++ /dev/null @@ -1,197 +0,0 @@ -!================================================================================================================= - module mp_wsm6_effectrad - use ccpp_kind_types,only: kind_phys - - - use mp_wsm6,only: alpha,n0s,n0smax,pidn0s,pidnc - - - implicit none - private - public:: mp_wsm6_effectRad_run, & - mp_wsm6_effectrad_init, & - mp_wsm6_effectRad_finalize - - - contains - - -!================================================================================================================= -!>\section arg_table_mp_wsm6_effectRad_init -!!\html\include mp_wsm6_effectRad_init.html -!! - subroutine mp_wsm6_effectRad_init(errmsg,errflg) -!================================================================================================================= - -!output arguments: - character(len=*),intent(out):: errmsg - integer,intent(out):: errflg - -!----------------------------------------------------------------------------------------------------------------- - - errmsg = 'mp_wsm6_effectRad_init OK' - errflg = 0 - - end subroutine mp_wsm6_effectRad_init - -!================================================================================================================= -!>\section arg_table_mp_wsm6_effectRad_finalize -!!\html\include mp_wsm6_effectRad_finalize.html -!! - subroutine mp_wsm6_effectRad_finalize(errmsg,errflg) -!================================================================================================================= - -!output arguments: - character(len=*),intent(out):: errmsg - integer,intent(out):: errflg - -!----------------------------------------------------------------------------------------------------------------- - - errmsg = 'mp_wsm6_effectRad_final OK' - errflg = 0 - - end subroutine mp_wsm6_effectRad_finalize - -!================================================================================================================= -!>\section arg_table_mp_wsm6_effectRad_run -!!\html\include mp_wsm6_effectRad_run.html -!! - subroutine mp_wsm6_effectRad_run(do_microp_re,t,qc,qi,qs,rho,qmin,t0c,re_qc_bg,re_qi_bg,re_qs_bg, & - re_qc_max,re_qi_max,re_qs_max,re_qc,re_qi,re_qs,its,ite,kts,kte, & - errmsg,errflg) -!================================================================================================================= -! Compute radiation effective radii of cloud water, ice, and snow for -! single-moment microphysics. -! These are entirely consistent with microphysics assumptions, not -! constant or otherwise ad hoc as is internal to most radiation -! schemes. -! Coded and implemented by Soo ya Bae, KIAPS, January 2015. -!----------------------------------------------------------------------------------------------------------------- - - -!..Sub arguments - logical,intent(in):: do_microp_re - integer,intent(in):: its,ite,kts,kte - real(kind=kind_phys),intent(in):: qmin - real(kind=kind_phys),intent(in):: t0c - real(kind=kind_phys),intent(in):: re_qc_bg,re_qi_bg,re_qs_bg - real(kind=kind_phys),intent(in):: re_qc_max,re_qi_max,re_qs_max - real(kind=kind_phys),dimension(its:,:),intent(in):: t - real(kind=kind_phys),dimension(its:,:),intent(in):: qc - real(kind=kind_phys),dimension(its:,:),intent(in):: qi - real(kind=kind_phys),dimension(its:,:),intent(in):: qs - real(kind=kind_phys),dimension(its:,:),intent(in):: rho - real(kind=kind_phys),dimension(its:,:),intent(inout):: re_qc - real(kind=kind_phys),dimension(its:,:),intent(inout):: re_qi - real(kind=kind_phys),dimension(its:,:),intent(inout):: re_qs - -!...Output arguments: - character(len=*),intent(out):: errmsg - integer,intent(out):: errflg - -!..Local variables - integer:: i,k - integer:: inu_c - real(kind=kind_phys),dimension(its:ite,kts:kte):: ni - real(kind=kind_phys),dimension(its:ite,kts:kte):: rqc - real(kind=kind_phys),dimension(its:ite,kts:kte):: rqi - real(kind=kind_phys),dimension(its:ite,kts:kte):: rni - real(kind=kind_phys),dimension(its:ite,kts:kte):: rqs - real(kind=kind_phys):: temp - real(kind=kind_phys):: lamdac - real(kind=kind_phys):: supcol,n0sfac,lamdas - real(kind=kind_phys):: diai ! diameter of ice in m - logical:: has_qc, has_qi, has_qs -!..Minimum microphys values - real(kind=kind_phys),parameter:: R1 = 1.E-12 - real(kind=kind_phys),parameter:: R2 = 1.E-6 -!..Mass power law relations: mass = am*D**bm - real(kind=kind_phys),parameter:: bm_r = 3.0 - real(kind=kind_phys),parameter:: obmr = 1.0/bm_r - real(kind=kind_phys),parameter:: nc0 = 3.E8 - -!----------------------------------------------------------------------------------------------------------------- - - if(.not. do_microp_re) return - -!--- initialization of effective radii of cloud water, cloud ice, and snow to background values: - do k = kts,kte - do i = its,ite - re_qc(i,k) = re_qc_bg - re_qi(i,k) = re_qi_bg - re_qs(i,k) = re_qs_bg - enddo - enddo - -!--- computation of effective radii: - has_qc = .false. - has_qi = .false. - has_qs = .false. - - do k = kts,kte - do i = its,ite - ! for cloud - rqc(i,k) = max(R1,qc(i,k)*rho(i,k)) - if (rqc(i,k).gt.R1) has_qc = .true. - ! for ice - rqi(i,k) = max(R1,qi(i,k)*rho(i,k)) - temp = (rho(i,k)*max(qi(i,k),qmin)) - temp = sqrt(sqrt(temp*temp*temp)) - ni(i,k) = min(max(5.38e7*temp,1.e3),1.e6) - rni(i,k)= max(R2,ni(i,k)*rho(i,k)) - if (rqi(i,k).gt.R1 .and. rni(i,k).gt.R2) has_qi = .true. - ! for snow - rqs(i,k) = max(R1,qs(i,k)*rho(i,k)) - if (rqs(i,k).gt.R1) has_qs = .true. - enddo - enddo - - if (has_qc) then - do k = kts,kte - do i = its,ite - if (rqc(i,k).le.R1) CYCLE - lamdac = (pidnc*nc0/rqc(i,k))**obmr - re_qc(i,k) = max(2.51E-6,min(1.5*(1.0/lamdac),re_qc_max)) - enddo - enddo - endif - - if (has_qi) then - do k = kts,kte - do i = its,ite - if (rqi(i,k).le.R1 .or. rni(i,k).le.R2) CYCLE - diai = 11.9*sqrt(rqi(i,k)/ni(i,k)) - re_qi(i,k) = max(10.01E-6,min(0.75*0.163*diai,re_qi_max)) - enddo - enddo - endif - - if (has_qs) then - do i = its,ite - do k = kts,kte - if (rqs(i,k).le.R1) CYCLE - supcol = t0c-t(i,k) - n0sfac = max(min(exp(alpha*supcol),n0smax/n0s),1.) - lamdas = sqrt(sqrt(pidn0s*n0sfac/rqs(i,k))) - re_qs(i,k) = max(25.E-6,min(0.5*(1./lamdas),re_qs_max)) - enddo - enddo - endif - -!--- limit effective radii of cloud water, cloud ice, and snow to maximum values: - do k = kts,kte - do i = its,ite - re_qc(i,k) = max(re_qc_bg,min(re_qc(i,k),re_qc_max)) - re_qi(i,k) = max(re_qi_bg,min(re_qi(i,k),re_qi_max)) - re_qs(i,k) = max(re_qs_bg,min(re_qs(i,k),re_qs_max)) - enddo - enddo - - errmsg = 'mp_wsm6_effectRad_run OK' - errflg = 0 - - end subroutine mp_wsm6_effectRad_run - -!================================================================================================================= - end module mp_wsm6_effectrad -!================================================================================================================= diff --git a/phys/physics_mmm/sf_sfclayrev.F90 b/phys/physics_mmm/sf_sfclayrev.F90 deleted file mode 100644 index f34701c57b..0000000000 --- a/phys/physics_mmm/sf_sfclayrev.F90 +++ /dev/null @@ -1,1121 +0,0 @@ -!================================================================================================================= - module sf_sfclayrev - use ccpp_kind_types,only: kind_phys - - implicit none - private - public:: sf_sfclayrev_run, & - sf_sfclayrev_init, & - sf_sfclayrev_finalize - - - real(kind=kind_phys),parameter:: vconvc= 1. - real(kind=kind_phys),parameter:: czo = 0.0185 - real(kind=kind_phys),parameter:: ozo = 1.59e-5 - - real(kind=kind_phys),dimension(0:1000 ),save:: psim_stab,psim_unstab,psih_stab,psih_unstab - - - contains - - -!================================================================================================================= -!>\section arg_table_sf_sfclayrev_init -!!\html\include sf_sfclayrev_init.html -!! - subroutine sf_sfclayrev_init(errmsg,errflg) -!================================================================================================================= - -!--- output arguments: - character(len=*),intent(out):: errmsg - integer,intent(out):: errflg - -!local variables: - integer:: n - real(kind=kind_phys):: zolf - -!----------------------------------------------------------------------------------------------------------------- - - do n = 0,1000 -! stable function tables - zolf = float(n)*0.01 - psim_stab(n)=psim_stable_full(zolf) - psih_stab(n)=psih_stable_full(zolf) - -! unstable function tables - zolf = -float(n)*0.01 - psim_unstab(n)=psim_unstable_full(zolf) - psih_unstab(n)=psih_unstable_full(zolf) - enddo - - errmsg = 'sf_sfclayrev_init OK' - errflg = 0 - - end subroutine sf_sfclayrev_init - -!================================================================================================================= -!>\section arg_table_sf_sfclayrev_finalize -!!\html\include sf_sfclayrev_finalize.html -!! - subroutine sf_sfclayrev_finalize(errmsg,errflg) -!================================================================================================================= - -!--- output arguments: - character(len=*),intent(out):: errmsg - integer,intent(out):: errflg - -!----------------------------------------------------------------------------------------------------------------- - - errmsg = 'sf_sfclayrev_finalize OK' - errflg = 0 - - end subroutine sf_sfclayrev_finalize - -!================================================================================================================= -!>\section arg_table_sf_sfclayrev_run -!!\html\include sf_sfclayrev_run.html -!! - subroutine sf_sfclayrev_run(ux,vx,t1d,qv1d,p1d,dz8w1d, & - cp,g,rovcp,r,xlv,psfcpa,chs,chs2,cqs2, & - cpm,pblh,rmol,znt,ust,mavail,zol,mol, & - regime,psim,psih,fm,fh, & - xland,hfx,qfx,tsk, & - u10,v10,th2,t2,q2,flhc,flqc,qgh, & - qsfc,lh,gz1oz0,wspd,br,isfflx,dx, & - svp1,svp2,svp3,svpt0,ep1,ep2, & - karman,p1000mb,lakemask, & - shalwater_z0,water_depth, & - isftcflx,iz0tlnd,scm_force_flux, & - ustm,ck,cka,cd,cda, & - its,ite,errmsg,errflg & - ) -!================================================================================================================= - -!--- input arguments: - logical,intent(in):: isfflx - logical,intent(in):: shalwater_z0 - logical,intent(in),optional:: scm_force_flux - - integer,intent(in):: its,ite - integer,intent(in),optional:: isftcflx, iz0tlnd - - real(kind=kind_phys),intent(in):: svp1,svp2,svp3,svpt0 - real(kind=kind_phys),intent(in):: ep1,ep2,karman - real(kind=kind_phys),intent(in):: p1000mb - real(kind=kind_phys),intent(in):: cp,g,rovcp,r,xlv - - real(kind=kind_phys),intent(in),dimension(its:):: & - mavail, & - pblh, & - psfcpa, & - tsk, & - xland, & - lakemask, & - water_depth - - real(kind=kind_phys),intent(in),dimension(its:):: & - dx, & - dz8w1d, & - ux, & - vx, & - qv1d, & - p1d, & - t1d - -!--- output arguments: - character(len=*),intent(out):: errmsg - integer,intent(out):: errflg - - real(kind=kind_phys),intent(out),dimension(its:):: & - lh, & - u10, & - v10, & - th2, & - t2, & - q2 - - real(kind=kind_phys),intent(out),dimension(its:),optional:: & - ck, & - cka, & - cd, & - cda - -!--- inout arguments: - real(kind=kind_phys),intent(inout),dimension(its:):: & - regime, & - hfx, & - qfx, & - qsfc, & - mol, & - rmol, & - gz1oz0, & - wspd, & - br, & - psim, & - psih, & - fm, & - fh, & - znt, & - zol, & - ust, & - cpm, & - chs2, & - cqs2, & - chs, & - flhc, & - flqc, & - qgh - - real(kind=kind_phys),intent(inout),dimension(its:),optional:: & - ustm - -!--- local variables: - integer:: n,i,k,kk,l,nzol,nk,nzol2,nzol10 - - real(kind=kind_phys),parameter:: xka = 2.4e-5 - real(kind=kind_phys),parameter:: prt = 1. - real(kind=kind_phys),parameter:: salinity_factor = 0.98 - - real(kind=kind_phys):: pl,thcon,tvcon,e1 - real(kind=kind_phys):: zl,tskv,dthvdz,dthvm,vconv,rzol,rzol2,rzol10,zol2,zol10 - real(kind=kind_phys):: dtg,psix,dtthx,psix10,psit,psit2,psiq,psiq2,psiq10 - real(kind=kind_phys):: fluxc,vsgd,z0q,visc,restar,czil,gz0ozq,gz0ozt - real(kind=kind_phys):: zw,zn1,zn2 - real(kind=kind_phys):: zolzz,zol0 - real(kind=kind_phys):: zl2,zl10,z0t - - real(kind=kind_phys),dimension(its:ite):: & - za, & - thvx, & - zqkl, & - zqklp1, & - thx, & - qx, & - psih2, & - psim2, & - psih10, & - psim10, & - denomq, & - denomq2, & - denomt2, & - wspdi, & - gz2oz0, & - gz10oz0, & - rhox, & - govrth, & - tgdsa, & - scr3, & - scr4, & - thgb, & - psfc - - real(kind=kind_phys),dimension(its:ite):: & - pq, & - pq2, & - pq10 - -!----------------------------------------------------------------------------------------------------------------- - - do i = its,ite -!PSFC cb - psfc(i)=psfcpa(i)/1000. - enddo -! -!----CONVERT GROUND TEMPERATURE TO POTENTIAL TEMPERATURE: -! - do 5 i = its,ite - tgdsa(i)=tsk(i) -!PSFC cb -! thgb(i)=tsk(i)*(100./psfc(i))**rovcp - thgb(i)=tsk(i)*(p1000mb/psfcpa(i))**rovcp - 5 continue -! -!-----DECOUPLE FLUX-FORM VARIABLES TO GIVE U,V,T,THETA,THETA-VIR., -! T-VIR., QV, AND QC AT CROSS POINTS AND AT KTAU-1. -! -! *** NOTE *** -! THE BOUNDARY WINDS MAY NOT BE ADEQUATELY AFFECTED BY FRICTION, -! SO USE ONLY INTERIOR VALUES OF UX AND VX TO CALCULATE -! TENDENCIES. -! - 10 continue - -!do 24 i = its,ite -! ux(i)=u1d(i) -! vx(i)=v1d(i) -!24 continue - - 26 continue - -!.....SCR3(I,K) STORE TEMPERATURE, -! SCR4(I,K) STORE VIRTUAL TEMPERATURE. - - do 30 i = its,ite -!PL cb - pl=p1d(i)/1000. - scr3(i)=t1d(i) -! thcon=(100./pl)**rovcp - thcon=(p1000mb*0.001/pl)**rovcp - thx(i)=scr3(i)*thcon - scr4(i)=scr3(i) - thvx(i)=thx(i) - qx(i)=0. - 30 continue -! - do i = its,ite - qgh(i)=0. - flhc(i)=0. - flqc(i)=0. - cpm(i)=cp - enddo -! -!if(idry.eq.1)goto 80 - do 50 i = its,ite - qx(i)=qv1d(i) - tvcon=(1.+ep1*qx(i)) - thvx(i)=thx(i)*tvcon - scr4(i)=scr3(i)*tvcon - 50 continue -! - do 60 i=its,ite - e1=svp1*exp(svp2*(tgdsa(i)-svpt0)/(tgdsa(i)-svp3)) - !the saturation vapor pressure for salty water is on average 2% lower - if(xland(i).gt.1.5 .and. lakemask(i).eq.0.) e1=e1*salinity_factor - !for land points qsfc can come from previous time step - if(xland(i).gt.1.5.or.qsfc(i).le.0.0)qsfc(i)=ep2*e1/(psfc(i)-e1) -!QGH CHANGED TO USE LOWEST-LEVEL AIR TEMP CONSISTENT WITH MYJSFC CHANGE -!Q2SAT = QGH IN LSM - e1=svp1*exp(svp2*(t1d(i)-svpt0)/(t1d(i)-svp3)) - pl=p1d(i)/1000. - qgh(i)=ep2*e1/(pl-e1) - cpm(i)=cp*(1.+0.8*qx(i)) - 60 continue - 80 continue - -!-----COMPUTE THE HEIGHT OF FULL- AND HALF-SIGMA LEVELS ABOVE GROUND -! LEVEL, AND THE LAYER THICKNESSES. - - do 90 i = its,ite - zqklp1(i)=0. - rhox(i)=psfc(i)*1000./(r*scr4(i)) - 90 continue -! - do 110 i = its,ite - zqkl(i)=dz8w1d(i)+zqklp1(i) - 110 continue -! - do 120 i = its,ite - za(i)=0.5*(zqkl(i)+zqklp1(i)) - 120 continue -! - do 160 i=its,ite - govrth(i)=g/thx(i) - 160 continue - -!-----CALCULATE BULK RICHARDSON NO. OF SURFACE LAYER, ACCORDING TO -! AKB(1976), EQ(12). - do 260 i = its,ite - gz1oz0(i)=alog((za(i)+znt(i))/znt(i)) ! log((z+z0)/z0) - gz2oz0(i)=alog((2.+znt(i))/znt(i)) ! log((2+z0)/z0) - gz10oz0(i)=alog((10.+znt(i))/znt(i)) ! log((10+z0)z0) - if((xland(i)-1.5).ge.0)then - zl=znt(i) - else - zl=0.01 - endif - wspd(i)=sqrt(ux(i)*ux(i)+vx(i)*vx(i)) - - tskv=thgb(i)*(1.+ep1*qsfc(i)) - dthvdz=(thvx(i)-tskv) -!-----CONVECTIVE VELOCITY SCALE VC AND SUBGRID-SCALE VELOCITY VSG -! FOLLOWING BELJAARS (1994, QJRMS) AND MAHRT AND SUN (1995, MWR) -! ... HONG AUG. 2001 -! -! vconv = 0.25*sqrt(g/tskv*pblh(i)*dthvm) -! USE BELJAARS OVER LAND, OLD MM5 (WYNGAARD) FORMULA OVER WATER - if(xland(i).lt.1.5) then - fluxc = max(hfx(i)/rhox(i)/cp & - + ep1*tskv*qfx(i)/rhox(i),0.) - vconv = vconvc*(g/tgdsa(i)*pblh(i)*fluxc)**.33 - else - if(-dthvdz.ge.0)then - dthvm=-dthvdz - else - dthvm=0. - endif -! vconv = 2.*sqrt(dthvm) -! V3.7: REDUCING CONTRIBUTION IN CALM CONDITIONS - vconv = sqrt(dthvm) - endif -! MAHRT AND SUN LOW-RES CORRECTION - vsgd = 0.32 * (max(dx(i)/5000.-1.,0.))**.33 - wspd(i)=sqrt(wspd(i)*wspd(i)+vconv*vconv+vsgd*vsgd) - wspd(i)=amax1(wspd(i),0.1) - br(i)=govrth(i)*za(i)*dthvdz/(wspd(i)*wspd(i)) -!-----IF PREVIOUSLY UNSTABLE, DO NOT LET INTO REGIMES 1 AND 2 - if(mol(i).lt.0.)br(i)=amin1(br(i),0.0) - rmol(i)=-govrth(i)*dthvdz*za(i)*karman - 260 continue - -! -!-----DIAGNOSE BASIC PARAMETERS FOR THE APPROPRIATED STABILITY CLASS: -! -! -! THE STABILITY CLASSES ARE DETERMINED BY BR (BULK RICHARDSON NO.) -! AND HOL (HEIGHT OF PBL/MONIN-OBUKHOV LENGTH). -! -! CRITERIA FOR THE CLASSES ARE AS FOLLOWS: -! -! 1. BR .GE. 0.0; -! REPRESENTS NIGHTTIME STABLE CONDITIONS (REGIME=1), -! -! 3. BR .EQ. 0.0 -! REPRESENTS FORCED CONVECTION CONDITIONS (REGIME=3), -! -! 4. BR .LT. 0.0 -! REPRESENTS FREE CONVECTION CONDITIONS (REGIME=4). -! - - do 320 i = its,ite -! - zol(i)=0. -! - if(br(i).gt.0) then - if(br(i).gt.250.0) then - zol(i)=zolri(250.0,za(i),znt(i)) - else - zol(i)=zolri(br(i),za(i),znt(i)) - endif - endif -! - if(br(i).lt.0) then - if(ust(i).lt.0.001)then - zol(i)=br(i)*gz1oz0(i) - else - if(br(i).lt.-250.0) then - zol(i)=zolri(-250.0,za(i),znt(i)) - else - zol(i)=zolri(br(i),za(i),znt(i)) - endif - endif - endif -! -! ... paj: compute integrated similarity functions. -! - zolzz=zol(i)*(za(i)+znt(i))/za(i) ! (z+z0/L - zol10=zol(i)*(10.+znt(i))/za(i) ! (10+z0)/L - zol2=zol(i)*(2.+znt(i))/za(i) ! (2+z0)/L - zol0=zol(i)*znt(i)/za(i) ! z0/L - zl2=(2.)/za(i)*zol(i) ! 2/L - zl10=(10.)/za(i)*zol(i) ! 10/L - - if((xland(i)-1.5).lt.0.)then - zl=(0.01)/za(i)*zol(i) ! (0.01)/L - else - zl=zol0 ! z0/L - endif - - if(br(i).lt.0.)goto 310 ! go to unstable regime (class 4) - if(br(i).eq.0.)goto 280 ! go to neutral regime (class 3) -! -!-----CLASS 1; STABLE (NIGHTTIME) CONDITIONS: -! - regime(i)=1. -! -! ... paj: psim and psih. follows cheng and brutsaert 2005 (cb05). -! - psim(i)=psim_stable(zolzz)-psim_stable(zol0) - psih(i)=psih_stable(zolzz)-psih_stable(zol0) -! - psim10(i)=psim_stable(zol10)-psim_stable(zol0) - psih10(i)=psih_stable(zol10)-psih_stable(zol0) -! - psim2(i)=psim_stable(zol2)-psim_stable(zol0) - psih2(i)=psih_stable(zol2)-psih_stable(zol0) -! -! ... paj: preparations to compute psiq. follows cb05+carlson boland jam 1978. -! - pq(i)=psih_stable(zol(i))-psih_stable(zl) - pq2(i)=psih_stable(zl2)-psih_stable(zl) - pq10(i)=psih_stable(zl10)-psih_stable(zl) -! -! 1.0 over monin-obukhov length - rmol(i)=zol(i)/za(i) -! - goto 320 -! -!-----CLASS 3; FORCED CONVECTION: -! - 280 regime(i)=3. - psim(i)=0.0 - psih(i)=psim(i) - psim10(i)=0. - psih10(i)=psim10(i) - psim2(i)=0. - psih2(i)=psim2(i) -! -! paj: preparations to compute PSIQ. -! - pq(i)=psih(i) - pq2(i)=psih2(i) - pq10(i)=0. -! - zol(i)=0. - rmol(i) = zol(i)/za(i) - - goto 320 -! -!-----CLASS 4; FREE CONVECTION: -! - 310 continue - regime(i)=4. -! -! ... paj: PSIM and PSIH ... -! - psim(i)=psim_unstable(zolzz)-psim_unstable(zol0) - psih(i)=psih_unstable(zolzz)-psih_unstable(zol0) -! - psim10(i)=psim_unstable(zol10)-psim_unstable(zol0) - psih10(i)=psih_unstable(zol10)-psih_unstable(zol0) -! - psim2(i)=psim_unstable(zol2)-psim_unstable(zol0) - psih2(i)=psih_unstable(zol2)-psih_unstable(zol0) -! -! ... paj: preparations to compute PSIQ -! - pq(i)=psih_unstable(zol(i))-psih_unstable(zl) - pq2(i)=psih_unstable(zl2)-psih_unstable(zl) - pq10(i)=psih_unstable(zl10)-psih_unstable(zl) -! -!-----LIMIT PSIH AND PSIM IN THE CASE OF THIN LAYERS AND HIGH ROUGHNESS -!-----THIS PREVENTS DENOMINATOR IN FLUXES FROM GETTING TOO SMALL - psih(i)=amin1(psih(i),0.9*gz1oz0(i)) - psim(i)=amin1(psim(i),0.9*gz1oz0(i)) - psih2(i)=amin1(psih2(i),0.9*gz2oz0(i)) - psim10(i)=amin1(psim10(i),0.9*gz10oz0(i)) -! -! AHW: mods to compute ck, cd - psih10(i)=amin1(psih10(i),0.9*gz10oz0(i)) - rmol(i) = zol(i)/za(i) - - 320 continue -! -!-----COMPUTE THE FRICTIONAL VELOCITY: -! ZA(1982) EQS(2.60),(2.61). -! - do 330 i = its,ite - dtg=thx(i)-thgb(i) - psix=gz1oz0(i)-psim(i) - psix10=gz10oz0(i)-psim10(i) - -! LOWER LIMIT ADDED TO PREVENT LARGE FLHC IN SOIL MODEL -! ACTIVATES IN UNSTABLE CONDITIONS WITH THIN LAYERS OR HIGH Z0 -! PSIT=AMAX1(GZ1OZ0(I)-PSIH(I),2.) - psit=gz1oz0(i)-psih(i) - psit2=gz2oz0(i)-psih2(i) -! - if((xland(i)-1.5).ge.0)then - zl=znt(i) - else - zl=0.01 - endif -! - psiq=alog(karman*ust(i)*za(i)/xka+za(i)/zl)-pq(i) - psiq2=alog(karman*ust(i)*2./xka+2./zl)-pq2(i) - -! AHW: mods to compute ck, cd - psiq10=alog(karman*ust(i)*10./xka+10./zl)-pq10(i) - -! v3.7: using fairall 2003 to compute z0q and z0t over water: -! adapted from module_sf_mynn.f - if((xland(i)-1.5).ge.0.) then - visc=(1.32+0.009*(scr3(i)-273.15))*1.e-5 - restar=ust(i)*znt(i)/visc - z0t = (5.5e-5)*(restar**(-0.60)) - z0t = min(z0t,1.0e-4) - z0t = max(z0t,2.0e-9) - z0q = z0t - -! following paj: - zolzz=zol(i)*(za(i)+z0t)/za(i) ! (z+z0t)/L - zol10=zol(i)*(10.+z0t)/za(i) ! (10+z0t)/L - zol2=zol(i)*(2.+z0t)/za(i) ! (2+z0t)/L - zol0=zol(i)*z0t/za(i) ! z0t/L -! - if(zol(i).gt.0.) then - psih(i)=psih_stable(zolzz)-psih_stable(zol0) - psih10(i)=psih_stable(zol10)-psih_stable(zol0) - psih2(i)=psih_stable(zol2)-psih_stable(zol0) - else - if(zol(i).eq.0) then - psih(i)=0. - psih10(i)=0. - psih2(i)=0. - else - psih(i)=psih_unstable(zolzz)-psih_unstable(zol0) - psih10(i)=psih_unstable(zol10)-psih_unstable(zol0) - psih2(i)=psih_unstable(zol2)-psih_unstable(zol0) - endif - endif - psit=alog((za(i)+z0t)/z0t)-psih(i) - psit2=alog((2.+z0t)/z0t)-psih2(i) - - zolzz=zol(i)*(za(i)+z0q)/za(i) ! (z+z0q)/L - zol10=zol(i)*(10.+z0q)/za(i) ! (10+z0q)/L - zol2=zol(i)*(2.+z0q)/za(i) ! (2+z0q)/L - zol0=zol(i)*z0q/za(i) ! z0q/L -! - if(zol(i).gt.0.) then - psih(i)=psih_stable(zolzz)-psih_stable(zol0) - psih10(i)=psih_stable(zol10)-psih_stable(zol0) - psih2(i)=psih_stable(zol2)-psih_stable(zol0) - else - if(zol(i).eq.0) then - psih(i)=0. - psih10(i)=0. - psih2(i)=0. - else - psih(i)=psih_unstable(zolzz)-psih_unstable(zol0) - psih10(i)=psih_unstable(zol10)-psih_unstable(zol0) - psih2(i)=psih_unstable(zol2)-psih_unstable(zol0) - endif - endif -! - psiq=alog((za(i)+z0q)/z0q)-psih(i) - psiq2=alog((2.+z0q)/z0q)-psih2(i) - psiq10=alog((10.+z0q)/z0q)-psih10(i) - endif - - if(present(isftcflx)) then - if(isftcflx.eq.1 .and. (xland(i)-1.5).ge.0.) then -! v3.1 -! z0q = 1.e-4 + 1.e-3*(max(0.,ust(i)-1.))**2 -! hfip1 -! z0q = 0.62*2.0e-5/ust(i) + 1.e-3*(max(0.,ust(i)-1.5))**2 -! v3.2 - z0q = 1.e-4 -! -! ... paj: recompute psih for z0q -! - zolzz=zol(i)*(za(i)+z0q)/za(i) ! (z+z0q)/L - zol10=zol(i)*(10.+z0q)/za(i) ! (10+z0q)/L - zol2=zol(i)*(2.+z0q)/za(i) ! (2+z0q)/L - zol0=zol(i)*z0q/za(i) ! z0q/L -! - if(zol(i).gt.0.) then - psih(i)=psih_stable(zolzz)-psih_stable(zol0) - psih10(i)=psih_stable(zol10)-psih_stable(zol0) - psih2(i)=psih_stable(zol2)-psih_stable(zol0) - else - if(zol(i).eq.0) then - psih(i)=0. - psih10(i)=0. - psih2(i)=0. - else - psih(i)=psih_unstable(zolzz)-psih_unstable(zol0) - psih10(i)=psih_unstable(zol10)-psih_unstable(zol0) - psih2(i)=psih_unstable(zol2)-psih_unstable(zol0) - endif - endif -! - psiq=alog((za(i)+z0q)/z0q)-psih(i) - psit=psiq - psiq2=alog((2.+z0q)/z0q)-psih2(i) - psiq10=alog((10.+z0q)/z0q)-psih10(i) - psit2=psiq2 - endif - if(isftcflx.eq.2 .and. (xland(i)-1.5).ge.0.) then -! AHW: Garratt formula: Calculate roughness Reynolds number -! Kinematic viscosity of air (linear approc to -! temp dependence at sea level) -! GZ0OZT and GZ0OZQ are based off formulas from Brutsaert (1975), which -! Garratt (1992) used with values of k = 0.40, Pr = 0.71, and Sc = 0.60 - visc=(1.32+0.009*(scr3(i)-273.15))*1.e-5 -! visc=1.5e-5 - restar=ust(i)*znt(i)/visc - gz0ozt=0.40*(7.3*sqrt(sqrt(restar))*sqrt(0.71)-5.) -! -! ... paj: compute psih for z0t for temperature ... -! - z0t=znt(i)/exp(gz0ozt) -! - zolzz=zol(i)*(za(i)+z0t)/za(i) ! (z+z0t)/L - zol10=zol(i)*(10.+z0t)/za(i) ! (10+z0t)/L - zol2=zol(i)*(2.+z0t)/za(i) ! (2+z0t)/L - zol0=zol(i)*z0t/za(i) ! z0t/L -! - if(zol(i).gt.0.) then - psih(i)=psih_stable(zolzz)-psih_stable(zol0) - psih10(i)=psih_stable(zol10)-psih_stable(zol0) - psih2(i)=psih_stable(zol2)-psih_stable(zol0) - else - if(zol(i).eq.0) then - psih(i)=0. - psih10(i)=0. - psih2(i)=0. - else - psih(i)=psih_unstable(zolzz)-psih_unstable(zol0) - psih10(i)=psih_unstable(zol10)-psih_unstable(zol0) - psih2(i)=psih_unstable(zol2)-psih_unstable(zol0) - endif - endif -! -! psit=gz1oz0(i)-psih(i)+restar2 -! psit2=gz2oz0(i)-psih2(i)+restar2 - psit=alog((za(i)+z0t)/z0t)-psih(i) - psit2=alog((2.+z0t)/z0t)-psih2(i) -! - gz0ozq=0.40*(7.3*sqrt(sqrt(restar))*sqrt(0.60)-5.) - z0q=znt(i)/exp(gz0ozq) -! - zolzz=zol(i)*(za(i)+z0q)/za(i) ! (z+z0q)/L - zol10=zol(i)*(10.+z0q)/za(i) ! (10+z0q)/L - zol2=zol(i)*(2.+z0q)/za(i) ! (2+z0q)/L - zol0=zol(i)*z0q/za(i) ! z0q/L -! - if(zol(i).gt.0.) then - psih(i)=psih_stable(zolzz)-psih_stable(zol0) - psih10(i)=psih_stable(zol10)-psih_stable(zol0) - psih2(i)=psih_stable(zol2)-psih_stable(zol0) - else - if(zol(i).eq.0) then - psih(i)=0. - psih10(i)=0. - psih2(i)=0. - else - psih(i)=psih_unstable(zolzz)-psih_unstable(zol0) - psih10(i)=psih_unstable(zol10)-psih_unstable(zol0) - psih2(i)=psih_unstable(zol2)-psih_unstable(zol0) - endif - endif -! - psiq=alog((za(i)+z0q)/z0q)-psih(i) - psiq2=alog((2.+z0q)/z0q)-psih2(i) - psiq10=alog((10.+z0q)/z0q)-psih10(i) -! psiq=gz1oz0(i)-psih(i)+2.28*sqrt(sqrt(restar))-2. -! psiq2=gz2oz0(i)-psih2(i)+2.28*sqrt(sqrt(restar))-2. -! psiq10=gz10oz0(i)-psih(i)+2.28*sqrt(sqrt(restar))-2. - endif - endif - if(present(ck) .and. present(cd) .and. present(cka) .and. present(cda)) then - ck(i)=(karman/psix10)*(karman/psiq10) - cd(i)=(karman/psix10)*(karman/psix10) - cka(i)=(karman/psix)*(karman/psiq) - cda(i)=(karman/psix)*(karman/psix) - endif - if(present(iz0tlnd)) then - if(iz0tlnd.ge.1 .and. (xland(i)-1.5).le.0.) then - zl=znt(i) -! CZIL RELATED CHANGES FOR LAND - visc=(1.32+0.009*(scr3(i)-273.15))*1.e-5 - restar=ust(i)*zl/visc -! Modify CZIL according to Chen & Zhang, 2009 if iz0tlnd = 1 -! If iz0tlnd = 2, use traditional value - - if(iz0tlnd.eq.1) then - czil = 10.0 ** ( -0.40 * ( zl / 0.07 ) ) - elseif(iz0tlnd.eq.2) then - czil = 0.1 - endif -! -! ... paj: compute phish for z0t over land -! - z0t=znt(i)/exp(czil*karman*sqrt(restar)) -! - zolzz=zol(i)*(za(i)+z0t)/za(i) ! (z+z0t)/L - zol10=zol(i)*(10.+z0t)/za(i) ! (10+z0t)/L - zol2=zol(i)*(2.+z0t)/za(i) ! (2+z0t)/L - zol0=zol(i)*z0t/za(i) ! z0t/L -! - if(zol(i).gt.0.) then - psih(i)=psih_stable(zolzz)-psih_stable(zol0) - psih10(i)=psih_stable(zol10)-psih_stable(zol0) - psih2(i)=psih_stable(zol2)-psih_stable(zol0) - else - if(zol(i).eq.0) then - psih(i)=0. - psih10(i)=0. - psih2(i)=0. - else - psih(i)=psih_unstable(zolzz)-psih_unstable(zol0) - psih10(i)=psih_unstable(zol10)-psih_unstable(zol0) - psih2(i)=psih_unstable(zol2)-psih_unstable(zol0) - endif - endif -! - psiq=alog((za(i)+z0t)/z0t)-psih(i) - psiq2=alog((2.+z0t)/z0t)-psih2(i) - psit=psiq - psit2=psiq2 -! -! psit=gz1oz0(i)-psih(i)+czil*karman*sqrt(restar) -! psiq=gz1oz0(i)-psih(i)+czil*karman*sqrt(restar) -! psit2=gz2oz0(i)-psih2(i)+czil*karman*sqrt(restar) -! psiq2=gz2oz0(i)-psih2(i)+czil*karman*sqrt(restar) - endif - endif -! TO PREVENT OSCILLATIONS AVERAGE WITH OLD VALUE - ust(i)=0.5*ust(i)+0.5*karman*wspd(i)/psix -! TKE coupling: compute ust without vconv for use in tke scheme - wspdi(i)=sqrt(ux(i)*ux(i)+vx(i)*vx(i)) - if(present(ustm)) then - ustm(i)=0.5*ustm(i)+0.5*karman*wspdi(i)/psix - endif - - u10(i)=ux(i)*psix10/psix - v10(i)=vx(i)*psix10/psix - th2(i)=thgb(i)+dtg*psit2/psit - q2(i)=qsfc(i)+(qx(i)-qsfc(i))*psiq2/psiq - t2(i) = th2(i)*(psfcpa(i)/p1000mb)**rovcp -! - if((xland(i)-1.5).lt.0.)then - ust(i)=amax1(ust(i),0.001) - endif - mol(i)=karman*dtg/psit/prt - denomq(i)=psiq - denomq2(i)=psiq2 - denomt2(i)=psit2 - fm(i)=psix - fh(i)=psit - 330 continue -! - 335 continue - -!-----COMPUTE THE SURFACE SENSIBLE AND LATENT HEAT FLUXES: - if(present(scm_force_flux) ) then - if(scm_force_flux) goto 350 - endif - do i = its,ite - qfx(i)=0. - hfx(i)=0. - enddo - 350 continue - - if(.not. isfflx) goto 410 - -!-----OVER WATER, ALTER ROUGHNESS LENGTH (ZNT) ACCORDING TO WIND (UST). - do 360 i = its,ite - if((xland(i)-1.5).ge.0)then -! znt(i)=czo*ust(i)*ust(i)/g+ozo - ! PSH - formulation for depth-dependent roughness from - ! ... Jimenez and Dudhia, 2018 - if(shalwater_z0) then - znt(i) = depth_dependent_z0(water_depth(i),znt(i),ust(i)) - else - !Since V3.7 (ref: EC Physics document for Cy36r1) - znt(i)=czo*ust(i)*ust(i)/g+0.11*1.5e-5/ust(i) - ! v3.9: add limit as in isftcflx = 1,2 - znt(i)=min(znt(i),2.85e-3) - endif -! COARE 3.5 (Edson et al. 2013) -! czc = 0.0017*wspd(i)-0.005 -! czc = min(czc,0.028) -! znt(i)=czc*ust(i)*ust(i)/g+0.11*1.5e-5/ust(i) -! AHW: change roughness length, and hence the drag coefficients Ck and Cd - if(present(isftcflx)) then - if(isftcflx.ne.0) then -! znt(i)=10.*exp(-9.*ust(i)**(-.3333)) -! znt(i)=10.*exp(-9.5*ust(i)**(-.3333)) -! znt(i)=znt(i) + 0.11*1.5e-5/amax1(ust(i),0.01) -! znt(i)=0.011*ust(i)*ust(i)/g+ozo -! znt(i)=max(znt(i),3.50e-5) -! AHW 2012: - zw = min((ust(i)/1.06)**(0.3),1.0) - zn1 = 0.011*ust(i)*ust(i)/g + ozo - zn2 = 10.*exp(-9.5*ust(i)**(-.3333)) + & - 0.11*1.5e-5/amax1(ust(i),0.01) - znt(i)=(1.0-zw) * zn1 + zw * zn2 - znt(i)=min(znt(i),2.85e-3) - znt(i)=max(znt(i),1.27e-7) - endif - endif - zl = znt(i) - else - zl = 0.01 - endif - flqc(i)=rhox(i)*mavail(i)*ust(i)*karman/denomq(i) -! flqc(i)=rhox(i)*mavail(i)*ust(i)*karman/( & -! alog(karman*ust(i)*za(i)/xka+za(i)/zl)-psih(i)) - dtthx=abs(thx(i)-thgb(i)) - if(dtthx.gt.1.e-5)then - flhc(i)=cpm(i)*rhox(i)*ust(i)*mol(i)/(thx(i)-thgb(i)) -! write(*,1001)flhc(i),cpm(i),rhox(i),ust(i),mol(i),thx(i),thgb(i),i - 1001 format(f8.5,2x,f12.7,2x,f12.10,2x,f12.10,2x,f13.10,2x,f12.8,f12.8,2x,i3) - else - flhc(i)=0. - endif - 360 continue - -! -!-----COMPUTE SURFACE MOIST FLUX: -! -!IF(IDRY.EQ.1)GOTO 390 -! - if(present(scm_force_flux)) then - if(scm_force_flux) goto 405 - endif - - do 370 i = its,ite - qfx(i)=flqc(i)*(qsfc(i)-qx(i)) -! qfx(i)=amax1(qfx(i),0.) - lh(i)=xlv*qfx(i) - 370 continue - -!-----COMPUTE SURFACE HEAT FLUX: -! - 390 continue - do 400 i = its,ite - if(xland(i)-1.5.gt.0.)then - hfx(i)=flhc(i)*(thgb(i)-thx(i)) -! if(present(isftcflx)) then -! if(isftcflx.ne.0) then -! AHW: add dissipative heating term (commented out in 3.6.1) -! hfx(i)=hfx(i)+rhox(i)*ustm(i)*ustm(i)*wspdi(i) -! endif -! endif - elseif(xland(i)-1.5.lt.0.)then - hfx(i)=flhc(i)*(thgb(i)-thx(i)) -! hfx(i)=amax1(hfx(i),-250.) - endif - 400 continue - - 405 continue - - do i = its,ite - if((xland(i)-1.5).ge.0)then - zl=znt(i) - else - zl=0.01 - endif -!v3.1.1 -! chs(i)=ust(i)*karman/(alog(karman*ust(i)*za(i) & -! /xka+za(i)/zl)-psih(i)) - chs(i)=ust(i)*karman/denomq(i) -! gz2oz0(i)=alog(2./znt(i)) -! psim2(i)=-10.*gz2oz0(i) -! psim2(i)=amax1(psim2(i),-10.) -! psih2(i)=psim2(i) -! v3.1.1 -! cqs2(i)=ust(i)*karman/(alog(karman*ust(i)*2.0 & -! /xka+2.0/zl)-psih2(i)) -! chs2(i)=ust(i)*karman/(gz2oz0(i)-psih2(i)) - cqs2(i)=ust(i)*karman/denomq2(i) - chs2(i)=ust(i)*karman/denomt2(i) - enddo - - 410 continue - -!jdf -! do i = its,ite -! if(ust(i).ge.0.1) then -! rmol(i)=rmol(i)*(-flhc(i))/(ust(i)*ust(i)*ust(i)) -! else -! rmol(i)=rmol(i)*(-flhc(i))/(0.1*0.1*0.1) -! endif -! enddo -!jdf - - errmsg = 'sf_sfclayrev_run OK' - errflg = 0 - - end subroutine sf_sfclayrev_run - -!================================================================================================================= - real(kind=kind_phys) function zolri(ri,z,z0) - real(kind=kind_phys),intent(in):: ri,z,z0 - - integer:: iter - real(kind=kind_phys):: fx1,fx2,x1,x2 - - - if(ri.lt.0.)then - x1=-5. - x2=0. - else - x1=0. - x2=5. - endif - - fx1=zolri2(x1,ri,z,z0) - fx2=zolri2(x2,ri,z,z0) - iter = 0 - do while (abs(x1 - x2) > 0.01) - if (iter .eq. 10) return -!check added for potential divide by zero (2019/11) - if(fx1.eq.fx2)return - if(abs(fx2).lt.abs(fx1))then - x1=x1-fx1/(fx2-fx1)*(x2-x1) - fx1=zolri2(x1,ri,z,z0) - zolri=x1 - else - x2=x2-fx2/(fx2-fx1)*(x2-x1) - fx2=zolri2(x2,ri,z,z0) - zolri=x2 - endif - iter = iter + 1 - enddo - - return - end function zolri - -!================================================================================================================= - real(kind=kind_phys) function zolri2(zol2,ri2,z,z0) - real(kind=kind_phys),intent(in):: ri2,z,z0 - real(kind=kind_phys),intent(inout):: zol2 - real(kind=kind_phys):: psih2,psix2,zol20,zol3 - - if(zol2*ri2 .lt. 0.)zol2=0. ! limit zol2 - must be same sign as ri2 - - zol20=zol2*z0/z ! z0/L - zol3=zol2+zol20 ! (z+z0)/L - - if(ri2.lt.0) then - psix2=log((z+z0)/z0)-(psim_unstable(zol3)-psim_unstable(zol20)) - psih2=log((z+z0)/z0)-(psih_unstable(zol3)-psih_unstable(zol20)) - else - psix2=log((z+z0)/z0)-(psim_stable(zol3)-psim_stable(zol20)) - psih2=log((z+z0)/z0)-(psih_stable(zol3)-psih_stable(zol20)) - endif - - zolri2=zol2*psih2/psix2**2-ri2 - - return - end function zolri2 - -!================================================================================================================= -! -! ... integrated similarity functions ... -! - real(kind=kind_phys) function psim_stable_full(zolf) - real(kind=kind_phys),intent(in):: zolf - psim_stable_full=-6.1*log(zolf+(1+zolf**2.5)**(1./2.5)) - - return - end function psim_stable_full - -!================================================================================================================= - real(kind=kind_phys) function psih_stable_full(zolf) - real(kind=kind_phys),intent(in):: zolf - psih_stable_full=-5.3*log(zolf+(1+zolf**1.1)**(1./1.1)) - - return - end function psih_stable_full - -!================================================================================================================= - real(kind=kind_phys) function psim_unstable_full(zolf) - real(kind=kind_phys),intent(in):: zolf - real(kind=kind_phys):: psimc,psimk,x,y,ym - x=(1.-16.*zolf)**.25 - psimk=2*ALOG(0.5*(1+X))+ALOG(0.5*(1+X*X))-2.*ATAN(X)+2.*ATAN(1.) - - ym=(1.-10.*zolf)**0.33 - psimc=(3./2.)*log((ym**2.+ym+1.)/3.)-sqrt(3.)*ATAN((2.*ym+1)/sqrt(3.))+4.*ATAN(1.)/sqrt(3.) - - psim_unstable_full=(psimk+zolf**2*(psimc))/(1+zolf**2.) - - return - end function psim_unstable_full - -!================================================================================================================= - real(kind=kind_phys) function psih_unstable_full(zolf) - real(kind=kind_phys),intent(in):: zolf - real(kind=kind_phys):: psihc,psihk,y,yh - y=(1.-16.*zolf)**.5 - psihk=2.*log((1+y)/2.) - - yh=(1.-34.*zolf)**0.33 - psihc=(3./2.)*log((yh**2.+yh+1.)/3.)-sqrt(3.)*ATAN((2.*yh+1)/sqrt(3.))+4.*ATAN(1.)/sqrt(3.) - - psih_unstable_full=(psihk+zolf**2*(psihc))/(1+zolf**2.) - - return - end function psih_unstable_full - -!================================================================================================================= -! ... look-up table functions ... - real(kind=kind_phys) function psim_stable(zolf) - real(kind=kind_phys),intent(in):: zolf - integer:: nzol - real(kind=kind_phys):: rzol - nzol = int(zolf*100.) - rzol = zolf*100. - nzol - if(nzol+1 .lt. 1000)then - psim_stable = psim_stab(nzol) + rzol*(psim_stab(nzol+1)-psim_stab(nzol)) - else - psim_stable = psim_stable_full(zolf) - endif - - return - end function psim_stable - -!================================================================================================================= - real(kind=kind_phys) function psih_stable(zolf) - real(kind=kind_phys),intent(in):: zolf - integer:: nzol - real(kind=kind_phys):: rzol - nzol = int(zolf*100.) - rzol = zolf*100. - nzol - if(nzol+1 .lt. 1000)then - psih_stable = psih_stab(nzol) + rzol*(psih_stab(nzol+1)-psih_stab(nzol)) - else - psih_stable = psih_stable_full(zolf) - endif - - return - end function psih_stable - -!================================================================================================================= - real(kind=kind_phys) function psim_unstable(zolf) - real(kind=kind_phys),intent(in):: zolf - integer:: nzol - real(kind=kind_phys):: rzol - nzol = int(-zolf*100.) - rzol = -zolf*100. - nzol - if(nzol+1 .lt. 1000)then - psim_unstable = psim_unstab(nzol) + rzol*(psim_unstab(nzol+1)-psim_unstab(nzol)) - else - psim_unstable = psim_unstable_full(zolf) - endif - - return - end function psim_unstable - -!================================================================================================================= - real(kind=kind_phys) function psih_unstable(zolf) - real(kind=kind_phys),intent(in):: zolf - integer:: nzol - real(kind=kind_phys):: rzol - nzol = int(-zolf*100.) - rzol = -zolf*100. - nzol - if(nzol+1 .lt. 1000)then - psih_unstable = psih_unstab(nzol) + rzol*(psih_unstab(nzol+1)-psih_unstab(nzol)) - else - psih_unstable = psih_unstable_full(zolf) - endif - - return - end function psih_unstable - -!================================================================================================================= - real(kind=kind_phys) function depth_dependent_z0(water_depth,z0,ust) - real(kind=kind_phys),intent(in):: water_depth,z0,ust - real(kind=kind_phys):: depth_b - real(kind=kind_phys):: effective_depth - if(water_depth .lt. 10.0) then - effective_depth = 10.0 - elseif(water_depth .gt. 100.0) then - effective_depth = 100.0 - else - effective_depth = water_depth - endif - - depth_b = 1 / 30.0 * log (1260.0 / effective_depth) - depth_dependent_z0 = exp((2.7 * ust - 1.8 / depth_b) / (ust + 0.17 / depth_b) ) - depth_dependent_z0 = MIN(depth_dependent_z0,0.1) - - return - end function depth_dependent_z0 - -!================================================================================================================= - end module sf_sfclayrev -!================================================================================================================= diff --git a/run/README.namelist b/run/README.namelist index 4f1d31f71b..bc6197ac07 100644 --- a/run/README.namelist +++ b/run/README.namelist @@ -92,7 +92,7 @@ Other output options: Note all auxhist[1-24], auxinput[2-24] interval variables than the history file requires Registry.EM file change auxhist9_interval (max_dom) = 10, ! interval in minutes io_form_auxhist9 = 2, ! output in netCDF - frames_per_auxhist9 = 1000, ! number of output times in this file + frames_per_auxhist9 (max_dom) = 1000, ! number of output times in this file For SST updating (used only with sst_update=1): @@ -108,7 +108,7 @@ For additional regional climate surface fields auxhist3_outname = 'wrfxtrm_d_' ! file name for added diagnostics io_form_auxhist3 = 2 ! netcdf auxhist3_interval (max_dom) = 1440 ! minutes between outputs (1440 gives daily max/min) - frames_per_auxhist3 = 1 ! output times per file + frames_per_auxhist3 (max_dom) = 1 ! output times per file Note: do restart only at multiple of auxhist3_intervals For observation nudging: @@ -255,10 +255,10 @@ Namelist variables specifically for the WPS input for real: = 2: it uses an alternative way (less biased when compared against input data) to compute height in program real and pressure in model. - wif_input_opt = 0 ! = 1: option to process the Water Ice Friendly Aerosol input from metgrid for use with mp_physics=28 - = 2: since V4.4, option to use black carbon aerosol category with mp_physics=28, as well as its radiative effect. Must include + wif_input_opt = 0 ! = 1: option to process the Water Ice Friendly Aerosol input from metgrid for use with mp_physics=28,29 + = 2: since V4.4, option to use black carbon aerosol category with mp_physics=28,29, as well as its radiative effect. Must include file QNWFA_QNIFA_QNBCA_SIGMA_MONTHLY.dat during WPS - num_wif_levels = 30 ! number of levels in the Thompson Water Ice Friendly aerosols (mp_physic=28) + num_wif_levels = 30 ! number of levels in the Thompson Water Ice Friendly aerosols (mp_physic=28,29) p_top_requested = 5000 ! p_top (Pa) to use in the model vert_refine_fact = 1 ! vertical refinement factor for ndown, not used for concurrent vertical grid refinement vert_refine_method (max_dom) = 0 ! vertical refinement method @@ -405,20 +405,23 @@ Namelist variables for controlling the adaptive time step option: use_adaptive_time_step = .false. ! T/F use adaptive time stepping. step_to_output_time = .true. ! if adaptive time stepping, T/F modify the time steps so that the exact history time is reached - target_cfl(max_dom) = 1.2,1.2 ! vertical and horizontal CFL <= to this value implies - no reason to reduce the time step, and to increase it - target_hcfl(max_dom) = .84,.84 ! horizontal CFL <= to this value implies - max_step_increase_pct(max_dom) = 5,51 ! percentage of previous time step to increase, if the + target_cfl(max_dom) = 1.2,1.2 ! if vertical CFL is <= to this value, it means there + is no reason to reduce the time step, and therefore + time step is increased + target_hcfl(max_dom) = .84,.84 ! if horizontal CFL <= to this value, it suggests no + need to reduce time step, and therefore time step + is increased + max_step_increase_pct(max_dom) = 5,51 ! increase percentage for the previous time step, if the max(vert cfl, horiz cfl) <= target_cfl, then the time - will increase by max_step_increase_pct. Use something - large for nests (51% suggested) - starting_time_step(max_dom) = -1,-1 ! flag = -1 implies use 4*dx (defined in start_em), + will increase by this percentage; use something + much larger for nests (51% suggested, i.e., = 5, 51, 51) + starting_time_step(max_dom) = -1,-1 ! flag = -1 sets time step to 4*dx (defined in start_em), starting_time_step = 100 means the starting time step for the coarse grid is 100 s - max_time_step(max_dom) = -1,-1 ! flag = -1 implies max time step is 8*dx, + max_time_step(max_dom) = -1,-1 ! flag = -1 sets the max time step to 8*dx, max_time_step = 100 means that the time step will not exceed 100 s - min_time_step(max_dom) = -1,-1 ! flag = -1 implies max time step is 3*dx, + min_time_step(max_dom) = -1,-1 ! flag = -1 sets max time step to 3*dx, min_time_step = 100 means that the time step will not be less than 100 s adaptation_domain = 1 ! default, all fine grid domains adaptive dt driven by coarse-grid @@ -494,19 +497,22 @@ Namelist variables for controlling the adaptive time step option: = 17, 19, 21, 22: Legacy NSSL-MP options: see README.NSSLmp for equivalent settings with 18 = 24, WSM 7-class scheme (separate hail and graupel categories) = 26, WDM 7-class scheme (separate hail and graupel categories) + = 27, UDM 7-class scheme, double moments in qnc and qnr plus qnn = 28, aerosol-aware Thompson scheme with water- and ice-friendly aerosol climatology This option has two climatological aerosol input options: use_aero_icbc = .F. : use constant values use_aero_icbc = .T. : use climatological aerosol input from WPS - use_rap_aero_icbc = .false. ! Set to .true. to ingest real-time data containing aerosols (new in 4.4) +use_rap_aero_icbc = .false. ! Set to .true. to ingest real-time data containing aerosols (new in 4.4) qna_update = 0 ! set to 1 to update time-varying sfc aerosol emission from climatology or real-time data - with mp_physics = 28. Use with input file ‘wrfqnainp_d0*’ + with mp_physics = 28,29. Use with input file ‘wrfqnainp_d0*’ (must set auxinput17_interval and io_form_auxinput17; new in 4.4) wif_fire_emit = .false. ! set to .true. to include biomass burning organic and black carbon - aerosols with mp_physics = 28 (new in 4.4) + aerosols with mp_physics = 28,29 (new in 4.4) wif_fire_inj = 1 ! (default) vertically distribute biomass burning emissions - in mp_physics = 28 (new in 4.4) + in mp_physics = 28,29 (new in 4.4) + = 29, RCON scheme, Thompson aerosol-aware with liquid-phase and cloud water modifications. + This option supports the thompson aerosol options above. = 30, HUJI (Hebrew University of Jerusalem, Israel) spectral bin microphysics, fast version = 32, HUJI spectral bin microphysics, full version @@ -567,8 +573,8 @@ Namelist variables for controlling the adaptive time step option: 0: do not use; 1: use effective radii (The mp schemes that compute effective radii are 3,4,6,7,8,10,14,16,18,24,26,28,50-53,55) - force_read_thompson = .false. ! whether to read tables for mp_physics = 8,28 - write_thompson_tables = .true. ! whether to read or compute tables for mp_phyiscs = 8,28 + force_read_thompson = .false. ! whether to read tables for mp_physics = 8,28,29 + write_thompson_tables = .true. ! whether to read or compute tables for mp_phyiscs = 8,28,29 write_thompson_mp38table = .false. ! whether to read table (qr_acr_qg_mp38V1.dat) for mp_physics = 38 ra_lw_physics (max_dom) longwave radiation option @@ -941,6 +947,7 @@ Namelist variables for controlling the adaptive time step option: = 10: CLM4 landsurface model = 2: Pleim-Xu landsurface model = 3: SSiB landsurface model + default_soiltype = 8, ! soil category applied in land cells where no soil category is defined, default is 8 = silty clay loam num_land_cat = 21, ! number of land categories in input data. 24 - for USGS (default); 20 for MODIS 28 - for USGS if including lake category @@ -993,7 +1000,7 @@ Namelist variables for controlling the adaptive time step option: rdmaxalb = .true. ! use snow albedo from geogrid; false means using values from table rdlai2d = .false. ! use LAI from input; false means using values from table if sst_update=1, LAI will also be in wrflowinp file - dust_emis = 0 ! Enable (0=no, 1=yes) surface dust emission scheme to enter mp_physics=28 QNIFA (ice-friendly aerosol variable) + dust_emis = 0 ! Enable (0=no, 1=yes) surface dust emission scheme to enter mp_physics=28,29 QNIFA (ice-friendly aerosol variable) erosion_dim = 3 ! In conjunction with dust_emis=1, this value can only be set equal to 3 (erodibility information) bucket_mm = -1. ! bucket reset value for water accumulations (value in mm, -1.=inactive) bucket_J = -1. ! bucket reset value for energy accumulations (value in J, -1.=inactive) @@ -1829,7 +1836,7 @@ data. To introduce new data sets, mods are required in the Registry and in module_initialize_real.F. There is a space-holder/practice set-up for "GCA". The actual data set for Thompson mp=28 (WIF) that utilizes QNWFA and QNIFA (water and ice friendly aerosols) has -been tested. +been tested. Also compatible with mp=29 (RCON scheme). &domains num_wif_levels = 30 diff --git a/share/landread.c b/share/landread.c index 935d143b41..17d79842d3 100644 --- a/share/landread.c +++ b/share/landread.c @@ -640,6 +640,7 @@ int GET_LANDUSE ( float *adx, } } tsCloseTileSet(); + return 0; } int GET_TERRAIN ( float *adx, diff --git a/share/mediation_integrate.F b/share/mediation_integrate.F index fb12f2eaed..cf0981e7a5 100644 --- a/share/mediation_integrate.F +++ b/share/mediation_integrate.F @@ -110,6 +110,13 @@ SUBROUTINE med_before_solve_io ( grid , config_flags ) ! output history at beginning of restart even if alarm is not ringing CALL med_hist_out ( grid , HISTORY_ALARM, config_flags ) CALL WRFU_AlarmRingerOff( grid%alarms( HISTORY_ALARM ), rc=rc ) +!---------------------------------------------------------------------- +! Write history for other streams at restart - James Ruppert - October 2024 +!---------------------------------------------------------------------- + DO ialarm = first_auxhist, last_auxhist + ! output history at beginning of restart + CALL med_hist_out ( grid , ialarm, config_flags ) + ENDDO ENDIF IF( WRFU_AlarmIsRinging( grid%alarms( INPUTOUT_ALARM ), rc=rc ) ) THEN diff --git a/share/module_check_a_mundo.F b/share/module_check_a_mundo.F index 8ad4e88a6d..551d4e9132 100644 --- a/share/module_check_a_mundo.F +++ b/share/module_check_a_mundo.F @@ -486,6 +486,19 @@ END FUNCTION bep_bem_ngr_u END IF ENDDO +!----------------------------------------------------------------------- +! Check that default_soiltype is between 1 and 19 and is not water (14) +!----------------------------------------------------------------------- + IF ((model_config_rec % default_soiltype .LT. 1) & + .OR. (model_config_rec % default_soiltype .GT. 19) & + .OR. (model_config_rec % default_soiltype .EQ. 14)) THEN + WRITE (wrf_err_message, FMT='(A,I4,A)') '--- ERROR: invalid default_soiltype category (', model_config_rec % default_soiltype, ')' + CALL wrf_message ( wrf_err_message ) + WRITE (wrf_err_message, FMT='(A)') '--- ERROR: resetting default_soiltype to 8 (silty clay loam)' + CALL wrf_message ( wrf_err_message ) + model_config_rec % default_soiltype = 8 + END IF + !----------------------------------------------------------------------- ! Check that mosiac option cannot turn on when sf_urban_physics = 2 and 3 !----------------------------------------------------------------------- @@ -671,7 +684,7 @@ END FUNCTION bep_bem_ngr_u !----------------------------------------------------------------------- ! There is a binary file for Goddard radiation. It is single precision. !----------------------------------------------------------------------- -# if ( defined(PROMOTE_FLOAT) || ( RWORDSIZE == DWORDSIZE ) ) +# ifdef DOUBLE_PRECISION god_r8 : DO i = 1, model_config_rec % max_dom IF ( .NOT. model_config_rec % grid_allowed(i) ) CYCLE IF ( ( model_config_rec % ra_lw_physics(i) == goddardlwscheme ) .OR. & @@ -773,7 +786,7 @@ END FUNCTION bep_bem_ngr_u !----------------------------------------------------------------------- ! Check that all values of mp_physics are the same for all domains !----------------------------------------------------------------------- - +! NOTE: This is redundant because frame/module_configure.F has already set all values to the value of mp_physics(max_dom) DO i = 2, model_config_rec % max_dom IF ( .NOT. model_config_rec % grid_allowed(i) ) CYCLE IF ( model_config_rec % mp_physics(i) .NE. & @@ -971,6 +984,8 @@ END FUNCTION bep_bem_ngr_u ( model_config_rec % ra_sw_physics(i) .EQ. RRTMG_SWSCHEME ) .OR. & ( model_config_rec % ra_sw_physics(i) .EQ. RRTMG_SWSCHEME_FAST ) ) ) ) THEN ! This is OK, no way would a negation have been understandable! + ELSE IF ( model_config_rec % ra_sw_physics(i) == 0 ) THEN + model_config_rec%ghg_input=0 ELSE oops = oops + 1 END IF @@ -2456,12 +2471,12 @@ END FUNCTION bep_bem_ngr_u #endif !----------------------------------------------------------------------- -! grav_settling = 1 must be turned off for mp_physics=28. +! grav_settling = 1 must be turned off for mp_physics=28 or mp_physics=29 !----------------------------------------------------------------------- oops = 0 DO i = 1, model_config_rec % max_dom IF ( .NOT. model_config_rec % grid_allowed(i) ) CYCLE - IF ( model_config_rec%mp_physics(i) .EQ. THOMPSONAERO ) THEN + IF ( model_config_rec%mp_physics(i) .EQ. THOMPSONAERO .OR. model_config_rec%mp_physics(i) .EQ. RCON_MP_SCHEME ) THEN IF ( model_config_rec%grav_settling(i) .NE. FOGSETTLING0 ) THEN model_config_rec%grav_settling(i) = 0 oops = oops + 1 @@ -2474,12 +2489,12 @@ END FUNCTION bep_bem_ngr_u END IF !----------------------------------------------------------------------- -! scalar_pblmix = 1 should be turned on for mp_physics=28. But can be off for MYNN (when bl_mynn_mixscalars = 1) +! scalar_pblmix = 1 should be turned on for mp_physics=28 and mp_physics=29. But can be off for MYNN (when bl_mynn_mixscalars = 1) !----------------------------------------------------------------------- oops = 0 DO i = 1, model_config_rec % max_dom IF ( .NOT. model_config_rec % grid_allowed(i) ) CYCLE - IF ( model_config_rec%mp_physics(i) .EQ. THOMPSONAERO ) THEN + IF ( model_config_rec%mp_physics(i) .EQ. THOMPSONAERO .OR. model_config_rec%mp_physics(i) .EQ. RCON_MP_SCHEME ) THEN IF ( (model_config_rec%use_aero_icbc .OR. model_config_rec%use_rap_aero_icbc) & .AND. model_config_rec%scalar_pblmix(i) .NE. 1 ) THEN model_config_rec%scalar_pblmix(i) = 1 @@ -2511,10 +2526,10 @@ END FUNCTION bep_bem_ngr_u END IF !----------------------------------------------------------------------- -! Set aer_init_opt for Thompson-MP-Aero (mp_physics=28) +! Set aer_init_opt for Thompson-MP-Aero (mp_physics=28) AND rcon mp (mp_physics=29) !----------------------------------------------------------------------- DO i = 1, model_config_rec % max_dom - IF ( model_config_rec%mp_physics(i) .EQ. THOMPSONAERO ) THEN + IF ( model_config_rec%mp_physics(i) .EQ. THOMPSONAERO .OR. model_config_rec%mp_physics(i) .EQ. RCON_MP_SCHEME ) THEN IF ( model_config_rec%use_aero_icbc ) THEN model_config_rec%aer_init_opt = 1 ELSE IF ( model_config_rec%use_rap_aero_icbc ) THEN @@ -2524,10 +2539,10 @@ END FUNCTION bep_bem_ngr_u END DO !----------------------------------------------------------------------- -! Check if qna_update=0 when aer_init_opt>1 for Thompson-MP-Aero (mp_physics=28) +! Check if qna_update=0 when aer_init_opt>1 for Thompson-MP-Aero (mp_physics=28) AND rcon mp (mp_physics=29 !----------------------------------------------------------------------- DO i = 1, model_config_rec % max_dom - IF ( model_config_rec%mp_physics(i) .EQ. THOMPSONAERO ) THEN + IF ( model_config_rec%mp_physics(i) .EQ. THOMPSONAERO .OR. model_config_rec%mp_physics(i) .EQ. RCON_MP_SCHEME ) THEN IF ( model_config_rec%aer_init_opt .GT. 1 .and. model_config_rec%qna_update .EQ. 0 ) THEN wrf_err_message = '--- ERROR: Time-varying sfc aerosol emissions not set for mp_physics=28 ' CALL wrf_debug ( 0, TRIM( wrf_err_message ) ) @@ -2539,10 +2554,10 @@ END FUNCTION bep_bem_ngr_u END DO !----------------------------------------------------------------------- -! Set aer_fire_emit_opt for Thompson-MP-Aero (mp_physics=28) +! Set aer_fire_emit_opt for Thompson-MP-Aero (mp_physics=28) AND rcon mp (mp_physics=29) !----------------------------------------------------------------------- DO i = 1, model_config_rec % max_dom - IF ( model_config_rec%mp_physics(i) .EQ. THOMPSONAERO .AND. model_config_rec%wif_fire_emit) THEN + IF ( (model_config_rec%mp_physics(i) .EQ. THOMPSONAERO .OR. model_config_rec%mp_physics(i) .EQ. RCON_MP_SCHEME) .AND. model_config_rec%wif_fire_emit) THEN IF ( model_config_rec%aer_init_opt .EQ. 2) THEN IF ( model_config_rec%wif_input_opt .EQ. 1 ) THEN model_config_rec%aer_fire_emit_opt = 1 @@ -2564,7 +2579,7 @@ END FUNCTION bep_bem_ngr_u ! is turned on when no PBL scheme is active !----------------------------------------------------------------------- DO i = 1, model_config_rec % max_dom - IF ( model_config_rec%mp_physics(i) .EQ. THOMPSONAERO .AND. model_config_rec%wif_fire_emit) THEN + IF ( (model_config_rec%mp_physics(i) .EQ. THOMPSONAERO .OR. model_config_rec%mp_physics(i) .EQ. RCON_MP_SCHEME) .AND. model_config_rec%wif_fire_emit) THEN IF ( model_config_rec%bl_pbl_physics(i) .EQ. 0 ) THEN wrf_err_message = '--- WARNING: PBL scheme not active but wif_fire_inj=1 for mp_physics=28 ' CALL wrf_debug ( 0, TRIM( wrf_err_message ) ) @@ -3382,38 +3397,39 @@ SUBROUTINE set_physics_rconfigs IF ( model_config_rec % mp_physics(i) .EQ. 22 ) THEN model_config_rec % mp_physics(i) = NSSL_2MOM model_config_rec % nssl_2moment_on = 1 - model_config_rec % nssl_hail_on(i) = 0 - model_config_rec % nssl_ccn_on = 0 + model_config_rec % nssl_hail_on = 0 + model_config_rec % nssl_ccn_on = 1 model_config_rec % nssl_density_on = 1 ! set graupel density WRITE (wrf_err_message, FMT='(A)') ' **CAUTION** mp_physics = 22 has been deprecated. '// & - 'Instead you can use mp_physics=18, nssl_hail_on=0, nssl_ccn_on=0' + 'Instead you can use mp_physics=18, nssl_hail_on=0, nssl_ccn_on=1' CALL wrf_debug ( 0, wrf_err_message ) ELSEIF ( model_config_rec % mp_physics(i) .EQ. 17 ) THEN model_config_rec % mp_physics(i) = NSSL_2MOM model_config_rec % nssl_2moment_on = 1 - model_config_rec % nssl_hail_on(i) = 1 - model_config_rec % nssl_ccn_on = 0 + model_config_rec % nssl_hail_on = 1 + model_config_rec % nssl_ccn_on = 1 model_config_rec % nssl_density_on = 2 ! set graupel+hail density WRITE (wrf_err_message, FMT='(A)') ' **CAUTION** mp_physics = 17 has been deprecated. '// & - 'Instead you can use mp_physics=18, nssl_ccn_on=0' + 'Please use mp_physics=18, Note that nssl_ccn_on=0 is not recommended and default set to 1' ! print statement for deprecated option CALL wrf_debug ( 0, wrf_err_message ) ELSEIF ( model_config_rec % mp_physics(i) .EQ. 19 ) THEN ! single-moment with hail + graupel density model_config_rec % mp_physics(i) = NSSL_2MOM model_config_rec % nssl_2moment_on = 0 - model_config_rec % nssl_hail_on(i) = 2 + model_config_rec % nssl_hail_on = 2 model_config_rec % nssl_density_on = 1 ! set graupel density ! print statement for deprecated option WRITE (wrf_err_message, FMT='(A)') ' **CAUTION** mp_physics = 19 has been deprecated. '// & 'Instead you can use mp_physics=18, nssl_2moment_on=0, nssl_ccn_on=0' CALL wrf_debug ( 0, wrf_err_message ) ELSEIF ( model_config_rec % mp_physics(i) .EQ. 21 ) THEN - ! single-moment without + ! single-moment without graupel volume, no hail model_config_rec % mp_physics(i) = NSSL_2MOM model_config_rec % nssl_2moment_on = 0 - model_config_rec % nssl_hail_on(i) = 0 + model_config_rec % nssl_hail_on = 0 model_config_rec % nssl_density_on = 0 ! set graupel density + model_config_rec % nssl_ccn_on = 0 ! print statement for deprecated option WRITE (wrf_err_message, FMT='(A)') ' **CAUTION** mp_physics = 21 has been deprecated. '// & 'Instead you can use mp_physics=18, nssl_2moment_on=0, nssl_ccn_on=0, nssl_hail_on=0' @@ -3423,7 +3439,7 @@ SUBROUTINE set_physics_rconfigs IF ( model_config_rec % mp_physics(i) /= NSSL_2MOM ) THEN ! If not NSSL-MP, make sure extra fields are turned off (in case of stray namelist settings) model_config_rec % nssl_2moment_on = 0 - model_config_rec % nssl_hail_on(i) = 0 + model_config_rec % nssl_hail_on = 0 model_config_rec % nssl_density_on = 0 ! set graupel density model_config_rec % nssl_3moment = 0 model_config_rec % nssl_ccn_on = 0 @@ -3431,23 +3447,25 @@ SUBROUTINE set_physics_rconfigs ELSE ! make sure settings are consistent IF ( model_config_rec % nssl_ccn_on < 0 ) THEN + ! nssl_ccn_on = -1, so set default model_config_rec % nssl_ccn_on = 1 ENDIF IF ( model_config_rec % nssl_2moment_on < 0 ) THEN ! turn on number concentrations + ! nssl_2moment_on = -1 so set default model_config_rec % nssl_2moment_on = 1 ENDIF - IF ( model_config_rec % nssl_hail_on(i) < 0 ) THEN + IF ( model_config_rec % nssl_hail_on < 0 ) THEN IF ( model_config_rec % nssl_2moment_on == 0 ) THEN - model_config_rec % nssl_hail_on(i) = 2 + model_config_rec % nssl_hail_on = 2 ELSE - model_config_rec % nssl_hail_on(i) = 1 + model_config_rec % nssl_hail_on = 1 ENDIF ENDIF IF ( model_config_rec % nssl_density_on < 0 ) THEN - IF ( model_config_rec % nssl_hail_on(i) == 1 ) THEN + IF ( model_config_rec % nssl_hail_on == 1 ) THEN model_config_rec % nssl_density_on = 2 ! set default of graupel+hail density ELSE model_config_rec % nssl_density_on = 1 ! set graupel density (hail off) @@ -3456,7 +3474,7 @@ SUBROUTINE set_physics_rconfigs IF ( model_config_rec % nssl_3moment == 1 ) THEN model_config_rec % nssl_2moment_on = 1 - IF ( model_config_rec % nssl_hail_on(i) == 1 ) THEN + IF ( model_config_rec % nssl_hail_on == 1 ) THEN model_config_rec % nssl_3moment = 2 ! 3mom rain, graupel and hail ELSE model_config_rec % nssl_3moment = 1 ! 3mom rain and graupel (no hail) diff --git a/share/wrf_timeseries.F b/share/wrf_timeseries.F index cab5a0aa10..53ccb27d1f 100644 --- a/share/wrf_timeseries.F +++ b/share/wrf_timeseries.F @@ -351,17 +351,21 @@ SUBROUTINE calc_ts( grid ) ! FALSE to output T and Q at 2-m and wind at 10-m diagnostic levels: LOGICAL, PARAMETER :: ts_model_level = .FALSE. + IF ( grid%ntsloc_domain .LE. 0 ) THEN + RETURN + END IF + +#if ((EM_CORE == 1) && (DA_CORE != 1)) + IF ( grid%dfi_opt /= DFI_NODFI .AND. grid%dfi_stage /= DFI_FST ) THEN + RETURN + END IF +#endif + !Allocate the arrays for wind components #if ( EM_CORE == 1 ) ALLOCATE ( earth_u_profile(grid%max_ts_level), earth_v_profile(grid%max_ts_level) ) #endif - IF ( grid%ntsloc_domain .LE. 0 ) RETURN - -#if ((EM_CORE == 1) && (DA_CORE != 1)) - IF ( grid%dfi_opt /= DFI_NODFI .AND. grid%dfi_stage /= DFI_FST ) RETURN -#endif - n = grid%next_ts_time ALLOCATE(p8w(grid%sm32:grid%em32)) diff --git a/test/em_real/namelist.input b/test/em_real/namelist.input index 1b209d8602..7014780b27 100644 --- a/test/em_real/namelist.input +++ b/test/em_real/namelist.input @@ -30,8 +30,10 @@ max_dom = 2, e_we = 150, 220, e_sn = 130, 214, - e_vert = 45, 45, - dzstretch_s = 1.1 + e_vert = 48, 48, + dzbot = 30. + dzstretch_s = 1.11 + dzstretch_u = 1.10 p_top_requested = 5000, num_metgrid_levels = 34, num_metgrid_soil_levels = 4, diff --git a/tools/CMakeLists.txt b/tools/CMakeLists.txt index 7f07eb2539..92dd562378 100644 --- a/tools/CMakeLists.txt +++ b/tools/CMakeLists.txt @@ -119,6 +119,9 @@ foreach( n RANGE 0 31 ) ) endforeach() +# Make sure this exists at the top level - I'm avoiding using cache variables deliberately +set( REGISTRY_FILE ${REGISTRY_FILE} PARENT_SCOPE ) + wrf_expand_definitions( RESULT_VAR REGISTRY_DEFS DEFINITIONS ${PROJECT_COMPILE_DEFINITIONS} @@ -165,6 +168,15 @@ add_custom_target( ${allocs_source} ) +set_source_files_properties( + ${CMAKE_BINARY_DIR}/frame/module_state_description.F + ${dealloc_source} + ${allocs_source} + DIRECTORY ${PROJECT_SOURCE_DIR} + PROPERTIES + GENERATED TRUE + ) + target_sources( ${PROJECT_NAME}_Core PRIVATE diff --git a/tools/data.h b/tools/data.h index 081ece8616..c6171e4c22 100644 --- a/tools/data.h +++ b/tools/data.h @@ -103,6 +103,8 @@ EXTERN char sw_commpath[NAMELEN] ; EXTERN int sw_new_bdys ; /* 20070207 JM support decomposed boundary arrays */ EXTERN int sw_unidir_shift_halo ; /* 20100210 JM assume that halo to shift is same in both directions and only gen one of them */ EXTERN int sw_new_with_old_bdys ; /* 20070207 JM for debugging interim phase, new comms w/ old data structs */ +EXTERN int sw_chem ; +EXTERN int sw_kpp ; EXTERN node_t * Type ; EXTERN node_t * Dim ; diff --git a/tools/gen_allocs.c b/tools/gen_allocs.c index 965a1fc04a..0ab8cd5f64 100644 --- a/tools/gen_allocs.c +++ b/tools/gen_allocs.c @@ -231,7 +231,7 @@ gen_alloc1 ( char * dirname ) " tl = tl_in\n" " inter_domain = inter_domain_in\n" " okay_to_alloc = okay_to_alloc_in\n\n" - "#if ( RWORDSIZE == 8 )\n" + "#ifdef DOUBLE_PRECISION\n" " initial_data_value = 0.\n" "#else\n" " CALL get_initial_data_value ( initial_data_value )\n" diff --git a/tools/manage_externals/.gitignore b/tools/manage_externals/.gitignore new file mode 100644 index 0000000000..a71ac0cd75 --- /dev/null +++ b/tools/manage_externals/.gitignore @@ -0,0 +1,17 @@ +# directories that are checked out by the tool +cime/ +cime_config/ +components/ + +# generated local files +*.log + +# editor files +*~ +*.bak + +# generated python files +*.pyc + +# test tmp file +test/tmp diff --git a/tools/manage_externals/LICENSE.txt b/tools/manage_externals/LICENSE.txt new file mode 100644 index 0000000000..665ee03fbc --- /dev/null +++ b/tools/manage_externals/LICENSE.txt @@ -0,0 +1,34 @@ +Copyright (c) 2017-2018, University Corporation for Atmospheric Research (UCAR) +All rights reserved. + +Developed by: + University Corporation for Atmospheric Research - National Center for Atmospheric Research + https://www2.cesm.ucar.edu/working-groups/sewg + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the "Software"), +to deal with the Software without restriction, including without limitation +the rights to use, copy, modify, merge, publish, distribute, sublicense, +and/or sell copies of the Software, and to permit persons to whom +the Software is furnished to do so, subject to the following conditions: + + - Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimers. + - Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimers in the documentation + and/or other materials provided with the distribution. + - Neither the names of [Name of Development Group, UCAR], + nor the names of its contributors may be used to endorse or promote + products derived from this Software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/tools/manage_externals/README.md b/tools/manage_externals/README.md new file mode 100644 index 0000000000..9475301b5d --- /dev/null +++ b/tools/manage_externals/README.md @@ -0,0 +1,231 @@ +-- AUTOMATICALLY GENERATED FILE. DO NOT EDIT -- + +[![Build Status](https://travis-ci.org/ESMCI/manage_externals.svg?branch=master)](https://travis-ci.org/ESMCI/manage_externals)[![Coverage Status](https://coveralls.io/repos/github/ESMCI/manage_externals/badge.svg?branch=master)](https://coveralls.io/github/ESMCI/manage_externals?branch=master) +``` +usage: checkout_externals [-h] [-e [EXTERNALS]] [-o] [-S] [-v] [--backtrace] + [-d] [--no-logging] + +checkout_externals manages checking out groups of externals from revision +control based on a externals description file. By default only the +required externals are checkout out. + +Operations performed by manage_externals utilities are explicit and +data driven. checkout_externals will always make the working copy *exactly* +match what is in the externals file when modifying the working copy of +a repository. + +If checkout_externals isn't doing what you expected, double check the contents +of the externals description file. + +Running checkout_externals without the '--status' option will always attempt to +synchronize the working copy to exactly match the externals description. + +optional arguments: + -h, --help show this help message and exit + -e [EXTERNALS], --externals [EXTERNALS] + The externals description filename. Default: + Externals.cfg. + -o, --optional By default only the required externals are checked + out. This flag will also checkout the optional + externals. + -S, --status Output status of the repositories managed by + checkout_externals. By default only summary + information is provided. Use verbose output to see + details. + -v, --verbose Output additional information to the screen and log + file. This flag can be used up to two times, + increasing the verbosity level each time. + --backtrace DEVELOPER: show exception backtraces as extra + debugging output + -d, --debug DEVELOPER: output additional debugging information to + the screen and log file. + --no-logging DEVELOPER: disable logging. + +``` +NOTE: checkout_externals *MUST* be run from the root of the source tree it +is managing. For example, if you cloned a repository with: + + $ git clone git@github.com/{SOME_ORG}/some-project some-project-dev + +Then the root of the source tree is /path/to/some-project-dev. If you +obtained a sub-project via a checkout of another project: + + $ git clone git@github.com/{SOME_ORG}/some-project some-project-dev + +and you need to checkout the sub-project externals, then the root of the +source tree is /path/to/some-project-dev. Do *NOT* run checkout_externals +from within /path/to/some-project-dev/sub-project + +The root of the source tree will be referred to as `${SRC_ROOT}` below. + +# Supported workflows + + * Checkout all required components from the default externals + description file: + + $ cd ${SRC_ROOT} + $ ./manage_externals/checkout_externals + + * To update all required components to the current values in the + externals description file, re-run checkout_externals: + + $ cd ${SRC_ROOT} + $ ./manage_externals/checkout_externals + + If there are *any* modifications to *any* working copy according + to the git or svn 'status' command, checkout_externals + will not update any external repositories. Modifications + include: modified files, added files, removed files, or missing + files. + + To avoid this safety check, edit the externals description file + and comment out the modified external block. + + * Checkout all required components from a user specified externals + description file: + + $ cd ${SRC_ROOT} + $ ./manage_externals/checkout_externals --externals my-externals.cfg + + * Status summary of the repositories managed by checkout_externals: + + $ cd ${SRC_ROOT} + $ ./manage_externals/checkout_externals --status + + ./cime + s ./components/cism + ./components/mosart + e-o ./components/rtm + M ./src/fates + e-o ./tools/PTCLM + + where: + * column one indicates the status of the repository in relation + to the externals description file. + * column two indicates whether the working copy has modified files. + * column three shows how the repository is managed, optional or required + + Column one will be one of these values: + * s : out-of-sync : repository is checked out at a different commit + compared with the externals description + * e : empty : directory does not exist - checkout_externals has not been run + * ? : unknown : directory exists but .git or .svn directories are missing + + Column two will be one of these values: + * M : Modified : modified, added, deleted or missing files + * : blank / space : clean + * - : dash : no meaningful state, for empty repositories + + Column three will be one of these values: + * o : optional : optionally repository + * : blank / space : required repository + + * Detailed git or svn status of the repositories managed by checkout_externals: + + $ cd ${SRC_ROOT} + $ ./manage_externals/checkout_externals --status --verbose + +# Externals description file + + The externals description contains a list of the external + repositories that are used and their version control locations. The + file format is the standard ini/cfg configuration file format. Each + external is defined by a section containing the component name in + square brackets: + + * name (string) : component name, e.g. [cime], [cism], etc. + + Each section has the following keyword-value pairs: + + * required (boolean) : whether the component is a required checkout, + 'true' or 'false'. + + * local_path (string) : component path *relative* to where + checkout_externals is called. + + * protoctol (string) : version control protocol that is used to + manage the component. Valid values are 'git', 'svn', + 'externals_only'. + + Switching an external between different protocols is not + supported, e.g. from svn to git. To switch protocols, you need to + manually move the old working copy to a new location. + + Note: 'externals_only' will only process the external's own + external description file without trying to manage a repository + for the component. This is used for retreiving externals for + standalone components like cam and clm. If the source root of the + externals_only component is the same as the main source root, then + the local path must be set to '.', the unix current working + directory, e. g. 'local_path = .' + + * repo_url (string) : URL for the repository location, examples: + * https://svn-ccsm-models.cgd.ucar.edu/glc + * git@github.com:esmci/cime.git + * /path/to/local/repository + * . + + NOTE: To operate on only the local clone and and ignore remote + repositories, set the url to '.' (the unix current path), + i.e. 'repo_url = .' . This can be used to checkout a local branch + instead of the upstream branch. + + If a repo url is determined to be a local path (not a network url) + then user expansion, e.g. ~/, and environment variable expansion, + e.g. $HOME or $REPO_ROOT, will be performed. + + Relative paths are difficult to get correct, especially for mixed + use repos. It is advised that local paths expand to absolute paths. + If relative paths are used, they should be relative to one level + above local_path. If local path is 'src/foo', the the relative url + should be relative to 'src'. + + * tag (string) : tag to checkout + + * hash (string) : the git hash to checkout. Only applies to git + repositories. + + * branch (string) : branch to checkout from the specified + repository. Specifying a branch on a remote repository means that + checkout_externals will checkout the version of the branch in the remote, + not the the version in the local repository (if it exists). + + Note: one and only one of tag, branch hash must be supplied. + + * externals (string) : used to make manage_externals aware of + sub-externals required by an external. This is a relative path to + the external's root directory. For example, the main externals + description has an external checkout out at 'src/useful_library'. + useful_library requires additional externals to be complete. + Those additional externals are managed from the source root by the + externals description file pointed 'useful_library/sub-xternals.cfg', + Then the main 'externals' field in the top level repo should point to + 'sub-externals.cfg'. + Note that by default, `checkout_externals` will clone an external's + submodules. As a special case, the entry, `externals = None`, will + prevent this behavior. For more control over which externals are + checked out, create an externals file (and see the `from_submodule` + configuration entry below). + + * from_submodule (True / False) : used to pull the repo_url, local_path, + and hash properties for this external from the .gitmodules file in + this repository. Note that the section name (the entry in square + brackets) must match the name in the .gitmodules file. + If from_submodule is True, the protocol must be git and no repo_url, + local_path, hash, branch, or tag entries are allowed. + Default: False + + * sparse (string) : used to control a sparse checkout. This optional + entry should point to a filename (path relative to local_path) that + contains instructions on which repository paths to include (or + exclude) from the working tree. + See the "SPARSE CHECKOUT" section of https://git-scm.com/docs/git-read-tree + Default: sparse checkout is disabled + + * Lines begining with '#' or ';' are comments and will be ignored. + +# Obtaining this tool, reporting issues, etc. + + The master repository for manage_externals is + https://github.com/ESMCI/manage_externals. Any issues with this tool + should be reported there. diff --git a/tools/manage_externals/README_FIRST b/tools/manage_externals/README_FIRST new file mode 100644 index 0000000000..c8a47d7806 --- /dev/null +++ b/tools/manage_externals/README_FIRST @@ -0,0 +1,54 @@ +CESM is comprised of a number of different components that are +developed and managed independently. Each component may have +additional 'external' dependancies and optional parts that are also +developed and managed independently. + +The checkout_externals.py tool manages retreiving and updating the +components and their externals so you have a complete set of source +files for the model. + +checkout_externals.py relies on a model description file that +describes what components are needed, where to find them and where to +put them in the source tree. The default file is called "CESM.xml" +regardless of whether you are checking out CESM or a standalone +component. + +checkout_externals requires access to git and svn repositories that +require authentication. checkout_externals may pass through +authentication requests, but it will not cache them for you. For the +best and most robust user experience, you should have svn and git +working without password authentication. See: + + https://help.github.com/articles/connecting-to-github-with-ssh/ + + ?svn ref? + +NOTE: checkout_externals.py *MUST* be run from the root of the source +tree it is managing. For example, if you cloned CLM with: + + $ git clone git@github.com/ncar/clm clm-dev + +Then the root of the source tree is /path/to/cesm-dev. If you obtained +CLM via an svn checkout of CESM and you need to checkout the CLM +externals, then the root of the source tree for CLM is: + + /path/to/cesm-dev/components/clm + +The root of the source tree will be referred to as ${SRC_ROOT} below. + +To get started quickly, checkout all required components from the +default model description file: + + $ cd ${SRC_ROOT} + $ ./checkout_cesm/checkout_externals.py + +For additional information about using checkout model, please see: + + ${SRC_ROOT}/checkout_cesm/README + +or run: + + $ cd ${SRC_ROOT} + $ ./checkout_cesm/checkout_externals.py --help + + diff --git a/tools/manage_externals/checkout_externals b/tools/manage_externals/checkout_externals new file mode 100755 index 0000000000..536c64eb65 --- /dev/null +++ b/tools/manage_externals/checkout_externals @@ -0,0 +1,43 @@ +#!/usr/bin/env python3 + +"""Main driver wrapper around the manic/checkout utility. + +Tool to assemble external respositories represented in an externals +description file. + +""" +from __future__ import absolute_import +from __future__ import unicode_literals +from __future__ import print_function + +import sys +import traceback +import os +import manic + +if sys.hexversion < 0x02070000: + print(70 * '*') + print('ERROR: {0} requires python >= 2.7.x. '.format(sys.argv[0])) + print('It appears that you are running python {0}'.format( + '.'.join(str(x) for x in sys.version_info[0:3]))) + print(70 * '*') + sys.exit(1) + + +if __name__ == '__main__': + ARGS = manic.checkout.commandline_arguments() + if ARGS.version: + version_info = '' + version_file_path = os.path.join(os.path.dirname(__file__),'version.txt') + with open(version_file_path) as f: + version_info = f.readlines()[0].strip() + print(version_info) + sys.exit(0) + try: + RET_STATUS, _ = manic.checkout.main(ARGS) + sys.exit(RET_STATUS) + except Exception as error: # pylint: disable=broad-except + manic.printlog(str(error)) + if ARGS.backtrace: + traceback.print_exc() + sys.exit(1) diff --git a/tools/manage_externals/manic/__init__.py b/tools/manage_externals/manic/__init__.py new file mode 100644 index 0000000000..11badedd3b --- /dev/null +++ b/tools/manage_externals/manic/__init__.py @@ -0,0 +1,9 @@ +"""Public API for the manage_externals library +""" + +from manic import checkout +from manic.utils import printlog + +__all__ = [ + 'checkout', 'printlog', +] diff --git a/tools/manage_externals/manic/checkout.py b/tools/manage_externals/manic/checkout.py new file mode 100755 index 0000000000..25c05ea233 --- /dev/null +++ b/tools/manage_externals/manic/checkout.py @@ -0,0 +1,449 @@ +#!/usr/bin/env python3 + +""" +Tool to assemble repositories represented in a model-description file. + +If loaded as a module (e.g., in a component's buildcpp), it can be used +to check the validity of existing subdirectories and load missing sources. +""" +from __future__ import absolute_import +from __future__ import unicode_literals +from __future__ import print_function + +import argparse +import logging +import os +import os.path +import sys + +from manic.externals_description import create_externals_description +from manic.externals_description import read_externals_description_file +from manic.externals_status import check_safe_to_update_repos +from manic.sourcetree import SourceTree +from manic.utils import printlog, fatal_error +from manic.global_constants import VERSION_SEPERATOR, LOG_FILE_NAME + +if sys.hexversion < 0x02070000: + print(70 * '*') + print('ERROR: {0} requires python >= 2.7.x. '.format(sys.argv[0])) + print('It appears that you are running python {0}'.format( + VERSION_SEPERATOR.join(str(x) for x in sys.version_info[0:3]))) + print(70 * '*') + sys.exit(1) + + +# --------------------------------------------------------------------- +# +# User input +# +# --------------------------------------------------------------------- +def commandline_arguments(args=None): + """Process the command line arguments + + Params: args - optional args. Should only be used during systems + testing. + + Returns: processed command line arguments + """ + description = ''' + +%(prog)s manages checking out groups of externals from revision +control based on an externals description file. By default only the +required externals are checkout out. + +Running %(prog)s without the '--status' option will always attempt to +synchronize the working copy to exactly match the externals description. +''' + + epilog = ''' +``` +NOTE: %(prog)s *MUST* be run from the root of the source tree it +is managing. For example, if you cloned a repository with: + + $ git clone git@github.com/{SOME_ORG}/some-project some-project-dev + +Then the root of the source tree is /path/to/some-project-dev. If you +obtained a sub-project via a checkout of another project: + + $ git clone git@github.com/{SOME_ORG}/some-project some-project-dev + +and you need to checkout the sub-project externals, then the root of the +source tree remains /path/to/some-project-dev. Do *NOT* run %(prog)s +from within /path/to/some-project-dev/sub-project + +The root of the source tree will be referred to as `${SRC_ROOT}` below. + + +# Supported workflows + + * Checkout all required components from the default externals + description file: + + $ cd ${SRC_ROOT} + $ ./manage_externals/%(prog)s + + * To update all required components to the current values in the + externals description file, re-run %(prog)s: + + $ cd ${SRC_ROOT} + $ ./manage_externals/%(prog)s + + If there are *any* modifications to *any* working copy according + to the git or svn 'status' command, %(prog)s + will not update any external repositories. Modifications + include: modified files, added files, removed files, or missing + files. + + To avoid this safety check, edit the externals description file + and comment out the modified external block. + + * Checkout all required components from a user specified externals + description file: + + $ cd ${SRC_ROOT} + $ ./manage_externals/%(prog)s --externals my-externals.cfg + + * Status summary of the repositories managed by %(prog)s: + + $ cd ${SRC_ROOT} + $ ./manage_externals/%(prog)s --status + + ./cime + s ./components/cism + ./components/mosart + e-o ./components/rtm + M ./src/fates + e-o ./tools/PTCLM + + + where: + * column one indicates the status of the repository in relation + to the externals description file. + * column two indicates whether the working copy has modified files. + * column three shows how the repository is managed, optional or required + + Column one will be one of these values: + * s : out-of-sync : repository is checked out at a different commit + compared with the externals description + * e : empty : directory does not exist - %(prog)s has not been run + * ? : unknown : directory exists but .git or .svn directories are missing + + Column two will be one of these values: + * M : Modified : modified, added, deleted or missing files + * : blank / space : clean + * - : dash : no meaningful state, for empty repositories + + Column three will be one of these values: + * o : optional : optionally repository + * : blank / space : required repository + + * Detailed git or svn status of the repositories managed by %(prog)s: + + $ cd ${SRC_ROOT} + $ ./manage_externals/%(prog)s --status --verbose + +# Externals description file + + The externals description contains a list of the external + repositories that are used and their version control locations. The + file format is the standard ini/cfg configuration file format. Each + external is defined by a section containing the component name in + square brackets: + + * name (string) : component name, e.g. [cime], [cism], etc. + + Each section has the following keyword-value pairs: + + * required (boolean) : whether the component is a required checkout, + 'true' or 'false'. + + * local_path (string) : component path *relative* to where + %(prog)s is called. + + * protoctol (string) : version control protocol that is used to + manage the component. Valid values are 'git', 'svn', + 'externals_only'. + + Switching an external between different protocols is not + supported, e.g. from svn to git. To switch protocols, you need to + manually move the old working copy to a new location. + + Note: 'externals_only' will only process the external's own + external description file without trying to manage a repository + for the component. This is used for retrieving externals for + standalone components like cam and ctsm which also serve as + sub-components within a larger project. If the source root of the + externals_only component is the same as the main source root, then + the local path must be set to '.', the unix current working + directory, e. g. 'local_path = .' + + * repo_url (string) : URL for the repository location, examples: + * https://svn-ccsm-models.cgd.ucar.edu/glc + * git@github.com:esmci/cime.git + * /path/to/local/repository + * . + + NOTE: To operate on only the local clone and and ignore remote + repositories, set the url to '.' (the unix current path), + i.e. 'repo_url = .' . This can be used to checkout a local branch + instead of the upstream branch. + + If a repo url is determined to be a local path (not a network url) + then user expansion, e.g. ~/, and environment variable expansion, + e.g. $HOME or $REPO_ROOT, will be performed. + + Relative paths are difficult to get correct, especially for mixed + use repos. It is advised that local paths expand to absolute paths. + If relative paths are used, they should be relative to one level + above local_path. If local path is 'src/foo', the the relative url + should be relative to 'src'. + + * tag (string) : tag to checkout + + * hash (string) : the git hash to checkout. Only applies to git + repositories. + + * branch (string) : branch to checkout from the specified + repository. Specifying a branch on a remote repository means that + %(prog)s will checkout the version of the branch in the remote, + not the the version in the local repository (if it exists). + + Note: one and only one of tag, branch hash must be supplied. + + * externals (string) : used to make manage_externals aware of + sub-externals required by an external. This is a relative path to + the external's root directory. For example, if LIBX is often used + as a sub-external, it might have an externals file (for its + externals) called Externals_LIBX.cfg. To use libx as a standalone + checkout, it would have another file, Externals.cfg with the + following entry: + + [ libx ] + local_path = . + protocol = externals_only + externals = Externals_LIBX.cfg + required = True + + Now, %(prog)s will process Externals.cfg and also process + Externals_LIBX.cfg as if it was a sub-external. + + Note that by default, checkout_externals will clone an external's + submodules. As a special case, the entry, "externals = None", will + prevent this behavior. For more control over which externals are + checked out, create an externals file (and see the from_submodule + configuration entry below). + + * from_submodule (True / False) : used to pull the repo_url, local_path, + and hash properties for this external from the .gitmodules file in + this repository. Note that the section name (the entry in square + brackets) must match the name in the .gitmodules file. + If from_submodule is True, the protocol must be git and no repo_url, + local_path, hash, branch, or tag entries are allowed. + Default: False + + * sparse (string) : used to control a sparse checkout. This optional + entry should point to a filename (path relative to local_path) that + contains instructions on which repository paths to include (or + exclude) from the working tree. + See the "SPARSE CHECKOUT" section of https://git-scm.com/docs/git-read-tree + Default: sparse checkout is disabled + + * Lines beginning with '#' or ';' are comments and will be ignored. + +# Obtaining this tool, reporting issues, etc. + + The master repository for manage_externals is + https://github.com/ESMCI/manage_externals. Any issues with this tool + should be reported there. + +# Troubleshooting + +Operations performed by manage_externals utilities are explicit and +data driven. %(prog)s will always attempt to make the working copy +*exactly* match what is in the externals file when modifying the +working copy of a repository. + +If %(prog)s is not doing what you expected, double check the contents +of the externals description file or examine the output of +./manage_externals/%(prog)s --status + +''' + + parser = argparse.ArgumentParser( + description=description, epilog=epilog, + formatter_class=argparse.RawDescriptionHelpFormatter) + + # + # user options + # + parser.add_argument("components", nargs="*", + help="Specific component(s) to checkout. By default, " + "all required externals are checked out.") + + parser.add_argument('-e', '--externals', nargs='?', + default='Externals.cfg', + help='The externals description filename. ' + 'Default: %(default)s.') + + parser.add_argument('-x', '--exclude', nargs='*', + help='Component(s) listed in the externals file which should be ignored.') + + parser.add_argument('-o', '--optional', action='store_true', default=False, + help='By default only the required externals ' + 'are checked out. This flag will also checkout the ' + 'optional externals.') + + parser.add_argument('-S', '--status', action='store_true', default=False, + help='Output the status of the repositories managed by ' + '%(prog)s. By default only summary information ' + 'is provided. Use the verbose option to see details.') + + parser.add_argument('-v', '--verbose', action='count', default=0, + help='Output additional information to ' + 'the screen and log file. This flag can be ' + 'used up to two times, increasing the ' + 'verbosity level each time.') + + parser.add_argument('--version', action='store_true', default=False, + help='Print manage_externals version and exit.') + + parser.add_argument('--svn-ignore-ancestry', action='store_true', default=False, + help='By default, subversion will abort if a component is ' + 'already checked out and there is no common ancestry with ' + 'the new URL. This flag passes the "--ignore-ancestry" flag ' + 'to the svn switch call. (This is not recommended unless ' + 'you are sure about what you are doing.)') + + # + # developer options + # + parser.add_argument('--backtrace', action='store_true', + help='DEVELOPER: show exception backtraces as extra ' + 'debugging output') + + parser.add_argument('-d', '--debug', action='store_true', default=False, + help='DEVELOPER: output additional debugging ' + 'information to the screen and log file.') + + logging_group = parser.add_mutually_exclusive_group() + + logging_group.add_argument('--logging', dest='do_logging', + action='store_true', + help='DEVELOPER: enable logging.') + logging_group.add_argument('--no-logging', dest='do_logging', + action='store_false', default=False, + help='DEVELOPER: disable logging ' + '(this is the default)') + + if args: + options = parser.parse_args(args) + else: + options = parser.parse_args() + return options + +def _dirty_local_repo_msg(program_name, config_file): + return """The external repositories labeled with 'M' above are not in a clean state. +The following are four options for how to proceed: +(1) Go into each external that is not in a clean state and issue either a 'git status' or + an 'svn status' command (depending on whether the external is managed by git or + svn). Either revert or commit your changes so that all externals are in a clean + state. (To revert changes in git, follow the instructions given when you run 'git + status'.) (Note, though, that it is okay to have untracked files in your working + directory.) Then rerun {program_name}. +(2) Alternatively, you do not have to rely on {program_name}. Instead, you can manually + update out-of-sync externals (labeled with 's' above) as described in the + configuration file {config_file}. (For example, run 'git fetch' and 'git checkout' + commands to checkout the appropriate tags for each external, as given in + {config_file}.) +(3) You can also use {program_name} to manage most, but not all externals: You can specify + one or more externals to ignore using the '-x' or '--exclude' argument to + {program_name}. Excluding externals labeled with 'M' will allow {program_name} to + update the other, non-excluded externals. +(4) As a last resort, if you are confident that there is no work that needs to be saved + from a given external, you can remove that external (via "rm -rf [directory]") and + then rerun the {program_name} tool. This option is mainly useful as a workaround for + issues with this tool (such as https://github.com/ESMCI/manage_externals/issues/157). +The external repositories labeled with '?' above are not under version +control using the expected protocol. If you are sure you want to switch +protocols, and you don't have any work you need to save from this +directory, then run "rm -rf [directory]" before rerunning the +{program_name} tool. +""".format(program_name=program_name, config_file=config_file) +# --------------------------------------------------------------------- +# +# main +# +# --------------------------------------------------------------------- +def main(args): + """ + Function to call when module is called from the command line. + Parse externals file and load required repositories or all repositories if + the --all option is passed. + + Returns a tuple (overall_status, tree_status). overall_status is 0 + on success, non-zero on failure. tree_status is a dict mapping local path + to ExternalStatus -- if no checkout is happening. If checkout is happening, tree_status + is None. + """ + if args.do_logging: + logging.basicConfig(filename=LOG_FILE_NAME, + format='%(levelname)s : %(asctime)s : %(message)s', + datefmt='%Y-%m-%d %H:%M:%S', + level=logging.DEBUG) + + program_name = os.path.basename(sys.argv[0]) + logging.info('Beginning of %s', program_name) + + load_all = False + if args.optional: + load_all = True + + root_dir = os.path.abspath(os.getcwd()) + model_data = read_externals_description_file(root_dir, args.externals) + ext_description = create_externals_description( + model_data, components=args.components, exclude=args.exclude) + + for comp in args.components: + if comp not in ext_description.keys(): + # Note we can't print out the list of found externals because + # they were filtered in create_externals_description above. + fatal_error( + "No component {} found in {}".format( + comp, args.externals)) + + source_tree = SourceTree(root_dir, ext_description, svn_ignore_ancestry=args.svn_ignore_ancestry) + if args.components: + components_str = 'specified components' + else: + components_str = 'required & optional components' + printlog('Checking local status of ' + components_str + ': ', end='') + tree_status = source_tree.status(print_progress=True) + printlog('') + + if args.status: + # user requested status-only + for comp in sorted(tree_status): + tree_status[comp].log_status_message(args.verbose) + else: + # checkout / update the external repositories. + safe_to_update = check_safe_to_update_repos(tree_status) + if not safe_to_update: + # print status + for comp in sorted(tree_status): + tree_status[comp].log_status_message(args.verbose) + # exit gracefully + printlog('-' * 70) + printlog(_dirty_local_repo_msg(program_name, args.externals)) + printlog('-' * 70) + else: + if not args.components: + source_tree.checkout(args.verbose, load_all) + for comp in args.components: + source_tree.checkout(args.verbose, load_all, load_comp=comp) + printlog('') + # New tree status is unknown, don't return anything. + tree_status = None + + logging.info('%s completed without exceptions.', program_name) + # NOTE(bja, 2017-11) tree status is used by the systems tests + return 0, tree_status diff --git a/tools/manage_externals/manic/externals_description.py b/tools/manage_externals/manic/externals_description.py new file mode 100644 index 0000000000..546e7fdcb4 --- /dev/null +++ b/tools/manage_externals/manic/externals_description.py @@ -0,0 +1,830 @@ +#!/usr/bin/env python3 + +"""Model description + +Model description is the representation of the various externals +included in the model. It processes in input data structure, and +converts it into a standard interface that is used by the rest of the +system. + +To maintain backward compatibility, externals description files should +follow semantic versioning rules, http://semver.org/ + + + +""" +from __future__ import absolute_import +from __future__ import unicode_literals +from __future__ import print_function + +import logging +import os +import os.path +import re + +# ConfigParser in python2 was renamed to configparser in python3. +# In python2, ConfigParser returns byte strings, str, instead of unicode. +# We need unicode to be compatible with xml and json parser and python3. +try: + # python2 + from ConfigParser import SafeConfigParser as config_parser + from ConfigParser import MissingSectionHeaderError + from ConfigParser import NoSectionError, NoOptionError + + USE_PYTHON2 = True + + def config_string_cleaner(text): + """convert strings into unicode + """ + return text.decode('utf-8') +except ImportError: + # python3 + from configparser import ConfigParser as config_parser + from configparser import MissingSectionHeaderError + from configparser import NoSectionError, NoOptionError + + USE_PYTHON2 = False + + def config_string_cleaner(text): + """Python3 already uses unicode strings, so just return the string + without modification. + + """ + return text + +from .utils import printlog, fatal_error, str_to_bool, expand_local_url +from .utils import execute_subprocess +from .global_constants import EMPTY_STR, PPRINTER, VERSION_SEPERATOR + +# +# Globals +# +DESCRIPTION_SECTION = 'externals_description' +VERSION_ITEM = 'schema_version' + + +def read_externals_description_file(root_dir, file_name): + """Read a file containing an externals description and + create its internal representation. + + """ + root_dir = os.path.abspath(root_dir) + msg = 'In directory : {0}'.format(root_dir) + logging.info(msg) + printlog('Processing externals description file : {0} ({1})'.format(file_name, + root_dir)) + + file_path = os.path.join(root_dir, file_name) + if not os.path.exists(file_name): + if file_name.lower() == "none": + msg = ('INTERNAL ERROR: Attempt to read externals file ' + 'from {0} when not configured'.format(file_path)) + else: + msg = ('ERROR: Model description file, "{0}", does not ' + 'exist at path:\n {1}\nDid you run from the root of ' + 'the source tree?'.format(file_name, file_path)) + + fatal_error(msg) + + externals_description = None + if file_name == ExternalsDescription.GIT_SUBMODULES_FILENAME: + externals_description = _read_gitmodules_file(root_dir, file_name) + else: + try: + config = config_parser() + config.read(file_path) + externals_description = config + except MissingSectionHeaderError: + # not a cfg file + pass + + if externals_description is None: + msg = 'Unknown file format!' + fatal_error(msg) + + return externals_description + +class LstripReader(object): + "LstripReader formats .gitmodules files to be acceptable for configparser" + def __init__(self, filename): + with open(filename, 'r') as infile: + lines = infile.readlines() + self._lines = list() + self._num_lines = len(lines) + self._index = 0 + for line in lines: + self._lines.append(line.lstrip()) + + def readlines(self): + """Return all the lines from this object's file""" + return self._lines + + def readline(self, size=-1): + """Format and return the next line or raise StopIteration""" + try: + line = self.next() + except StopIteration: + line = '' + + if (size > 0) and (len(line) < size): + return line[0:size] + + return line + + def __iter__(self): + """Begin an iteration""" + self._index = 0 + return self + + def next(self): + """Return the next line or raise StopIteration""" + if self._index >= self._num_lines: + raise StopIteration + + self._index = self._index + 1 + return self._lines[self._index - 1] + + def __next__(self): + return self.next() + +def git_submodule_status(repo_dir): + """Run the git submodule status command to obtain submodule hashes. + """ + # This function is here instead of GitRepository to avoid a dependency loop + cmd = 'git -C {repo_dir} submodule status'.format( + repo_dir=repo_dir).split() + git_output = execute_subprocess(cmd, output_to_caller=True) + submodules = {} + submods = git_output.split('\n') + for submod in submods: + if submod: + status = submod[0] + items = submod[1:].split(' ') + if len(items) > 2: + tag = items[2] + else: + tag = None + + submodules[items[1]] = {'hash':items[0], 'status':status, 'tag':tag} + + return submodules + +def parse_submodules_desc_section(section_items, file_path): + """Find the path and url for this submodule description""" + path = None + url = None + for item in section_items: + name = item[0].strip().lower() + if name == 'path': + path = item[1].strip() + elif name == 'url': + url = item[1].strip() + elif name == 'branch': + # We do not care about branch since we have a hash - silently ignore + pass + else: + msg = 'WARNING: Ignoring unknown {} property, in {}' + msg = msg.format(item[0], file_path) # fool pylint + logging.warning(msg) + + return path, url + +def _read_gitmodules_file(root_dir, file_name): + # pylint: disable=deprecated-method + # Disabling this check because the method is only used for python2 + # pylint: disable=too-many-locals + # pylint: disable=too-many-branches + # pylint: disable=too-many-statements + """Read a .gitmodules file and convert it to be compatible with an + externals description. + """ + root_dir = os.path.abspath(root_dir) + msg = 'In directory : {0}'.format(root_dir) + logging.info(msg) + + file_path = os.path.join(root_dir, file_name) + if not os.path.exists(file_name): + msg = ('ERROR: submodules description file, "{0}", does not ' + 'exist in dir:\n {1}'.format(file_name, root_dir)) + fatal_error(msg) + + submodules_description = None + externals_description = None + try: + config = config_parser() + if USE_PYTHON2: + config.readfp(LstripReader(file_path), filename=file_name) + else: + config.read_file(LstripReader(file_path), source=file_name) + + submodules_description = config + except MissingSectionHeaderError: + # not a cfg file + pass + + if submodules_description is None: + msg = 'Unknown file format!' + fatal_error(msg) + else: + # Convert the submodules description to an externals description + externals_description = config_parser() + # We need to grab all the commit hashes for this repo + submods = git_submodule_status(root_dir) + for section in submodules_description.sections(): + if section[0:9] == 'submodule': + sec_name = section[9:].strip(' "') + externals_description.add_section(sec_name) + section_items = submodules_description.items(section) + path, url = parse_submodules_desc_section(section_items, + file_path) + + if path is None: + msg = 'Submodule {} missing path'.format(sec_name) + fatal_error(msg) + + if url is None: + msg = 'Submodule {} missing url'.format(sec_name) + fatal_error(msg) + + externals_description.set(sec_name, + ExternalsDescription.PATH, path) + externals_description.set(sec_name, + ExternalsDescription.PROTOCOL, 'git') + externals_description.set(sec_name, + ExternalsDescription.REPO_URL, url) + externals_description.set(sec_name, + ExternalsDescription.REQUIRED, 'True') + if sec_name in submods: + submod_name = sec_name + else: + # The section name does not have to match the path + submod_name = path + + if submod_name in submods: + git_hash = submods[submod_name]['hash'] + externals_description.set(sec_name, + ExternalsDescription.HASH, + git_hash) + else: + emsg = "submodule status has no section, '{}'" + emsg += "\nCheck section names in externals config file" + fatal_error(emsg.format(submod_name)) + + # Required items + externals_description.add_section(DESCRIPTION_SECTION) + externals_description.set(DESCRIPTION_SECTION, VERSION_ITEM, '1.0.0') + + return externals_description + +def create_externals_description( + model_data, model_format='cfg', components=None, exclude=None, parent_repo=None): + """Create the a externals description object from the provided data + + components: list of component names to include, None to include all. If a + name isn't found, it is silently omitted from the return value. + exclude: list of component names to skip. + """ + externals_description = None + if model_format == 'dict': + externals_description = ExternalsDescriptionDict( + model_data, components=components, exclude=exclude) + elif model_format == 'cfg': + major, _, _ = get_cfg_schema_version(model_data) + if major == 1: + externals_description = ExternalsDescriptionConfigV1( + model_data, components=components, exclude=exclude, parent_repo=parent_repo) + else: + msg = ('Externals description file has unsupported schema ' + 'version "{0}".'.format(major)) + fatal_error(msg) + else: + msg = 'Unknown model data format "{0}"'.format(model_format) + fatal_error(msg) + return externals_description + + +def get_cfg_schema_version(model_cfg): + """Extract the major, minor, patch version of the config file schema + + Params: + model_cfg - config parser object containing the externas description data + + Returns: + major = integer major version + minor = integer minor version + patch = integer patch version + """ + semver_str = '' + try: + semver_str = model_cfg.get(DESCRIPTION_SECTION, VERSION_ITEM) + except (NoSectionError, NoOptionError): + msg = ('externals description file must have the required ' + 'section: "{0}" and item "{1}"'.format(DESCRIPTION_SECTION, + VERSION_ITEM)) + fatal_error(msg) + + # NOTE(bja, 2017-11) Assume we don't care about the + # build/pre-release metadata for now! + version_list = re.split(r'[-+]', semver_str) + version_str = version_list[0] + version = version_str.split(VERSION_SEPERATOR) + try: + major = int(version[0].strip()) + minor = int(version[1].strip()) + patch = int(version[2].strip()) + except ValueError: + msg = ('Config file schema version must have integer digits for ' + 'major, minor and patch versions. ' + 'Received "{0}"'.format(version_str)) + fatal_error(msg) + return major, minor, patch + + +class ExternalsDescription(dict): + """Base externals description class that is independent of the user input + format. Different input formats can all be converted to this + representation to provide a consistent represtentation for the + rest of the objects in the system. + + NOTE(bja, 2018-03): do NOT define _schema_major etc at the class + level in the base class. The nested/recursive nature of externals + means different schema versions may be present in a single run! + + All inheriting classes must overwrite: + self._schema_major and self._input_major + self._schema_minor and self._input_minor + self._schema_patch and self._input_patch + + where _schema_x is the supported schema, _input_x is the user + input value. + + """ + # keywords defining the interface into the externals description data; these + # are brought together by the schema below. + EXTERNALS = 'externals' # path to externals file. + BRANCH = 'branch' + SUBMODULE = 'from_submodule' + HASH = 'hash' + NAME = 'name' + PATH = 'local_path' + PROTOCOL = 'protocol' + REPO = 'repo' + REPO_URL = 'repo_url' + REQUIRED = 'required' + TAG = 'tag' + SPARSE = 'sparse' + + PROTOCOL_EXTERNALS_ONLY = 'externals_only' + PROTOCOL_GIT = 'git' + PROTOCOL_SVN = 'svn' + GIT_SUBMODULES_FILENAME = '.gitmodules' + KNOWN_PRROTOCOLS = [PROTOCOL_GIT, PROTOCOL_SVN, PROTOCOL_EXTERNALS_ONLY] + + # v1 xml keywords + _V1_TREE_PATH = 'TREE_PATH' + _V1_ROOT = 'ROOT' + _V1_TAG = 'TAG' + _V1_BRANCH = 'BRANCH' + _V1_REQ_SOURCE = 'REQ_SOURCE' + + # Dictionary keys are component names. The corresponding values are laid out + # according to this schema. + _source_schema = {REQUIRED: True, + PATH: 'string', + EXTERNALS: 'string', + SUBMODULE : True, + REPO: {PROTOCOL: 'string', + REPO_URL: 'string', + TAG: 'string', + BRANCH: 'string', + HASH: 'string', + SPARSE: 'string', + } + } + + def __init__(self, parent_repo=None): + """Convert the xml into a standardized dict that can be used to + construct the source objects + + """ + dict.__init__(self) + + self._schema_major = None + self._schema_minor = None + self._schema_patch = None + self._input_major = None + self._input_minor = None + self._input_patch = None + self._parent_repo = parent_repo + + def _verify_schema_version(self): + """Use semantic versioning rules to verify we can process this schema. + + """ + known = '{0}.{1}.{2}'.format(self._schema_major, + self._schema_minor, + self._schema_patch) + received = '{0}.{1}.{2}'.format(self._input_major, + self._input_minor, + self._input_patch) + + if self._input_major != self._schema_major: + # should never get here, the factory should handle this correctly! + msg = ('DEV_ERROR: version "{0}" parser received ' + 'version "{1}" input.'.format(known, received)) + fatal_error(msg) + + if self._input_minor > self._schema_minor: + msg = ('Incompatible schema version:\n' + ' User supplied schema version "{0}" is too new."\n' + ' Can only process version "{1}" files and ' + 'older.'.format(received, known)) + fatal_error(msg) + + if self._input_patch > self._schema_patch: + # NOTE(bja, 2018-03) ignoring for now... Not clear what + # conditions the test is needed. + pass + + def _check_user_input(self): + """Run a series of checks to attempt to validate the user input and + detect errors as soon as possible. + + NOTE(bja, 2018-03) These checks are called *after* the file is + read. That means the schema check can not occur here. + + Note: the order is important. check_optional will create + optional with null data. run check_data first to ensure + required data was provided correctly by the user. + + """ + self._check_data() + self._check_optional() + self._validate() + + def _check_data(self): + # pylint: disable=too-many-branches,too-many-statements + """Check user supplied data is valid where possible. + """ + for ext_name in self.keys(): + if (self[ext_name][self.REPO][self.PROTOCOL] + not in self.KNOWN_PRROTOCOLS): + msg = 'Unknown repository protocol "{0}" in "{1}".'.format( + self[ext_name][self.REPO][self.PROTOCOL], ext_name) + fatal_error(msg) + + if (self[ext_name][self.REPO][self.PROTOCOL] == + self.PROTOCOL_SVN): + if self.HASH in self[ext_name][self.REPO]: + msg = ('In repo description for "{0}". svn repositories ' + 'may not include the "hash" keyword.'.format( + ext_name)) + fatal_error(msg) + + if ((self[ext_name][self.REPO][self.PROTOCOL] != self.PROTOCOL_GIT) + and (self.SUBMODULE in self[ext_name])): + msg = ('self.SUBMODULE is only supported with {0} protocol, ' + '"{1}" is defined as an {2} repository') + fatal_error(msg.format(self.PROTOCOL_GIT, ext_name, + self[ext_name][self.REPO][self.PROTOCOL])) + + if (self[ext_name][self.REPO][self.PROTOCOL] != + self.PROTOCOL_EXTERNALS_ONLY): + ref_count = 0 + found_refs = '' + if self.TAG in self[ext_name][self.REPO]: + ref_count += 1 + found_refs = '"{0} = {1}", {2}'.format( + self.TAG, self[ext_name][self.REPO][self.TAG], + found_refs) + if self.BRANCH in self[ext_name][self.REPO]: + ref_count += 1 + found_refs = '"{0} = {1}", {2}'.format( + self.BRANCH, self[ext_name][self.REPO][self.BRANCH], + found_refs) + if self.HASH in self[ext_name][self.REPO]: + ref_count += 1 + found_refs = '"{0} = {1}", {2}'.format( + self.HASH, self[ext_name][self.REPO][self.HASH], + found_refs) + if (self.SUBMODULE in self[ext_name] and + self[ext_name][self.SUBMODULE]): + ref_count += 1 + found_refs = '"{0} = {1}", {2}'.format( + self.SUBMODULE, + self[ext_name][self.SUBMODULE], found_refs) + + if ref_count > 1: + msg = 'Model description is over specified! ' + if self.SUBMODULE in self[ext_name]: + msg += ('from_submodule is not compatible with ' + '"tag", "branch", or "hash" ') + else: + msg += (' Only one of "tag", "branch", or "hash" ' + 'may be specified ') + + msg += 'for repo description of "{0}".'.format(ext_name) + msg = '{0}\nFound: {1}'.format(msg, found_refs) + fatal_error(msg) + elif ref_count < 1: + msg = ('Model description is under specified! One of ' + '"tag", "branch", or "hash" must be specified for ' + 'repo description of "{0}"'.format(ext_name)) + fatal_error(msg) + + if (self.REPO_URL not in self[ext_name][self.REPO] and + (self.SUBMODULE not in self[ext_name] or + not self[ext_name][self.SUBMODULE])): + msg = ('Model description is under specified! Must have ' + '"repo_url" in repo ' + 'description for "{0}"'.format(ext_name)) + fatal_error(msg) + + if (self.SUBMODULE in self[ext_name] and + self[ext_name][self.SUBMODULE]): + if self.REPO_URL in self[ext_name][self.REPO]: + msg = ('Model description is over specified! ' + 'from_submodule keyword is not compatible ' + 'with {0} keyword for'.format(self.REPO_URL)) + msg = '{0} repo description of "{1}"'.format(msg, + ext_name) + fatal_error(msg) + + if self.PATH in self[ext_name]: + msg = ('Model description is over specified! ' + 'from_submodule keyword is not compatible with ' + '{0} keyword for'.format(self.PATH)) + msg = '{0} repo description of "{1}"'.format(msg, + ext_name) + fatal_error(msg) + + if self.REPO_URL in self[ext_name][self.REPO]: + url = expand_local_url( + self[ext_name][self.REPO][self.REPO_URL], ext_name) + self[ext_name][self.REPO][self.REPO_URL] = url + + def _check_optional(self): + # pylint: disable=too-many-branches + """Some fields like externals, repo:tag repo:branch are + (conditionally) optional. We don't want the user to be + required to enter them in every externals description file, but + still want to validate the input. Check conditions and add + default values if appropriate. + + """ + submod_desc = None # Only load submodules info once + for field in self: + # truely optional + if self.EXTERNALS not in self[field]: + self[field][self.EXTERNALS] = EMPTY_STR + + # git and svn repos must tags and branches for validation purposes. + if self.TAG not in self[field][self.REPO]: + self[field][self.REPO][self.TAG] = EMPTY_STR + if self.BRANCH not in self[field][self.REPO]: + self[field][self.REPO][self.BRANCH] = EMPTY_STR + if self.HASH not in self[field][self.REPO]: + self[field][self.REPO][self.HASH] = EMPTY_STR + if self.REPO_URL not in self[field][self.REPO]: + self[field][self.REPO][self.REPO_URL] = EMPTY_STR + if self.SPARSE not in self[field][self.REPO]: + self[field][self.REPO][self.SPARSE] = EMPTY_STR + + # from_submodule has a complex relationship with other fields + if self.SUBMODULE in self[field]: + # User wants to use submodule information, is it available? + if self._parent_repo is None: + # No parent == no submodule information + PPRINTER.pprint(self[field]) + msg = 'No parent submodule for "{0}"'.format(field) + fatal_error(msg) + elif self._parent_repo.protocol() != self.PROTOCOL_GIT: + PPRINTER.pprint(self[field]) + msg = 'Parent protocol, "{0}", does not support submodules' + fatal_error(msg.format(self._parent_repo.protocol())) + else: + args = self._repo_config_from_submodule(field, submod_desc) + repo_url, repo_path, ref_hash, submod_desc = args + + if repo_url is None: + msg = ('Cannot checkout "{0}" as a submodule, ' + 'repo not found in {1} file') + fatal_error(msg.format(field, + self.GIT_SUBMODULES_FILENAME)) + # Fill in submodule fields + self[field][self.REPO][self.REPO_URL] = repo_url + self[field][self.REPO][self.HASH] = ref_hash + self[field][self.PATH] = repo_path + + if self[field][self.SUBMODULE]: + # We should get everything from the parent submodule + # configuration. + pass + # No else (from _submodule = False is the default) + else: + # Add the default value (not using submodule information) + self[field][self.SUBMODULE] = False + + def _repo_config_from_submodule(self, field, submod_desc): + """Find the external config information for a repository from + its submodule configuration information. + """ + if submod_desc is None: + repo_path = os.getcwd() # Is this always correct? + submod_file = self._parent_repo.submodules_file(repo_path=repo_path) + if submod_file is None: + msg = ('Cannot checkout "{0}" from submodule information\n' + ' Parent repo, "{1}" does not have submodules') + fatal_error(msg.format(field, self._parent_repo.name())) + + printlog( + 'Processing submodules description file : {0} ({1})'.format( + submod_file, repo_path)) + submod_model_data= _read_gitmodules_file(repo_path, submod_file) + submod_desc = create_externals_description(submod_model_data) + + # Can we find our external? + repo_url = None + repo_path = None + ref_hash = None + for ext_field in submod_desc: + if field == ext_field: + ext = submod_desc[ext_field] + repo_url = ext[self.REPO][self.REPO_URL] + repo_path = ext[self.PATH] + ref_hash = ext[self.REPO][self.HASH] + break + + return repo_url, repo_path, ref_hash, submod_desc + + def _validate(self): + """Validate that the parsed externals description contains all necessary + fields. + + """ + def print_compare_difference(data_a, data_b, loc_a, loc_b): + """Look through the data structures and print the differences. + + """ + for item in data_a: + if item in data_b: + if not isinstance(data_b[item], type(data_a[item])): + printlog(" {item}: {loc} = {val} ({val_type})".format( + item=item, loc=loc_a, val=data_a[item], + val_type=type(data_a[item]))) + printlog(" {item} {loc} = {val} ({val_type})".format( + item=' ' * len(item), loc=loc_b, val=data_b[item], + val_type=type(data_b[item]))) + else: + printlog(" {item}: {loc} = {val} ({val_type})".format( + item=item, loc=loc_a, val=data_a[item], + val_type=type(data_a[item]))) + printlog(" {item} {loc} missing".format( + item=' ' * len(item), loc=loc_b)) + + def validate_data_struct(schema, data): + """Compare a data structure against a schema and validate all required + fields are present. + + """ + is_valid = False + in_ref = True + valid = True + if isinstance(schema, dict) and isinstance(data, dict): + # Both are dicts, recursively verify that all fields + # in schema are present in the data. + for key in schema: + in_ref = in_ref and (key in data) + if in_ref: + valid = valid and ( + validate_data_struct(schema[key], data[key])) + + is_valid = in_ref and valid + else: + # non-recursive structure. verify data and schema have + # the same type. + is_valid = isinstance(data, type(schema)) + + if not is_valid: + printlog(" Unmatched schema and input:") + if isinstance(schema, dict): + print_compare_difference(schema, data, 'schema', 'input') + print_compare_difference(data, schema, 'input', 'schema') + else: + printlog(" schema = {0} ({1})".format( + schema, type(schema))) + printlog(" input = {0} ({1})".format(data, type(data))) + + return is_valid + + for field in self: + valid = validate_data_struct(self._source_schema, self[field]) + if not valid: + PPRINTER.pprint(self._source_schema) + PPRINTER.pprint(self[field]) + msg = 'ERROR: source for "{0}" did not validate'.format(field) + fatal_error(msg) + + +class ExternalsDescriptionDict(ExternalsDescription): + """Create a externals description object from a dictionary using the API + representations. Primarily used to simplify creating model + description files for unit testing. + + """ + + def __init__(self, model_data, components=None, exclude=None): + """Parse a native dictionary into a externals description. + """ + ExternalsDescription.__init__(self) + self._schema_major = 1 + self._schema_minor = 0 + self._schema_patch = 0 + self._input_major = 1 + self._input_minor = 0 + self._input_patch = 0 + self._verify_schema_version() + if components: + for key in list(model_data.keys()): + if key not in components: + del model_data[key] + + if exclude: + for key in list(model_data.keys()): + if key in exclude: + del model_data[key] + + self.update(model_data) + self._check_user_input() + + +class ExternalsDescriptionConfigV1(ExternalsDescription): + """Create a externals description object from a config_parser object, + schema version 1. + + """ + + def __init__(self, model_data, components=None, exclude=None, parent_repo=None): + """Convert the config data into a standardized dict that can be used to + construct the source objects + + components: list of component names to include, None to include all. + exclude: list of component names to skip. + """ + ExternalsDescription.__init__(self, parent_repo=parent_repo) + self._schema_major = 1 + self._schema_minor = 1 + self._schema_patch = 0 + self._input_major, self._input_minor, self._input_patch = \ + get_cfg_schema_version(model_data) + self._verify_schema_version() + self._remove_metadata(model_data) + self._parse_cfg(model_data, components=components, exclude=exclude) + self._check_user_input() + + @staticmethod + def _remove_metadata(model_data): + """Remove the metadata section from the model configuration file so + that it is simpler to look through the file and construct the + externals description. + + """ + model_data.remove_section(DESCRIPTION_SECTION) + + def _parse_cfg(self, cfg_data, components=None, exclude=None): + """Parse a config_parser object into a externals description. + + components: list of component names to include, None to include all. + exclude: list of component names to skip. + """ + def list_to_dict(input_list, convert_to_lower_case=True): + """Convert a list of key-value pairs into a dictionary. + """ + output_dict = {} + for item in input_list: + key = config_string_cleaner(item[0].strip()) + value = config_string_cleaner(item[1].strip()) + if convert_to_lower_case: + key = key.lower() + output_dict[key] = value + return output_dict + + for section in cfg_data.sections(): + name = config_string_cleaner(section.lower().strip()) + if (components and name not in components) or (exclude and name in exclude): + continue + self[name] = {} + self[name].update(list_to_dict(cfg_data.items(section))) + self[name][self.REPO] = {} + loop_keys = self[name].copy().keys() + for item in loop_keys: + if item in self._source_schema: + if isinstance(self._source_schema[item], bool): + self[name][item] = str_to_bool(self[name][item]) + elif item in self._source_schema[self.REPO]: + self[name][self.REPO][item] = self[name][item] + del self[name][item] + else: + msg = ('Invalid input: "{sect}" contains unknown ' + 'item "{item}".'.format(sect=name, item=item)) + fatal_error(msg) diff --git a/tools/manage_externals/manic/externals_status.py b/tools/manage_externals/manic/externals_status.py new file mode 100644 index 0000000000..6bc29e9732 --- /dev/null +++ b/tools/manage_externals/manic/externals_status.py @@ -0,0 +1,164 @@ +"""ExternalStatus + +Class to store status and state information about repositories and +create a string representation. + +""" +from __future__ import absolute_import +from __future__ import unicode_literals +from __future__ import print_function + +from .global_constants import EMPTY_STR +from .utils import printlog, indent_string +from .global_constants import VERBOSITY_VERBOSE, VERBOSITY_DUMP + + +class ExternalStatus(object): + """Class to represent the status of a given source repository or tree. + + Individual repositories determine their own status in the + Repository objects. This object is just resposible for storing the + information and passing it up to a higher level for reporting or + global decisions. + + There are two states of concern: + + * If the repository is in-sync with the externals description file. + + * If the repostiory working copy is clean and there are no pending + transactions (e.g. add, remove, rename, untracked files). + + """ + # sync_state and clean_state can be one of the following: + DEFAULT = '-' # not set yet (sync_state). clean_state can be this if sync_state is EMPTY. + UNKNOWN = '?' + EMPTY = 'e' + MODEL_MODIFIED = 's' # repo version != externals (sync_state only) + DIRTY = 'M' # repo is dirty (clean_state only) + STATUS_OK = ' ' # repo is clean (clean_state) or matches externals version (sync_state) + STATUS_ERROR = '!' + + # source_type can be one of the following: + OPTIONAL = 'o' + STANDALONE = 's' + MANAGED = ' ' + + def __init__(self): + self.sync_state = self.DEFAULT + self.clean_state = self.DEFAULT + self.source_type = self.DEFAULT + self.path = EMPTY_STR + self.current_version = EMPTY_STR + self.expected_version = EMPTY_STR + self.status_output = EMPTY_STR + + def log_status_message(self, verbosity): + """Write status message to the screen and log file + """ + printlog(self._default_status_message()) + if verbosity >= VERBOSITY_VERBOSE: + printlog(self._verbose_status_message()) + if verbosity >= VERBOSITY_DUMP: + printlog(self._dump_status_message()) + + def __repr__(self): + return self._default_status_message() + + def _default_status_message(self): + """Return the default terse status message string + """ + return '{sync}{clean}{src_type} {path}'.format( + sync=self.sync_state, clean=self.clean_state, + src_type=self.source_type, path=self.path) + + def _verbose_status_message(self): + """Return the verbose status message string + """ + clean_str = self.DEFAULT + if self.clean_state == self.STATUS_OK: + clean_str = 'clean sandbox' + elif self.clean_state == self.DIRTY: + clean_str = 'modified sandbox' + + sync_str = 'on {0}'.format(self.current_version) + if self.sync_state != self.STATUS_OK: + sync_str = '{current} --> {expected}'.format( + current=self.current_version, expected=self.expected_version) + return ' {clean}, {sync}'.format(clean=clean_str, sync=sync_str) + + def _dump_status_message(self): + """Return the dump status message string + """ + return indent_string(self.status_output, 12) + + def safe_to_update(self): + """Report if it is safe to update a repository. Safe is defined as: + + * If a repository is empty, it is safe to update. + + * If a repository exists and has a clean working copy state + with no pending transactions. + + """ + safe_to_update = False + repo_exists = self.exists() + if not repo_exists: + safe_to_update = True + else: + # If the repo exists, it must be in ok or modified + # sync_state. Any other sync_state at this point + # represents a logic error that should have been handled + # before now! + sync_safe = ((self.sync_state == ExternalStatus.STATUS_OK) or + (self.sync_state == ExternalStatus.MODEL_MODIFIED)) + if sync_safe: + # The clean_state must be STATUS_OK to update. Otherwise we + # are dirty or there was a missed error previously. + if self.clean_state == ExternalStatus.STATUS_OK: + safe_to_update = True + return safe_to_update + + def exists(self): + """Determine if the repo exists. This is indicated by: + + * sync_state is not EMPTY + + * if the sync_state is empty, then the valid states for + clean_state are default, empty or unknown. Anything else + and there was probably an internal logic error. + + NOTE(bja, 2017-10) For the moment we are considering a + sync_state of default or unknown to require user intervention, + but we may want to relax this convention. This is probably a + result of a network error or internal logic error but more + testing is needed. + + """ + is_empty = (self.sync_state == ExternalStatus.EMPTY) + clean_valid = ((self.clean_state == ExternalStatus.DEFAULT) or + (self.clean_state == ExternalStatus.EMPTY) or + (self.clean_state == ExternalStatus.UNKNOWN)) + + if is_empty and clean_valid: + exists = False + else: + exists = True + return exists + + +def check_safe_to_update_repos(tree_status): + """Check if *ALL* repositories are in a safe state to update. We don't + want to do a partial update of the repositories then die, leaving + the model in an inconsistent state. + + Note: if there is an update to do, the repositories will by + definiation be out of synce with the externals description, so we + can't use that as criteria for updating. + + """ + safe_to_update = True + for comp in tree_status: + stat = tree_status[comp] + safe_to_update &= stat.safe_to_update() + + return safe_to_update diff --git a/tools/manage_externals/manic/global_constants.py b/tools/manage_externals/manic/global_constants.py new file mode 100644 index 0000000000..0e91cffc90 --- /dev/null +++ b/tools/manage_externals/manic/global_constants.py @@ -0,0 +1,18 @@ +"""Globals shared across modules +""" + +from __future__ import absolute_import +from __future__ import unicode_literals +from __future__ import print_function + +import pprint + +EMPTY_STR = '' +LOCAL_PATH_INDICATOR = '.' +VERSION_SEPERATOR = '.' +LOG_FILE_NAME = 'manage_externals.log' +PPRINTER = pprint.PrettyPrinter(indent=4) + +VERBOSITY_DEFAULT = 0 +VERBOSITY_VERBOSE = 1 +VERBOSITY_DUMP = 2 diff --git a/tools/manage_externals/manic/repository.py b/tools/manage_externals/manic/repository.py new file mode 100644 index 0000000000..ea4230fb7b --- /dev/null +++ b/tools/manage_externals/manic/repository.py @@ -0,0 +1,98 @@ +"""Base class representation of a repository +""" + +from .externals_description import ExternalsDescription +from .utils import fatal_error +from .global_constants import EMPTY_STR + + +class Repository(object): + """ + Class to represent and operate on a repository description. + """ + + def __init__(self, component_name, repo): + """ + Parse repo externals description + """ + self._name = component_name + self._protocol = repo[ExternalsDescription.PROTOCOL] + self._tag = repo[ExternalsDescription.TAG] + self._branch = repo[ExternalsDescription.BRANCH] + self._hash = repo[ExternalsDescription.HASH] + self._url = repo[ExternalsDescription.REPO_URL] + self._sparse = repo[ExternalsDescription.SPARSE] + + if self._url is EMPTY_STR: + fatal_error('repo must have a URL') + + if ((self._tag is EMPTY_STR) and (self._branch is EMPTY_STR) and + (self._hash is EMPTY_STR)): + fatal_error('{0} repo must have a branch, tag or hash element') + + ref_count = 0 + if self._tag is not EMPTY_STR: + ref_count += 1 + if self._branch is not EMPTY_STR: + ref_count += 1 + if self._hash is not EMPTY_STR: + ref_count += 1 + if ref_count != 1: + fatal_error('repo {0} must have exactly one of ' + 'tag, branch or hash.'.format(self._name)) + + def checkout(self, base_dir_path, repo_dir_name, verbosity, recursive): # pylint: disable=unused-argument + """ + If the repo destination directory exists, ensure it is correct (from + correct URL, correct branch or tag), and possibly update the source. + If the repo destination directory does not exist, checkout the correce + branch or tag. + NB: is include as an argument for compatibility with + git functionality (repository_git.py) + """ + msg = ('DEV_ERROR: checkout method must be implemented in all ' + 'repository classes! {0}'.format(self.__class__.__name__)) + fatal_error(msg) + + def status(self, stat, repo_dir_path): # pylint: disable=unused-argument + """Report the status of the repo + + """ + msg = ('DEV_ERROR: status method must be implemented in all ' + 'repository classes! {0}'.format(self.__class__.__name__)) + fatal_error(msg) + + def submodules_file(self, repo_path=None): + # pylint: disable=no-self-use,unused-argument + """Stub for use by non-git VC systems""" + return None + + def url(self): + """Public access of repo url. + """ + return self._url + + def tag(self): + """Public access of repo tag + """ + return self._tag + + def branch(self): + """Public access of repo branch. + """ + return self._branch + + def hash(self): + """Public access of repo hash. + """ + return self._hash + + def name(self): + """Public access of repo name. + """ + return self._name + + def protocol(self): + """Public access of repo protocol. + """ + return self._protocol diff --git a/tools/manage_externals/manic/repository_factory.py b/tools/manage_externals/manic/repository_factory.py new file mode 100644 index 0000000000..18c73ffc4b --- /dev/null +++ b/tools/manage_externals/manic/repository_factory.py @@ -0,0 +1,30 @@ +"""Factory for creating and initializing the appropriate repository class +""" + +from __future__ import absolute_import +from __future__ import unicode_literals +from __future__ import print_function + +from .repository_git import GitRepository +from .repository_svn import SvnRepository +from .externals_description import ExternalsDescription +from .utils import fatal_error + + +def create_repository(component_name, repo_info, svn_ignore_ancestry=False): + """Determine what type of repository we have, i.e. git or svn, and + create the appropriate object. + + Can return None (e.g. if protocol is 'externals_only'). + """ + protocol = repo_info[ExternalsDescription.PROTOCOL].lower() + if protocol == 'git': + repo = GitRepository(component_name, repo_info) + elif protocol == 'svn': + repo = SvnRepository(component_name, repo_info, ignore_ancestry=svn_ignore_ancestry) + elif protocol == 'externals_only': + repo = None + else: + msg = 'Unknown repo protocol "{0}"'.format(protocol) + fatal_error(msg) + return repo diff --git a/tools/manage_externals/manic/repository_git.py b/tools/manage_externals/manic/repository_git.py new file mode 100644 index 0000000000..aab1a468a8 --- /dev/null +++ b/tools/manage_externals/manic/repository_git.py @@ -0,0 +1,859 @@ +"""Class for interacting with git repositories +""" + +from __future__ import absolute_import +from __future__ import unicode_literals +from __future__ import print_function + +import copy +import os +import sys + +from .global_constants import EMPTY_STR, LOCAL_PATH_INDICATOR +from .global_constants import VERBOSITY_VERBOSE +from .repository import Repository +from .externals_status import ExternalStatus +from .externals_description import ExternalsDescription, git_submodule_status +from .utils import expand_local_url, split_remote_url, is_remote_url +from .utils import fatal_error, printlog +from .utils import execute_subprocess + + +class GitRepository(Repository): + """Class to represent and operate on a repository description. + + For testing purpose, all system calls to git should: + + * be isolated in separate functions with no application logic + * of the form: + - cmd = 'git -C {dirname} ...'.format(dirname=dirname).split() + - value = execute_subprocess(cmd, output_to_caller={T|F}, + status_to_caller={T|F}) + - return value + * be static methods (not rely on self) + * name as _git_subcommand_args(user_args) + + This convention allows easy unit testing of the repository logic + by mocking the specific calls to return predefined results. + + """ + + def __init__(self, component_name, repo): + """ + repo: ExternalsDescription. + """ + Repository.__init__(self, component_name, repo) + self._gitmodules = None + self._submods = None + + # ---------------------------------------------------------------- + # + # Public API, defined by Repository + # + # ---------------------------------------------------------------- + def checkout(self, base_dir_path, repo_dir_name, verbosity, recursive): + """ + If the repo destination directory exists, ensure it is correct (from + correct URL, correct branch or tag), and possibly update the source. + If the repo destination directory does not exist, checkout the correct + branch or tag. + """ + repo_dir_path = os.path.join(base_dir_path, repo_dir_name) + repo_dir_exists = os.path.exists(repo_dir_path) + if (repo_dir_exists and not os.listdir( + repo_dir_path)) or not repo_dir_exists: + self._clone_repo(base_dir_path, repo_dir_name, verbosity) + self._checkout_ref(repo_dir_path, verbosity, recursive) + gmpath = os.path.join(repo_dir_path, + ExternalsDescription.GIT_SUBMODULES_FILENAME) + if os.path.exists(gmpath): + self._gitmodules = gmpath + self._submods = git_submodule_status(repo_dir_path) + else: + self._gitmodules = None + self._submods = None + + def status(self, stat, repo_dir_path): + """ + If the repo destination directory exists, ensure it is correct (from + correct URL, correct branch or tag), and possibly update the source. + If the repo destination directory does not exist, checkout the correct + branch or tag. + """ + self._check_sync(stat, repo_dir_path) + if os.path.exists(repo_dir_path): + self._status_summary(stat, repo_dir_path) + + def submodules_file(self, repo_path=None): + if repo_path is not None: + gmpath = os.path.join(repo_path, + ExternalsDescription.GIT_SUBMODULES_FILENAME) + if os.path.exists(gmpath): + self._gitmodules = gmpath + self._submods = git_submodule_status(repo_path) + + return self._gitmodules + + # ---------------------------------------------------------------- + # + # Internal work functions + # + # ---------------------------------------------------------------- + def _clone_repo(self, base_dir_path, repo_dir_name, verbosity): + """Clones repo_dir_name into base_dir_path. + """ + self._git_clone(self._url, os.path.join(base_dir_path, repo_dir_name), + verbosity=verbosity) + + def _current_ref(self, dirname): + """Determine the *name* associated with HEAD at dirname. + + If we're on a tag, then returns the tag name; otherwise, returns + the current hash. Returns an empty string if no reference can be + determined (e.g., if we're not actually in a git repository). + + If we're on a branch, then the branch name is also included in + the returned string (in addition to the tag / hash). + """ + ref_found = False + + # If we're exactly at a tag, use that as the current ref + tag_found, tag_name = self._git_current_tag(dirname) + if tag_found: + current_ref = tag_name + ref_found = True + + if not ref_found: + # Otherwise, use current hash as the current ref + hash_found, hash_name = self._git_current_hash(dirname) + if hash_found: + current_ref = hash_name + ref_found = True + + if ref_found: + # If we're on a branch, include branch name in current ref + branch_found, branch_name = self._git_current_branch(dirname) + if branch_found: + current_ref = "{} (branch {})".format(current_ref, branch_name) + else: + # If we still can't find a ref, return empty string. This + # can happen if we're not actually in a git repo + current_ref = '' + + return current_ref + + def _check_sync(self, stat, repo_dir_path): + """Determine whether a git repository is in-sync with the model + description. + + Because repos can have multiple remotes, the only criteria is + whether the branch or tag is the same. + + """ + if not os.path.exists(repo_dir_path): + # NOTE(bja, 2017-10) condition should have been determined + # by _Source() object and should never be here! + stat.sync_state = ExternalStatus.STATUS_ERROR + else: + git_dir = os.path.join(repo_dir_path, '.git') + if not os.path.exists(git_dir): + # NOTE(bja, 2017-10) directory exists, but no git repo + # info.... Can't test with subprocess git command + # because git will move up directory tree until it + # finds the parent repo git dir! + stat.sync_state = ExternalStatus.UNKNOWN + else: + self._check_sync_logic(stat, repo_dir_path) + + def _check_sync_logic(self, stat, repo_dir_path): + """Compare the underlying hashes of the currently checkout ref and the + expected ref. + + Output: sets the sync_state as well as the current and + expected ref in the input status object. + + """ + def compare_refs(current_ref, expected_ref): + """Compare the current and expected ref. + + """ + if current_ref == expected_ref: + status = ExternalStatus.STATUS_OK + else: + status = ExternalStatus.MODEL_MODIFIED + return status + + # get the full hash of the current commit + _, current_ref = self._git_current_hash(repo_dir_path) + + if self._branch: + if self._url == LOCAL_PATH_INDICATOR: + expected_ref = self._branch + else: + remote_name = self._remote_name_for_url(self._url, + repo_dir_path) + if not remote_name: + # git doesn't know about this remote. by definition + # this is a modified state. + expected_ref = "unknown_remote/{0}".format(self._branch) + else: + expected_ref = "{0}/{1}".format(remote_name, self._branch) + elif self._hash: + expected_ref = self._hash + elif self._tag: + expected_ref = self._tag + else: + msg = 'In repo "{0}": none of branch, hash or tag are set'.format( + self._name) + fatal_error(msg) + + # record the *names* of the current and expected branches + stat.current_version = self._current_ref(repo_dir_path) + stat.expected_version = copy.deepcopy(expected_ref) + + if current_ref == EMPTY_STR: + stat.sync_state = ExternalStatus.UNKNOWN + else: + # get the underlying hash of the expected ref + revparse_status, expected_ref_hash = self._git_revparse_commit( + expected_ref, repo_dir_path) + if revparse_status: + # We failed to get the hash associated with + # expected_ref. Maybe we should assign this to some special + # status, but for now we're just calling this out-of-sync to + # remain consistent with how this worked before. + stat.sync_state = ExternalStatus.MODEL_MODIFIED + else: + # compare the underlying hashes + stat.sync_state = compare_refs(current_ref, expected_ref_hash) + + @classmethod + def _remote_name_for_url(cls, remote_url, dirname): + """Return the remote name matching remote_url (or None) + + """ + git_output = cls._git_remote_verbose(dirname) + git_output = git_output.splitlines() + for line in git_output: + data = line.strip() + if not data: + continue + data = data.split() + name = data[0].strip() + url = data[1].strip() + if remote_url == url: + return name + return None + + def _create_remote_name(self): + """The url specified in the externals description file was not known + to git. We need to add it, which means adding a unique and + safe name.... + + The assigned name needs to be safe for git to use, e.g. can't + look like a path 'foo/bar' and work with both remote and local paths. + + Remote paths include but are not limited to: git, ssh, https, + github, gitlab, bitbucket, custom server, etc. + + Local paths can be relative or absolute. They may contain + shell variables, e.g. ${REPO_ROOT}/repo_name, or username + expansion, i.e. ~/ or ~someuser/. + + Relative paths must be at least one layer of redirection, i.e. + container/../ext_repo, but may be many layers deep, e.g. + container/../../../../../ext_repo + + NOTE(bja, 2017-11) + + The base name below may not be unique, for example if the + user has local paths like: + + /path/to/my/repos/nice_repo + /path/to/other/repos/nice_repo + + But the current implementation should cover most common + use cases for remotes and still provide usable names. + + """ + url = copy.deepcopy(self._url) + if is_remote_url(url): + url = split_remote_url(url) + else: + url = expand_local_url(url, self._name) + url = url.split('/') + repo_name = url[-1] + base_name = url[-2] + # repo name should nominally already be something that git can + # deal with. We need to remove other possibly troublesome + # punctuation, e.g. /, $, from the base name. + unsafe_characters = '!@#$%^&*()[]{}\\/,;~' + for unsafe in unsafe_characters: + base_name = base_name.replace(unsafe, '') + remote_name = "{0}_{1}".format(base_name, repo_name) + return remote_name + + def _checkout_ref(self, repo_dir, verbosity, submodules): + """Checkout the user supplied reference + if is True, recursively initialize and update + the repo's submodules + """ + # import pdb; pdb.set_trace() + if self._url.strip() == LOCAL_PATH_INDICATOR: + self._checkout_local_ref(verbosity, submodules, repo_dir) + else: + self._checkout_external_ref(verbosity, submodules, repo_dir) + + if self._sparse: + self._sparse_checkout(repo_dir, verbosity) + + + def _checkout_local_ref(self, verbosity, submodules, dirname): + """Checkout the reference considering the local repo only. Do not + fetch any additional remotes or specify the remote when + checkout out the ref. + if is True, recursively initialize and update + the repo's submodules + """ + if self._tag: + ref = self._tag + elif self._branch: + ref = self._branch + else: + ref = self._hash + + self._check_for_valid_ref(ref, remote_name=None, + dirname=dirname) + self._git_checkout_ref(ref, verbosity, submodules, dirname) + + def _checkout_external_ref(self, verbosity, submodules, dirname): + """Checkout the reference from a remote repository into dirname. + if is True, recursively initialize and update + the repo's submodules. + Note that this results in a 'detached HEAD' state if checking out + a branch, because we check out the remote branch rather than the + local. See https://github.com/ESMCI/manage_externals/issues/34 for + more discussion. + """ + if self._tag: + ref = self._tag + elif self._branch: + ref = self._branch + else: + ref = self._hash + + remote_name = self._remote_name_for_url(self._url, dirname) + if not remote_name: + remote_name = self._create_remote_name() + self._git_remote_add(remote_name, self._url, dirname) + self._git_fetch(remote_name, dirname) + + # NOTE(bja, 2018-03) we need to send separate ref and remote + # name to check_for_vaild_ref, but the combined name to + # checkout_ref! + self._check_for_valid_ref(ref, remote_name, dirname) + + if self._branch: + # Prepend remote name to branch. This means we avoid various + # special cases if the local branch is not tracking the remote or + # cannot be trivially fast-forwarded to match; but, it also + # means we end up in a 'detached HEAD' state. + ref = '{0}/{1}'.format(remote_name, ref) + self._git_checkout_ref(ref, verbosity, submodules, dirname) + + def _sparse_checkout(self, repo_dir, verbosity): + """Use git read-tree to thin the working tree.""" + cmd = ['cp', os.path.join(repo_dir, self._sparse), + os.path.join(repo_dir, + '.git/info/sparse-checkout')] + if verbosity >= VERBOSITY_VERBOSE: + printlog(' {0}'.format(' '.join(cmd))) + execute_subprocess(cmd) + self._git_sparse_checkout(verbosity, repo_dir) + + def _check_for_valid_ref(self, ref, remote_name, dirname): + """Try some basic sanity checks on the user supplied reference so we + can provide a more useful error message than calledprocess + error... + + remote_name can be NOne + """ + is_tag = self._ref_is_tag(ref, dirname) + is_branch = self._ref_is_branch(ref, remote_name, dirname) + is_hash = self._ref_is_hash(ref, dirname) + is_valid = is_tag or is_branch or is_hash + if not is_valid: + msg = ('In repo "{0}": reference "{1}" does not appear to be a ' + 'valid tag, branch or hash! Please verify the reference ' + 'name (e.g. spelling), is available from: {2} '.format( + self._name, ref, self._url)) + fatal_error(msg) + + if is_tag: + is_unique_tag, msg = self._is_unique_tag(ref, remote_name, + dirname) + if not is_unique_tag: + msg = ('In repo "{0}": tag "{1}" {2}'.format( + self._name, self._tag, msg)) + fatal_error(msg) + + return is_valid + + def _is_unique_tag(self, ref, remote_name, dirname): + """Verify that a reference is a valid tag and is unique (not a branch) + + Tags may be tag names, or SHA id's. It is also possible that a + branch and tag have the some name. + + Note: values returned by git_showref_* and git_revparse are + shell return codes, which are zero for success, non-zero for + error! + + """ + is_tag = self._ref_is_tag(ref, dirname) + is_branch = self._ref_is_branch(ref, remote_name, dirname) + is_hash = self._ref_is_hash(ref, dirname) + + msg = '' + is_unique_tag = False + if is_tag and not is_branch: + # unique tag + msg = 'is ok' + is_unique_tag = True + elif is_tag and is_branch: + msg = ('is both a branch and a tag. git may checkout the branch ' + 'instead of the tag depending on your version of git.') + is_unique_tag = False + elif not is_tag and is_branch: + msg = ('is a branch, and not a tag. If you intended to checkout ' + 'a branch, please change the externals description to be ' + 'a branch. If you intended to checkout a tag, it does not ' + 'exist. Please check the name.') + is_unique_tag = False + else: # not is_tag and not is_branch: + if is_hash: + # probably a sha1 or HEAD, etc, we call it a tag + msg = 'is ok' + is_unique_tag = True + else: + # undetermined state. + msg = ('does not appear to be a valid tag, branch or hash! ' + 'Please check the name and repository.') + is_unique_tag = False + + return is_unique_tag, msg + + def _ref_is_tag(self, ref, dirname): + """Verify that a reference is a valid tag according to git. + + Note: values returned by git_showref_* and git_revparse are + shell return codes, which are zero for success, non-zero for + error! + """ + is_tag = False + value = self._git_showref_tag(ref, dirname) + if value == 0: + is_tag = True + return is_tag + + def _ref_is_branch(self, ref, remote_name, dirname): + """Verify if a ref is any kind of branch (local, tracked remote, + untracked remote). + + remote_name can be None. + """ + local_branch = False + remote_branch = False + if remote_name: + remote_branch = self._ref_is_remote_branch(ref, remote_name, + dirname) + local_branch = self._ref_is_local_branch(ref, dirname) + + is_branch = False + if local_branch or remote_branch: + is_branch = True + return is_branch + + def _ref_is_local_branch(self, ref, dirname): + """Verify that a reference is a valid branch according to git. + + show-ref branch returns local branches that have been + previously checked out. It will not necessarily pick up + untracked remote branches. + + Note: values returned by git_showref_* and git_revparse are + shell return codes, which are zero for success, non-zero for + error! + + """ + is_branch = False + value = self._git_showref_branch(ref, dirname) + if value == 0: + is_branch = True + return is_branch + + def _ref_is_remote_branch(self, ref, remote_name, dirname): + """Verify that a reference is a valid branch according to git. + + show-ref branch returns local branches that have been + previously checked out. It will not necessarily pick up + untracked remote branches. + + Note: values returned by git_showref_* and git_revparse are + shell return codes, which are zero for success, non-zero for + error! + + """ + is_branch = False + value = self._git_lsremote_branch(ref, remote_name, dirname) + if value == 0: + is_branch = True + return is_branch + + def _ref_is_commit(self, ref, dirname): + """Verify that a reference is a valid commit according to git. + + This could be a tag, branch, sha1 id, HEAD and potentially others... + + Note: values returned by git_showref_* and git_revparse are + shell return codes, which are zero for success, non-zero for + error! + """ + is_commit = False + value, _ = self._git_revparse_commit(ref, dirname) + if value == 0: + is_commit = True + return is_commit + + def _ref_is_hash(self, ref, dirname): + """Verify that a reference is a valid hash according to git. + + Git doesn't seem to provide an exact way to determine if user + supplied reference is an actual hash. So we verify that the + ref is a valid commit and return the underlying commit + hash. Then check that the commit hash begins with the user + supplied string. + + Note: values returned by git_showref_* and git_revparse are + shell return codes, which are zero for success, non-zero for + error! + + """ + is_hash = False + status, git_output = self._git_revparse_commit(ref, dirname) + if status == 0: + if git_output.strip().startswith(ref): + is_hash = True + return is_hash + + def _status_summary(self, stat, repo_dir_path): + """Determine the clean/dirty status of a git repository + + """ + git_output = self._git_status_porcelain_v1z(repo_dir_path) + is_dirty = self._status_v1z_is_dirty(git_output) + if is_dirty: + stat.clean_state = ExternalStatus.DIRTY + else: + stat.clean_state = ExternalStatus.STATUS_OK + + # Now save the verbose status output incase the user wants to + # see it. + stat.status_output = self._git_status_verbose(repo_dir_path) + + @staticmethod + def _status_v1z_is_dirty(git_output): + """Parse the git status output from --porcelain=v1 -z and determine if + the repo status is clean or dirty. Dirty means: + + * modified files + * missing files + * added files + * removed + * renamed + * unmerged + + Whether untracked files are considered depends on how the status + command was run (i.e., whether it was run with the '-u' option). + + NOTE: Based on the above definition, the porcelain status + should be an empty string to be considered 'clean'. Of course + this assumes we only get an empty string from an status + command on a clean checkout, and not some error + condition... Could alse use 'git diff --quiet'. + + """ + is_dirty = False + if git_output: + is_dirty = True + return is_dirty + + # ---------------------------------------------------------------- + # + # system call to git for information gathering + # + # ---------------------------------------------------------------- + @staticmethod + def _git_current_hash(dirname): + """Return the full hash of the currently checked-out version. + + Returns a tuple, (hash_found, hash), where hash_found is a + logical specifying whether a hash was found for HEAD (False + could mean we're not in a git repository at all). (If hash_found + is False, then hash is ''.) + """ + status, git_output = GitRepository._git_revparse_commit("HEAD", + dirname) + hash_found = not status + if not hash_found: + git_output = '' + return hash_found, git_output + + @staticmethod + def _git_current_remote_branch(dirname): + """Determines the name of the current remote branch, if any. + + if dir is None, uses the cwd. + + Returns a tuple, (branch_found, branch_name), where branch_found + is a bool specifying whether a branch name was found for + HEAD. (If branch_found is False, then branch_name is ''). + branch_name is in the format '$remote/$branch', e.g. 'origin/foo'. + """ + branch_found = False + branch_name = '' + + cmd = 'git -C {dirname} log -n 1 --pretty=%d HEAD'.format( + dirname=dirname).split() + status, git_output = execute_subprocess(cmd, + output_to_caller=True, + status_to_caller=True) + branch_found = 'HEAD,' in git_output + if branch_found: + # git_output is of the form " (HEAD, origin/blah)" + branch_name = git_output.split(',')[1].strip()[:-1] + return branch_found, branch_name + + @staticmethod + def _git_current_branch(dirname): + """Determines the name of the current local branch. + + Returns a tuple, (branch_found, branch_name), where branch_found + is a bool specifying whether a branch name was found for + HEAD. (If branch_found is False, then branch_name is ''.) + Note that currently we check out the remote branch rather than + the local, so this command does not return the just-checked-out + branch. See _git_current_remote_branch. + """ + cmd = 'git -C {dirname} symbolic-ref --short -q HEAD'.format( + dirname=dirname).split() + status, git_output = execute_subprocess(cmd, + output_to_caller=True, + status_to_caller=True) + branch_found = not status + if branch_found: + git_output = git_output.strip() + else: + git_output = '' + return branch_found, git_output + + @staticmethod + def _git_current_tag(dirname): + """Determines the name tag corresponding to HEAD (if any). + + if dirname is None, uses the cwd. + + Returns a tuple, (tag_found, tag_name), where tag_found is a + bool specifying whether we found a tag name corresponding to + HEAD. (If tag_found is False, then tag_name is ''.) + """ + cmd = 'git -C {dirname} describe --exact-match --tags HEAD'.format( + dirname=dirname).split() + status, git_output = execute_subprocess(cmd, + output_to_caller=True, + status_to_caller=True) + tag_found = not status + if tag_found: + git_output = git_output.strip() + else: + git_output = '' + return tag_found, git_output + + @staticmethod + def _git_showref_tag(ref, dirname): + """Run git show-ref check if the user supplied ref is a tag. + + could also use git rev-parse --quiet --verify tagname^{tag} + """ + cmd = ('git -C {dirname} show-ref --quiet --verify refs/tags/{ref}' + .format(dirname=dirname, ref=ref).split()) + status = execute_subprocess(cmd, status_to_caller=True) + return status + + @staticmethod + def _git_showref_branch(ref, dirname): + """Run git show-ref check if the user supplied ref is a local or + tracked remote branch. + + """ + cmd = ('git -C {dirname} show-ref --quiet --verify refs/heads/{ref}' + .format(dirname=dirname, ref=ref).split()) + status = execute_subprocess(cmd, status_to_caller=True) + return status + + @staticmethod + def _git_lsremote_branch(ref, remote_name, dirname): + """Run git ls-remote to check if the user supplied ref is a remote + branch that is not being tracked + + """ + cmd = ('git -C {dirname} ls-remote --exit-code --heads ' + '{remote_name} {ref}').format( + dirname=dirname, remote_name=remote_name, ref=ref).split() + status, output = execute_subprocess(cmd, status_to_caller=True, output_to_caller=True) + if not status and not f"refs/heads/{ref}" in output: + # In this case the ref is contained in the branch name but is not the complete branch name + return -1 + return status + + @staticmethod + def _git_revparse_commit(ref, dirname): + """Run git rev-parse to detect if a reference is a SHA, HEAD or other + valid commit. + + """ + cmd = ('git -C {dirname} rev-parse --quiet --verify {ref}^{commit}' + .format(dirname=dirname, ref=ref, commit='{commit}').split()) + status, git_output = execute_subprocess(cmd, status_to_caller=True, + output_to_caller=True) + git_output = git_output.strip() + return status, git_output + + @staticmethod + def _git_status_porcelain_v1z(dirname): + """Run git status to obtain repository information. + + This is run with '--untracked=no' to ignore untracked files. + + The machine-portable format that is guaranteed not to change + between git versions or *user configuration*. + + """ + cmd = ('git -C {dirname} status --untracked-files=no --porcelain -z' + .format(dirname=dirname)).split() + git_output = execute_subprocess(cmd, output_to_caller=True) + return git_output + + @staticmethod + def _git_status_verbose(dirname): + """Run the git status command to obtain repository information. + """ + cmd = 'git -C {dirname} status'.format(dirname=dirname).split() + git_output = execute_subprocess(cmd, output_to_caller=True) + return git_output + + @staticmethod + def _git_remote_verbose(dirname): + """Run the git remote command to obtain repository information. + + Returned string is of the form: + myfork git@github.com:johnpaulalex/manage_externals_jp.git (fetch) + myfork git@github.com:johnpaulalex/manage_externals_jp.git (push) + """ + cmd = 'git -C {dirname} remote --verbose'.format( + dirname=dirname).split() + return execute_subprocess(cmd, output_to_caller=True) + + @staticmethod + def has_submodules(repo_dir_path): + """Return True iff the repository at has a + '.gitmodules' file + """ + fname = os.path.join(repo_dir_path, + ExternalsDescription.GIT_SUBMODULES_FILENAME) + + return os.path.exists(fname) + + # ---------------------------------------------------------------- + # + # system call to git for sideffects modifying the working tree + # + # ---------------------------------------------------------------- + @staticmethod + def _git_clone(url, repo_dir_name, verbosity): + """Clones url into repo_dir_name. + """ + cmd = 'git clone --quiet {url} {repo_dir_name}'.format( + url=url, repo_dir_name=repo_dir_name).split() + if verbosity >= VERBOSITY_VERBOSE: + printlog(' {0}'.format(' '.join(cmd))) + execute_subprocess(cmd) + + @staticmethod + def _git_remote_add(name, url, dirname): + """Run the git remote command for the side effect of adding a remote + """ + cmd = 'git -C {dirname} remote add {name} {url}'.format( + dirname=dirname, name=name, url=url).split() + execute_subprocess(cmd) + + @staticmethod + def _git_fetch(remote_name, dirname): + """Run the git fetch command for the side effect of updating the repo + """ + cmd = 'git -C {dirname} fetch --quiet --tags {remote_name}'.format( + dirname=dirname, remote_name=remote_name).split() + execute_subprocess(cmd) + + @staticmethod + def _git_checkout_ref(ref, verbosity, submodules, dirname): + """Run the git checkout command for the side effect of updating the repo + + Param: ref is a reference to a local or remote object in the + form 'origin/my_feature', or 'tag1'. + + """ + cmd = 'git -C {dirname} checkout --quiet {ref}'.format( + dirname=dirname, ref=ref).split() + if verbosity >= VERBOSITY_VERBOSE: + printlog(' {0}'.format(' '.join(cmd))) + execute_subprocess(cmd) + if submodules: + GitRepository._git_update_submodules(verbosity, dirname) + + @staticmethod + def _git_sparse_checkout(verbosity, dirname): + """Configure repo via read-tree.""" + cmd = 'git -C {dirname} config core.sparsecheckout true'.format( + dirname=dirname).split() + if verbosity >= VERBOSITY_VERBOSE: + printlog(' {0}'.format(' '.join(cmd))) + execute_subprocess(cmd) + cmd = 'git -C {dirname} read-tree -mu HEAD'.format( + dirname=dirname).split() + if verbosity >= VERBOSITY_VERBOSE: + printlog(' {0}'.format(' '.join(cmd))) + execute_subprocess(cmd) + + @staticmethod + def _git_update_submodules(verbosity, dirname): + """Run git submodule update for the side effect of updating this + repo's submodules. + """ + # due to https://vielmetti.typepad.com/logbook/2022/10/git-security-fixes-lead-to-fatal-transport-file-not-allowed-error-in-ci-systems-cve-2022-39253.html + # submodules from file doesn't work without overriding the protocol, this is done + # for testing submodule support but should not be done in practice + file_protocol = "" + if 'unittest' in sys.modules.keys(): + file_protocol = "-c protocol.file.allow=always" + + # First, verify that we have a .gitmodules file + if os.path.exists( + os.path.join(dirname, + ExternalsDescription.GIT_SUBMODULES_FILENAME)): + cmd = ('git {file_protocol} -C {dirname} submodule update --init --recursive' + .format(file_protocol=file_protocol, dirname=dirname)).split() + if verbosity >= VERBOSITY_VERBOSE: + printlog(' {0}'.format(' '.join(cmd))) + + execute_subprocess(cmd) diff --git a/tools/manage_externals/manic/repository_svn.py b/tools/manage_externals/manic/repository_svn.py new file mode 100644 index 0000000000..b66c72e079 --- /dev/null +++ b/tools/manage_externals/manic/repository_svn.py @@ -0,0 +1,291 @@ +"""Class for interacting with svn repositories +""" + +from __future__ import absolute_import +from __future__ import unicode_literals +from __future__ import print_function + +import os +import re +import xml.etree.ElementTree as ET + +from .global_constants import EMPTY_STR, VERBOSITY_VERBOSE +from .repository import Repository +from .externals_status import ExternalStatus +from .utils import fatal_error, indent_string, printlog +from .utils import execute_subprocess + + +class SvnRepository(Repository): + """ + Class to represent and operate on a repository description. + + For testing purpose, all system calls to svn should: + + * be isolated in separate functions with no application logic + * of the form: + - cmd = ['svn', ...] + - value = execute_subprocess(cmd, output_to_caller={T|F}, + status_to_caller={T|F}) + - return value + * be static methods (not rely on self) + * name as _svn_subcommand_args(user_args) + + This convention allows easy unit testing of the repository logic + by mocking the specific calls to return predefined results. + + """ + RE_URLLINE = re.compile(r'^URL:') + + def __init__(self, component_name, repo, ignore_ancestry=False): + """ + Parse repo (a XML element). + """ + Repository.__init__(self, component_name, repo) + self._ignore_ancestry = ignore_ancestry + if self._url.endswith('/'): + # there is already a '/' separator in the URL; no need to add another + url_sep = '' + else: + url_sep = '/' + if self._branch: + self._url = self._url + url_sep + self._branch + elif self._tag: + self._url = self._url + url_sep + self._tag + else: + msg = "DEV_ERROR in svn repository. Shouldn't be here!" + fatal_error(msg) + + # ---------------------------------------------------------------- + # + # Public API, defined by Repository + # + # ---------------------------------------------------------------- + def checkout(self, base_dir_path, repo_dir_name, verbosity, recursive): # pylint: disable=unused-argument + """Checkout or update the working copy + + If the repo destination directory exists, switch the sandbox to + match the externals description. + + If the repo destination directory does not exist, checkout the + correct branch or tag. + NB: is include as an argument for compatibility with + git functionality (repository_git.py) + + """ + repo_dir_path = os.path.join(base_dir_path, repo_dir_name) + if 'github.com' in self._url: + msg = "SVN access to github.com is no longer supported" + fatal_error(msg) + if os.path.exists(repo_dir_path): + cwd = os.getcwd() + os.chdir(repo_dir_path) + self._svn_switch(self._url, self._ignore_ancestry, verbosity) + # svn switch can lead to a conflict state, but it gives a + # return code of 0. So now we need to make sure that we're + # in a clean (non-conflict) state. + self._abort_if_dirty(repo_dir_path, + "Expected clean state following switch") + os.chdir(cwd) + else: + self._svn_checkout(self._url, repo_dir_path, verbosity) + + def status(self, stat, repo_dir_path): + """ + Check and report the status of the repository + """ + self._check_sync(stat, repo_dir_path) + if os.path.exists(repo_dir_path): + self._status_summary(stat, repo_dir_path) + + # ---------------------------------------------------------------- + # + # Internal work functions + # + # ---------------------------------------------------------------- + def _check_sync(self, stat, repo_dir_path): + """Check to see if repository directory exists and is at the expected + url. Return: status object + + """ + if not os.path.exists(repo_dir_path): + # NOTE(bja, 2017-10) this state should have been handled by + # the source object and we never get here! + stat.sync_state = ExternalStatus.STATUS_ERROR + else: + svn_output = self._svn_info(repo_dir_path) + if not svn_output: + # directory exists, but info returned nothing. .svn + # directory removed or incomplete checkout? + stat.sync_state = ExternalStatus.UNKNOWN + else: + stat.sync_state, stat.current_version = \ + self._check_url(svn_output, self._url) + stat.expected_version = '/'.join(self._url.split('/')[3:]) + + def _abort_if_dirty(self, repo_dir_path, message): + """Check if the repo is in a dirty state; if so, abort with a + helpful message. + + """ + + stat = ExternalStatus() + self._status_summary(stat, repo_dir_path) + if stat.clean_state != ExternalStatus.STATUS_OK: + status = self._svn_status_verbose(repo_dir_path) + status = indent_string(status, 4) + errmsg = """In directory + {cwd} + +svn status now shows: +{status} + +ERROR: {message} + +One possible cause of this problem is that there may have been untracked +files in your working directory that had the same name as tracked files +in the new revision. + +To recover: Clean up the above directory (resolving conflicts, etc.), +then rerun checkout_externals. +""".format(cwd=repo_dir_path, message=message, status=status) + + fatal_error(errmsg) + + @staticmethod + def _check_url(svn_output, expected_url): + """Determine the svn url from svn info output and return whether it + matches the expected value. + + """ + url = None + for line in svn_output.splitlines(): + if SvnRepository.RE_URLLINE.match(line): + url = line.split(': ')[1].strip() + break + if not url: + status = ExternalStatus.UNKNOWN + elif url == expected_url: + status = ExternalStatus.STATUS_OK + else: + status = ExternalStatus.MODEL_MODIFIED + + if url: + current_version = '/'.join(url.split('/')[3:]) + else: + current_version = EMPTY_STR + + return status, current_version + + def _status_summary(self, stat, repo_dir_path): + """Report whether the svn repository is in-sync with the model + description and whether the sandbox is clean or dirty. + + """ + svn_output = self._svn_status_xml(repo_dir_path) + is_dirty = self.xml_status_is_dirty(svn_output) + if is_dirty: + stat.clean_state = ExternalStatus.DIRTY + else: + stat.clean_state = ExternalStatus.STATUS_OK + + # Now save the verbose status output incase the user wants to + # see it. + stat.status_output = self._svn_status_verbose(repo_dir_path) + + @staticmethod + def xml_status_is_dirty(svn_output): + """Parse svn status xml output and determine if the working copy is + clean or dirty. Dirty is defined as: + + * modified files + * added files + * deleted files + * missing files + + Unversioned files do not affect the clean/dirty status. + + 'external' is also an acceptable state + + """ + # pylint: disable=invalid-name + SVN_EXTERNAL = 'external' + SVN_UNVERSIONED = 'unversioned' + # pylint: enable=invalid-name + + is_dirty = False + try: + xml_status = ET.fromstring(svn_output) + except BaseException: + fatal_error( + "SVN returned invalid XML message {}".format(svn_output)) + xml_target = xml_status.find('./target') + entries = xml_target.findall('./entry') + for entry in entries: + status = entry.find('./wc-status') + item = status.get('item') + if item == SVN_EXTERNAL: + continue + if item == SVN_UNVERSIONED: + continue + is_dirty = True + break + return is_dirty + + # ---------------------------------------------------------------- + # + # system call to svn for information gathering + # + # ---------------------------------------------------------------- + @staticmethod + def _svn_info(repo_dir_path): + """Return results of svn info command + """ + cmd = ['svn', 'info', repo_dir_path] + output = execute_subprocess(cmd, output_to_caller=True) + return output + + @staticmethod + def _svn_status_verbose(repo_dir_path): + """capture the full svn status output + """ + cmd = ['svn', 'status', repo_dir_path] + svn_output = execute_subprocess(cmd, output_to_caller=True) + return svn_output + + @staticmethod + def _svn_status_xml(repo_dir_path): + """ + Get status of the subversion sandbox in repo_dir + """ + cmd = ['svn', 'status', '--xml', repo_dir_path] + svn_output = execute_subprocess(cmd, output_to_caller=True) + return svn_output + + # ---------------------------------------------------------------- + # + # system call to svn for sideffects modifying the working tree + # + # ---------------------------------------------------------------- + @staticmethod + def _svn_checkout(url, repo_dir_path, verbosity): + """ + Checkout a subversion repository (repo_url) to checkout_dir. + """ + cmd = ['svn', 'checkout', '--quiet', url, repo_dir_path] + if verbosity >= VERBOSITY_VERBOSE: + printlog(' {0}'.format(' '.join(cmd))) + execute_subprocess(cmd) + + @staticmethod + def _svn_switch(url, ignore_ancestry, verbosity): + """ + Switch branches for in an svn sandbox + """ + cmd = ['svn', 'switch', '--quiet'] + if ignore_ancestry: + cmd.append('--ignore-ancestry') + cmd.append(url) + if verbosity >= VERBOSITY_VERBOSE: + printlog(' {0}'.format(' '.join(cmd))) + execute_subprocess(cmd) diff --git a/tools/manage_externals/manic/sourcetree.py b/tools/manage_externals/manic/sourcetree.py new file mode 100644 index 0000000000..cf2a5b7569 --- /dev/null +++ b/tools/manage_externals/manic/sourcetree.py @@ -0,0 +1,425 @@ +""" +Classes to represent an externals config file (SourceTree) and the components +within it (_External). +""" + +import errno +import logging +import os + +from .externals_description import ExternalsDescription +from .externals_description import read_externals_description_file +from .externals_description import create_externals_description +from .repository_factory import create_repository +from .repository_git import GitRepository +from .externals_status import ExternalStatus +from .utils import fatal_error, printlog +from .global_constants import EMPTY_STR, LOCAL_PATH_INDICATOR +from .global_constants import VERBOSITY_VERBOSE + +class _External(object): + """ + A single component hosted in an external repository (and any children). + + The component may or may not be checked-out upon construction. + """ + # pylint: disable=R0902 + + def __init__(self, root_dir, name, local_path, required, subexternals_path, + repo, svn_ignore_ancestry, subexternal_sourcetree): + """Create a single external component (checked out or not). + + Input: + root_dir : string - the (checked-out) parent repo's root dir. + local_path : string - this external's (checked-out) subdir relative + to root_dir, e.g. "components/mom" + repo: Repository - the repo object for this external. Can be None (e.g. if this external just refers to another external file). + + name : string - name of this external (as named by the parent + reference). May or may not correspond to something in the path. + + ext_description : dict - source ExternalsDescription object + + svn_ignore_ancestry : bool - use --ignore-externals with svn switch + + subexternals_path: string - path to sub-externals config file, if any. Relative to local_path, or special value 'none'. + subexternal_sourcetree: SourceTree - corresponding to subexternals_path, if subexternals_path exists (it might not, if it is not checked out yet). + """ + self._name = name + self._required = required + + self._stat = None # Populated in status() + + self._local_path = local_path + # _repo_dir_path : full repository directory, e.g. + # "/components/mom" + repo_dir = os.path.join(root_dir, local_path) + self._repo_dir_path = os.path.abspath(repo_dir) + # _base_dir_path : base directory *containing* the repository, e.g. + # "/components" + self._base_dir_path = os.path.dirname(self._repo_dir_path) + # _repo_dir_name : base_dir_path + repo_dir_name = repo_dir_path + # e.g., "mom" + self._repo_dir_name = os.path.basename(self._repo_dir_path) + self._repo = repo + + # Does this component have subcomponents aka an externals config? + self._subexternals_path = subexternals_path + self._subexternal_sourcetree = subexternal_sourcetree + + + def get_name(self): + """ + Return the external object's name + """ + return self._name + + def get_local_path(self): + """ + Return the external object's path + """ + return self._local_path + + def get_repo_dir_path(self): + return self._repo_dir_path + + def get_subexternals_path(self): + return self._subexternals_path + + def get_repo(self): + return self._repo + + def status(self, force=False, print_progress=False): + """ + Returns status of this component and all subcomponents. + + Returns a dict mapping our local path (not component name!) to an + ExternalStatus dict. Any subcomponents will have their own top-level + path keys. Note the return value includes entries for this and all + subcomponents regardless of whether they are locally installed or not. + + Side-effect: If self._stat is empty or force is True, calculates _stat. + """ + calc_stat = force or not self._stat + + if calc_stat: + self._stat = ExternalStatus() + self._stat.path = self.get_local_path() + if not self._required: + self._stat.source_type = ExternalStatus.OPTIONAL + elif self._local_path == LOCAL_PATH_INDICATOR: + # LOCAL_PATH_INDICATOR, '.' paths, are standalone + # component directories that are not managed by + # checkout_subexternals. + self._stat.source_type = ExternalStatus.STANDALONE + else: + # managed by checkout_subexternals + self._stat.source_type = ExternalStatus.MANAGED + + subcomponent_stats = {} + if not os.path.exists(self._repo_dir_path): + if calc_stat: + # No local repository. + self._stat.sync_state = ExternalStatus.EMPTY + msg = ('status check: repository directory for "{0}" does not ' + 'exist.'.format(self._name)) + logging.info(msg) + self._stat.current_version = 'not checked out' + # NOTE(bja, 2018-01) directory doesn't exist, so we cannot + # use repo to determine the expected version. We just take + # a best-guess based on the assumption that only tag or + # branch should be set, but not both. + if not self._repo: + self._stat.expected_version = 'unknown' + else: + self._stat.expected_version = self._repo.tag() + self._repo.branch() + else: + # Merge local repository state (e.g. clean/dirty) into self._stat. + if calc_stat and self._repo: + self._repo.status(self._stat, self._repo_dir_path) + + # Status of subcomponents, if any. + if self._subexternals_path and self._subexternal_sourcetree: + cwd = os.getcwd() + # SourceTree.status() expects to be called from the correct + # root directory. + os.chdir(self._repo_dir_path) + subcomponent_stats = self._subexternal_sourcetree.status(self._local_path, force=force, print_progress=print_progress) + os.chdir(cwd) + + # Merge our status + subcomponent statuses into one return dict keyed + # by component path. + all_stats = {} + # don't add the root component because we don't manage it + # and can't provide useful info about it. + if self._local_path != LOCAL_PATH_INDICATOR: + # store the stats under the local_path, not comp name so + # it will be sorted correctly + all_stats[self._stat.path] = self._stat + + if subcomponent_stats: + all_stats.update(subcomponent_stats) + + return all_stats + + def checkout(self, verbosity): + """ + If the repo destination directory exists, ensure it is correct (from + correct URL, correct branch or tag), and possibly updateit. + If the repo destination directory does not exist, checkout the correct + branch or tag. + Does not check out sub-externals, see SourceTree.checkout(). + """ + # Make sure we are in correct location + if not os.path.exists(self._repo_dir_path): + # repository directory doesn't exist. Need to check it + # out, and for that we need the base_dir_path to exist + try: + os.makedirs(self._base_dir_path) + except OSError as error: + if error.errno != errno.EEXIST: + msg = 'Could not create directory "{0}"'.format( + self._base_dir_path) + fatal_error(msg) + + if not self._stat: + self.status() + assert self._stat + + if self._stat.source_type != ExternalStatus.STANDALONE: + if verbosity >= VERBOSITY_VERBOSE: + # NOTE(bja, 2018-01) probably do not want to pass + # verbosity in this case, because if (verbosity == + # VERBOSITY_DUMP), then the previous status output would + # also be dumped, adding noise to the output. + self._stat.log_status_message(VERBOSITY_VERBOSE) + + if self._repo: + if self._stat.sync_state == ExternalStatus.STATUS_OK: + # If we're already in sync, avoid showing verbose output + # from the checkout command, unless the verbosity level + # is 2 or more. + checkout_verbosity = verbosity - 1 + else: + checkout_verbosity = verbosity + + self._repo.checkout(self._base_dir_path, self._repo_dir_name, + checkout_verbosity, self.clone_recursive()) + + def replace_subexternal_sourcetree(self, sourcetree): + self._subexternal_sourcetree = sourcetree + + def clone_recursive(self): + 'Return True iff any .gitmodules files should be processed' + # Try recursive .gitmodules unless there is an externals entry + recursive = not self._subexternals_path + + return recursive + + +class SourceTree(object): + """ + SourceTree represents a group of managed externals. + + Those externals may not be checked out locally yet, they might only + have Repository objects pointing to their respective repositories. + """ + + @classmethod + def from_externals_file(cls, parent_repo_dir_path, parent_repo, + externals_path): + """Creates a SourceTree representing the given externals file. + + Looks up a git submodules file as an optional backup if there is no + externals file specified. + + Returns None if there is no externals file (i.e. it's None or 'none'), + or if the externals file hasn't been checked out yet. + + parent_repo_dir_path: parent repo root dir + parent_repo: parent repo. + externals_path: path to externals file, relative to parent_repo_dir_path. + """ + if not os.path.exists(parent_repo_dir_path): + # NOTE(bja, 2017-10) repository has not been checked out + # yet, can't process the externals file. Assume we are + # checking status before code is checkoud out and this + # will be handled correctly later. + return None + + if externals_path.lower() == 'none': + # With explicit 'none', do not look for git submodules file. + return None + + cwd = os.getcwd() + os.chdir(parent_repo_dir_path) + + if not externals_path: + if GitRepository.has_submodules(parent_repo_dir_path): + externals_path = ExternalsDescription.GIT_SUBMODULES_FILENAME + else: + return None + + if not os.path.exists(externals_path): + # NOTE(bja, 2017-10) this check is redundant with the one + # in read_externals_description_file! + msg = ('Externals description file "{0}" ' + 'does not exist! In directory: {1}'.format( + externals_path, parent_repo_dir_path)) + fatal_error(msg) + + externals_root = parent_repo_dir_path + # model_data is a dict-like object which mirrors the file format. + model_data = read_externals_description_file(externals_root, + externals_path) + # ext_description is another dict-like object (see ExternalsDescription) + ext_description = create_externals_description(model_data, + parent_repo=parent_repo) + externals_sourcetree = SourceTree(externals_root, ext_description) + os.chdir(cwd) + return externals_sourcetree + + def __init__(self, root_dir, ext_description, svn_ignore_ancestry=False): + """ + Build a SourceTree object from an ExternalDescription. + + root_dir: the (checked-out) parent repo root dir. + """ + self._root_dir = os.path.abspath(root_dir) + self._all_components = {} # component_name -> _External + self._required_compnames = [] + for comp, desc in ext_description.items(): + local_path = desc[ExternalsDescription.PATH] + required = desc[ExternalsDescription.REQUIRED] + repo_info = desc[ExternalsDescription.REPO] + subexternals_path = desc[ExternalsDescription.EXTERNALS] + + repo = create_repository(comp, + repo_info, + svn_ignore_ancestry=svn_ignore_ancestry) + + sourcetree = None + # Treat a .gitmodules file as a backup externals config + if not subexternals_path: + parent_repo_dir_path = os.path.abspath(os.path.join(root_dir, + local_path)) + if GitRepository.has_submodules(parent_repo_dir_path): + subexternals_path = ExternalsDescription.GIT_SUBMODULES_FILENAME + + # Might return None (if the subexternal isn't checked out yet, or subexternal is None or 'none') + subexternal_sourcetree = SourceTree.from_externals_file( + os.path.join(self._root_dir, local_path), + repo, + subexternals_path) + src = _External(self._root_dir, comp, local_path, required, + subexternals_path, repo, svn_ignore_ancestry, + subexternal_sourcetree) + + self._all_components[comp] = src + if required: + self._required_compnames.append(comp) + + def status(self, relative_path_base=LOCAL_PATH_INDICATOR, + force=False, print_progress=False): + """Return a dictionary of local path->ExternalStatus. + + Notes about the returned dictionary: + * It is keyed by local path (e.g. 'components/mom'), not by + component name (e.g. 'mom'). + * It contains top-level keys for all traversed components, whether + discovered by recursion or top-level. + * It contains entries for all components regardless of whether they + are locally installed or not, or required or optional. +x """ + load_comps = self._all_components.keys() + + summary = {} # Holds merged statuses from all components. + for comp in load_comps: + if print_progress: + printlog('{0}, '.format(comp), end='') + stat = self._all_components[comp].status(force=force, + print_progress=print_progress) + + # Returned status dictionary is keyed by local path; prepend + # relative_path_base if not already there. + stat_final = {} + for name in stat.keys(): + if stat[name].path.startswith(relative_path_base): + stat_final[name] = stat[name] + else: + modified_path = os.path.join(relative_path_base, + stat[name].path) + stat_final[modified_path] = stat[name] + stat_final[modified_path].path = modified_path + summary.update(stat_final) + + return summary + + def _find_installed_optional_components(self): + """Returns a list of installed optional component names, if any.""" + installed_comps = [] + for comp_name, ext in self._all_components.items(): + if comp_name in self._required_compnames: + continue + # Note that in practice we expect this status to be cached. + path_to_stat = ext.status() + + # If any part of this component exists locally, consider it + # installed and therefore eligible for updating. + if any(s.sync_state != ExternalStatus.EMPTY + for s in path_to_stat.values()): + installed_comps.append(comp_name) + return installed_comps + + def checkout(self, verbosity, load_all, load_comp=None): + """ + Checkout or update indicated components into the configured subdirs. + + If load_all is True, checkout all externals (required + optional), recursively. + If load_all is False and load_comp is set, checkout load_comp (and any required subexternals, plus any optional subexternals that are already checked out, recursively) + If load_all is False and load_comp is None, checkout all required externals, plus any optionals that are already checked out, recursively. + """ + if load_all: + tmp_comps = self._all_components.keys() + elif load_comp is not None: + tmp_comps = [load_comp] + else: + local_optional_compnames = self._find_installed_optional_components() + tmp_comps = self._required_compnames + local_optional_compnames + if local_optional_compnames: + printlog('Found locally installed optional components: ' + + ', '.join(local_optional_compnames)) + bad_compnames = set(local_optional_compnames) - set(self._all_components.keys()) + if bad_compnames: + printlog('Internal error: found locally installed components that are not in the global list of all components: ' + ','.join(bad_compnames)) + + if verbosity >= VERBOSITY_VERBOSE: + printlog('Checking out externals: ') + else: + printlog('Checking out externals: ', end='') + + # Sort by path so that if paths are nested the + # parent repo is checked out first. + load_comps = sorted(tmp_comps, key=lambda comp: self._all_components[comp].get_local_path()) + + # checkout. + for comp_name in load_comps: + if verbosity < VERBOSITY_VERBOSE: + printlog('{0}, '.format(comp_name), end='') + else: + # verbose output handled by the _External object, just + # output a newline + printlog(EMPTY_STR) + c = self._all_components[comp_name] + # Does not recurse. + c.checkout(verbosity) + # Recursively check out subexternals, if any. Returns None + # if there's no subexternals path. + component_subexternal_sourcetree = SourceTree.from_externals_file( + c.get_repo_dir_path(), + c.get_repo(), + c.get_subexternals_path()) + c.replace_subexternal_sourcetree(component_subexternal_sourcetree) + if component_subexternal_sourcetree: + component_subexternal_sourcetree.checkout(verbosity, load_all) + printlog('') diff --git a/tools/manage_externals/manic/utils.py b/tools/manage_externals/manic/utils.py new file mode 100644 index 0000000000..9c63ffe65e --- /dev/null +++ b/tools/manage_externals/manic/utils.py @@ -0,0 +1,330 @@ +#!/usr/bin/env python3 +""" +Common public utilities for manic package + +""" + +from __future__ import absolute_import +from __future__ import unicode_literals +from __future__ import print_function + +import logging +import os +import subprocess +import sys +from threading import Timer + +from .global_constants import LOCAL_PATH_INDICATOR + +# --------------------------------------------------------------------- +# +# screen and logging output and functions to massage text for output +# +# --------------------------------------------------------------------- + + +def log_process_output(output): + """Log each line of process output at debug level so it can be + filtered if necessary. By default, output is a single string, and + logging.debug(output) will only put log info heading on the first + line. This makes it hard to filter with grep. + + """ + output = output.split('\n') + for line in output: + logging.debug(line) + + +def printlog(msg, **kwargs): + """Wrapper script around print to ensure that everything printed to + the screen also gets logged. + + """ + logging.info(msg) + if kwargs: + print(msg, **kwargs) + else: + print(msg) + sys.stdout.flush() + + +def last_n_lines(the_string, n_lines, truncation_message=None): + """Returns the last n lines of the given string + + Args: + the_string: str + n_lines: int + truncation_message: str, optional + + Returns a string containing the last n lines of the_string + + If truncation_message is provided, the returned string begins with + the given message if and only if the string is greater than n lines + to begin with. + """ + + lines = the_string.splitlines(True) + if len(lines) <= n_lines: + return_val = the_string + else: + lines_subset = lines[-n_lines:] + str_truncated = ''.join(lines_subset) + if truncation_message: + str_truncated = truncation_message + '\n' + str_truncated + return_val = str_truncated + + return return_val + + +def indent_string(the_string, indent_level): + """Indents the given string by a given number of spaces + + Args: + the_string: str + indent_level: int + + Returns a new string that is the same as the_string, except that + each line is indented by 'indent_level' spaces. + + In python3, this can be done with textwrap.indent. + """ + + lines = the_string.splitlines(True) + padding = ' ' * indent_level + lines_indented = [padding + line for line in lines] + return ''.join(lines_indented) + +# --------------------------------------------------------------------- +# +# error handling +# +# --------------------------------------------------------------------- + + +def fatal_error(message): + """ + Error output function + """ + logging.error(message) + raise RuntimeError("{0}ERROR: {1}".format(os.linesep, message)) + + +# --------------------------------------------------------------------- +# +# Data conversion / manipulation +# +# --------------------------------------------------------------------- +def str_to_bool(bool_str): + """Convert a sting representation of as boolean into a true boolean. + + Conversion should be case insensitive. + """ + value = None + str_lower = bool_str.lower() + if str_lower in ('true', 't'): + value = True + elif str_lower in ('false', 'f'): + value = False + if value is None: + msg = ('ERROR: invalid boolean string value "{0}". ' + 'Must be "true" or "false"'.format(bool_str)) + fatal_error(msg) + return value + + +REMOTE_PREFIXES = ['http://', 'https://', 'ssh://', 'git@'] + + +def is_remote_url(url): + """check if the user provided a local file path instead of a + remote. If so, it must be expanded to an absolute + path. + + """ + remote_url = False + for prefix in REMOTE_PREFIXES: + if url.startswith(prefix): + remote_url = True + return remote_url + + +def split_remote_url(url): + """check if the user provided a local file path or a + remote. If remote, try to strip off protocol info. + + """ + remote_url = is_remote_url(url) + if not remote_url: + return url + + for prefix in REMOTE_PREFIXES: + url = url.replace(prefix, '') + + if '@' in url: + url = url.split('@')[1] + + if ':' in url: + url = url.split(':')[1] + + return url + + +def expand_local_url(url, field): + """check if the user provided a local file path instead of a + remote. If so, it must be expanded to an absolute + path. + + Note: local paths of LOCAL_PATH_INDICATOR have special meaning and + represent local copy only, don't work with the remotes. + + """ + remote_url = is_remote_url(url) + if not remote_url: + if url.strip() == LOCAL_PATH_INDICATOR: + pass + else: + url = os.path.expandvars(url) + url = os.path.expanduser(url) + if not os.path.isabs(url): + msg = ('WARNING: Externals description for "{0}" contains a ' + 'url that is not remote and does not expand to an ' + 'absolute path. Version control operations may ' + 'fail.\n\nurl={1}'.format(field, url)) + printlog(msg) + else: + url = os.path.normpath(url) + return url + + +# --------------------------------------------------------------------- +# +# subprocess +# +# --------------------------------------------------------------------- + +# Give the user a helpful message if we detect that a command seems to +# be hanging. +_HANGING_SEC = 300 + + +def _hanging_msg(working_directory, command): + print(""" + +Command '{command}' +from directory {working_directory} +has taken {hanging_sec} seconds. It may be hanging. + +The command will continue to run, but you may want to abort +manage_externals with ^C and investigate. A possible cause of hangs is +when svn or git require authentication to access a private +repository. On some systems, svn and git requests for authentication +information will not be displayed to the user. In this case, the program +will appear to hang. Ensure you can run svn and git manually and access +all repositories without entering your authentication information. + +""".format(command=command, + working_directory=working_directory, + hanging_sec=_HANGING_SEC)) + + +def execute_subprocess(commands, status_to_caller=False, + output_to_caller=False): + """Wrapper around subprocess.check_output to handle common + exceptions. + + check_output runs a command with arguments and waits + for it to complete. + + check_output raises an exception on a nonzero return code. if + status_to_caller is true, execute_subprocess returns the subprocess + return code, otherwise execute_subprocess treats non-zero return + status as an error and raises an exception. + + """ + cwd = os.getcwd() + msg = 'In directory: {0}\nexecute_subprocess running command:'.format(cwd) + logging.info(msg) + commands_str = ' '.join(commands) + logging.info(commands_str) + return_to_caller = status_to_caller or output_to_caller + status = -1 + output = '' + hanging_timer = Timer(_HANGING_SEC, _hanging_msg, + kwargs={"working_directory": cwd, + "command": commands_str}) + hanging_timer.start() + try: + output = subprocess.check_output(commands, stderr=subprocess.STDOUT, + universal_newlines=True) + log_process_output(output) + status = 0 + except OSError as error: + msg = failed_command_msg( + 'Command execution failed. Does the executable exist?', + commands) + logging.error(error) + fatal_error(msg) + except ValueError as error: + msg = failed_command_msg( + 'DEV_ERROR: Invalid arguments trying to run subprocess', + commands) + logging.error(error) + fatal_error(msg) + except subprocess.CalledProcessError as error: + # Only report the error if we are NOT returning to the + # caller. If we are returning to the caller, then it may be a + # simple status check. If returning, it is the callers + # responsibility determine if an error occurred and handle it + # appropriately. + if not return_to_caller: + msg_context = ('Process did not run successfully; ' + 'returned status {0}'.format(error.returncode)) + msg = failed_command_msg(msg_context, commands, + output=error.output) + logging.error(error) + logging.error(msg) + log_process_output(error.output) + fatal_error(msg) + status = error.returncode + finally: + hanging_timer.cancel() + + if status_to_caller and output_to_caller: + ret_value = (status, output) + elif status_to_caller: + ret_value = status + elif output_to_caller: + ret_value = output + else: + ret_value = None + + return ret_value + + +def failed_command_msg(msg_context, command, output=None): + """Template for consistent error messages from subprocess calls. + + If 'output' is given, it should provide the output from the failed + command + """ + + if output: + output_truncated = last_n_lines(output, 20, + truncation_message='[... Output truncated for brevity ...]') + errmsg = ('Failed with output:\n' + + indent_string(output_truncated, 4) + + '\nERROR: ') + else: + errmsg = '' + + command_str = ' '.join(command) + errmsg += """In directory + {cwd} +{context}: + {command} +""".format(cwd=os.getcwd(), context=msg_context, command=command_str) + + if output: + errmsg += 'See above for output from failed command.\n' + + return errmsg diff --git a/tools/manage_externals/version.txt b/tools/manage_externals/version.txt new file mode 100644 index 0000000000..cbda54c515 --- /dev/null +++ b/tools/manage_externals/version.txt @@ -0,0 +1 @@ +manic-1.2.24-3-gba00e50 diff --git a/tools/registry.c b/tools/registry.c index b2dd0a5f6a..7919492cf9 100644 --- a/tools/registry.c +++ b/tools/registry.c @@ -54,6 +54,8 @@ main( int argc, char *argv[], char *env[] ) other data streams are written to file per process */ sw_new_bdys = 0 ; sw_unidir_shift_halo = 0 ; + sw_chem = 0; + sw_kpp = 0; strcpy( fname_in , "" ) ; @@ -127,6 +129,12 @@ main( int argc, char *argv[], char *env[] ) fprintf(stderr,"Usage: %s [-DDEREF_KLUDGE] [-DDM_PARALLEL] [-DDISTRIB_IO_LAYER] [-DDM_SERIAL_IN_ONLY] [-DD3VAR_IRY_KLUDGE] registryfile\n",thisprog) ; exit(1) ; } + if (!strcmp(*argv,"-DWRF_CHEM")) { + sw_chem = 1 ; + } + if (!strcmp(*argv,"-DWRF_KPP")) { + sw_kpp = 1 ; + } } else /* consider it an input file */ { @@ -144,10 +152,8 @@ main( int argc, char *argv[], char *env[] ) // possible IRR diagnostcis? // do_irr_diag = 0; - env_val = getenv( "WRF_CHEM" ); - if( env_val != NULL && !strncmp( env_val, "1", 1 ) ) { - env_val = getenv( "WRF_KPP" ); - if( env_val != NULL && !strncmp( env_val, "1", 1 ) ) do_irr_diag = 1; + if( sw_chem == 1 ) { + if( sw_kpp == 1 ) do_irr_diag = 1; } if( do_irr_diag ) { if( access( fname_in,F_OK ) ) { diff --git a/var/build/da.make b/var/build/da.make index 898d57464c..522a013f78 100644 --- a/var/build/da.make +++ b/var/build/da.make @@ -445,10 +445,10 @@ da_setup_structures.o : fi if $(FGREP) '!$$OMP' $*.f ; then \ if [ -n "$(OMP)" ] ; then echo COMPILING $*.f90 WITH OMP ; fi ; \ - $(FC) -c $(FCFLAGS) $(OMP) $(PROMOTION) $(CRTM_SRC) $(RTTOV_SRC) $(HDF5_INC) $*.f ; \ + $(FC) -c $(FCFLAGS) $(OMP) $(PROMOTION) $(CRTM_SRC) $(RTTOV_SRC) $(HDF5_INC) -I$(NETCDF)/include $*.f ; \ else \ if [ -n "$(OMP)" ] ; then echo COMPILING $*.f90 WITHOUT OMP ; fi ; \ - $(FC) -c $(FCFLAGS) $(PROMOTION) $(CRTM_SRC) $(RTTOV_SRC) $(HDF5_INC) $*.f ; \ + $(FC) -c $(FCFLAGS) $(PROMOTION) $(CRTM_SRC) $(RTTOV_SRC) $(HDF5_INC) -I$(NETCDF)/include $*.f ; \ fi da_obs_io.o \ diff --git a/var/build/depend.txt b/var/build/depend.txt index 3632d9e20e..8ad937e19c 100644 --- a/var/build/depend.txt +++ b/var/build/depend.txt @@ -380,7 +380,7 @@ da_wavelet.o : da_wavelet.f90 da_transform_through_wavelet_adj.inc da_transform_ da_wrf_interfaces.o : da_wrf_interfaces.f90 module_configure.o module_domain.o da_wrfvar_esmf.o : da_wrfvar_esmf.f90 da_wrfvar_esmf_super.o : da_wrfvar_esmf_super.f90 da_wrfvar_interface.inc da_esmf_finalize.inc da_esmf_run.inc da_esmf_init.inc -da_wrfvar_io.o : copyfile.c da_wrfvar_io.f90 da_med_initialdata_output_lbc.inc da_med_initialdata_output.inc da_med_initialdata_input.inc da_update_firstguess.inc da_4dvar.o da_tracing.o da_reporting.o da_control.o module_io_domain.o module_domain.o module_date_time.o module_configure.o module_domain_type.o +da_wrfvar_io.o : copyfile.c da_wrfvar_io.f90 da_med_initialdata_output_lbc.inc da_med_initialdata_output.inc da_med_initialdata_input.inc da_update_firstguess.inc da_write_anaincrements.inc da_4dvar.o da_tracing.o da_reporting.o da_control.o module_io_domain.o module_domain.o module_date_time.o module_configure.o module_domain_type.o da_wrfvar_main.o : da_wrfvar_main.f90 da_4dvar.o da_wrfvar_top.o da_wrf_interfaces.o da_tracing.o da_control.o module_symbols_util.o da_wrfvar_top.o : da_wrfvar_top.f90 da_solve_init.inc da_solve_dual_res_init.inc da_solve.inc da_wrfvar_finalize.inc da_wrfvar_interface.inc da_wrfvar_run.inc da_wrfvar_init2.inc da_wrfvar_init1.inc da_wrf_interfaces.o da_rain.o da_synop.o da_ssmi.o da_sound.o da_ships.o da_satem.o da_radar.o da_lightning.o da_mtgirs.o da_qscat.o da_profiler.o da_polaramv.o da_pilot.o da_metar.o da_gpsref.o da_gpspw.o da_geoamv.o da_buoy.o da_bogus.o da_airsr.o da_airep.o da_crtm.o da_tools.o da_vtox_transforms.o da_transfer_model.o da_tracing.o da_tools_serial.o da_test.o da_setup_structures.o da_reporting.o da_varbc.o da_radiance1.o da_physics.o da_par_util.o da_obs_io.o da_obs.o da_minimisation.o da_define_structures.o da_control.o module_comm_dm.o module_dm.o module_tiles.o module_state_description.o module_radiance.o da_wrfvar_io.o da_4dvar.o module_symbols_util.o module_driver_constants.o module_domain.o module_configure.o module_io_domain.o da_netcdf_interface.o da_gpseph.o da_varbc_tamdar.o module_io_wrf.o da_chem_sfc.o decode_airs.o : decode_airs.f90 module_read_airs.o diff --git a/var/da/da_control/da_control.f90 b/var/da/da_control/da_control.f90 index 46810d7bec..6b9a6f93e2 100644 --- a/var/da/da_control/da_control.f90 +++ b/var/da/da_control/da_control.f90 @@ -99,7 +99,7 @@ module da_control !hcl-note: should the top and interval be namelist options? integer, parameter :: interpolate_level = 2000 -#if RWORDSIZE==8 +#ifdef DOUBLE_PRECISION real, parameter :: da_zero = 0D0 #else real, parameter :: da_zero = 0.0 diff --git a/var/da/da_main/da_solve.inc b/var/da/da_main/da_solve.inc index a2ce91ccba..9e2caa2548 100644 --- a/var/da/da_main/da_solve.inc +++ b/var/da/da_main/da_solve.inc @@ -1129,6 +1129,9 @@ (config_flags%real_data_init_type == 3)) then if ( .not. offline_varbc ) & call da_update_firstguess(input_grid) + ! output analysis increments + call da_write_anaincrements (grid, config_flags) + #ifdef VAR4D !if (var4d) call da_med_initialdata_output_lbc (head_grid , config_flags) if ( var4d_lbc ) then diff --git a/var/da/da_main/da_wrfvar_io.f90 b/var/da/da_main/da_wrfvar_io.f90 index eca072a404..c95952656b 100644 --- a/var/da/da_main/da_wrfvar_io.f90 +++ b/var/da/da_main/da_wrfvar_io.f90 @@ -6,6 +6,7 @@ module da_wrfvar_io use module_domain, only : domain, get_ijk_from_grid use module_io_domain, only : open_r_dataset,close_dataset, & input_input, open_w_dataset,output_input, & + output_auxhist5, & input_boundary, output_boundary, output_auxhist4, & input_auxhist6, input_auxhist4 use module_io, only: wrf_get_dom_ti_integer @@ -30,5 +31,6 @@ module da_wrfvar_io #include "da_med_initialdata_output.inc" #include "da_med_initialdata_output_lbc.inc" #include "da_update_firstguess.inc" +#include "da_write_anaincrements.inc" end module da_wrfvar_io diff --git a/var/da/da_main/da_wrfvar_top.f90 b/var/da/da_main/da_wrfvar_top.f90 index 240ceb5be0..3d0ccd78a9 100644 --- a/var/da/da_main/da_wrfvar_top.f90 +++ b/var/da/da_main/da_wrfvar_top.f90 @@ -95,7 +95,7 @@ module da_wrfvar_top use da_vtox_transforms, only : da_transform_vtox, da_transform_xtoxa, & da_transform_xtoxa_adj, da_copy_xa, da_add_xa, da_transform_vpatox, & da_transform_vtox_inv - use da_wrfvar_io, only : da_med_initialdata_input, da_update_firstguess + use da_wrfvar_io, only : da_med_initialdata_input, da_update_firstguess,da_write_anaincrements use da_tools, only : da_set_randomcv, da_get_julian_time use da_tools, only : map_info,map_info_ens,proj_merc, proj_ps,proj_lc,proj_latlon, & diff --git a/var/da/da_main/da_write_anaincrements.inc b/var/da/da_main/da_write_anaincrements.inc new file mode 100644 index 0000000000..7a351ccc52 --- /dev/null +++ b/var/da/da_main/da_write_anaincrements.inc @@ -0,0 +1,76 @@ +subroutine da_write_anaincrements(grid, config_flags) + + use module_domain, only : get_ijk_from_grid, program_name + use da_control, only : use_radarobs, use_rad, crtm_cloud, & + use_radar_rhv, use_radar_rqv + use module_state_description, only : p_qv, p_qc, p_qr, p_qi, & + p_qs, p_qg, & + f_qc, f_qr, f_qi, f_qs, f_qg + use module_model_constants, only: R_d, R_v, T0 +#if (WRF_CHEM == 1) + use module_domain_type, only : fieldlist + use da_control, only : use_chemic_surfobs, stdout + use module_state_description, only : PARAM_FIRST_SCALAR, num_chem +#endif + + implicit none + + INTERFACE + integer(c_int32_t) function copyfile(ifile, ofile) bind(c) + import :: c_int32_t, C_CHAR + CHARACTER(KIND=C_CHAR), DIMENSION(*), intent(in) :: ifile, ofile + END function copyfile + END INTERFACE + + include 'netcdf.inc' + + type(domain), intent(inout) :: grid + type(grid_config_rec_type),intent(inout) :: config_flags + +! Declare local parameters + character(len=120) :: file_name,filnam + character(len=19) :: DateStr1 + character(len=4) :: staggering=' N/A' + character(len=3) :: ordering + character(len=80), dimension(3) :: dimnames + character(len=80) :: rmse_var + integer :: dh1,dh0 + integer :: i,j,k + integer :: ndim1 + integer :: WrfType + integer :: it, ierr, Status, Status_next_time + integer :: wrf_real + integer :: nlon_regional,nlat_regional,nsig_regional + integer :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe + integer, dimension(4) :: start_index, end_index1 + real, dimension(:), allocatable :: globbuf + real*4,allocatable :: field3(:,:,:),field2(:,:) + real*4,allocatable :: field3u(:,:,:),field3v(:,:,:),field3ph(:,:,:) + character(len=4) :: fgname + integer :: julyr, julday + real :: gmt + real*4 :: gmt4 + real :: qvf + + if ( grid%auxhist5_oid .NE. 0 ) then + call close_dataset ( grid%auxhist5_oid , config_flags , "DATASET=AUXHIST5" ) + endif + + call open_w_dataset (grid%auxhist5_oid, trim(config_flags%auxhist5_outname), grid, config_flags, & + output_auxhist5, "DATASET=AUXHIST5", ierr) + if ( ierr .NE. 0 ) CALL wrf_error_fatal('Error opening '//trim(filnam)) + + start_date=current_date + + call geth_julgmt(julyr, julday, gmt) + config_flags%gmt = gmt + config_flags%julyr = julyr + config_flags%julday = julday + + call output_auxhist5 (grid%auxhist5_oid, grid , config_flags , ierr) + if ( ierr .NE. 0 ) CALL wrf_error_fatal('Error writing Gradient in auxhist5') + call close_dataset (grid%auxhist5_oid, config_flags, "DATASET=AUXHIST5") + +end subroutine da_write_anaincrements diff --git a/var/da/da_obs_io/da_read_obs_bufr.inc b/var/da/da_obs_io/da_read_obs_bufr.inc index ca29ceada9..60098764aa 100644 --- a/var/da/da_obs_io/da_read_obs_bufr.inc +++ b/var/da/da_obs_io/da_read_obs_bufr.inc @@ -542,7 +542,7 @@ bufrfile: do ibufr=1,numbufr end if if ( obs(7,1) < r8bfms ) then pwq=nint(qms(7,1)) -#if ( RWORDSIZE == 4 ) +#ifndef DOUBLE_PRECISION pwe = min(DBLE(err_pw), oes(7,1)) #else pwe = min(err_pw, oes(7,1)) @@ -604,7 +604,7 @@ bufrfile: do ibufr=1,numbufr !Not currently used !cat=nint(obs(8,k)) -#if ( RWORDSIZE == 4 ) +#ifndef DOUBLE_PRECISION toe = min(DBLE(err_t), oes(3,k)) woe = min(DBLE(err_uv), oes(5,k)) qoe = min(DBLE(err_q), oes(2,k)*10.0) ! convert to % from PREPBUFR percent divided by 10 @@ -686,7 +686,7 @@ bufrfile: do ibufr=1,numbufr ! assign u,v,t,q obs errors for synop and metar if ( t29 == 512 .or. t29 == 511 .or. t29 == 514 ) then -#if ( RWORDSIZE == 4 ) +#ifndef DOUBLE_PRECISION toe = min(DBLE(err_t), oes(3,1)) woe = min(DBLE(err_uv), oes(5,1)) qoe = min(DBLE(err_q), oes(2,1)*10.0) ! convert to % from PREPBUFR percent divided by 10 diff --git a/var/da/da_par_util/da_par_util1.f90 b/var/da/da_par_util/da_par_util1.f90 index 3dce88fb24..bea5a672c0 100644 --- a/var/da/da_par_util/da_par_util1.f90 +++ b/var/da/da_par_util/da_par_util1.f90 @@ -3,7 +3,7 @@ module da_par_util1 use da_control, only : rootproc, ierr, comm, root #ifdef DM_PARALLEL -#if ( DWORDSIZE != RWORDSIZE ) +#ifndef DOUBLE_PRECISION ! use mpi, only : mpi_sum, mpi_integer, mpi_complex, mpi_real #else ! use mpi, only : mpi_sum, mpi_integer, mpi_double_complex, mpi_real8 @@ -21,7 +21,7 @@ module da_par_util1 #ifdef DM_PARALLEL include 'mpif.h' -#if ( DWORDSIZE != RWORDSIZE ) +#ifndef DOUBLE_PRECISION integer, parameter :: true_mpi_real = mpi_real integer, parameter :: true_mpi_complex = mpi_complex #else diff --git a/var/da/da_par_util/da_proc_maxmin_combine.inc b/var/da/da_par_util/da_proc_maxmin_combine.inc index bd3fe40d13..141586ad9e 100644 --- a/var/da/da_par_util/da_proc_maxmin_combine.inc +++ b/var/da/da_par_util/da_proc_maxmin_combine.inc @@ -32,7 +32,7 @@ subroutine da_proc_maxmin_combine(n, max, min) in(2*i) = myproc end do -#if ( RWORDSIZE == 4 ) +#ifndef DOUBLE_PRECISION call mpi_reduce(in, out, n, mpi_2real, mpi_minloc, root, comm, ierr) #else call mpi_reduce(in, out, n, mpi_2double_precision, mpi_minloc, root, comm, ierr) @@ -65,7 +65,7 @@ subroutine da_proc_maxmin_combine(n, max, min) in(2*i-1) = max(i)%value in(2*i) = myproc end do -#if ( RWORDSIZE == 4 ) +#ifndef DOUBLE_PRECISION call mpi_reduce(in, out, n, mpi_2real, mpi_maxloc, root, comm, ierr) #else call mpi_reduce(in, out, n, mpi_2double_precision, mpi_maxloc, root, comm, ierr) diff --git a/var/da/da_par_util/da_proc_stats_combine.inc b/var/da/da_par_util/da_proc_stats_combine.inc index d8fd895f57..74573c9300 100644 --- a/var/da/da_par_util/da_proc_stats_combine.inc +++ b/var/da/da_par_util/da_proc_stats_combine.inc @@ -43,7 +43,7 @@ subroutine da_proc_stats_combine(proc_ave, proc_err, proc_min, proc_max, & ! Get minimum value and associated processor index. in(1) = proc_min in(2) = myproc -#if ( RWORDSIZE == 4 ) +#ifndef DOUBLE_PRECISION call mpi_reduce(in, out, 1, mpi_2real, mpi_minloc, root, comm, ierr) #else call mpi_reduce(in, out, 1, mpi_2double_precision, mpi_minloc, root, comm, ierr) @@ -73,7 +73,7 @@ subroutine da_proc_stats_combine(proc_ave, proc_err, proc_min, proc_max, & in(1) = proc_max in(2) = myproc -#if ( RWORDSIZE == 4 ) +#ifndef DOUBLE_PRECISION call mpi_reduce(in, out, 1, mpi_2real, mpi_maxloc, root, comm, ierr) #else call mpi_reduce(in, out, 1, mpi_2double_precision, mpi_maxloc, root, comm, ierr) diff --git a/var/da/da_radiance/gsi_kinds.f90 b/var/da/da_radiance/gsi_kinds.f90 index 0c0ac7c27c..672a43fb5d 100644 --- a/var/da/da_radiance/gsi_kinds.f90 +++ b/var/da/da_radiance/gsi_kinds.f90 @@ -96,7 +96,7 @@ module gsi_kinds ! Default values ! **** CHANGE THE FOLLOWING TO CHANGE THE DEFAULT REAL TYPE KIND *** ! 1=single, 2=double, 3=quad -#if ( RWORDSIZE == 4 ) +#ifndef DOUBLE_PRECISION integer, parameter, private :: default_real = 1 #else integer, parameter, private :: default_real = 2 diff --git a/var/da/da_transfer_model/da_transfer_xatowrf.inc b/var/da/da_transfer_model/da_transfer_xatowrf.inc index 1c8b64856e..85328935dd 100644 --- a/var/da/da_transfer_model/da_transfer_xatowrf.inc +++ b/var/da/da_transfer_model/da_transfer_xatowrf.inc @@ -265,6 +265,7 @@ subroutine da_transfer_xatowrf(grid, config_flags) ! The analysis perturbation = Hydro_ph - base_ph + nonhydro_xb_ph: grid%ph_2(i,j,k+1) = ph_full - grid%phb(i,j,k+1) & + (grid%xb%hf(i,j,k+1)*gravity - ph_xb_hd) + grid%t_iau(i,j,k) = grid%xa%t(i,j,k) end do end do end do @@ -303,6 +304,7 @@ subroutine da_transfer_xatowrf(grid, config_flags) phm = mu_full*c3h(k) + c4h(k) + grid%p_top ph(k+1) = ph(k) + ald(k)*phm*LOG(pfd/pfu) grid%ph_2(i,j,k+1) = ph(k+1) - grid%phb(i,j,k+1) + grid%t_iau(i,j,k) = grid%xa%t(i,j,k) END DO ! Update geopotential perturbation @@ -323,6 +325,7 @@ subroutine da_transfer_xatowrf(grid, config_flags) do j=jts,jte do i=its,ite ph_cgrid(i,j,k) = grid%ph_2(i,j,k) - ph_cgrid(i,j,k) + grid%ph_iau(i,j,k) = ph_cgrid(i,j,k) end do end do end do @@ -429,6 +432,7 @@ subroutine da_transfer_xatowrf(grid, config_flags) grid%mu_2(i,j) = grid%mu_2(i,j) + mu_cgrid(i,j) grid%w_2(i,j,kte+1)= grid%w_2(i,j,kte+1) + grid%xa%w(i,j,kte+1) grid%psfc(i,j) = grid%psfc(i,j) + grid%xa%psfc(i,j) + grid%mu_iau(i,j) = mu_cgrid(i,j) end do do k=kts,kte @@ -437,6 +441,9 @@ subroutine da_transfer_xatowrf(grid, config_flags) grid%u_2(i,j,k) = grid%u_2(i,j,k) + u_cgrid(i,j,k) grid%v_2(i,j,k) = grid%v_2(i,j,k) + v_cgrid(i,j,k) #endif + grid%u_iau(i,j,k) = u_cgrid(i,j,k) + grid%v_iau(i,j,k) = v_cgrid(i,j,k) + grid%w_iau(i,j,k) = grid%xa%w(i,j,k) grid%w_2(i,j,k) = grid%w_2(i,j,k) + grid%xa%w(i,j,k) ! (xb%q+xa%q in specific humidity) >= 0.0 @@ -448,19 +455,25 @@ subroutine da_transfer_xatowrf(grid, config_flags) else grid%moist(i,j,k,P_QV) = grid%moist(i,j,k,P_QV)+q_cgrid(i,j,k) end if + grid%qv_iau(i,j,k) = q_cgrid(i,j,k) if (size(grid%moist,dim=4) >= 4 .and. cloud_cv_options >= 1) then grid%moist(i,j,k,p_qc) = max(grid%moist(i,j,k,p_qc) + grid%xa%qcw(i,j,k), 0.0) grid%moist(i,j,k,p_qr) = max(grid%moist(i,j,k,p_qr) + grid%xa%qrn(i,j,k), 0.0) + grid%qc_iau(i,j,k) = grid%xa%qcw(i,j,k) + grid%qr_iau(i,j,k) = grid%xa%qrn(i,j,k) end if if (size(grid%moist,dim=4) >= 6 .and. cloud_cv_options >= 2) then grid%moist(i,j,k,p_qi) = max(grid%moist(i,j,k,p_qi) + grid%xa%qci(i,j,k), 0.0) grid%moist(i,j,k,p_qs) = max(grid%moist(i,j,k,p_qs) + grid%xa%qsn(i,j,k), 0.0) + grid%qi_iau(i,j,k) = grid%xa%qci(i,j,k) + grid%qs_iau(i,j,k) = grid%xa%qsn(i,j,k) end if if (size(grid%moist,dim=4) >= 7 .and. cloud_cv_options >= 2) then grid%moist(i,j,k,p_qg) = max(grid%moist(i,j,k,p_qg) + grid%xa%qgr(i,j,k), 0.0) + grid%qg_iau(i,j,k) = grid%xa%qgr(i,j,k) end if end do end do diff --git a/wrftladj/CMakeLists.txt b/wrftladj/CMakeLists.txt new file mode 100644 index 0000000000..f15de98f46 --- /dev/null +++ b/wrftladj/CMakeLists.txt @@ -0,0 +1,86 @@ +# WRF CMake Build + + +target_sources( + ${PROJECT_NAME}_Core + PRIVATE + # Mods MP + module_mp_mkessler.F + module_mp_nconvp.F + # Mods BL + module_bl_surface_drag.F + # Mods CU + module_cu_du.F + # Mods LL + module_linked_list2.F + # Mods PT + mediation_pertmod_io.F + # Dynem mods + module_advect_em_tl.F + module_advect_em_ad.F + module_diffusion_em_tl.F + module_diffusion_em_ad.F + module_small_step_em_tl.F + module_small_step_em_ad.F + module_big_step_utilities_em_tl.F + module_big_step_utilities_em_ad.F + module_em_tl.F + module_em_ad.F + module_bc_em_tl.F + module_bc_em_ad.F + module_first_rk_step_part1_tl.F + module_first_rk_step_part1_ad.F + module_first_rk_step_part2_tl.F + module_first_rk_step_part2_ad.F + module_sfs_nba_tl.F + module_sfs_nba_ad.F + module_sfs_driver_tl.F + module_sfs_driver_ad.F + # Dynem objs + solve_em_tl.F + solve_em_ad.F + start_em_tl.F + start_em_ad.F + # Phys mods + module_bl_gwdo_tl.F + module_bl_gwdo_ad.F + module_bl_surface_drag_tl.F + module_bl_surface_drag_ad.F + module_cu_du_tl.F + module_cu_du_ad.F + module_mp_mkessler_tl.F + module_mp_mkessler_ad.F + module_mp_wsm6r_tl.F + module_mp_wsm6r_ad.F + module_mp_nconvp_tl.F + module_mp_nconvp_ad.F + module_physics_addtendc_tl.F + module_physics_addtendc_ad.F + module_physics_init_tl.F + module_physics_init_ad.F + module_pbl_driver_tl.F + module_pbl_driver_ad.F + module_cumulus_driver_tl.F + module_cumulus_driver_ad.F + module_microphysics_driver_tl.F + module_microphysics_driver_ad.F + module_microphysics_zero_out_tl.F + module_microphysics_zero_out_ad.F + # Share mods + module_adtl_grid_utilities.F + module_bc_tl.F + module_bc_ad.F + # Share objs + jcdfi.F + # Frame objs + adStack.c + adBuffer.F + ) + +set_source_files_properties( + adBuffer.F + TARGET_DIRECTORY ${PROJECT_NAME}_Core + PROPERTIES + Fortran_FORMAT FIXED + ) + diff --git a/wrftladj/module_big_step_utilities_em_ad.F b/wrftladj/module_big_step_utilities_em_ad.F index 8cc13725e9..b4f42ca6b7 100644 --- a/wrftladj/module_big_step_utilities_em_ad.F +++ b/wrftladj/module_big_step_utilities_em_ad.F @@ -11,7 +11,7 @@ MODULE a_module_big_step_utilities_em kfetascheme, mskfscheme, g3scheme, p_qv, param_first_scalar, p_qr, p_qc, DFI_FWD USE module_configure, ONLY : grid_config_rec_type USE module_wrf_error -#if (RWORDSIZE == 4) +#ifndef DOUBLE_PRECISION # define VPOWX vspowx # define VPOW vspow #else diff --git a/wrftladj/module_big_step_utilities_em_tl.F b/wrftladj/module_big_step_utilities_em_tl.F index cab1e5e525..67d79f9b7d 100644 --- a/wrftladj/module_big_step_utilities_em_tl.F +++ b/wrftladj/module_big_step_utilities_em_tl.F @@ -5,7 +5,7 @@ ! and LSEC of ICMSEC, AMSS(2001-2003) ! The copyright of the DFT system was declared by Walls at LASG, 1998-2010 ! ====================================================================================== -#if (RWORDSIZE == 4) +#ifndef DOUBLE_PRECISION # define VPOWX vspowx # define VPOW vspow #else diff --git a/wrftladj/solve_em_ad.F b/wrftladj/solve_em_ad.F index 5acb79d4d8..1a2acd38be 100644 --- a/wrftladj/solve_em_ad.F +++ b/wrftladj/solve_em_ad.F @@ -178,7 +178,8 @@ SUBROUTINE solve_em_ad ( grid , config_flags & LOGICAL :: leapfrog INTEGER :: l,kte,kk LOGICAL :: f_flux ! flag for computing averaged fluxes in cu_gd - REAL :: curr_secs + REAL :: curr_secs, curr_secs2, curr_mins2 + REAL(8) :: curr_secs_r8, curr_secs2_r8 INTEGER :: num_sound_steps INTEGER :: idex, jdex REAL :: max_msft @@ -191,8 +192,9 @@ SUBROUTINE solve_em_ad ( grid , config_flags & ! urban related variables INTEGER :: NUM_ROOF_LAYERS, NUM_WALL_LAYERS, NUM_ROAD_LAYERS ! urban - TYPE(WRFU_TimeInterval) :: tmpTimeInterval + TYPE(WRFU_TimeInterval) :: tmpTimeInterval, tmpTimeInterval2 REAL :: real_time + REAL(8) :: real_time_r8 LOGICAL :: adapt_step_flag LOGICAL :: fill_w_flag @@ -299,7 +301,12 @@ SUBROUTINE solve_em_ad ( grid , config_flags & ! calculate it here--but, this is not clean!! ! tmpTimeInterval = domain_get_current_time ( grid ) - domain_get_sim_start_time ( grid ) + tmpTimeInterval2 = domain_get_current_time ( grid ) - domain_get_start_time ( grid ) curr_secs = real_time(tmpTimeInterval) + curr_secs2 = real_time(tmpTimeInterval2) + curr_secs_r8 = real_time_r8(tmpTimeInterval) + curr_secs2_r8 = real_time_r8(tmpTimeInterval2) + curr_mins2 = REAL( curr_secs2_r8 / 60.0d0 ) old_dt = grid%dt ! store old time step for flux averaging code at end of RK loop !----------------------------------------------------------------------------- @@ -672,7 +679,7 @@ SUBROUTINE solve_em_ad ( grid , config_flags & , ph_tendf, mu_tendf & , tke_tend & , config_flags%use_adaptive_time_step & - , curr_secs & + , curr_secs, curr_mins2 & , psim , psih , gz1oz0 & , chklowq & , cu_act_flag , hol , th_phy & @@ -3833,7 +3840,7 @@ SUBROUTINE solve_em_ad ( grid , config_flags & & ,DGNUM4D=grid%dgnum4d,DGNUMWET4D=grid%dgnumwet4d & !====================== #endif - & ,XLAND=grid%xland,SNOWH=grid%SNOW & + & ,XLAND=grid%xland,SNOWH=grid%SNOW,XICE=grid%XICE & & ,SPECIFIED=specified_bdy, CHANNEL_SWITCH=channel_bdy & & ,F_RAIN_PHY=grid%f_rain_phy & & ,F_RIMEF_PHY=grid%f_rimef_phy &