diff --git a/.gitignore b/.gitignore index c0852c1bdb..42e80e9e98 100644 --- a/.gitignore +++ b/.gitignore @@ -37,6 +37,7 @@ restart_timestamp # Text files (For statistical output from ocean model) *.txt +!CMakeLists.txt # Directories with individual .gitignore files are: # src/external (Externals might have a different compilation method) @@ -47,8 +48,8 @@ restart_timestamp *.TBL *DATA* -# Ignore MPAS core build files. -.mpas_core_* +# Files for detecting whether builds of cores or shared framework can be reused +.build_opts* # Ignore all runtime config files namelist.* diff --git a/CMakeLists.txt b/CMakeLists.txt new file mode 100644 index 0000000000..6f213c9145 --- /dev/null +++ b/CMakeLists.txt @@ -0,0 +1,160 @@ +## MPAS-Model +cmake_minimum_required(VERSION 3.12) + +include(${CMAKE_CURRENT_SOURCE_DIR}/cmake/Functions/MPAS_Functions.cmake) +get_mpas_version(MPAS_VERSION) +project(MPAS LANGUAGES C Fortran VERSION ${MPAS_VERSION} DESCRIPTION "MPAS - Model for Prediction Across Scales") + +list(INSERT CMAKE_MODULE_PATH 0 ${CMAKE_CURRENT_SOURCE_DIR}/cmake/Modules) +set(CMAKE_DIRECTORY_LABELS ${PROJECT_NAME}) +include(GNUInstallDirs) + +# Options +set(MPAS_ALL_CORES atmosphere init_atmosphere) +set(MPAS_CORES atmosphere CACHE STRING "MPAS cores to build. Options: ${MPAS_ALL_CORES}") +if(MPAS_CORES MATCHES " ") #Convert strings separated with spaces to CMake list separated with ';' + string(REPLACE " " ";" MPAS_CORES ${MPAS_CORES}) + set(MPAS_CORES ${MPAS_CORES} CACHE STRING "MPAS cores to build. Options: ${MPAS_ALL_CORES}" FORCE) +endif() +option(DO_PHYSICS "Use built-in physics schemes." TRUE) +option(MPAS_DOUBLE_PRECISION "Use double precision 64-bit Floating point." TRUE) +option(MPAS_PROFILE "Enable GPTL profiling" OFF) +option(MPAS_OPENMP "Enable OpenMP" OFF) +option(BUILD_SHARED_LIBS "Build shared libraries" ON) + +message(STATUS "[OPTION] MPAS_CORES: ${MPAS_CORES}") +message(STATUS "[OPTION] MPAS_DOUBLE_PRECISION: ${MPAS_DOUBLE_PRECISION}") +message(STATUS "[OPTION] MPAS_PROFILE: ${MPAS_PROFILE}") +message(STATUS "[OPTION] MPAS_OPENMP: ${MPAS_OPENMP}") +message(STATUS "[OPTION] BUILD_SHARED_LIBS: ${BUILD_SHARED_LIBS}") + +# Build product output locations +set(CMAKE_RUNTIME_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/bin) +set(CMAKE_LIBRARY_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/lib) +set(CMAKE_ARCHIVE_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/lib) + +# Set default build type to RelWithDebInfo +if(NOT CMAKE_BUILD_TYPE) + message(STATUS "Setting default build type to Release. Specify CMAKE_BUILD_TYPE to override.") + set(CMAKE_BUILD_TYPE "Release" CACHE STRING "CMake Build type" FORCE) + set_property(CACHE CMAKE_BUILD_TYPE PROPERTY STRINGS "Debug" "Release" "MinSizeRel" "RelWithDebInfo") +endif() + +# Detect MPAS git version +if(NOT MPAS_GIT_VERSION) + find_package(Git QUIET) + if(GIT_FOUND) + execute_process(COMMAND ${GIT_EXECUTABLE} describe --dirty + WORKING_DIRECTORY "${CMAKE_SOURCE_DIR}" + OUTPUT_VARIABLE _mpas_git_version + ERROR_QUIET OUTPUT_STRIP_TRAILING_WHITESPACE) + else() + set(_mpas_git_version "Unknown") + endif() + set(MPAS_GIT_VERSION ${_mpas_git_version} CACHE STRING "MPAS-Model git version") +endif() + +### Dependencies +find_package(OpenMP COMPONENTS Fortran) +find_package(MPI REQUIRED COMPONENTS Fortran) +find_package(NetCDF REQUIRED COMPONENTS Fortran C) +find_package(PnetCDF REQUIRED COMPONENTS Fortran) +find_package(PIO REQUIRED COMPONENTS Fortran C) +if(MPAS_PROFILE) + find_package(GPTL REQUIRED) +endif() + +# Find C pre-processor +if(CMAKE_C_COMPILER_ID MATCHES GNU) + find_program(CPP_EXECUTABLE NAMES cpp REQUIRED) + set(CPP_EXTRA_FLAGS -traditional) +elseif(CMAKE_C_COMPILER_ID MATCHES "(Apple)?Clang" ) + find_program(CPP_EXECUTABLE NAMES cpp REQUIRED) +else() + message(STATUS "Unknown compiler: ${CMAKE_C_COMPILER_ID}") + set(CPP_EXECUTABLE ${CMAKE_C_COMPILER}) +endif() + +## Common Variables + +# Fortran module output directory for build interface +set(MPAS_MODULE_DIR ${PROJECT_NAME}/module/${CMAKE_Fortran_COMPILER_ID}/${CMAKE_Fortran_COMPILER_VERSION}) +# Install Fortran module directory +install(DIRECTORY ${CMAKE_BINARY_DIR}/${MPAS_MODULE_DIR}/ DESTINATION ${CMAKE_INSTALL_LIBDIR}/${MPAS_MODULE_DIR}/) + +# Location of common subdriver module compiled by each cores +set(MPAS_MAIN_SRC ${CMAKE_CURRENT_SOURCE_DIR}/src/driver/mpas.F) +set(MPAS_SUBDRIVER_SRC ${CMAKE_CURRENT_SOURCE_DIR}/src/driver/mpas_subdriver.F) + +## Create targets +add_subdirectory(src/external/ezxml) # Target: MPAS::external::ezxml +if(ESMF_FOUND) + message(STATUS "Configure MPAS for external ESMF") + add_definitions(-DMPAS_EXTERNAL_ESMF_LIB -DMPAS_NO_ESMF_INIT) + add_library(${PROJECT_NAME}::external::esmf ALIAS esmf) +else() + message(STATUS "Configure MPAS for internal ESMF") + add_subdirectory(src/external/esmf_time_f90) # Target: MPAS::external::esmf_time +endif() +add_subdirectory(src/tools/input_gen) # Targets: namelist_gen, streams_gen +add_subdirectory(src/tools/registry) # Targets: mpas_parse_ +add_subdirectory(src/framework) # Target: MPAS::framework +add_subdirectory(src/operators) # Target: MPAS::operators + +foreach(_core IN LISTS MPAS_CORES) + add_subdirectory(src/core_${_core}) # Target: MPAS::core:: +endforeach() + +### Package config +include(CMakePackageConfigHelpers) + +# Build-tree target exports +export(EXPORT ${PROJECT_NAME}ExportsExternal NAMESPACE ${PROJECT_NAME}::external:: FILE ${PROJECT_NAME}-targets-external.cmake) +export(EXPORT ${PROJECT_NAME}Exports NAMESPACE ${PROJECT_NAME}:: FILE ${PROJECT_NAME}-targets.cmake) +export(EXPORT ${PROJECT_NAME}ExportsCore NAMESPACE ${PROJECT_NAME}::core:: FILE ${PROJECT_NAME}-targets-core.cmake) + +# CMake Config file install location +set(CONFIG_INSTALL_DESTINATION ${CMAKE_INSTALL_LIBDIR}/cmake/${PROJECT_NAME}) +# Install MPAS-supplied Find.cmake modules for use by downstream CMake dependencies +install(DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR}/cmake/Modules DESTINATION ${CONFIG_INSTALL_DESTINATION}) + +## -config.cmake: build-tree +# Variables to export for use from build-tree +set(BINDIR ${CMAKE_BINARY_DIR}/bin) +set(CORE_DATADIR_ROOT ${CMAKE_BINARY_DIR}/${PROJECT_NAME}) +set(CMAKE_MODULE_INSTALL_PATH ${CMAKE_CURRENT_SOURCE_DIR}/cmake/Modules) +string(TOLOWER ${PROJECT_NAME} PROJECT_NAME_LOWER) +configure_package_config_file(cmake/PackageConfig.cmake.in ${PROJECT_NAME_LOWER}-config.cmake + INSTALL_DESTINATION . + INSTALL_PREFIX ${CMAKE_CURRENT_BINARY_DIR} + PATH_VARS BINDIR CORE_DATADIR_ROOT CMAKE_MODULE_INSTALL_PATH) + +## -config.cmake: install-tree +# Variables to export for use from install-tree +set(BINDIR ${CMAKE_INSTALL_BINDIR}) +set(CORE_DATADIR_ROOT ${CMAKE_INSTALL_DATADIR}/${PROJECT_NAME}) +set(CMAKE_MODULE_INSTALL_PATH ${CONFIG_INSTALL_DESTINATION}/Modules) +configure_package_config_file(cmake/PackageConfig.cmake.in install/${PROJECT_NAME_LOWER}-config.cmake + INSTALL_DESTINATION ${CONFIG_INSTALL_DESTINATION} + PATH_VARS BINDIR CORE_DATADIR_ROOT CMAKE_MODULE_INSTALL_PATH) +install(FILES ${CMAKE_CURRENT_BINARY_DIR}/install/${PROJECT_NAME_LOWER}-config.cmake + DESTINATION ${CONFIG_INSTALL_DESTINATION}) + +## -config-version.cmake +write_basic_package_version_file( + ${CMAKE_CURRENT_BINARY_DIR}/${PROJECT_NAME_LOWER}-config-version.cmake + VERSION ${PROJECT_VERSION} + COMPATIBILITY AnyNewerVersion) +install(FILES ${CMAKE_CURRENT_BINARY_DIR}/${PROJECT_NAME_LOWER}-config-version.cmake + DESTINATION ${CONFIG_INSTALL_DESTINATION}) + +## package-targets.cmake and package-targets-.cmake +install(EXPORT ${PROJECT_NAME}ExportsExternal NAMESPACE ${PROJECT_NAME}::external:: + FILE ${PROJECT_NAME_LOWER}-targets-external.cmake + DESTINATION ${CONFIG_INSTALL_DESTINATION}) +install(EXPORT ${PROJECT_NAME}Exports NAMESPACE ${PROJECT_NAME}:: + FILE ${PROJECT_NAME_LOWER}-targets.cmake + DESTINATION ${CONFIG_INSTALL_DESTINATION}) +install(EXPORT ${PROJECT_NAME}ExportsCore NAMESPACE ${PROJECT_NAME}::core:: + FILE ${PROJECT_NAME_LOWER}-targets-core.cmake + DESTINATION ${CONFIG_INSTALL_DESTINATION}) diff --git a/Makefile b/Makefile index 10e5d30beb..dfc2bfae57 100644 --- a/Makefile +++ b/Makefile @@ -154,7 +154,7 @@ nvhpc: # BUILDTARGET NVIDIA HPC SDK "FFLAGS_DEBUG = -O0 -g -Mbounds -Mchkptr -byteswapio -Mfree -Ktrap=divz,fp,inv,ovf -traceback" \ "CFLAGS_DEBUG = -O0 -g -traceback" \ "CXXFLAGS_DEBUG = -O0 -g -traceback" \ - "LDFLAGS_DEBUG = -O0 -g -Mbounds -Mchkptr -Ktrap=divz,fp,inv,ovf -traceback" \ + "LDFLAGS_DEBUG = -O0 -g -Mbounds -Ktrap=divz,fp,inv,ovf -traceback" \ "FFLAGS_OMP = -mp" \ "CFLAGS_OMP = -mp" \ "FFLAGS_ACC = -Mnofma -acc -gpu=cc70,cc80 -Minfo=accel" \ @@ -184,7 +184,7 @@ pgi: # BUILDTARGET PGI compiler suite "FFLAGS_DEBUG = -O0 -g -Mbounds -Mchkptr -byteswapio -Mfree -Ktrap=divz,fp,inv,ovf -traceback" \ "CFLAGS_DEBUG = -O0 -g -traceback" \ "CXXFLAGS_DEBUG = -O0 -g -traceback" \ - "LDFLAGS_DEBUG = -O0 -g -Mbounds -Mchkptr -Ktrap=divz,fp,inv,ovf -traceback" \ + "LDFLAGS_DEBUG = -O0 -g -Mbounds -Ktrap=divz,fp,inv,ovf -traceback" \ "FFLAGS_OMP = -mp" \ "CFLAGS_OMP = -mp" \ "FFLAGS_ACC = -Mnofma -acc -Minfo=accel" \ @@ -216,7 +216,7 @@ pgi-summit: # BUILDTARGET PGI compiler suite w/OpenACC options for ORNL Summit "FFLAGS_DEBUG = -O0 -g -Mbounds -Mchkptr -byteswapio -Mfree -Ktrap=divz,fp,inv,ovf -traceback" \ "CFLAGS_DEBUG = -O0 -g -traceback" \ "CXXFLAGS_DEBUG = -O0 -g -traceback" \ - "LDFLAGS_DEBUG = -O0 -g -Mbounds -Mchkptr -Ktrap=divz,fp,inv,ovf -traceback" \ + "LDFLAGS_DEBUG = -O0 -g -Mbounds -Ktrap=divz,fp,inv,ovf -traceback" \ "FFLAGS_OMP = -mp" \ "CFLAGS_OMP = -mp" \ "PICFLAG = -fpic" \ @@ -670,7 +670,7 @@ intel: # BUILDTARGET Intel oneAPI Fortran, C, and C++ compiler suite "FFLAGS_DEBUG = -g -convert big_endian -free -check all -fpe0 -traceback" \ "CFLAGS_DEBUG = -g -traceback" \ "CXXFLAGS_DEBUG = -g -traceback" \ - "LDFLAGS_DEBUG = -g -fpe0 -traceback" \ + "LDFLAGS_DEBUG = -g -check all -fpe0 -traceback" \ "FFLAGS_OMP = -qopenmp" \ "CFLAGS_OMP = -qopenmp" \ "PICFLAG = -fpic" \ @@ -958,28 +958,6 @@ else OPENACC_MESSAGE="MPAS was built without OpenACC accelerator support." endif -ifneq ($(wildcard .mpas_core_*), ) # CHECK FOR BUILT CORE - -ifneq ($(wildcard .mpas_core_$(CORE)), ) # CHECK FOR SAME CORE AS ATTEMPTED BUILD. - override AUTOCLEAN=false - CONTINUE=true -else - LAST_CORE=`cat .mpas_core_*` - -ifeq "$(AUTOCLEAN)" "true" # CHECK FOR CLEAN PRIOR TO BUILD OF A NEW CORE. - CONTINUE=true - AUTOCLEAN_MESSAGE="Infrastructure was cleaned prior to building ." -else - CONTINUE=false -endif # END OF AUTOCLEAN CHECK - -endif # END OF CORE=LAST_CORE CHECK - -else - - override AUTOCLEAN=false - CONTINUE=true -endif # END IF BUILT CORE CHECK ifneq ($(wildcard namelist.$(NAMELIST_SUFFIX)), ) # Check for generated namelist file. NAMELIST_MESSAGE="A default namelist file (namelist.$(NAMELIST_SUFFIX).defaults) has been generated, but namelist.$(NAMELIST_SUFFIX) has not been modified." @@ -1036,12 +1014,119 @@ report_builds: @echo "CORE=$(CORE)" endif -ifeq "$(CONTINUE)" "true" all: mpas_main -else -all: clean_core + endif +# +# The rebuild_check target determines whether the shared framework or $(CORE) were +# previously compiled with incompatible options, and stops the build with an error +# message if so. +# +rebuild_check: + @# + @# Write current build options to a file .build_opts.tmp, to later be + @# compared with build options use for the shared framework or core. + @# Only build options that affect compatibility are written, while options + @# like $(RM), $(BUILD_TARGET), and $(CORE) are not. + @# + $(shell printf "FC=$(FC)\n$\ + CC=$(CC)\n$\ + CXX=$(CXX)\n$\ + SFC=$(SFC)\n$\ + SCC=$(SCC)\n$\ + CFLAGS=$(CFLAGS)\n$\ + CXXFLAGS=$(CXXFLAGS)\n$\ + FFLAGS=$(FFLAGS)\n$\ + LDFLAGS=$(LDFLAGS)\n$\ + CPPFLAGS=$(CPPFLAGS)\n$\ + LIBS=$(LIBS)\n$\ + CPPINCLUDES=$(CPPINCLUDES)\n$\ + OPENMP=$(OPENMP)\n$\ + OPENMP_OFFLOAD=$(OPENMP_OFFLOAD)\n$\ + OPENACC=$(OPENACC)\n$\ + TAU=$(TAU)\n$\ + PICFLAG=$(PICFLAG)\n$\ + TIMER_LIB=$(TIMER_LIB)\n$\ + GEN_F90=$(GEN_F90)\n" | sed 's/-DMPAS_EXE_NAME=[^[:space:]]*//' | sed 's/-DMPAS_NAMELIST_SUFFIX=[^[:space:]]*//' | sed 's/-DCORE_[^[:space:]]*//' | sed 's/-DMPAS_GIT_VERSION=[^[:space:]]*//' > .build_opts.tmp ) + + @# + @# PREV_BUILD is set to "OK" if the shared framework and core are either + @# clean or were previously compiled with compatible options. Otherwise, + @# PREV_BUILD is set to "shared framework" if the shared framework was + @# built with incompatible options, or "$(CORE) core" if the core was + @# built with incompatible options. + @# + $(eval PREV_BUILD := $(shell $\ + if [ -f ".build_opts.framework" ]; then $\ + cmp -s .build_opts.tmp .build_opts.framework; $\ + if [ $$? -eq 0 ]; then $\ + stat=0; $\ + else $\ + stat=1; $\ + x="shared framework"; $\ + if [ "$(AUTOCLEAN)" = "true" ]; then $\ + cp .build_opts.tmp .build_opts.framework; $\ + fi; $\ + fi $\ + else $\ + stat=0; $\ + cp .build_opts.tmp .build_opts.framework; $\ + fi; $\ + : ; $\ + : At this this point, stat is already set, and we should only ; $\ + : set it to 1 but never to 0, as that might mask an incompatibility ; $\ + : in the framework build. ; $\ + : ; $\ + if [ -f ".build_opts.$(CORE)" ]; then $\ + cmp -s .build_opts.tmp .build_opts.$(CORE); $\ + if [ $$? -ne 0 ]; then $\ + stat=1; $\ + if [ "$$x" = "" ]; then $\ + x="$(CORE) core"; $\ + else $\ + x="$$x and $(CORE) core"; $\ + fi; $\ + if [ "$(AUTOCLEAN)" = "true" ]; then $\ + cp .build_opts.tmp .build_opts.$(CORE); $\ + fi; $\ + fi; $\ + else $\ + if [ $$stat -eq 0 ]; then $\ + cp .build_opts.tmp .build_opts.$(CORE); $\ + fi; $\ + fi; $\ + rm -f .build_opts.tmp; $\ + if [ $$stat -eq 1 ]; then $\ + printf "$$x"; $\ + else $\ + printf "OK"; $\ + fi; $\ + )) + + $(if $(findstring and,$(PREV_BUILD)),$(eval VERB=were),$(eval VERB=was)) +ifeq "$(AUTOCLEAN)" "true" + $(if $(findstring framework,$(PREV_BUILD)),$(eval AUTOCLEAN_DEPS+=clean_shared)) + $(if $(findstring core,$(PREV_BUILD)),$(eval AUTOCLEAN_DEPS+=clean_core)) + $(if $(findstring OK,$(PREV_BUILD)), $(eval override AUTOCLEAN=false), ) + $(eval AUTOCLEAN_MESSAGE=The $(PREV_BUILD) $(VERB) cleaned and re-compiled.) +else + $(if $(findstring OK,$(PREV_BUILD)), \ + , \ + $(info ************************************************************************) \ + $(info The $(PREV_BUILD) $(VERB) previously compiled with ) \ + $(info incompatible options. Please do one of the following:) \ + $(info ) \ + $(info - Clean the $(CORE) core, which will also cause the shared) \ + $(info framework to be cleaned; then compile the $(CORE) core.) \ + $(info ) \ + $(info or)\ + $(info ) \ + $(info - Add AUTOCLEAN=true to the build command to automatically clean) \ + $(info and re-compile the $(PREV_BUILD).) \ + $(info ) \ + $(info ************************************************************************) \ + $(error )) endif @@ -1289,19 +1374,15 @@ mpi_f08_test: $(if $(findstring 1,$(MPAS_MPI_F08)), $(info mpi_f08 module detected.)) ifneq "$(PIO)" "" -MAIN_DEPS = openmp_test openacc_test pio_test mpi_f08_test +MAIN_DEPS = rebuild_check openmp_test openacc_test pio_test mpi_f08_test override CPPFLAGS += "-DMPAS_PIO_SUPPORT" else -MAIN_DEPS = openmp_test openacc_test mpi_f08_test +MAIN_DEPS = rebuild_check openmp_test openacc_test mpi_f08_test IO_MESSAGE = "Using the SMIOL library." override CPPFLAGS += "-DMPAS_SMIOL_SUPPORT" endif - mpas_main: $(MAIN_DEPS) -ifeq "$(AUTOCLEAN)" "true" - $(RM) .mpas_core_* -endif cd src; $(MAKE) FC="$(FC)" \ CC="$(CC)" \ CXX="$(CXX)" \ @@ -1320,11 +1401,11 @@ endif FCINCLUDES="$(FCINCLUDES)" \ CORE="$(CORE)"\ AUTOCLEAN="$(AUTOCLEAN)" \ + AUTOCLEAN_DEPS="$(AUTOCLEAN_DEPS)" \ GEN_F90="$(GEN_F90)" \ NAMELIST_SUFFIX="$(NAMELIST_SUFFIX)" \ EXE_NAME="$(EXE_NAME)" - @echo "$(EXE_NAME)" > .mpas_core_$(CORE) if [ -e src/$(EXE_NAME) ]; then mv src/$(EXE_NAME) .; fi ( cd src/core_$(CORE); $(MAKE) ROOT_DIR="$(PWD)" post_build ) @echo "*******************************************************************************" @@ -1346,11 +1427,13 @@ endif @echo $(IO_MESSAGE) @echo "*******************************************************************************" clean: - cd src; $(MAKE) clean RM="$(RM)" CORE="$(CORE)" - $(RM) .mpas_core_* + cd src; $(MAKE) clean RM="$(RM)" CORE="$(CORE)" AUTOCLEAN="$(AUTOCLEAN)" $(RM) $(EXE_NAME) $(RM) namelist.$(NAMELIST_SUFFIX).defaults $(RM) streams.$(NAMELIST_SUFFIX).defaults + if [ -f .build_opts.framework ]; then $(RM) .build_opts.framework; fi + if [ -f .build_opts.$(CORE) ]; then $(RM) .build_opts.$(CORE); fi + core_error: @echo "" @echo "*******************************************************************************" @@ -1361,26 +1444,6 @@ core_error: exit 1 error: errmsg -clean_core: - @echo "" - @echo "*******************************************************************************" - @echo " The MPAS infrastructure is currently built for the $(LAST_CORE) core." - @echo " Before building the $(CORE) core, please do one of the following." - @echo "" - @echo "" - @echo " To remove the $(LAST_CORE)_model executable and clean the MPAS infrastructure, run:" - @echo " make clean CORE=$(LAST_CORE)" - @echo "" - @echo " To preserve all executables except $(CORE)_model and clean the MPAS infrastructure, run:" - @echo " make clean CORE=$(CORE)" - @echo "" - @echo " Alternatively, AUTOCLEAN=true can be appended to the make command to force a clean," - @echo " build a new $(CORE)_model executable, and preserve all other executables." - @echo "" - @echo "*******************************************************************************" - @echo "" - exit 1 - else # CORE IF all: error @@ -1408,7 +1471,7 @@ errmsg: @echo " DEBUG=true - builds debug version. Default is optimized version." @echo " USE_PAPI=true - builds version using PAPI for timers. Default is off." @echo " TAU=true - builds version using TAU hooks for profiling. Default is off." - @echo " AUTOCLEAN=true - forces a clean of infrastructure prior to build new core." + @echo " AUTOCLEAN=true - Enables automatic cleaning and re-compilation of code as needed." @echo " GEN_F90=true - Generates intermediate .f90 files through CPP, and builds with them." @echo " TIMER_LIB=opt - Selects the timer library interface to be used for profiling the model. Options are:" @echo " TIMER_LIB=native - Uses native built-in timers in MPAS" diff --git a/README.md b/README.md index 9823010d8b..b48f282e17 100644 --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -MPAS-v8.1.0 +MPAS-v8.2.0 ==== The Model for Prediction Across Scales (MPAS) is a collaborative project for diff --git a/cmake/Functions/MPAS_Functions.cmake b/cmake/Functions/MPAS_Functions.cmake new file mode 100644 index 0000000000..ee329691f5 --- /dev/null +++ b/cmake/Functions/MPAS_Functions.cmake @@ -0,0 +1,215 @@ +## +# get_mpas_version( ) +# +# Extracts the MPAS-Model project's version from the README.md file. +# The extracted version is a string following the format "X.Y.Z", where +# "X", "Y", and "Z" correspond to the major, minor, and patch versions +# respectively. +# +# Precondition: +# * README.md file needs to be in the current source directory. +# * README.md file should contain the project version formatted +# as "MPAS-vX.Y.Z". +# +# Postcondition: +# * If a match is found, will contain the version string, +# else it will be empty. +# +# Args: +# - The name of the variable that will hold the extracted version +# string. +# +# Example usage: +# get_mpas_version(MPAS_VERSION) +# message("MPAS Version: ${MPAS_VERSION}") +## +function(get_mpas_version mpas_version) + file(READ "${CMAKE_CURRENT_SOURCE_DIR}/README.md" readme_contents) + string(REGEX MATCH "MPAS-v([0-9]+\\.[0-9]+\\.[0-9]+)" _ ${readme_contents}) + set(${mpas_version} ${CMAKE_MATCH_1} PARENT_SCOPE) +endfunction() + +## +# mpas_fortran_target( ) +# +# Fortran configuration and options common to all MPAS Fortran targets +# +# * Installs common Fortan modules to a per-compiler-version directory +# * General Fortran formatting and configuration options +# * Per-compiler configuration and options +# * MPAS_DOUBLE_PRECISION related flags +# +# Args: +# - The name of the target to prepare +# + +function(mpas_fortran_target target) + # Fortran modules include path + set_target_properties(${target} PROPERTIES Fortran_MODULE_DIRECTORY ${CMAKE_BINARY_DIR}/${MPAS_MODULE_DIR}) + target_include_directories(${target} INTERFACE $ + $) + #Relocatable, portable, runtime dynamic linking + set_target_properties(${target} PROPERTIES INSTALL_RPATH "\$ORIGIN/../${CMAKE_INSTALL_LIBDIR}") + + # Global Fortran configuration + set_target_properties(${target} PROPERTIES Fortran_FORMAT FREE) + set(MPAS_FORTRAN_TARGET_COMPILE_DEFINITIONS + _MPI=1 + USE_PIO2=1 + ) + # Enable OpenMP support + if(MPAS_OPENMP) + target_link_libraries(${target} PUBLIC OpenMP::OpenMP_Fortran) + endif() + + # Compiler-specific options and flags + if(CMAKE_Fortran_COMPILER_ID MATCHES GNU) + list(APPEND MPAS_FORTRAN_TARGET_COMPILE_OPTIONS_PRIVATE + $<$:-ffree-line-length-none> + ) + list(APPEND MPAS_FORTRAN_TARGET_COMPILE_OPTIONS_PUBLIC + $<$:-fconvert=big-endian> + ) + + if(CMAKE_Fortran_COMPILER_VERSION VERSION_GREATER_EQUAL 10) + list(APPEND MPAS_FORTRAN_TARGET_COMPILE_OPTIONS_PRIVATE + $<$:-fallow-argument-mismatch> + $<$:-fallow-invalid-boz> + ) + endif() + if(MPAS_DOUBLE_PRECISION) + list(APPEND MPAS_FORTRAN_TARGET_COMPILE_OPTIONS_PRIVATE + $<$:-fdefault-real-8> $<$:-fdefault-double-8> + ) + else() + list(APPEND MPAS_FORTRAN_TARGET_COMPILE_DEFINITIONS SINGLE_PRECISION) + endif() + elseif(CMAKE_Fortran_COMPILER_ID MATCHES Intel) + list(APPEND MPAS_FORTRAN_TARGET_COMPILE_OPTIONS_PUBLIC + $<$:-align array64byte> + $<$:-convert big_endian> + ) + if(MPAS_DOUBLE_PRECISION) + list(APPEND MPAS_FORTRAN_TARGET_COMPILE_OPTIONS_PRIVATE + $<$:-real-size 64> + ) + else() + list(APPEND MPAS_FORTRAN_TARGET_COMPILE_DEFINITIONS SINGLE_PRECISION) + endif() + endif() + target_compile_definitions(${target} PRIVATE ${MPAS_FORTRAN_TARGET_COMPILE_DEFINITIONS}) + target_compile_options(${target} PRIVATE ${MPAS_FORTRAN_TARGET_COMPILE_OPTIONS_PRIVATE}) + target_compile_options(${target} PUBLIC ${MPAS_FORTRAN_TARGET_COMPILE_OPTIONS_PUBLIC}) +endfunction() + + +# mpas_core_target(CORE TARGET INCLUDE ) +# +# Common configuration and properties for `MPAS::core::` targets. +# * Calls mpas_fortran_target() for common Fortran target configuration. +# * Installs Fortran modules to a per-core directory and adds target include directories +# appropriate for build and install trees. +# * XML Processing, parsing and generation of includes, namelists and streams +# * Each core uses a core-specific parser executable +# * Links to MPAS::framework and MPAS::operators +# * Exports MPAS::core:: target alias for use by external dependencies +# * Installs core libraries modules and generated files. +# +# Args: +# CORE - Name of core +# TARGET - Name of core_target (without namespace) +# INCLUDES - List of generated include files +# +function(mpas_core_target) + cmake_parse_arguments(ARG "" "CORE;TARGET" "INCLUDES" ${ARGN}) + + mpas_fortran_target(${ARG_TARGET}) + + set_property(TARGET ${ARG_TARGET} APPEND PROPERTY SOURCES ${MPAS_SUBDRIVER_SRC}) + + string(TOUPPER "${ARG_TARGET}" TARGET) + set_target_properties(${ARG_TARGET} PROPERTIES OUTPUT_NAME mpas_${ARG_CORE}) + + #Fortran modules output location + set(CORE_MODULE_DIR ${MPAS_MODULE_DIR}/${ARG_TARGET}) + set_target_properties(${ARG_TARGET} PROPERTIES Fortran_MODULE_DIRECTORY ${CMAKE_BINARY_DIR}/${CORE_MODULE_DIR}) + target_include_directories(${ARG_TARGET} INTERFACE $ + $) + + #MPAS Specific option + target_compile_definitions(${ARG_TARGET} PRIVATE ${TARGET}=1) + + #Generated includes are included from either ./inc/ or ./ so we create a symlink in the build directory + #To handle the inc/ variety (sw, test, seaice) uniformly with the ./ variety (atmosphere, init_atmosphere) + add_custom_target(${ARG_CORE}_include_link ALL + COMMAND ${CMAKE_COMMAND} -E create_symlink ${CMAKE_CURRENT_BINARY_DIR} ${CMAKE_CURRENT_BINARY_DIR}/inc) + add_dependencies(${ARG_TARGET} ${ARG_CORE}_include_link) + target_include_directories(${ARG_TARGET} PUBLIC $) + + #Core-independent library dependencies + target_link_libraries(${ARG_TARGET} PUBLIC ${PROJECT_NAME}::operators ${PROJECT_NAME}::framework) + + #Define alias for external use + add_library(${PROJECT_NAME}::core::${ARG_CORE} ALIAS ${ARG_TARGET}) + + #Create main executable + add_executable(mpas_${ARG_CORE} ${MPAS_MAIN_SRC}) + mpas_fortran_target(mpas_${ARG_CORE}) + target_link_libraries(mpas_${ARG_CORE} PUBLIC ${PROJECT_NAME}::core::${ARG_CORE}) + + #Per-core generated output and tables directory location + set(CORE_DATADIR ${CMAKE_BINARY_DIR}/${PROJECT_NAME}/${ARG_TARGET}) + file(MAKE_DIRECTORY ${CORE_DATADIR}) + + #Process registry and generate includes, namelists, and streams + if(${ARG_CORE} STREQUAL "atmosphere" AND ${DO_PHYSICS}) + set(CPP_EXTRA_FLAGS ${CPP_EXTRA_FLAGS} -DDO_PHYSICS) + endif() + add_custom_command(OUTPUT Registry_processed.xml + COMMAND ${CPP_EXECUTABLE} -E -P ${CPP_EXTRA_FLAGS} ${CMAKE_CURRENT_SOURCE_DIR}/Registry.xml > Registry_processed.xml + COMMENT "CORE ${ARG_CORE}: Pre-Process Registry" + DEPENDS Registry.xml) + add_custom_command(OUTPUT ${ARG_INCLUDES} + COMMAND mpas_parse_${ARG_CORE} Registry_processed.xml + COMMENT "CORE ${ARG_CORE}: Parse Registry" + DEPENDS mpas_parse_${ARG_CORE} Registry_processed.xml) + add_custom_command(OUTPUT namelist.${ARG_CORE} + WORKING_DIRECTORY ${CORE_DATADIR} + COMMAND mpas_namelist_gen ${CMAKE_CURRENT_BINARY_DIR}/Registry_processed.xml namelist.${ARG_CORE} in_defaults=true + COMMENT "CORE ${ARG_CORE}: Generate Namelist" + DEPENDS mpas_namelist_gen Registry_processed.xml) + add_custom_command(OUTPUT streams.${ARG_CORE} + WORKING_DIRECTORY ${CORE_DATADIR} + COMMAND mpas_streams_gen ${CMAKE_CURRENT_BINARY_DIR}/Registry_processed.xml streams.${ARG_CORE} stream_list.${ARG_CORE}. listed + COMMENT "CORE ${ARG_CORE}: Generate Streams" + DEPENDS mpas_streams_gen Registry_processed.xml) + add_custom_target(gen_${ARG_CORE} DEPENDS ${ARG_INCLUDES} namelist.${ARG_CORE} streams.${ARG_CORE}) + add_dependencies(${ARG_TARGET} gen_${ARG_CORE}) + + #Install data and target library and executable + install(DIRECTORY ${CORE_DATADIR}/ DESTINATION ${CMAKE_INSTALL_DATADIR}/${PROJECT_NAME}/${ARG_TARGET} + FILES_MATCHING PATTERN "namelist.*" PATTERN "streams.*" PATTERN "stream_list.*" ) + install(TARGETS ${ARG_TARGET} EXPORT ${PROJECT_NAME}ExportsCore + ARCHIVE DESTINATION ${CMAKE_INSTALL_LIBDIR} + LIBRARY DESTINATION ${CMAKE_INSTALL_LIBDIR}) + install(TARGETS mpas_${ARG_CORE} + RUNTIME DESTINATION ${CMAKE_INSTALL_BINDIR}) +endfunction() + +## +# set_MPAS_DEBUG_flag( ) +# +# Sets the MPAS_DEBUG compile definition for a given target when the build type is Debug. +# +# Args: +# - The target for which the compile definition will be set +# +# Usage example: +# set_MPAS_DEBUG_flag(TARGET) +# This will define MPAS_DEBUG for the target TARGET during a Debug build +## +function(set_MPAS_DEBUG_flag target) + if(CMAKE_BUILD_TYPE MATCHES Debug) + target_compile_definitions(${target} PRIVATE MPAS_DEBUG) + endif() +endfunction() \ No newline at end of file diff --git a/cmake/Modules/FindGPTL.cmake b/cmake/Modules/FindGPTL.cmake new file mode 100644 index 0000000000..8e8014c337 --- /dev/null +++ b/cmake/Modules/FindGPTL.cmake @@ -0,0 +1,175 @@ +# FindGPTL.cmake +# +# Copyright UCAR 2020 +# +# Find the GPTL: General Purpose Timing Library (https://jmrosinski.github.io/GPTL/) +# +# This find module sets the following variables and targets: +# +# Variables: +# GPTL_FOUND - True if GPTL was found +# GPTL_VERSION_STRING - Version of installed GPTL +# GPTL_BIN_DIR - GPTL binary directory +# GPTL_HAS_PKG_CONFIG - GPTL was found with installed `gptl.pc` and pkg-config. This indicates full support +# for compiler and linker flags as exported by GPTL. +# Targets: +# GPTL::GPTL - Imported interface target to pass to target_link_libraries() +# +# NOTE: This find modules uses `pkg-config` to locate GPTL and glean the appropriate flags, directories, +# and link dependency ordering. For this to work, both a `pkg-config` executable and a `gptl.pc` +# config file need to be found. +# * To find the `pkg-config` executable, ensure it is on your PATH. +# * For non-standard locations the official CMake FindPkgConfig uses Cmake variable `PKG_CONFIG_EXECUTABLE` +# or environment variable `PKG_CONFIG`. See: https://cmake.org/cmake/help/latest/module/FindPkgConfig.html +# * To find `gptl.pc` ensure it is on the (colon-separated) directories listed in standard pkg-config +# environment variable `PKG_CONFIG_PATH`. +# * See: https://linux.die.net/man/1/pkg-config +# * A working GPTL pkg-config install can be confirmed on the command line, e.g., +# ``` +# $ pkg-config --modversion gptl +# 8.0.2 +# ``` +# To set a non-standard location for GPTL, ensure the correct `gptl.pc` pkg config file is found first +# on the environment's `PKG_CONFIG_PATH`. This can be checked with the pkg-config executable, e.g., +# ``` +# $ pkg-config --variable=prefix gptl +# /usr/local +# ``` +# Only when pkg-config is not supported or available, GPTL will be searched by the standard CMake search procedures. +# Set environment or CMake variable GPTL_ROOT to control this search. The GPTL_ROOT variable will have no effect +# if GPTL_HAS_PKG_CONFIG=True. +# + +find_package(PkgConfig QUIET) +if(PKG_CONFIG_FOUND) + message(DEBUG "[FindGPTL] Using PKG_CONFIG_EXECUTABLE:${PKG_CONFIG_EXECUTABLE}") +endif() + +#Helper: +#check_pkg_config(ret_var pcname pcflags...) +# Check if pcname is known to pkg-config +# Returns: +# Boolean: true if ${pcname}.pc file is found by pkg-config). +# Args: +# ret_var: return variable name. +# pcname: pkg-config name to look for (.pc file) +function(check_pkg_config ret_var pcname) + if(NOT PKG_CONFIG_FOUND OR NOT EXISTS ${PKG_CONFIG_EXECUTABLE}) + set(${ret_var} False PARENT_SCOPE) + else() + execute_process(COMMAND ${PKG_CONFIG_EXECUTABLE} --exists ${pcname} RESULT_VARIABLE _found) + if(_found EQUAL 0) + set(${ret_var} True PARENT_SCOPE) + else() + set(${ret_var} False PARENT_SCOPE) + endif() + endif() +endfunction() + +#Helper: +#get_pkg_config(ret_var pcname pcflags...) +# Get the output of pkg-config +# Args: +# ret_var: return variable name +# pcname: pkg-config name to look for (.pc file) +# pcflags: pkg-config flags to pass +function(get_pkg_config ret_var pcname pcflags) + execute_process(COMMAND ${PKG_CONFIG_EXECUTABLE} ${ARGN} ${pcname} ${pcflags} OUTPUT_VARIABLE _out RESULT_VARIABLE _ret OUTPUT_STRIP_TRAILING_WHITESPACE) + if(_ret EQUAL 0) + separate_arguments(_out) + set(${ret_var} ${_out} PARENT_SCOPE) + else() + set(${ret_var} "" PARENT_SCOPE) + endif() +endfunction() + +check_pkg_config(GPTL_HAS_PKG_CONFIG gptl) +if(GPTL_HAS_PKG_CONFIG) + #Use pkg-config to find the prefix, flags, directories, executables, and libraries + get_pkg_config(GPTL_VERSION_STRING gptl --modversion) + get_pkg_config(GPTL_PREFIX gptl --variable=prefix) + get_pkg_config(GPTL_INCLUDE_DIR gptl --cflags-only-I) + if(EXISTS GPTL_INCLUDE_DIR) + string(REGEX REPLACE "-I([^ ]+)" "\\1;" GPTL_INCLUDE_DIR ${GPTL_INCLUDE_DIR}) #Remove -I + else() + find_path(GPTL_INCLUDE_DIR NAMES gptl.h PATH_SUFFIXES include include/gptl PATHS ${GPTL_PREFIX} NO_DEFAULT_PATH) + endif() + find_path(GPTL_MODULE_DIR NAMES gptl.mod PATH_SUFFIXES include include/gptl module module/gptl PATHS ${GPTL_PREFIX} NO_DEFAULT_PATH) + get_pkg_config(GPTL_COMPILE_OPTIONS gptl --cflags-only-other) + get_pkg_config(GPTL_LINK_LIBRARIES gptl --libs-only-l) + get_pkg_config(GPTL_LINK_DIRECTORIES gptl --libs-only-L) + if(GPTL_LINK_DIRECTORIES) + string(REGEX REPLACE "-L([^ ]+)" "\\1;" GPTL_LINK_DIRECTORIES ${GPTL_LINK_DIRECTORIES}) #Remove -L + endif() + get_pkg_config(GPTL_LINK_OPTIONS gptl --libs-only-other) + find_library(GPTL_LIBRARY NAMES gptl PATH_SUFFIXES lib lib64 PATHS ${GPTL_PREFIX} NO_DEFAULT_PATH) + find_path(GPTL_BIN_DIR NAMES gptl_avail PATH_SUFFIXES bin PATHS ${GPTL_PREFIX} NO_DEFAULT_PATH) +else() + #Attempt to find GPTL without pkg-config as last resort. + message(WARNING "\ +FindGPTL: The `pkg-config` executable was not found. Ensure it is on your path or set \ +environment variable PKG_CONFIG to your pkg-config executable. \ +Attempting to find GPTL without pkg-config support may cause some required compiler and linker options to be unset.") + + find_path(GPTL_INCLUDE_DIR NAMES gptl.h PATH_SUFFIXES include include/gptl) + find_path(GPTL_MODULE_DIR NAMES gptl.mod PATH_SUFFIXES include include/gptl module module/gptl) + find_library(GPTL_LIBRARY NAMES gptl PATH_SUFFIXES lib lib64) + find_path(GPTL_BIN_DIR NAMES gptl_avail PATH_SUFFIXES bin) +endif() + +#Hide non-documented cache variables reserved for internal/advanced usage +mark_as_advanced( GPTL_INCLUDE_DIR + GPTL_MODULE_DIR + GPTL_LIBRARY ) + +#Debugging output +message(DEBUG "[FindGPTL] GPTL_FOUND: ${GPTL_FOUND}") +message(DEBUG "[FindGPTL] GPTL_VERSION_STRING: ${GPTL_VERSION_STRING}") +message(DEBUG "[FindGPTL] GPTL_HAS_PKG_CONFIG: ${GPTL_HAS_PKG_CONFIG}") +message(DEBUG "[FindGPTL] GPTL_PREFIX: ${GPTL_PREFIX}") +message(DEBUG "[FindGPTL] GPTL_BIN_DIR: ${GPTL_BIN_DIR}") +message(DEBUG "[FindGPTL] GPTL_INCLUDE_DIR: ${GPTL_INCLUDE_DIR}") +message(DEBUG "[FindGPTL] GPTL_MODULE_DIR: ${GPTL_MODULE_DIR}") +message(DEBUG "[FindGPTL] GPTL_LIBRARY: ${GPTL_LIBRARY}") +message(DEBUG "[FindGPTL] GPTL_LINK_LIBRARIES: ${GPTL_LINK_LIBRARIES}") +message(DEBUG "[FindGPTL] GPTL_LINK_DIRECTORIES: ${GPTL_LINK_DIRECTORIES}") +message(DEBUG "[FindGPTL] GPTL_LINK_OPTIONS: ${GPTL_LINK_OPTIONS}") + +#Check package has been found correctly +include(FindPackageHandleStandardArgs) +find_package_handle_standard_args( + GPTL + REQUIRED_VARS + GPTL_LIBRARY + GPTL_INCLUDE_DIR + GPTL_MODULE_DIR + GPTL_BIN_DIR + VERSION_VAR + GPTL_VERSION_STRING +) + +#Create GPTL::GPTL imported interface target +if(GPTL_FOUND AND NOT TARGET GPTL::GPTL) + add_library(GPTL::GPTL INTERFACE IMPORTED) + set_property(TARGET GPTL::GPTL PROPERTY INTERFACE_INCLUDE_DIRECTORIES ${GPTL_INCLUDE_DIR}) + if(GPTL_MODULE_DIR) + set_property(TARGET GPTL::GPTL APPEND PROPERTY INTERFACE_INCLUDE_DIRECTORIES ${GPTL_MODULE_DIR}) + endif() + if(GPTL_COMPILE_OPTIONS) + set_property(TARGET GPTL::GPTL PROPERTY INTERFACE_COMPILE_OPTIONS ${GPTL_COMPILE_OPTIONS}) + endif() + if(GPTL_LINK_DIRECTORIES) + set_property(TARGET GPTL::GPTL PROPERTY INTERFACE_LINK_DIRECTORIES ${GPTL_LINK_DIRECTORIES}) + endif() + if(GPTL_LINK_OPTIONS) + set_property(TARGET GPTL::GPTL PROPERTY INTERFACE_LINK_OPTIONS ${GPTL_LINK_OPTIONS}) + endif() + if(GPTL_LINK_LIBRARIES) + set_property(TARGET GPTL::GPTL PROPERTY INTERFACE_LINK_LIBRARIES ${GPTL_LINK_LIBRARIES}) + else() + set_property(TARGET GPTL::GPTL PROPERTY INTERFACE_LINK_LIBRARIES ${GPTL_LIBRARY}) + get_filename_component(_lib_dir ${GPTL_LIBRARY} DIRECTORY) + set_property(TARGET GPTL::GPTL APPEND PROPERTY INTERFACE_LINK_DIRECTORIES ${_lib_dir}) + unset(_lib_dir) + endif() +endif() diff --git a/cmake/Modules/FindNetCDF.cmake b/cmake/Modules/FindNetCDF.cmake new file mode 100644 index 0000000000..f2fc6ac514 --- /dev/null +++ b/cmake/Modules/FindNetCDF.cmake @@ -0,0 +1,343 @@ +# (C) Copyright 2017-2020 UCAR +# +# This software is licensed under the terms of the Apache Licence Version 2.0 +# which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +# +# (C) Copyright 2011- ECMWF. +# +# This software is licensed under the terms of the Apache Licence Version 2.0 +# which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +# In applying this licence, ECMWF does not waive the privileges and immunities +# granted to it by virtue of its status as an intergovernmental organisation nor +# does it submit to any jurisdiction. +# +# Try to find NetCDF includes and library. +# Supports static and shared libaries and allows each component to be found in sepearte prefixes. +# +# This module defines +# +# - NetCDF_FOUND - System has NetCDF +# - NetCDF_INCLUDE_DIRS - the NetCDF include directories +# - NetCDF_VERSION - the version of NetCDF +# - NetCDF_CONFIG_EXECUTABLE - the netcdf-config executable if found +# - NetCDF_PARALLEL - Boolean True if NetCDF4 has parallel IO support via hdf5 and/or pnetcdf +# - NetCDF_HAS_PNETCDF - Boolean True if NetCDF4 has pnetcdf support +# +# Deprecated Defines +# - NetCDF_LIBRARIES - [Deprecated] Use NetCDF::NetCDF_ targets instead. +# +# +# Following components are available: +# +# - C - C interface to NetCDF (netcdf) +# - CXX - CXX4 interface to NetCDF (netcdf_c++4) +# - Fortran - Fortran interface to NetCDF (netcdff) +# +# For each component the following are defined: +# +# - NetCDF__FOUND - whether the component is found +# - NetCDF__LIBRARIES - the libraries for the component +# - NetCDF__LIBRARY_SHARED - Boolean is true if libraries for component are shared +# - NetCDF__INCLUDE_DIRS - the include directories for specified component +# - NetCDF::NetCDF_ - target of component to be used with target_link_libraries() +# +# The following paths will be searched in order if set in CMake (first priority) or environment (second priority) +# +# - NetCDF_ROOT - root of NetCDF installation +# - NetCDF_PATH - root of NetCDF installation +# +# The search process begins with locating NetCDF Include headers. If these are in a non-standard location, +# set one of the following CMake or environment variables to point to the location: +# +# - NetCDF_INCLUDE_DIR or NetCDF_${comp}_INCLUDE_DIR +# - NetCDF_INCLUDE_DIRS or NetCDF_${comp}_INCLUDE_DIR +# +# Notes: +# +# - Use "NetCDF::NetCDF_" targets only. NetCDF_LIBRARIES exists for backwards compatibility and should not be used. +# - These targets have all the knowledge of include directories and library search directories, and a single +# call to target_link_libraries will provide all these transitive properties to your target. Normally all that is +# needed to build and link against NetCDF is, e.g.: +# target_link_libraries(my_c_tgt PUBLIC NetCDF::NetCDF_C) +# - "NetCDF" is always the preferred naming for this package, its targets, variables, and environment variables +# - For compatibility, some variables are also set/checked using alternate names NetCDF4, NETCDF, or NETCDF4 +# - Environments relying on these older environment variable names should move to using a "NetCDF_ROOT" environment variable +# - Preferred component capitalization follows the CMake LANGUAGES variables: i.e., C, Fortran, CXX +# - For compatibility, alternate capitalizations are supported but should not be used. +# - If no components are defined, all components will be searched +# + +list( APPEND _possible_components C CXX Fortran ) + +## Include names for each component +set( NetCDF_C_INCLUDE_NAME netcdf.h ) +set( NetCDF_CXX_INCLUDE_NAME netcdf ) +set( NetCDF_Fortran_INCLUDE_NAME netcdf.mod ) + +## Library names for each component +set( NetCDF_C_LIBRARY_NAME netcdf ) +set( NetCDF_CXX_LIBRARY_NAME netcdf_c++4 ) +set( NetCDF_Fortran_LIBRARY_NAME netcdff ) + +## Enumerate search components +foreach( _comp ${_possible_components} ) + string( TOUPPER "${_comp}" _COMP ) + set( _arg_${_COMP} ${_comp} ) + set( _name_${_COMP} ${_comp} ) +endforeach() + +set( _search_components C) +foreach( _comp ${${CMAKE_FIND_PACKAGE_NAME}_FIND_COMPONENTS} ) + string( TOUPPER "${_comp}" _COMP ) + set( _arg_${_COMP} ${_comp} ) + list( APPEND _search_components ${_name_${_COMP}} ) + if( NOT _name_${_COMP} ) + message(SEND_ERROR "Find${CMAKE_FIND_PACKAGE_NAME}: COMPONENT ${_comp} is not a valid component. Valid components: ${_possible_components}" ) + endif() +endforeach() +list( REMOVE_DUPLICATES _search_components ) + +## Search hints for finding include directories and libraries +foreach( _comp IN ITEMS "_" "_C_" "_Fortran_" "_CXX_" ) + foreach( _name IN ITEMS NetCDF4 NetCDF NETCDF4 NETCDF ) + foreach( _var IN ITEMS ROOT PATH ) + list(APPEND _search_hints ${${_name}${_comp}${_var}} $ENV{${_name}${_comp}${_var}} ) + list(APPEND _include_search_hints + ${${_name}${_comp}INCLUDE_DIR} $ENV{${_name}${_comp}INCLUDE_DIR} + ${${_name}${_comp}INCLUDE_DIRS} $ENV{${_name}${_comp}INCLUDE_DIRS} ) + endforeach() + endforeach() +endforeach() +#Old-school HPC module env variable names +foreach( _name IN ITEMS NetCDF4 NetCDF NETCDF4 NETCDF ) + foreach( _comp IN ITEMS "_C" "_Fortran" "_CXX" ) + list(APPEND _search_hints ${${_name}} $ENV{${_name}}) + list(APPEND _search_hints ${${_name}${_comp}} $ENV{${_name}${_comp}}) + endforeach() +endforeach() + +## Find headers for each component +set(NetCDF_INCLUDE_DIRS) +set(_new_search_components) +foreach( _comp IN LISTS _search_components ) + if(NOT ${PROJECT_NAME}_NetCDF_${_comp}_FOUND) + list(APPEND _new_search_components ${_comp}) + endif() + find_file(NetCDF_${_comp}_INCLUDE_FILE + NAMES ${NetCDF_${_comp}_INCLUDE_NAME} + DOC "NetCDF ${_comp} include directory" + HINTS ${_include_search_hints} ${_search_hints} + PATH_SUFFIXES include include/netcdf + ) + mark_as_advanced(NetCDF_${_comp}_INCLUDE_FILE) + message(DEBUG "NetCDF_${_comp}_INCLUDE_FILE: ${NetCDF_${_comp}_INCLUDE_FILE}") + if( NetCDF_${_comp}_INCLUDE_FILE ) + get_filename_component(NetCDF_${_comp}_INCLUDE_FILE ${NetCDF_${_comp}_INCLUDE_FILE} ABSOLUTE) + get_filename_component(NetCDF_${_comp}_INCLUDE_DIR ${NetCDF_${_comp}_INCLUDE_FILE} DIRECTORY) + list(APPEND NetCDF_INCLUDE_DIRS ${NetCDF_${_comp}_INCLUDE_DIR}) + endif() +endforeach() +if(NetCDF_INCLUDE_DIRS) + list(REMOVE_DUPLICATES NetCDF_INCLUDE_DIRS) +endif() +set(NetCDF_INCLUDE_DIRS "${NetCDF_INCLUDE_DIRS}" CACHE STRING "NetCDF Include directory paths" FORCE) + +## Find n*-config executables for search components +foreach( _comp IN LISTS _search_components ) + if( _comp MATCHES "^(C)$" ) + set(_conf "c") + elseif( _comp MATCHES "^(Fortran)$" ) + set(_conf "f") + elseif( _comp MATCHES "^(CXX)$" ) + set(_conf "cxx4") + endif() + find_program( NetCDF_${_comp}_CONFIG_EXECUTABLE + NAMES n${_conf}-config + HINTS ${NetCDF_INCLUDE_DIRS} ${_include_search_hints} ${_search_hints} + PATH_SUFFIXES bin Bin ../bin ../../bin + DOC "NetCDF n${_conf}-config helper" ) + message(DEBUG "NetCDF_${_comp}_CONFIG_EXECUTABLE: ${NetCDF_${_comp}_CONFIG_EXECUTABLE}") +endforeach() + +set(_C_libs_flag --libs) +set(_Fortran_libs_flag --flibs) +set(_CXX_libs_flag --libs) +set(_C_includes_flag --includedir) +set(_Fortran_includes_flag --includedir) +set(_CXX_includes_flag --includedir) +function(netcdf_config exec flag output_var) + set(${output_var} False PARENT_SCOPE) + if( exec ) + execute_process( COMMAND ${exec} ${flag} RESULT_VARIABLE _ret OUTPUT_VARIABLE _val) + if( _ret EQUAL 0 ) + string( STRIP ${_val} _val ) + set( ${output_var} ${_val} PARENT_SCOPE ) + endif() + endif() +endfunction() + +## Find libraries for each component +set( NetCDF_LIBRARIES ) +foreach( _comp IN LISTS _search_components ) + string( TOUPPER "${_comp}" _COMP ) + + find_library( NetCDF_${_comp}_LIBRARY + NAMES ${NetCDF_${_comp}_LIBRARY_NAME} + DOC "NetCDF ${_comp} library" + HINTS ${NetCDF_${_comp}_INCLUDE_DIRS} ${_search_hints} + PATH_SUFFIXES lib64 lib ../lib64 ../lib ../../lib64 ../../lib ) + mark_as_advanced( NetCDF_${_comp}_LIBRARY ) + get_filename_component(NetCDF_${_comp}_LIBRARY ${NetCDF_${_comp}_LIBRARY} ABSOLUTE) + set(NetCDF_${_comp}_LIBRARY ${NetCDF_${_comp}_LIBRARY} CACHE STRING "NetCDF ${_comp} library" FORCE) + message(DEBUG "NetCDF_${_comp}_LIBRARY: ${NetCDF_${_comp}_LIBRARY}") + + + if( NetCDF_${_comp}_LIBRARY ) + if( NetCDF_${_comp}_LIBRARY MATCHES ".a$" ) + set( NetCDF_${_comp}_LIBRARY_SHARED FALSE ) + set( _library_type STATIC) + else() + if( NOT ${NetCDF_${_comp}_LIBRARY} IN_LIST NetCDF_LIBRARIES ) + list( APPEND NetCDF_LIBRARIES ${NetCDF_${_comp}_LIBRARY} ) + message(DEBUG "Adding new netcdf library [${_comp}]: ${NetCDF_${_comp}_LIBRARY}") + endif() + set( NetCDF_${_comp}_LIBRARY_SHARED TRUE ) + set( _library_type SHARED) + endif() + endif() + + #Use nc-config to set per-component LIBRARIES variable if possible + netcdf_config( ${NetCDF_${_comp}_CONFIG_EXECUTABLE} ${_${_comp}_libs_flag} _val ) + if( _val ) + set( NetCDF_${_comp}_LIBRARIES ${_val} ) + if(NOT NetCDF_${_comp}_LIBRARY_SHARED AND NOT NetCDF_${_comp}_FOUND) #Static targets should use nc_config to get a proper link line with all necessary static targets. + list( APPEND NetCDF_LIBRARIES ${NetCDF_${_comp}_LIBRARIES} ) + endif() + else() + set( NetCDF_${_comp}_LIBRARIES ${NetCDF_${_comp}_LIBRARY} ) + if(NOT NetCDF_${_comp}_LIBRARY_SHARED) + message(SEND_ERROR "Unable to properly find NetCDF. Found static libraries at: ${NetCDF_${_comp}_LIBRARY} but could not run nc-config: ${NetCDF_CONFIG_EXECUTABLE}") + endif() + endif() + + #Use nc-config to set per-component INCLUDE_DIRS variable if possible + netcdf_config( ${NetCDF_${_comp}_CONFIG_EXECUTABLE} ${_${_comp}_includes_flag} _val ) + if( _val ) + string( REPLACE " " ";" _val ${_val} ) + set( NetCDF_${_comp}_INCLUDE_DIRS ${_val} ) + else() + set( NetCDF_${_comp}_INCLUDE_DIRS ${NetCDF_${_comp}_INCLUDE_DIR} ) + endif() + + if( NetCDF_${_comp}_LIBRARIES AND NetCDF_${_comp}_INCLUDE_DIRS ) + set( ${CMAKE_FIND_PACKAGE_NAME}_${_arg_${_COMP}}_FOUND TRUE ) + if (NOT TARGET NetCDF::NetCDF_${_comp}) + add_library(NetCDF::NetCDF_${_comp} ${_library_type} IMPORTED) + set_target_properties(NetCDF::NetCDF_${_comp} PROPERTIES + IMPORTED_LOCATION ${NetCDF_${_comp}_LIBRARY} + INTERFACE_INCLUDE_DIRECTORIES "${NetCDF_${_comp}_INCLUDE_DIRS}" + INTERFACE_LINK_LIBRARIES ${NetCDF_${_comp}_LIBRARIES} ) + endif() + endif() +endforeach() +set(NetCDF_LIBRARIES "${NetCDF_LIBRARIES}" CACHE STRING "NetCDF library targets" FORCE) + +## Find version via netcdf-config if possible +if (NetCDF_INCLUDE_DIRS) + if( NetCDF_C_CONFIG_EXECUTABLE ) + netcdf_config( ${NetCDF_C_CONFIG_EXECUTABLE} --version _vers ) + if( _vers ) + string(REGEX REPLACE ".* ((([0-9]+)\\.)+([0-9]+)).*" "\\1" NetCDF_VERSION "${_vers}" ) + endif() + else() + foreach( _dir IN LISTS NetCDF_INCLUDE_DIRS) + if( EXISTS "${_dir}/netcdf_meta.h" ) + file(STRINGS "${_dir}/netcdf_meta.h" _netcdf_version_lines + REGEX "#define[ \t]+NC_VERSION_(MAJOR|MINOR|PATCH|NOTE)") + string(REGEX REPLACE ".*NC_VERSION_MAJOR *\([0-9]*\).*" "\\1" _netcdf_version_major "${_netcdf_version_lines}") + string(REGEX REPLACE ".*NC_VERSION_MINOR *\([0-9]*\).*" "\\1" _netcdf_version_minor "${_netcdf_version_lines}") + string(REGEX REPLACE ".*NC_VERSION_PATCH *\([0-9]*\).*" "\\1" _netcdf_version_patch "${_netcdf_version_lines}") + string(REGEX REPLACE ".*NC_VERSION_NOTE *\"\([^\"]*\)\".*" "\\1" _netcdf_version_note "${_netcdf_version_lines}") + set(NetCDF_VERSION "${_netcdf_version_major}.${_netcdf_version_minor}.${_netcdf_version_patch}${_netcdf_version_note}") + unset(_netcdf_version_major) + unset(_netcdf_version_minor) + unset(_netcdf_version_patch) + unset(_netcdf_version_note) + unset(_netcdf_version_lines) + endif() + endforeach() + endif() +endif () + +## Detect additional package properties +netcdf_config(${NetCDF_C_CONFIG_EXECUTABLE} --has-parallel4 _val) +if( NOT _val MATCHES "^(yes|no)$" ) + netcdf_config(${NetCDF_C_CONFIG_EXECUTABLE} --has-parallel _val) +endif() +if( _val MATCHES "^(yes)$" ) + set(NetCDF_PARALLEL TRUE CACHE STRING "NetCDF has parallel IO capability via pnetcdf or hdf5." FORCE) +else() + set(NetCDF_PARALLEL FALSE CACHE STRING "NetCDF has no parallel IO capability." FORCE) +endif() + +## Finalize find_package +include(FindPackageHandleStandardArgs) + +if(NOT NetCDF_FOUND OR _new_search_components) + find_package_handle_standard_args( ${CMAKE_FIND_PACKAGE_NAME} + REQUIRED_VARS NetCDF_INCLUDE_DIRS NetCDF_LIBRARIES + VERSION_VAR NetCDF_VERSION + HANDLE_COMPONENTS ) +endif() + +foreach( _comp IN LISTS _search_components ) + if( NetCDF_${_comp}_FOUND ) + #Record found components to avoid duplication in NetCDF_LIBRARIES for static libraries + set(NetCDF_${_comp}_FOUND ${NetCDF_${_comp}_FOUND} CACHE BOOL "NetCDF ${_comp} Found" FORCE) + #Set a per-package, per-component found variable to communicate between multiple calls to find_package() + set(${PROJECT_NAME}_NetCDF_${_comp}_FOUND True) + endif() +endforeach() + +if( ${CMAKE_FIND_PACKAGE_NAME}_FOUND AND NOT ${CMAKE_FIND_PACKAGE_NAME}_FIND_QUIETLY AND _new_search_components) + message( STATUS "Find${CMAKE_FIND_PACKAGE_NAME} [${CMAKE_CURRENT_LIST_DIR}/FindNetCDF.cmake]:" ) + message( STATUS " - NetCDF_VERSION [${NetCDF_VERSION}]") + message( STATUS " - NetCDF_PARALLEL [${NetCDF_PARALLEL}]") + foreach( _comp IN LISTS _new_search_components ) + string( TOUPPER "${_comp}" _COMP ) + message( STATUS " - NetCDF_${_comp}_CONFIG_EXECUTABLE [${NetCDF_${_comp}_CONFIG_EXECUTABLE}]") + if( ${CMAKE_FIND_PACKAGE_NAME}_${_arg_${_COMP}}_FOUND ) + get_filename_component(_root ${NetCDF_${_comp}_INCLUDE_DIR}/.. ABSOLUTE) + if( NetCDF_${_comp}_LIBRARY_SHARED ) + message( STATUS " - NetCDF::NetCDF_${_comp} [SHARED] [Root: ${_root}] Lib: ${NetCDF_${_comp}_LIBRARY} ") + else() + message( STATUS " - NetCDF::NetCDF_${_comp} [STATIC] [Root: ${_root}] Lib: ${NetCDF_${_comp}_LIBRARY} ") + endif() + endif() + endforeach() +endif() + +foreach( _prefix NetCDF NetCDF4 NETCDF NETCDF4 ${CMAKE_FIND_PACKAGE_NAME} ) + set( ${_prefix}_INCLUDE_DIRS ${NetCDF_INCLUDE_DIRS} ) + set( ${_prefix}_LIBRARIES ${NetCDF_LIBRARIES}) + set( ${_prefix}_VERSION ${NetCDF_VERSION} ) + set( ${_prefix}_FOUND ${${CMAKE_FIND_PACKAGE_NAME}_FOUND} ) + set( ${_prefix}_CONFIG_EXECUTABLE ${NetCDF_CONFIG_EXECUTABLE} ) + set( ${_prefix}_PARALLEL ${NetCDF_PARALLEL} ) + + foreach( _comp ${_search_components} ) + string( TOUPPER "${_comp}" _COMP ) + set( _arg_comp ${_arg_${_COMP}} ) + set( ${_prefix}_${_comp}_FOUND ${${CMAKE_FIND_PACKAGE_NAME}_${_arg_comp}_FOUND} ) + set( ${_prefix}_${_COMP}_FOUND ${${CMAKE_FIND_PACKAGE_NAME}_${_arg_comp}_FOUND} ) + set( ${_prefix}_${_arg_comp}_FOUND ${${CMAKE_FIND_PACKAGE_NAME}_${_arg_comp}_FOUND} ) + + set( ${_prefix}_${_comp}_LIBRARIES ${NetCDF_${_comp}_LIBRARIES} ) + set( ${_prefix}_${_COMP}_LIBRARIES ${NetCDF_${_comp}_LIBRARIES} ) + set( ${_prefix}_${_arg_comp}_LIBRARIES ${NetCDF_${_comp}_LIBRARIES} ) + + set( ${_prefix}_${_comp}_INCLUDE_DIRS ${NetCDF_${_comp}_INCLUDE_DIRS} ) + set( ${_prefix}_${_COMP}_INCLUDE_DIRS ${NetCDF_${_comp}_INCLUDE_DIRS} ) + set( ${_prefix}_${_arg_comp}_INCLUDE_DIRS ${NetCDF_${_comp}_INCLUDE_DIRS} ) + endforeach() +endforeach() diff --git a/cmake/Modules/FindPIO.cmake b/cmake/Modules/FindPIO.cmake new file mode 100644 index 0000000000..4988264c46 --- /dev/null +++ b/cmake/Modules/FindPIO.cmake @@ -0,0 +1,181 @@ +# FindPIO.cmake +# +# Copyright UCAR 2020 +# +# Find PIO: A high-level Parallel I/O Library for structured grid applications +# https://github.com/NCAR/ParallelIO +# +# Components available for query: +# C - Has C support +# Fortran - Has Fortran support +# STATIC - Has static targets for supported LANG +# SHARED - Has shared targets for supported LANG +# +# Variables provided: +# PIO_FOUND - True if PIO was found +# PIO_VERSION - Version of installed PIO +# +# Targets provided: +# PIO::PIO_Fortran_STATIC - Fortran interface target for static libraries +# PIO::PIO_Fortran_SHARED - Fortran interface target for shared libraries +# PIO::PIO_Fortran - Fortran interface target alias to shared libraries if available else static libraries +# PIO::PIO_C_STATIC - C interface target for static libraries +# PIO::PIO_C_SHARED - C interface target for shared libraries +# PIO::PIO_C - C interface target alias to shared libraries if available else static libraries +# +# To control finding of this package, set PIO_ROOT environment variable to the full path to the prefix +# under which PIO was installed (e.g., /usr/local) +# + +## Find libraries and paths, and determine found components +find_path(PIO_INCLUDE_DIR NAMES pio.h HINTS "${PIO_PREFIX}" PATH_SUFFIXES include include/pio) +if(PIO_INCLUDE_DIR) + string(REGEX REPLACE "/include(/.+)?" "" PIO_PREFIX ${PIO_INCLUDE_DIR}) + set(PIO_PREFIX ${PIO_PREFIX} CACHE STRING "") + find_path(PIO_MODULE_DIR NAMES pio.mod PATHS "${PIO_PREFIX}" + PATH_SUFFIXES include include/pio lib/pio/module module module/pio NO_DEFAULT_PATH) + if(APPLE) + set(_SHARED_LIB_EXT .dylib) + else() + set(_SHARED_LIB_EXT .so) + endif() + find_library(PIO_C_STATIC_LIB libpioc.a PATHS "${PIO_PREFIX}" PATH_SUFFIXES lib lib64 NO_DEFAULT_PATH) + find_library(PIO_C_SHARED_LIB libpioc${_SHARED_LIB_EXT} PATHS "${PIO_PREFIX}" PATH_SUFFIXES lib lib64 NO_DEFAULT_PATH) + find_library(PIO_Fortran_STATIC_LIB libpiof.a PATHS "${PIO_PREFIX}" PATH_SUFFIXES lib lib64 NO_DEFAULT_PATH) + find_library(PIO_Fortran_SHARED_LIB libpiof${_SHARED_LIB_EXT} PATHS "${PIO_PREFIX}" PATH_SUFFIXES lib lib64 NO_DEFAULT_PATH) + unset(_SHARED_LIB_EXT) + + #Check for Fortran components + if(PIO_MODULE_DIR) + if(PIO_Fortran_STATIC_LIB) + set(PIO_Fortran_STATIC_FOUND 1) + endif() + if(PIO_Fortran_SHARED_LIB) + set(PIO_Fortran_SHARED_FOUND 1) + endif() + if(PIO_Fortran_STATIC_FOUND OR PIO_Fortran_SHARED_FOUND) + set(PIO_Fortran_FOUND 1) + endif() + endif() + #Check for C components + if(PIO_C_STATIC_LIB) + set(PIO_C_STATIC_FOUND 1) + endif() + if(PIO_C_SHARED_LIB) + set(PIO_C_SHARED_FOUND 1) + endif() + if(PIO_C_STATIC_FOUND OR PIO_C_SHARED_FOUND) + set(PIO_C_FOUND 1) + endif() + if(PIO_C_SHARED_FOUND AND (NOT PIO_Fortran_FOUND OR PIO_Fortran_SHARED_FOUND)) + set(PIO_SHARED_FOUND 1) + endif() + if(PIO_C_STATIC_FOUND AND (NOT PIO_Fortran_FOUND OR PIO_Fortran_STATIC_FOUND)) + set(PIO_STATIC_FOUND 1) + endif() +endif() + +## Debugging output +message(DEBUG "[FindPIO] PIO_INCLUDE_DIR: ${PIO_INCLUDE_DIR}") +message(DEBUG "[FindPIO] PIO_PREFIX: ${PIO_PREFIX}") +message(DEBUG "[FindPIO] PIO_MODULE_DIR: ${PIO_MODULE_DIR}") +message(DEBUG "[FindPIO] PIO_Fortran_STATIC_LIB: ${PIO_Fortran_STATIC_LIB}") +message(DEBUG "[FindPIO] PIO_Fortran_SHARED_LIB: ${PIO_Fortran_SHARED_LIB}") +message(DEBUG "[FindPIO] PIO_C_STATIC_LIB: ${PIO_C_STATIC_LIB}") +message(DEBUG "[FindPIO] PIO_C_SHARED_LIB: ${PIO_C_SHARED_LIB}") +message(DEBUG "[FindPIO] PIO_Fortran_FOUND: ${PIO_Fortran_FOUND}") +message(DEBUG "[FindPIO] PIO_C_FOUND: ${PIO_C_FOUND}") +message(DEBUG "[FindPIO] PIO_SHARED_FOUND: ${PIO_SHARED_FOUND}") +message(DEBUG "[FindPIO] PIO_STATIC_FOUND: ${PIO_STATIC_FOUND}") + +## Check package has been found correctly +include(FindPackageHandleStandardArgs) +find_package_handle_standard_args( + PIO + REQUIRED_VARS + PIO_PREFIX + PIO_INCLUDE_DIR + HANDLE_COMPONENTS +) +message(DEBUG "[FindPIO] PIO_FOUND: ${PIO_FOUND}") + +## Create targets +set(_new_components) + + +# PIO::PIO_Fortran_STATIC imported interface target +if(PIO_Fortran_FOUND AND PIO_STATIC_FOUND AND NOT TARGET PIO::PIO_Fortran_STATIC) + add_library(PIO::PIO_Fortran_STATIC INTERFACE IMPORTED) + set_target_properties(PIO::PIO_Fortran_STATIC PROPERTIES + INTERFACE_INCLUDE_DIRECTORIES ${PIO_INCLUDE_DIR} + INTERFACE_LINK_LIBRARIES ${PIO_Fortran_STATIC_LIB} + IMPORTED_GLOBAL True ) + if(PIO_MODULE_DIR AND NOT PIO_MODULE_DIR STREQUAL PIO_INCLUDE_DIR ) + set_property(TARGET PIO::PIO_Fortran_STATIC APPEND PROPERTY INTERFACE_INCLUDE_DIRECTORIES ${PIO_MODULE_DIR}) + endif() + target_link_libraries(PIO::PIO_Fortran_STATIC INTERFACE NetCDF::NetCDF_C) + set(_new_components 1) +endif() + +# PIO::PIO_Fortran_SHARED imported interface target +if(PIO_Fortran_FOUND AND PIO_SHARED_FOUND AND NOT TARGET PIO::PIO_Fortran_SHARED) + add_library(PIO::PIO_Fortran_SHARED INTERFACE IMPORTED) + set_target_properties(PIO::PIO_Fortran_SHARED PROPERTIES + INTERFACE_INCLUDE_DIRECTORIES ${PIO_INCLUDE_DIR} + INTERFACE_LINK_LIBRARIES ${PIO_Fortran_SHARED_LIB} + IMPORTED_GLOBAL True ) + if(PIO_MODULE_DIR AND NOT PIO_MODULE_DIR STREQUAL PIO_INCLUDE_DIR ) + set_property(TARGET PIO::PIO_Fortran_SHARED APPEND PROPERTY INTERFACE_INCLUDE_DIRECTORIES ${PIO_MODULE_DIR}) + endif() + set(_new_components 1) +endif() + +# PIO::PIO_C_STATIC imported interface target +if(PIO_C_FOUND AND PIO_STATIC_FOUND AND NOT TARGET PIO::PIO_C_STATIC) + add_library(PIO::PIO_C_STATIC INTERFACE IMPORTED) + set_target_properties(PIO::PIO_C_STATIC PROPERTIES + INTERFACE_INCLUDE_DIRECTORIES ${PIO_INCLUDE_DIR} + INTERFACE_LINK_LIBRARIES ${PIO_C_STATIC_LIB} + IMPORTED_GLOBAL True ) + target_link_libraries(PIO::PIO_C_STATIC INTERFACE NetCDF::NetCDF_C) + set(_new_components 1) +endif() + +# PIO::PIO_C_SHARED imported interface target +if(PIO_C_FOUND AND PIO_SHARED_FOUND AND NOT TARGET PIO::PIO_C_SHARED) + add_library(PIO::PIO_C_SHARED INTERFACE IMPORTED) + set_target_properties(PIO::PIO_C_SHARED PROPERTIES + INTERFACE_INCLUDE_DIRECTORIES ${PIO_INCLUDE_DIR} + INTERFACE_LINK_LIBRARIES ${PIO_C_SHARED_LIB} + IMPORTED_GLOBAL True ) + set(_new_components 1) +endif() + +# PIO::PIO_Fortran - Shared libraries if available, static otherwise +if(TARGET PIO::PIO_Fortran_SHARED) + add_library(PIO::PIO_Fortran ALIAS PIO::PIO_Fortran_SHARED) +elseif(TARGET PIO::PIO_Fortran_STATIC) + add_library(PIO::PIO_Fortran ALIAS PIO::PIO_Fortran_STATIC) +endif() + +# PIO::PIO_C - Shared libraries if available, static otherwise +if(TARGET PIO::PIO_C_SHARED) + add_library(PIO::PIO_C ALIAS PIO::PIO_C_SHARED) +elseif(TARGET PIO::PIO_C_STATIC) + add_library(PIO::PIO_C ALIAS PIO::PIO_C_STATIC) +endif() + +## Print status +if(${CMAKE_FIND_PACKAGE_NAME}_FOUND AND NOT ${CMAKE_FIND_PACKAGE_NAME}_FIND_QUIETLY AND _new_components) + message( STATUS "Find${CMAKE_FIND_PACKAGE_NAME}:" ) + message( STATUS " - ${CMAKE_FIND_PACKAGE_NAME}_PREFIX [${${CMAKE_FIND_PACKAGE_NAME}_PREFIX}]") + set(_found_comps) + foreach( _comp IN ITEMS Fortran C STATIC SHARED ) + if( ${CMAKE_FIND_PACKAGE_NAME}_${_comp}_FOUND ) + list(APPEND _found_comps ${_comp}) + endif() + endforeach() + message( STATUS " - ${CMAKE_FIND_PACKAGE_NAME} Components Found: ${_found_comps}") + unset(_found_comps) +endif() +unset(_new_components) diff --git a/cmake/Modules/FindPnetCDF.cmake b/cmake/Modules/FindPnetCDF.cmake new file mode 100644 index 0000000000..91a076ba57 --- /dev/null +++ b/cmake/Modules/FindPnetCDF.cmake @@ -0,0 +1,174 @@ +# FindPnetCDF.cmake +# +# Copyright UCAR 2020 +# +# Find PnetCDF: A Parallel I/O Library for NetCDF File Access +# https://parallel-netcdf.github.io/ +# +# Components available for query: +# C - Has C support +# CXX - Has CXX support +# Fortran - Has Fortran support +# NetCDF4 - Has NetCDF4 output support +# GPTL - Has profiling support with GPTL enabled +# Threads - Has thread safety enabled +# +# Variables provided: +# PnetCDF_FOUND - True if PnetCDFL was found +# PnetCDF_CONFIG_EXE - pnetcdf-config executable if found +# PnetCDF_VERSION - Version of installed PnetCDF +# PnetCDF_BIN_DIR - PnetCDF binary directory +# PnetCDF_DEBUG - True if PnetCDF is built in debug mode +# +# Targets provided: +# PnetCDF::PnetCDF_Fortran - Fortran interface target +# PnetCDF::PnetCDF_C - C interface target +# PnetCDF::PnetCDF_CXX - CXX interface target +# +# Functions provided: +# pnetcdf_get_config(ret_var flags) - Call `pnetcdf-config` with flags and set ret_var with output on execution success. +# +# +# This module requires the `pnetcdf-config` executable to detect the directories and compiler and linker flags +# necessary for the PnetCDF::PnetCDF target. To control where PnetCDF is found: +# * Option 1: Set an environment or cmake variable `PnetCDF_ROOT` to the install prefix for PnetCDF (e.g. /usr/local) +# * Option 2: Set an environment or cmake variable `PnetCDF_CONFIG_EXE` to the full path to the `pnetcdf-config` +# (e.g., /usr/local/bin/pnetcdf-config) +# + +find_program(PnetCDF_CONFIG_EXE NAMES pnetcdf-config PATH_SUFFIXES bin bin64 PATHS + $ENV{PnetCDF_CONFIG_EXE} ${PnetCDF_ROOT} $ENV{PnetCDF_ROOT} ${PNETCDF_ROOT} $ENV{PNETCDF_ROOT}) +message(DEBUG "[FindPnetCDF] Using PnetCDF_CONFIG_EXE:${PnetCDF_CONFIG_EXE}") + +# pnetcdf_get_config(ret_var flags...) +# Get the output of pnetcdf-config +# Args: +# ret_var: return variable name +# flags: flags to pass to pnetcdf-config +function(pnetcdf_get_config ret_var pcflags) + execute_process(COMMAND ${PnetCDF_CONFIG_EXE} ${pcflags} OUTPUT_VARIABLE _out RESULT_VARIABLE _ret OUTPUT_STRIP_TRAILING_WHITESPACE) + if(_ret EQUAL 0) + separate_arguments(_out) + set(${ret_var} ${_out} PARENT_SCOPE) + else() + set(${ret_var} "" PARENT_SCOPE) + endif() +endfunction() + +## Find libraries and paths, and determine found components +if(EXISTS ${PnetCDF_CONFIG_EXE}) + #Use pnetcdf-config to find the prefix, flags, directories, executables, and libraries + pnetcdf_get_config(PnetCDF_VERSION --version) + string(REGEX MATCH "([0-9.]+)" PnetCDF_VERSION "${PnetCDF_VERSION}") #Match only version actual number + + pnetcdf_get_config(PnetCDF_PREFIX --prefix) + pnetcdf_get_config(PnetCDF_CXX_FOUND --has-c++) + pnetcdf_get_config(PnetCDF_Fortran_FOUND --has-fortran) + pnetcdf_get_config(PnetCDF_NetCDF4_FOUND --netcdf4) + pnetcdf_get_config(PnetCDF_GPTL_FOUND --profiling) + pnetcdf_get_config(PnetCDF_Threads_FOUND --thread-safe) + pnetcdf_get_config(PnetCDF_DEBUG --debug) + pnetcdf_get_config(PnetCDF_INCLUDE_DIR --includedir) + pnetcdf_get_config(PnetCDF_LIB_DIR --libdir) + + #Translate boolean variables from pnetcdf-config enabled/disabled to True/False + foreach(_var IN ITEMS PnetCDF_CXX_FOUND PnetCDF_Fortran_FOUND PnetCDF_NetCDF4_FOUND PnetCDF_GPTL_FOUND PnetCDF_Threads_FOUND PnetCDF_DEBUG) + if( ${_var} MATCHES "(enabled)|([Yy][Ee][Ss])") + set(${_var} True) + else() + set(${_var} False) + endif() + endforeach() + + find_path(PnetCDF_MODULE_DIR NAMES pnetcdf.mod HINTS ${PnetCDF_PREFIX} ${PnetCDF_INCLUDE_DIR} + PATH_SUFFIXES include include/pnetcdf module module/pnetcdf lib/pnetcdf/module NO_DEFAULT_PATH) + if(PnetCDF_Fortran_FOUND AND NOT EXISTS ${PnetCDF_MODULE_DIR}) + message(WARNING "[PnetCDF] pnetcdf-config --has-fortran=yes, but could not find pnetcdf.mod. Set PnetCDF_MODULE_DIR to path containing pnetcdf.mod") + set(PnetCDF_Fortran_FOUND NO) + endif() + + if(PnetCDF_INCLUDE_DIR AND PnetCDF_LIB_DIR) + set(PnetCDF_C_FOUND True) + endif() + + find_path(PnetCDF_BIN_DIR NAMES pnetcdf-config PATH_SUFFIXES bin PATHS ${PnetCDF_PREFIX} NO_DEFAULT_PATH) + find_library(PnetCDF_LIBRARY NAMES pnetcdf PATH_SUFFIXES lib lib64 PATHS ${PnetCDF_PREFIX} NO_DEFAULT_PATH) + #Hide non-documented cache variables reserved for internal/advanced usage + mark_as_advanced( PnetCDF_MODULE_DIR PnetCDF_LIBRARY ) +endif() + +## Debugging output +message(DEBUG "[FindPnetCDF] PnetCDF_CONFIG_EXE: ${PnetCDF_CONFIG_EXE}") +message(DEBUG "[FindPnetCDF] PnetCDF_VERSION: ${PnetCDF_VERSION}") +message(DEBUG "[FindPnetCDF] PnetCDF_C_FOUND: ${PnetCDF_C_FOUND}") +message(DEBUG "[FindPnetCDF] PnetCDF_CXX_FOUND: ${PnetCDF_CXX_FOUND}") +message(DEBUG "[FindPnetCDF] PnetCDF_Fortran_FOUND: ${PnetCDF_Fortran_FOUND}") +message(DEBUG "[FindPnetCDF] PnetCDF_NetCDF4_FOUND: ${PnetCDF_NetCDF4_FOUND}") +message(DEBUG "[FindPnetCDF] PnetCDF_GPTL_FOUND: ${PnetCDF_GPTL_FOUND}") +message(DEBUG "[FindPnetCDF] PnetCDF_Threads_FOUND: ${PnetCDF_Threads_FOUND}") +message(DEBUG "[FindPnetCDF] PnetCDF_DEBUG: ${PnetCDF_DEBUG}") +message(DEBUG "[FindPnetCDF] PnetCDF_PREFIX: ${PnetCDF_PREFIX}") +message(DEBUG "[FindPnetCDF] PnetCDF_BIN_DIR: ${PnetCDF_BIN_DIR}") +message(DEBUG "[FindPnetCDF] PnetCDF_INCLUDE_DIR: ${PnetCDF_INCLUDE_DIR}") +message(DEBUG "[FindPnetCDF] PnetCDF_MODULE_DIR: ${PnetCDF_MODULE_DIR}") +message(DEBUG "[FindPnetCDF] PnetCDF_LIB_DIR: ${PnetCDF_LIB_DIR}") + +## Check package has been found correctly +include(FindPackageHandleStandardArgs) +find_package_handle_standard_args( + PnetCDF + REQUIRED_VARS + PnetCDF_CONFIG_EXE + PnetCDF_PREFIX + VERSION_VAR + PnetCDF_VERSION + HANDLE_COMPONENTS +) +message(DEBUG "[FindPnetCDF] PnetCDF_FOUND: ${PnetCDF_FOUND}") + +## Create targets +set(_new_components) + +# PnetCDF::PnetCDF_Fortran imported interface target +if(PnetCDF_Fortran_FOUND AND NOT TARGET PnetCDF::PnetCDF_Fortran) + add_library(PnetCDF::PnetCDF_Fortran INTERFACE IMPORTED) + set_target_properties(PnetCDF::PnetCDF_Fortran PROPERTIES INTERFACE_INCLUDE_DIRECTORIES ${PnetCDF_INCLUDE_DIR} + INTERFACE_LINK_DIRECTORIES ${PnetCDF_LIB_DIR}) + if(PnetCDF_MODULE_DIR AND NOT PnetCDF_MODULE_DIR STREQUAL PnetCDF_INCLUDE_DIR ) + set_property(TARGET PnetCDF::PnetCDF_Fortran APPEND PROPERTY INTERFACE_INCLUDE_DIRECTORIES ${PnetCDF_MODULE_DIR}) + endif() + set(_new_components 1) + target_link_libraries(PnetCDF::PnetCDF_Fortran INTERFACE -lpnetcdf) +endif() + +# PnetCDF::PnetCDF_C imported interface target +if(PnetCDF_C_FOUND AND NOT TARGET PnetCDF::PnetCDF_C) + add_library(PnetCDF::PnetCDF_C INTERFACE IMPORTED) + set_target_properties(PnetCDF::PnetCDF_C PROPERTIES INTERFACE_INCLUDE_DIRECTORIES ${PnetCDF_INCLUDE_DIR} + INTERFACE_LINK_DIRECTORIES ${PnetCDF_LIB_DIR}) + set(_new_components 1) +endif() + +# PnetCDF::PnetCDF_CXX imported interface target +if(PnetCDF_CXX_FOUND AND NOT TARGET PnetCDF::PnetCDF_CXX) + add_library(PnetCDF::PnetCDF_CXX INTERFACE IMPORTED) + set_target_properties(PnetCDF::PnetCDF_CXX PROPERTIES INTERFACE_INCLUDE_DIRECTORIES ${PnetCDF_INCLUDE_DIR} + INTERFACE_LINK_DIRECTORIES ${PnetCDF_LIB_DIR}) + set(_new_components 1) +endif() + +## Print status +if(${CMAKE_FIND_PACKAGE_NAME}_FOUND AND NOT ${CMAKE_FIND_PACKAGE_NAME}_FIND_QUIETLY AND _new_components) + message( STATUS "Find${CMAKE_FIND_PACKAGE_NAME}:" ) + message( STATUS " - ${CMAKE_FIND_PACKAGE_NAME}_VERSION [${${CMAKE_FIND_PACKAGE_NAME}_VERSION}]") + message( STATUS " - ${CMAKE_FIND_PACKAGE_NAME}_PREFIX [${${CMAKE_FIND_PACKAGE_NAME}_PREFIX}]") + set(_found_comps) + foreach( _comp IN ITEMS Fortran C CXX NetCDF4 GPTL Threads ) + if( ${CMAKE_FIND_PACKAGE_NAME}_${_comp}_FOUND ) + list(APPEND _found_comps ${_comp}) + endif() + endforeach() + message( STATUS " - ${CMAKE_FIND_PACKAGE_NAME} Components Found: ${_found_comps}") + unset(_found_comps) +endif() +unset(_new_components) diff --git a/cmake/PackageConfig.cmake.in b/cmake/PackageConfig.cmake.in new file mode 100644 index 0000000000..e7b8860c9c --- /dev/null +++ b/cmake/PackageConfig.cmake.in @@ -0,0 +1,121 @@ +@PACKAGE_INIT@ + +# @PROJECT_NAME@-config.cmake +# +# Valid Find COMPONENTS: +# * SHARED - Require shared libraries. +# * STATIC - Require static libraries. +# * DOUBLE_PRECISION - Find double precision libraries +# * PROFILE - True if GPTL profiling is enabled +# * OpenMP - True if OpenMP support is enabled +# * core_atmosphere - Find atmosphere core +# * core_init_atmosphere - Find init_atmosphere core +# * core_ocean - Find ocean core +# * core_landice - Find landice core +# * core_seaice - Find seaice core +# * core_sw - Find sw core +# * core_test - Find test core +# +# +# Output variables set: +# * @PROJECT_NAME@_VERSION - Version of install package +# * @PROJECT_NAME@_VERSION_MAJOR - Major version of install package +# * @PROJECT_NAME@_VERSION_MINOR - Minor version of install package +# * @PROJECT_NAME@_MODULES_Fortran_COMPILER_ID - Compiler used to generate Fortran Modules +# * @PROJECT_NAME@_MODULES_Fortran_COMPILER_VERSION - Compiler version used to generate Fortran Modules +# * @PROJECT_NAME@_CORE__DATADIR - Location for data files for core (namelist, streams, data tables, etc.) +# * @PROJECT_NAME@_BINDIR - Location for installed auxiliary binaries. +# + +# Imported interface targets provided: +# * @PROJECT_NAME@::core:: - Core targets +# * @PROJECT_NAME@::operators - Operators library target +# * @PROJECT_NAME@::framework - Framework library target +# * @PROJECT_NAME@::external::esmf - exmf_time library target +# * @PROJECT_NAME@::external::ezxml - ezxml library target +# + +# * @PROJECT_NAME@::@PROJECT_NAME@_shared - shared library target: + +#Include targets file. This will create IMPORTED target @PROJECT_NAME@ +string(TOLOWER @PROJECT_NAME@ _project_name_lower) +if(NOT TARGET @PROJECT_NAME@::framework) + include("${CMAKE_CURRENT_LIST_DIR}/${_project_name_lower}-targets-external.cmake") + include("${CMAKE_CURRENT_LIST_DIR}/${_project_name_lower}-targets.cmake") + include("${CMAKE_CURRENT_LIST_DIR}/${_project_name_lower}-targets-core.cmake") +endif() + +set(@PROJECT_NAME@_VERSION @PROJECT_VERSION@) +set(@PROJECT_NAME@_VERSION_MAJOR @PROJECT_VERSION_MAJOR@) +set(@PROJECT_NAME@_VERSION_MINOR @PROJECT_VERSION_MINOR@) + +#Export Fortran compiler version and check module compatibility +set(@PROJECT_NAME@_MODULES_Fortran_COMPILER_ID @CMAKE_Fortran_COMPILER_ID@) +set(@PROJECT_NAME@_MODULES_Fortran_COMPILER_VERSION @CMAKE_Fortran_COMPILER_VERSION@) +if(NOT @PROJECT_NAME@_MODULES_Fortran_COMPILER_ID STREQUAL CMAKE_Fortran_COMPILER_ID + OR NOT @PROJECT_NAME@_MODULES_Fortran_COMPILER_VERSION VERSION_EQUAL CMAKE_Fortran_COMPILER_VERSION) + message(SEND_ERROR "Package @PROJECT_NAME@ provides Fortran modules built with " + "${@PROJECT_NAME@_MODULES_Fortran_COMPILER_ID}-${@PROJECT_NAME@_MODULES_Fortran_COMPILER_VERSION} " + "but this build for ${PROJECT_NAME} uses incompatible compiler ${CMAKE_Fortran_COMPILER_ID}-${CMAKE_Fortran_COMPILER_VERSION}") +endif() + +set_and_check(@PROJECT_NAME@_BINDIR @PACKAGE_BINDIR@) +set_and_check(@PROJECT_NAME@_CMAKE_MODULE_PATH @PACKAGE_CMAKE_MODULE_INSTALL_PATH@) +set(CMAKE_MODULE_PATH ${@PROJECT_NAME@_CMAKE_MODULE_PATH} ${CMAKE_MODULE_PATH}) + +include(CMakeFindDependencyMacro) +if(@OpenMP_Fortran_FOUND@) #OpenMP_Fortran_FOUND + if(NOT OpenMP_Fortran_FOUND) + find_package(OpenMP REQUIRED COMPONENTS Fortran) + endif() + set(@PROJECT_NAME@_OpenMP_FOUND True) +endif() +if(NOT MPI_Fortran_FOUND) + find_package(MPI REQUIRED COMPONENTS Fortran) +endif() +if(NOT NetCDF_Fortran_FOUND) + find_package(NetCDF REQUIRED COMPONENTS Fortran) +endif() +find_package(PnetCDF REQUIRED COMPONENTS Fortran) +find_package(PIO REQUIRED COMPONENTS Fortran C) +if(@MPAS_PROFILE@) #MPAS_PROFILE + if(NOT GPTL_FOUND) + find_dependency(GPTL REQUIRED) + endif() + set(@PROJECT_NAME@_PROFILE_FOUND) +endif() + +if(@BUILD_SHARED_LIBS@) #BUILD_SHARED_LIBS + set(@PROJECT_NAME@_SHARED_FOUND True) +else() + set(@PROJECT_NAME@_STATIC_FOUND True) +endif() +if(@MPAS_DOUBLE_PRECISION@) #MPAS_DOUBLE_PRECISION + set(@PROJECT_NAME@_DOUBLE_PRECISION_FOUND True) +else() + set(@PROJECT_NAME@_DOUBLE_PRECISION_FOUND False) +endif() +set(MPAS_CORES @MPAS_CORES@) +foreach(_core IN LISTS MPAS_CORES) + string(TOUPPER ${_core} _CORE) + set_and_check(@PROJECT_NAME@_CORE_${_CORE}_DATADIR @PACKAGE_CORE_DATADIR_ROOT@/core_${_core}) + set(@PROJECT_NAME@_core_${_core}_FOUND True) +endforeach() + +check_required_components("@PROJECT_NAME@") + +## Print status +if(NOT @PROJECT_NAME@_FIND_QUIETLY) + #Get list of all found components for printing + set(_found_components) + set(_all_components SHARED STATIC PROFILE OpenMP DOUBLE_PRECISION core_atmosphere core_init_atmosphere core_landice core_ocean core_sw core_test) + foreach(_cmp IN LISTS _all_components) + if(@PROJECT_NAME@_${_cmp}_FOUND) + list(APPEND _found_components ${_cmp}) + endif() + endforeach() + + message(STATUS "Found @PROJECT_NAME@: (version: \"@PROJECT_VERSION@\") (components: ${_found_components})") + unset(_found_components) + unset(_all_components) +endif() diff --git a/src/Makefile b/src/Makefile index cc0cc020d9..b9c037c8cc 100644 --- a/src/Makefile +++ b/src/Makefile @@ -6,12 +6,6 @@ include Makefile.in.$(ESM) else -ifeq "$(AUTOCLEAN)" "true" -AUTOCLEAN_DEPS=clean_shared -else -AUTOCLEAN_DEPS= -endif - all: mpas mpas: $(AUTOCLEAN_DEPS) externals frame ops dycore drver @@ -45,18 +39,24 @@ dycore: $(AUTOCLEAN_DEPS) build_tools externals frame ops clean: clean_shared clean_core clean_core: +ifeq "$(AUTOCLEAN)" "true" + $(info ) + $(info *********************************************************************************************) + $(info The $(CORE) core will be cleaned and re-compiled.) + $(info *********************************************************************************************) + $(info ) +endif if [ -d core_$(CORE) ] ; then \ ( cd core_$(CORE); $(MAKE) clean ) \ fi; clean_shared: ifeq "$(AUTOCLEAN)" "true" - @echo "" - @echo "*********************************************************************************************" - @echo "The MPAS infrastructure is currently built for a core different from $(CORE)." - @echo "The infrastructure will be cleaned and re-built for the $(CORE) core." - @echo "*********************************************************************************************" - @echo "" + $(info ) + $(info *********************************************************************************************) + $(info The infrastructure will be cleaned and re-compiled.) + $(info *********************************************************************************************) + $(info ) endif $(RM) libframework.a libops.a libdycore.a lib$(CORE).a *.o ( cd tools; $(MAKE) clean ) diff --git a/src/core_atmosphere/CMakeLists.txt b/src/core_atmosphere/CMakeLists.txt new file mode 100644 index 0000000000..9563fcac87 --- /dev/null +++ b/src/core_atmosphere/CMakeLists.txt @@ -0,0 +1,200 @@ + +## Source files +# physics/ +set(ATMOSPHERE_CORE_PHYSICS_SOURCES + ccpp_kinds.F + mpas_atmphys_camrad_init.F + mpas_atmphys_constants.F + mpas_atmphys_control.F + mpas_atmphys_date_time.F + mpas_atmphys_driver_cloudiness.F + mpas_atmphys_driver_microphysics.F + mpas_atmphys_driver_oml.F + mpas_atmphys_finalize.F + mpas_atmphys_functions.F + mpas_atmphys_init_microphysics.F + mpas_atmphys_interface.F + mpas_atmphys_landuse.F + mpas_atmphys_lsm_noahinit.F + mpas_atmphys_manager.F + mpas_atmphys_o3climatology.F + mpas_atmphys_rrtmg_lwinit.F + mpas_atmphys_rrtmg_swinit.F + mpas_atmphys_update.F + mpas_atmphys_update_surface.F + mpas_atmphys_utilities.F + mpas_atmphys_driver.F + mpas_atmphys_driver_convection.F + mpas_atmphys_driver_gwdo.F + mpas_atmphys_driver_lsm.F + mpas_atmphys_driver_pbl.F + mpas_atmphys_driver_radiation_lw.F + mpas_atmphys_driver_radiation_sw.F + mpas_atmphys_driver_seaice.F + mpas_atmphys_driver_sfclayer.F + mpas_atmphys_init.F + mpas_atmphys_lsm_shared.F + mpas_atmphys_packages.F + mpas_atmphys_todynamics.F + mpas_atmphys_vars.F +) +list(TRANSFORM ATMOSPHERE_CORE_PHYSICS_SOURCES PREPEND physics/) + +## Unused +# physics/physics_wrf/ +set(ATMOSPHERE_CORE_PHYSICS_WRF_SOURCES + libmassv.F + module_bep_bem_helper.F + module_bl_gwdo.F + module_bl_ysu.F + module_cam_error_function.F + module_cam_shr_kind_mod.F + module_cam_support.F + module_cu_gf.mpas.F + module_mp_kessler.F + module_mp_radar.F + module_mp_thompson.F + module_mp_thompson_cldfra3.F + module_mp_wsm6.F + module_ra_cam_support.F + module_ra_rrtmg_lw.F + module_ra_rrtmg_sw.F + module_ra_rrtmg_vinterp.F + module_sf_bem.F + module_sf_bep.F + module_sf_bep_bem.F + module_sf_noah_seaice.F + module_sf_noah_seaice_drv.F + module_sf_noahdrv.F + module_sf_noahlsm.F + module_sf_noahlsm_glacial_only.F + module_sf_oml.F + module_sf_sfcdiags.F + module_sf_sfclay.F + module_sf_sfclayrev.F + module_sf_urban.F + bl_mynn_post.F + bl_mynn_pre.F + module_bl_mynn.F + module_cu_kfeta.F + module_cu_ntiedtke.F + module_cu_tiedtke.F + module_ra_cam.F + module_sf_mynn.F + sf_mynn_pre.F +) + +list(TRANSFORM ATMOSPHERE_CORE_PHYSICS_WRF_SOURCES PREPEND physics/physics_wrf/) + +set(ATMOSPHERE_CORE_PHYSICS_MMM_SOURCES + bl_gwdo.F + bl_ysu.F + cu_ntiedtke.F + module_libmassv.F + mp_wsm6.F + mp_wsm6_effectRad.F + bl_mynn.F + bl_mynn_subroutines.F + mp_radar.F + mynn_shared.F + sf_mynn.F + sf_sfclayrev.F +) + +list(TRANSFORM ATMOSPHERE_CORE_PHYSICS_MMM_SOURCES PREPEND physics/physics_mmm/) + +# diagnostics/ +set(ATMOSPHERE_CORE_DIAGNOSTIC_SOURCES + mpas_atm_diagnostic_template.F + mpas_atm_diagnostics_manager.F + mpas_atm_diagnostics_utils.F + mpas_cloud_diagnostics.F + mpas_convective_diagnostics.F + mpas_isobaric_diagnostics.F + mpas_pv_diagnostics.F + mpas_soundings.F +) + +list(TRANSFORM ATMOSPHERE_CORE_DIAGNOSTIC_SOURCES PREPEND diagnostics/) + +# dynamics/ +set(ATMOSPHERE_CORE_DYNAMICS_SOURCES + mpas_atm_boundaries.F + mpas_atm_iau.F + mpas_atm_time_integration.F) +list(TRANSFORM ATMOSPHERE_CORE_DYNAMICS_SOURCES PREPEND dynamics/) + +# utils/ +set(ATMOSPHERE_CORE_UTILS_SOURCES + atmphys_build_tables_thompson.F + build_tables.F) +list(TRANSFORM ATMOSPHERE_CORE_UTILS_SOURCES PREPEND utils/) + +# core_atosphere +set(ATMOSPHERE_CORE_SOURCES + mpas_atm_dimensions.F + mpas_atm_threading.F + mpas_atm_core.F + mpas_atm_core_interface.F + mpas_atm_halos.F +) + +## Generated includes +set(ATMOSPHERE_CORE_INCLUDES + block_dimension_routines.inc + core_variables.inc + define_packages.inc + domain_variables.inc + namelist_call.inc + namelist_defines.inc + setup_immutable_streams.inc + structs_and_variables.inc) + + +add_library(core_atmosphere ${ATMOSPHERE_CORE_SOURCES} + ${ATMOSPHERE_CORE_PHYSICS_SOURCES} + ${ATMOSPHERE_CORE_PHYSICS_MMM_SOURCES} + ${ATMOSPHERE_CORE_PHYSICS_WRF_SOURCES} + ${ATMOSPHERE_CORE_DIAGNOSTIC_SOURCES} + ${ATMOSPHERE_CORE_DYNAMICS_SOURCES}) + +set(CORE_ATMOSPHERE_COMPILE_DEFINITIONS + mpas=1 + MPAS_NATIVE_TIMERS +) +if (${DO_PHYSICS}) + list(APPEND CORE_ATMOSPHERE_COMPILE_DEFINITIONS DO_PHYSICS) +endif () +target_compile_definitions(core_atmosphere PRIVATE ${CORE_ATMOSPHERE_COMPILE_DEFINITIONS}) +set_MPAS_DEBUG_flag(core_atmosphere) +mpas_core_target(CORE atmosphere TARGET core_atmosphere INCLUDES ${ATMOSPHERE_CORE_INCLUDES}) + +#Get physics_wrf tables from MPAS-Data +include(FetchContent) +if (${PROJECT_VERSION} VERSION_GREATER_EQUAL 7.0) + set(MPAS_DATA_GIT_TAG v${PROJECT_VERSION_MAJOR}.0) +else () + set(MPAS_DATA_GIT_TAG master) +endif () + +FetchContent_Declare(mpas_data + GIT_REPOSITORY https://github.com/MPAS-Dev/MPAS-Data.git + GIT_TAG ${MPAS_DATA_GIT_TAG} + GIT_PROGRESS True + GIT_SHALLOW True) +FetchContent_Populate(mpas_data) +message(STATUS "MPAS-Data source dir: ${mpas_data_SOURCE_DIR}") +set(PHYSICS_WRF_DATA_DIR ${mpas_data_SOURCE_DIR}/atmosphere/physics_wrf/files) +file(GLOB PHYSICS_WRF_DATA RELATIVE ${PHYSICS_WRF_DATA_DIR} "${PHYSICS_WRF_DATA_DIR}/*") +file(MAKE_DIRECTORY ${CMAKE_BINARY_DIR}/${PROJECT_NAME}/core_atmosphere) +foreach (data_file IN LISTS PHYSICS_WRF_DATA) + execute_process(COMMAND ${CMAKE_COMMAND} -E create_symlink ${PHYSICS_WRF_DATA_DIR}/${data_file} + ${CMAKE_BINARY_DIR}/${PROJECT_NAME}/core_atmosphere/${data_file}) +endforeach () +install(DIRECTORY ${PHYSICS_WRF_DATA_DIR}/ DESTINATION ${CMAKE_INSTALL_DATADIR}/${PROJECT_NAME}/core_atmosphere) + +add_executable(mpas_atmosphere_build_tables ${ATMOSPHERE_CORE_UTILS_SOURCES}) +target_link_libraries(mpas_atmosphere_build_tables PUBLIC core_atmosphere) +mpas_fortran_target(mpas_atmosphere_build_tables) +install(TARGETS mpas_atmosphere_build_tables EXPORT ${PROJECT_NAME}ExportsCore + RUNTIME DESTINATION ${CMAKE_INSTALL_BINDIR}) diff --git a/src/core_atmosphere/Externals.cfg b/src/core_atmosphere/Externals.cfg new file mode 100644 index 0000000000..3626ec3674 --- /dev/null +++ b/src/core_atmosphere/Externals.cfg @@ -0,0 +1,10 @@ +[MMM-physics] +local_path = ./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/src/core_atmosphere/Makefile b/src/core_atmosphere/Makefile index c06d2a74b8..8d9f4f1a39 100644 --- a/src/core_atmosphere/Makefile +++ b/src/core_atmosphere/Makefile @@ -30,7 +30,7 @@ core_input_gen: gen_includes: core_reg (if [ ! -d inc ]; then mkdir -p inc; fi) # To generate *.inc files - (cd inc; $(REG_PARSE) < ../Registry_processed.xml ) + (cd inc; $(REG_PARSE) ../Registry_processed.xml $(CPPFLAGS) ) post_build: if [ ! -e $(ROOT_DIR)/default_inputs ]; then mkdir $(ROOT_DIR)/default_inputs; fi @@ -42,6 +42,7 @@ physcore: mpas_atm_dimensions.o ( mkdir libphys; cd libphys; ar -x ../physics/libphys.a ) ( cd ../..; ln -sf ./src/core_atmosphere/physics/physics_wrf/files/*TBL .) ( cd ../..; ln -sf ./src/core_atmosphere/physics/physics_wrf/files/*DATA* .) + ( cd ../..; ln -sf ./src/core_atmosphere/physics/physics_noahmp/parameters/*TBL .) dycore: mpas_atm_dimensions.o $(PHYSCORE) ( cd dynamics; $(MAKE) all PHYSICS="$(PHYSICS)" ) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 4dbab8d9dc..10cfbca3ea 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -1,5 +1,5 @@ - + @@ -397,12 +397,14 @@ + + @@ -485,11 +487,39 @@ + #ifdef MPAS_CAM_DYCORE #endif - +#ifdef DO_PHYSICS + + + + + + + + + + + + + + + + + + + + + + + + + + +#endif @@ -517,17 +547,6 @@ #ifdef DO_PHYSICS - - - - - - - - - - - @@ -548,16 +567,6 @@ - - - - - - - - - - #endif @@ -606,13 +615,15 @@ #ifdef DO_PHYSICS - - - - - - - + + + + + + + + + @@ -625,7 +636,9 @@ + + @@ -773,6 +786,18 @@ + + + + + + + + + + + + @@ -790,20 +815,12 @@ + + + - - - - - - - - - - - @@ -820,16 +837,6 @@ - - - - - - - - - - @@ -837,6 +844,7 @@ + #endif @@ -1135,6 +1143,73 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @@ -1473,31 +1548,43 @@ + packages="bl_mynn_in;bl_ysu_in;cu_ntiedtke_in;mp_kessler_in;mp_thompson_in;mp_thompson_aers_in;mp_wsm6_in"/> + packages="mp_kessler_in;mp_thompson_in;mp_thompson_aers_in;mp_wsm6_in"/> + packages="bl_mynn_in;bl_ysu_in;cu_ntiedtke_in;mp_thompson_in;mp_thompson_aers_in;mp_wsm6_in"/> + packages="bl_mynn_in;mp_thompson_in;mp_thompson_aers_in;mp_wsm6_in"/> + packages="mp_thompson_in;mp_thompson_aers_in;mp_wsm6_in"/> + packages="bl_mynn_in;mp_thompson_in;mp_thompson_aers_in"/> + packages="mp_thompson_in;mp_thompson_aers_in"/> + + + + + + #endif @@ -1605,6 +1692,14 @@ + + + + @@ -1795,31 +1890,43 @@ + packages="bl_mynn_in;bl_ysu_in;cu_ntiedtke_in;mp_kessler_in;mp_thompson_in;mp_thompson_aers_in;mp_wsm6_in"/> + packages="mp_kessler_in;mp_thompson_in;mp_thompson_aers_in;mp_wsm6_in"/> + packages="bl_mynn_in;bl_ysu_in;cu_ntiedtke_in;mp_thompson_in;mp_thompson_aers_in;mp_wsm6_in"/> + packages="bl_mynn_in;mp_thompson_in;mp_thompson_aers_in;mp_wsm6_in"/> + packages="mp_thompson_in;mp_thompson_aers_in;mp_wsm6_in"/> + packages="bl_mynn_in;mp_thompson_in;mp_thompson_aers_in"/> + packages="mp_thompson_in;mp_thompson_aers_in"/> + + + + + + #endif @@ -1855,29 +1962,49 @@ description="Lateral boundary tendency of rho_zz-coupled theta_m"/> - - - - - - - - + + + + + + @@ -1981,6 +2108,11 @@ description="logical for turning on/off top-down, radiation_driven mixing" possible_values=".true. to turn on top-down radiation_driven mixing; .false. otherwise"/> + + + possible_values="`suite',`mp_wsm6',`mp_thompson',`mp_thompson_aerosols', `mp_kessler',`off'"/> + possible_values="`suite',`sf_noah',`sf_noahmp`, `off'"/> + packages="mp_thompson_in;mp_thompson_aers_in;mp_wsm6_in"/> + packages="mp_thompson_in;mp_thompson_aers_in;mp_wsm6_in"/> + packages="mp_thompson_in;mp_thompson_aers_in;mp_wsm6_in"/> + packages="mp_kessler_in;mp_thompson_in;mp_thompson_aers_in;mp_wsm6_in"/> + packages="mp_kessler_in;mp_thompson_in;mp_thompson_aers_in;mp_wsm6_in"/> + packages="mp_thompson_in;mp_thompson_aers_in;mp_wsm6_in"/> + packages="mp_thompson_in;mp_thompson_aers_in;mp_wsm6_in"/> + packages="mp_kessler_in;mp_thompson_in;mp_thompson_aers_in;mp_wsm6_in"/> + packages="mp_thompson_in;mp_thompson_aers_in;mp_wsm6_in"/> + packages="mp_thompson_in;mp_thompson_aers_in;mp_wsm6_in"/> + packages="mp_thompson_in;mp_thompson_aers_in;mp_wsm6_in"/> + packages="mp_thompson_in;mp_thompson_aers_in;mp_wsm6_in"/> + packages="mp_thompson_in;mp_thompson_aers_in;mp_wsm6_in"/> + packages="mp_thompson_in;mp_thompson_aers_in;mp_wsm6_in"/> + packages="mp_thompson_in;mp_thompson_aers_in;mp_wsm6_in"/> + packages="mp_thompson_in;mp_thompson_aers_in"/> + packages="mp_thompson_in;mp_thompson_aers_in"/> + + + + @@ -2945,13 +3085,26 @@ - + + + + + + + + + + @@ -3086,6 +3239,58 @@ persistence="scratch" /> #ifdef DO_PHYSICS + + + + + + + + + + + + + + + + + + + + + + + + + + + + @@ -3165,10 +3370,22 @@ description="tendency of snow mixing ratio due to pbl processes" packages="bl_mynn_in"/> + + + + + + @@ -3339,22 +3556,28 @@ description="Potential temperature increment"/> - - - - - - @@ -3365,5 +3588,6 @@ #include "diagnostics/Registry_diagnostics.xml" +#include "physics/Registry_noahmp.xml" diff --git a/src/core_atmosphere/build_options.mk b/src/core_atmosphere/build_options.mk index 34caf8d663..3b5a873451 100644 --- a/src/core_atmosphere/build_options.mk +++ b/src/core_atmosphere/build_options.mk @@ -2,6 +2,9 @@ PWD=$(shell pwd) EXE_NAME=atmosphere_model NAMELIST_SUFFIX=atmosphere override CPPFLAGS += -DCORE_ATMOSPHERE +FCINCLUDES += -I$(PWD)/src/core_atmosphere/physics/physics_noahmp/drivers/mpas \ + -I$(PWD)/src/core_atmosphere/physics/physics_noahmp/utility \ + -I$(PWD)/src/core_atmosphere/physics/physics_noahmp/src report_builds: @echo "CORE=atmosphere" diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index a68b3e5a19..e2bafe8752 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -6,6 +6,14 @@ ! distributed with this code, or at http://mpas-dev.github.com/license.html ! +#ifdef MPAS_OPENACC +#define MPAS_ACC_TIMER_START(X) call mpas_timer_start(X) +#define MPAS_ACC_TIMER_STOP(X) call mpas_timer_stop(X) +#else +#define MPAS_ACC_TIMER_START(X) +#define MPAS_ACC_TIMER_STOP(X) +#endif + module atm_time_integration use mpas_derived_types @@ -188,6 +196,24 @@ subroutine mpas_atm_dynamics_init(domain) type (field2DReal), pointer :: tend_ru_physicsField, tend_rtheta_physicsField, tend_rho_physicsField #endif +#ifdef MPAS_OPENACC + type (mpas_pool_type), pointer :: mesh + + real (kind=RKIND), dimension(:), pointer :: dvEdge + integer, dimension(:,:), pointer :: cellsOnCell + integer, dimension(:,:), pointer :: cellsOnEdge + integer, dimension(:,:), pointer :: advCellsForEdge + integer, dimension(:,:), pointer :: edgesOnCell + integer, dimension(:), pointer :: nAdvCellsForEdge + integer, dimension(:), pointer :: nEdgesOnCell + real (kind=RKIND), dimension(:,:), pointer :: adv_coefs + real (kind=RKIND), dimension(:,:), pointer :: adv_coefs_3rd + real (kind=RKIND), dimension(:,:), pointer :: edgesOnCell_sign + real (kind=RKIND), dimension(:), pointer :: invAreaCell + integer, dimension(:), pointer :: bdyMaskCell + integer, dimension(:), pointer :: bdyMaskEdge +#endif + #ifdef MPAS_CAM_DYCORE nullify(tend_physics) @@ -203,6 +229,50 @@ subroutine mpas_atm_dynamics_init(domain) call mpas_allocate_scratch_field(tend_ru_physicsField) #endif +#ifdef MPAS_OPENACC + nullify(mesh) + call mpas_pool_get_subpool(domain % blocklist % structs, 'mesh', mesh) + + call mpas_pool_get_array(mesh, 'dvEdge', dvEdge) + !$acc enter data copyin(dvEdge) + + call mpas_pool_get_array(mesh, 'cellsOnCell', cellsOnCell) + !$acc enter data copyin(cellsOnCell) + + call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) + !$acc enter data copyin(cellsOnEdge) + + call mpas_pool_get_array(mesh, 'advCellsForEdge', advCellsForEdge) + !$acc enter data copyin(advCellsForEdge) + + call mpas_pool_get_array(mesh, 'edgesOnCell', edgesOnCell) + !$acc enter data copyin(edgesOnCell) + + call mpas_pool_get_array(mesh, 'nAdvCellsForEdge', nAdvCellsForEdge) + !$acc enter data copyin(nAdvCellsForEdge) + + call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) + !$acc enter data copyin(nEdgesOnCell) + + call mpas_pool_get_array(mesh, 'adv_coefs', adv_coefs) + !$acc enter data copyin(adv_coefs) + + call mpas_pool_get_array(mesh, 'adv_coefs_3rd', adv_coefs_3rd) + !$acc enter data copyin(adv_coefs_3rd) + + call mpas_pool_get_array(mesh, 'edgesOnCell_sign', edgesOnCell_sign) + !$acc enter data copyin(edgesOnCell_sign) + + call mpas_pool_get_array(mesh, 'invAreaCell', invAreaCell) + !$acc enter data copyin(invAreaCell) + + call mpas_pool_get_array(mesh, 'bdyMaskCell', bdyMaskCell) + !$acc enter data copyin(bdyMaskCell) + + call mpas_pool_get_array(mesh, 'bdyMaskEdge', bdyMaskEdge) + !$acc enter data copyin(bdyMaskEdge) +#endif + end subroutine mpas_atm_dynamics_init @@ -233,6 +303,24 @@ subroutine mpas_atm_dynamics_finalize(domain) type (field2DReal), pointer :: tend_ru_physicsField, tend_rtheta_physicsField, tend_rho_physicsField #endif +#ifdef MPAS_OPENACC + type (mpas_pool_type), pointer :: mesh + + real (kind=RKIND), dimension(:), pointer :: dvEdge + integer, dimension(:,:), pointer :: cellsOnCell + integer, dimension(:,:), pointer :: cellsOnEdge + integer, dimension(:,:), pointer :: advCellsForEdge + integer, dimension(:,:), pointer :: edgesOnCell + integer, dimension(:), pointer :: nAdvCellsForEdge + integer, dimension(:), pointer :: nEdgesOnCell + real (kind=RKIND), dimension(:,:), pointer :: adv_coefs + real (kind=RKIND), dimension(:,:), pointer :: adv_coefs_3rd + real (kind=RKIND), dimension(:,:), pointer :: edgesOnCell_sign + real (kind=RKIND), dimension(:), pointer :: invAreaCell + integer, dimension(:), pointer :: bdyMaskCell + integer, dimension(:), pointer :: bdyMaskEdge +#endif + #ifdef MPAS_CAM_DYCORE nullify(tend_physics) @@ -248,6 +336,50 @@ subroutine mpas_atm_dynamics_finalize(domain) call mpas_deallocate_scratch_field(tend_ru_physicsField) #endif +#ifdef MPAS_OPENACC + nullify(mesh) + call mpas_pool_get_subpool(domain % blocklist % structs, 'mesh', mesh) + + call mpas_pool_get_array(mesh, 'dvEdge', dvEdge) + !$acc exit data delete(dvEdge) + + call mpas_pool_get_array(mesh, 'cellsOnCell', cellsOnCell) + !$acc exit data delete(cellsOnCell) + + call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) + !$acc exit data delete(cellsOnEdge) + + call mpas_pool_get_array(mesh, 'advCellsForEdge', advCellsForEdge) + !$acc exit data delete(advCellsForEdge) + + call mpas_pool_get_array(mesh, 'edgesOnCell', edgesOnCell) + !$acc exit data delete(edgesOnCell) + + call mpas_pool_get_array(mesh, 'nAdvCellsForEdge', nAdvCellsForEdge) + !$acc exit data delete(nAdvCellsForEdge) + + call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) + !$acc exit data delete(nEdgesOnCell) + + call mpas_pool_get_array(mesh, 'adv_coefs', adv_coefs) + !$acc exit data delete(adv_coefs) + + call mpas_pool_get_array(mesh, 'adv_coefs_3rd', adv_coefs_3rd) + !$acc exit data delete(adv_coefs_3rd) + + call mpas_pool_get_array(mesh, 'edgesOnCell_sign', edgesOnCell_sign) + !$acc exit data delete(edgesOnCell_sign) + + call mpas_pool_get_array(mesh, 'invAreaCell', invAreaCell) + !$acc exit data delete(invAreaCell) + + call mpas_pool_get_array(mesh, 'bdyMaskCell', bdyMaskCell) + !$acc exit data delete(bdyMaskCell) + + call mpas_pool_get_array(mesh, 'bdyMaskEdge', bdyMaskEdge) + !$acc exit data delete(bdyMaskEdge) +#endif + end subroutine mpas_atm_dynamics_finalize @@ -367,7 +499,7 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) character (len=StrKIND), pointer :: config_convection_scheme integer, pointer :: num_scalars, index_qv, nCells, nCellsSolve, nEdges, nEdgesSolve, nVertices, nVerticesSolve, nVertLevels - integer, pointer :: index_qc, index_qr, index_qi, index_qs, index_qg, index_nr, index_ni + integer, pointer :: index_qc, index_qr, index_qi, index_qs, index_qg, index_nr, index_ni, index_nc, index_nifa, index_nwfa character(len=StrKIND), pointer :: config_IAU_option @@ -471,6 +603,9 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) call mpas_pool_get_dimension(state, 'index_qg', index_qg) call mpas_pool_get_dimension(state, 'index_nr', index_nr) call mpas_pool_get_dimension(state, 'index_ni', index_ni) + call mpas_pool_get_dimension(state, 'index_nc', index_nc) + call mpas_pool_get_dimension(state, 'index_nifa', index_nifa) + call mpas_pool_get_dimension(state, 'index_nwfa', index_nwfa) endif ! @@ -927,7 +1062,15 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) if (index_ni > 0) then scalars_driving(index_ni,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'ni', rk_timestep(rk_step) ) end if - + if (index_nc > 0) then + scalars_driving(index_nc,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'nc', rk_timestep(rk_step) ) + end if + if (index_nifa > 0) then + scalars_driving(index_nifa,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'nifa', rk_timestep(rk_step) ) + end if + if (index_nwfa > 0) then + scalars_driving(index_nwfa,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'nwfa', rk_timestep(rk_step) ) + end if !$OMP PARALLEL DO do thread=1,nThreads call atm_bdy_adjust_scalars( state, diag, mesh, block % configs, scalars_driving, nVertLevels, dt, rk_timestep(rk_step), & @@ -1094,7 +1237,15 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) if (index_ni > 0) then scalars_driving(index_ni,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'ni', rk_timestep(rk_step) ) end if - + if (index_nc > 0) then + scalars_driving(index_nc,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'nc', rk_timestep(rk_step) ) + end if + if (index_nifa > 0) then + scalars_driving(index_nifa,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'nifa', rk_timestep(rk_step) ) + end if + if (index_nwfa > 0) then + scalars_driving(index_nwfa,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'nwfa', rk_timestep(rk_step) ) + end if !$OMP PARALLEL DO do thread=1,nThreads call atm_bdy_adjust_scalars( state, diag, mesh, block % configs, scalars_driving, nVertLevels, dt, rk_timestep(rk_step), & @@ -1182,7 +1333,7 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) call mpas_timer_start('microphysics') !$OMP PARALLEL DO do thread=1,nThreads - call driver_microphysics ( block % configs, mesh, state, 2, diag, diag_physics, tend, itimestep, & + call driver_microphysics ( block % configs, mesh, state, 2, diag, diag_physics, tend_physics, tend, itimestep, & cellSolveThreadStart(thread), cellSolveThreadEnd(thread)) end do !$OMP END PARALLEL DO @@ -1254,7 +1405,15 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) if (index_ni > 0) then scalars_driving(index_ni,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'ni', dt ) end if - + if (index_nc > 0) then + scalars_driving(index_nc,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'nc', dt ) + end if + if (index_nifa > 0) then + scalars_driving(index_nifa,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'nifa', dt ) + end if + if (index_nwfa > 0) then + scalars_driving(index_nwfa,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'nwfa', dt ) + end if !$OMP PARALLEL DO do thread=1,nThreads call atm_bdy_set_scalars( state, mesh, scalars_driving, nVertLevels, & @@ -1352,7 +1511,7 @@ subroutine advance_scalars(field_name, domain, rk_step, rk_timestep, config_mono call mpas_pool_get_dimension(mesh, 'nCells', nCells) call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) - call mpas_pool_get_dimension(state, 'num_scalars', num_scalars) + call mpas_pool_get_dimension(state, 'num_'//trim(field_name), num_scalars) call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) @@ -2976,154 +3135,197 @@ subroutine atm_advance_scalars_work(nCells, num_scalars, dt, & weight_time_old = 1. - weight_time_new + MPAS_ACC_TIMER_START('atm_advance_scalars [ACC_data_xfer]') + !$acc enter data create(horiz_flux_arr) + !$acc enter data copyin(uhAvg, scalar_new) + MPAS_ACC_TIMER_STOP('atm_advance_scalars [ACC_data_xfer]') + + !$acc parallel async + !$acc loop gang worker private(scalar_weight2, ica) do iEdge=edgeStart,edgeEnd - if( (.not.config_apply_lbcs) .or. (bdyMaskEdge(iEdge) .lt. nRelaxZone-1) ) then ! full flux calculation + if ((.not.config_apply_lbcs) & + .or. (bdyMaskEdge(iEdge) < nRelaxZone-1)) then ! full flux calculation - select case(nAdvCellsForEdge(iEdge)) + select case(nAdvCellsForEdge(iEdge)) - case(10) + case(10) - do j=1,10 -!DIR$ IVDEP - do k=1,nVertLevels - scalar_weight2(k,j) = adv_coefs(j,iEdge) + sign(1.0_RKIND,uhAvg(k,iEdge))*adv_coefs_3rd(j,iEdge) + !$acc loop vector collapse(2) + do j=1,10 + do k=1,nVertLevels + scalar_weight2(k,j) = adv_coefs(j,iEdge) + sign(1.0_RKIND,uhAvg(k,iEdge))*adv_coefs_3rd(j,iEdge) + end do end do - end do - do j=1,10 - ica(j) = advCellsForEdge(j,iEdge) - end do -!DIR$ IVDEP - do k = 1,nVertLevels -!DIR$ IVDEP - do iScalar = 1,num_scalars - horiz_flux_arr(iScalar,k,iEdge) = & - scalar_weight2(k,1) * scalar_new(iScalar,k,ica(1)) + & - scalar_weight2(k,2) * scalar_new(iScalar,k,ica(2)) + & - scalar_weight2(k,3) * scalar_new(iScalar,k,ica(3)) + & - scalar_weight2(k,4) * scalar_new(iScalar,k,ica(4)) + & - scalar_weight2(k,5) * scalar_new(iScalar,k,ica(5)) + & - scalar_weight2(k,6) * scalar_new(iScalar,k,ica(6)) + & - scalar_weight2(k,7) * scalar_new(iScalar,k,ica(7)) + & - scalar_weight2(k,8) * scalar_new(iScalar,k,ica(8)) + & - scalar_weight2(k,9) * scalar_new(iScalar,k,ica(9)) + & - scalar_weight2(k,10) * scalar_new(iScalar,k,ica(10)) + + !$acc loop vector + do j=1,10 + ica(j) = advCellsForEdge(j,iEdge) end do - end do - case default + !$acc loop vector collapse(2) + do k = 1,nVertLevels + do iScalar = 1,num_scalars + horiz_flux_arr(iScalar,k,iEdge) = & + scalar_weight2(k,1) * scalar_new(iScalar,k,ica(1)) + & + scalar_weight2(k,2) * scalar_new(iScalar,k,ica(2)) + & + scalar_weight2(k,3) * scalar_new(iScalar,k,ica(3)) + & + scalar_weight2(k,4) * scalar_new(iScalar,k,ica(4)) + & + scalar_weight2(k,5) * scalar_new(iScalar,k,ica(5)) + & + scalar_weight2(k,6) * scalar_new(iScalar,k,ica(6)) + & + scalar_weight2(k,7) * scalar_new(iScalar,k,ica(7)) + & + scalar_weight2(k,8) * scalar_new(iScalar,k,ica(8)) + & + scalar_weight2(k,9) * scalar_new(iScalar,k,ica(9)) + & + scalar_weight2(k,10) * scalar_new(iScalar,k,ica(10)) + end do + end do - horiz_flux_arr(:,:,iEdge) = 0.0 - do j=1,nAdvCellsForEdge(iEdge) - iAdvCell = advCellsForEdge(j,iEdge) -!DIR$ IVDEP + case default + + !$acc loop vector collapse(2) do k=1,nVertLevels - scalar_weight = adv_coefs(j,iEdge) + sign(1.0_RKIND,uhAvg(k,iEdge))*adv_coefs_3rd(j,iEdge) -!DIR$ IVDEP do iScalar=1,num_scalars - horiz_flux_arr(iScalar,k,iEdge) = horiz_flux_arr(iScalar,k,iEdge) + scalar_weight * scalar_new(iScalar,k,iAdvCell) + horiz_flux_arr(iScalar,k,iEdge) = 0.0_RKIND end do end do - end do - end select + !$acc loop seq + do j=1,nAdvCellsForEdge(iEdge) + iAdvCell = advCellsForEdge(j,iEdge) + + !$acc loop vector collapse(2) + do k=1,nVertLevels + do iScalar=1,num_scalars + scalar_weight = adv_coefs(j,iEdge) + sign(1.0_RKIND,uhAvg(k,iEdge))*adv_coefs_3rd(j,iEdge) + horiz_flux_arr(iScalar,k,iEdge) = horiz_flux_arr(iScalar,k,iEdge) & + + scalar_weight * scalar_new(iScalar,k,iAdvCell) + end do + end do + end do + end select + + else if(config_apply_lbcs & + .and. (bdyMaskEdge(iEdge) >= nRelaxZone-1) & + .and. (bdyMaskEdge(iEdge) <= nRelaxZone)) then - else if(config_apply_lbcs .and. (bdyMaskEdge(iEdge) .ge. nRelaxZone-1) .and. (bdyMaskEdge(iEdge) .le. nRelaxZone) ) then - ! upwind flux evaluation for outermost 2 edges in specified zone + ! upwind flux evaluation for outermost 2 edges in specified zone cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) -!DIR$ IVDEP + + !$acc loop vector collapse(2) do k=1,nVertLevels - u_direction = sign(0.5_RKIND,uhAvg(k,iEdge)) - u_positive = dvEdge(iEdge)*abs(u_direction + 0.5_RKIND) - u_negative = dvEdge(iEdge)*abs(u_direction - 0.5_RKIND) -!DIR$ IVDEP do iScalar=1,num_scalars + u_direction = sign(0.5_RKIND,uhAvg(k,iEdge)) + u_positive = dvEdge(iEdge)*abs(u_direction + 0.5_RKIND) + u_negative = dvEdge(iEdge)*abs(u_direction - 0.5_RKIND) horiz_flux_arr(iScalar,k,iEdge) = u_positive*scalar_new(iScalar,k,cell1) + u_negative*scalar_new(iScalar,k,cell2) end do end do end if ! end of regional MPAS test - end do + !$acc end parallel !$OMP BARRIER -! scalar update, for each column sum fluxes over horizontal edges, add physics tendency, and add vertical flux divergence in update. + ! + ! scalar update, for each column sum fluxes over horizontal edges, add physics tendency, + ! and add vertical flux divergence in update. + ! - + MPAS_ACC_TIMER_START('atm_advance_scalars [ACC_data_xfer]') +#ifndef DO_PHYSICS + !$acc enter data create(scalar_tend_save) +#else + !$acc enter data copyin(scalar_tend_save) +#endif + !$acc enter data copyin(scalar_old, fnm, fnp, rdnw, wwAvg, rho_zz_old, rho_zz_new) + !$acc enter data create(scalar_tend_column, wdtn) + MPAS_ACC_TIMER_STOP('atm_advance_scalars [ACC_data_xfer]') + + !$acc parallel wait + !$acc loop gang worker private(scalar_tend_column, wdtn) do iCell=cellSolveStart,cellSolveEnd if(bdyMaskCell(iCell) <= nRelaxZone) then ! specified zone for regional_MPAS is not updated in this routine + !$acc loop vector collapse(2) + do k=1,nVertLevels + do iScalar=1,num_scalars + scalar_tend_column(iScalar,k) = 0.0_RKIND #ifndef DO_PHYSICS - scalar_tend_save(:,:,iCell) = 0.0 ! testing purposes - we have no sources or sinks + scalar_tend_save(iScalar,k,iCell) = 0.0_RKIND ! testing purposes - we have no sources or sinks #endif - scalar_tend_column(1:num_scalars,1:nVertlevels) = 0. + end do + end do + !$acc loop seq do i=1,nEdgesOnCell(iCell) iEdge = edgesOnCell(i,iCell) ! here we add the horizontal flux divergence into the scalar tendency. ! note that the scalar tendency is modified. -!DIR$ IVDEP + !$acc loop vector collapse(2) do k=1,nVertLevels -!DIR$ IVDEP do iScalar=1,num_scalars scalar_tend_column(iScalar,k) = scalar_tend_column(iScalar,k) & - edgesOnCell_sign(i,iCell) * uhAvg(k,iEdge)*horiz_flux_arr(iScalar,k,iEdge) end do end do - + end do -!DIR$ IVDEP + !$acc loop vector collapse(2) do k=1,nVertLevels -!DIR$ IVDEP do iScalar=1,num_scalars - scalar_tend_column(iScalar,k) = scalar_tend_column(iScalar,k) * invAreaCell(iCell) + scalar_tend_save(iScalar,k,iCell) + scalar_tend_column(iScalar,k) = scalar_tend_column(iScalar,k) * invAreaCell(iCell) & + + scalar_tend_save(iScalar,k,iCell) end do end do - - ! - ! vertical flux divergence and update of the scalars - ! - wdtn(:,1) = 0.0 - wdtn(:,nVertLevels+1) = 0.0 - k = 2 - do iScalar=1,num_scalars - wdtn(iScalar,k) = wwAvg(k,iCell)*(fnm(k)*scalar_new(iScalar,k,iCell)+fnp(k)*scalar_new(iScalar,k-1,iCell)) - end do - -!DIR$ IVDEP - do k=3,nVertLevels-1 -!DIR$ IVDEP + ! + ! vertical flux divergence and update of the scalars + ! + + !$acc loop vector do iScalar=1,num_scalars - wdtn(iScalar,k) = flux3( scalar_new(iScalar,k-2,iCell),scalar_new(iScalar,k-1,iCell), & - scalar_new(iScalar,k ,iCell),scalar_new(iScalar,k+1,iCell), & - wwAvg(k,iCell), coef_3rd_order ) + wdtn(iScalar,1) = 0.0 + wdtn(iScalar,2) = wwAvg(2,iCell)*(fnm(2)*scalar_new(iScalar,2,iCell)+fnp(2)*scalar_new(iScalar,2-1,iCell)) + wdtn(iScalar,nVertLevels) = wwAvg(nVertLevels,iCell) * & + ( fnm(nVertLevels)*scalar_new(iScalar,nVertLevels,iCell) & + +fnp(nVertLevels)*scalar_new(iScalar,nVertLevels-1,iCell) ) + wdtn(iScalar,nVertLevels+1) = 0.0 end do - end do - k = nVertLevels - do iScalar=1,num_scalars - wdtn(iScalar,k) = wwAvg(k,iCell)*(fnm(k)*scalar_new(iScalar,k,iCell)+fnp(k)*scalar_new(iScalar,k-1,iCell)) - end do -!DIR$ IVDEP - do k=1,nVertLevels - rho_zz_new_inv = 1.0_RKIND / (weight_time_old*rho_zz_old(k,iCell) + weight_time_new*rho_zz_new(k,iCell)) -!DIR$ IVDEP - do iScalar=1,num_scalars - scalar_new(iScalar,k,iCell) = ( scalar_old(iScalar,k,iCell)*rho_zz_old(k,iCell) & - + dt*( scalar_tend_column(iScalar,k) -rdnw(k)*(wdtn(iScalar,k+1)-wdtn(iScalar,k)) ) ) * rho_zz_new_inv + !$acc loop vector collapse(2) + do k=3,nVertLevels-1 + do iScalar=1,num_scalars + wdtn(iScalar,k) = flux3( scalar_new(iScalar,k-2,iCell),scalar_new(iScalar,k-1,iCell), & + scalar_new(iScalar,k ,iCell),scalar_new(iScalar,k+1,iCell), & + wwAvg(k,iCell), coef_3rd_order ) + end do end do - end do - end if ! specified zone regional_MPAS test + !$acc loop vector collapse(2) + do k=1,nVertLevels + do iScalar=1,num_scalars + rho_zz_new_inv = 1.0_RKIND / (weight_time_old*rho_zz_old(k,iCell) + weight_time_new*rho_zz_new(k,iCell)) + scalar_new(iScalar,k,iCell) = ( scalar_old(iScalar,k,iCell)*rho_zz_old(k,iCell) & + + dt*( scalar_tend_column(iScalar,k) -rdnw(k)*(wdtn(iScalar,k+1)-wdtn(iScalar,k)) ) ) * rho_zz_new_inv + end do + end do + + end if ! specified zone regional_MPAS test end do + !$acc end parallel + + MPAS_ACC_TIMER_START('atm_advance_scalars [ACC_data_xfer]') + !$acc exit data copyout(scalar_new) + !$acc exit data delete(scalar_tend_column, wdtn, uhAvg, wwAvg, scalar_old, fnm, fnp, & + !$acc rdnw, rho_zz_old, rho_zz_new, horiz_flux_arr, scalar_tend_save) + MPAS_ACC_TIMER_STOP('atm_advance_scalars [ACC_data_xfer]') end subroutine atm_advance_scalars_work @@ -3234,7 +3436,7 @@ subroutine atm_advance_scalars_mono(field_name, block, tend, state, diag, mesh, call mpas_allocate_scratch_field(scale) call mpas_pool_get_array(halo_scratch, 'scale', scale_arr) - call atm_advance_scalars_mono_work(block, state, nCells, nEdges, num_scalars, dt, & + call atm_advance_scalars_mono_work(field_name, block, state, nCells, nEdges, num_scalars, dt, & cellStart, cellEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, & coef_3rd_order, nCellsSolve, uhAvg, wwAvg, scalar_tend, rho_zz_old, & @@ -3282,7 +3484,7 @@ end subroutine atm_advance_scalars_mono !> as used in the RK3 scheme as described in Wang et al MWR 2009 ! !----------------------------------------------------------------------- - subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, num_scalars, dt, & + subroutine atm_advance_scalars_mono_work(field_name, block, state, nCells, nEdges, num_scalars, dt, & cellStart, cellEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, & coef_3rd_order, nCellsSolve, uhAvg, wwAvg, scalar_tend, rho_zz_old, & @@ -3297,6 +3499,7 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, num_scala implicit none + character(len=*), intent(in) :: field_name type (block_type), intent(inout), target :: block type (mpas_pool_type), intent(inout) :: state integer, intent(in) :: nCells ! for allocating stack variables @@ -3335,7 +3538,6 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, num_scala real (kind=RKIND), dimension(nVertLevels,2,nCells+1), intent(inout) :: scale_arr real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(inout) :: flux_arr real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(inout) :: flux_upwind_tmp, flux_tmp - type (field3DReal), pointer :: scalars_old_field integer, parameter :: SCALE_IN = 1, SCALE_OUT = 2 @@ -3374,37 +3576,64 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, num_scala local_advance_density = .true. end if - call mpas_pool_get_field(state, 'scalars', scalars_old_field, 1) - ! for positive-definite or monotonic option, we first update scalars using the tendency from sources other than ! the resolved transport (these should constitute a positive definite update). ! Note, however, that we enforce positive-definiteness in this update. ! The transport will maintain this positive definite solution and optionally, shape preservation (monotonicity). + + MPAS_ACC_TIMER_START('atm_advance_scalars_mono [ACC_data_xfer]') + !$acc data present(nEdgesOnCell, edgesOnCell, edgesOnCell_sign, & + !$acc invAreaCell, cellsOnCell, cellsOnEdge, nAdvCellsForEdge, & + !$acc advCellsForEdge, adv_coefs, adv_coefs_3rd, dvEdge, bdyMaskCell) + +#ifdef DO_PHYSICS + !$acc enter data copyin(scalar_tend) +#else + !$acc enter data create(scalar_tend) +#endif + if (local_advance_density) then + !$acc enter data copyin(rho_zz_int) + end if + !$acc enter data copyin(scalars_old, rho_zz_old, rdnw, uhAvg, wwAvg) + MPAS_ACC_TIMER_STOP('atm_advance_scalars_mono [ACC_data_xfer]') + + !$acc parallel + + !$acc loop gang worker do iCell=cellSolveStart,cellSolveEnd -!DIR$ IVDEP - do k = 1,nVertLevels -!DIR$ IVDEP - do iScalar = 1,num_scalars + + !$acc loop vector collapse(2) + do k = 1,nVertLevels + do iScalar = 1,num_scalars #ifndef DO_PHYSICS -!TBH: Michael, would you please check this change? Our test uses -DDO_PHYSICS -!TBH: so this code is not executed. The change avoids redundant work. - scalar_tend(iScalar,k,iCell) = 0.0 ! testing purposes - we have no sources or sinks + scalar_tend(iScalar,k,iCell) = 0.0_RKIND ! testing purposes - we have no sources or sinks #endif - scalars_old(iScalar,k,iCell) = scalars_old(iScalar,k,iCell)+dt*scalar_tend(iScalar,k,iCell) / rho_zz_old(k,iCell) - scalar_tend(iScalar,k,iCell) = 0.0 - end do + scalars_old(iScalar,k,iCell) = scalars_old(iScalar,k,iCell)+dt*scalar_tend(iScalar,k,iCell) / rho_zz_old(k,iCell) + scalar_tend(iScalar,k,iCell) = 0.0_RKIND + end do end do + end do + !$acc end parallel + + MPAS_ACC_TIMER_START('atm_advance_scalars_mono [ACC_data_xfer]') + !$acc exit data copyout(scalar_tend) + + !$acc update self(scalars_old) + MPAS_ACC_TIMER_STOP('atm_advance_scalars_mono [ACC_data_xfer]') !$OMP BARRIER !$OMP MASTER - call exchange_halo_group(block % domain, 'dynamics:scalars_old') + call exchange_halo_group(block % domain, 'dynamics:'//trim(field_name)//'_old') !$OMP END MASTER !$OMP BARRIER + MPAS_ACC_TIMER_START('atm_advance_scalars_mono [ACC_data_xfer]') + !$acc update device(scalars_old) + MPAS_ACC_TIMER_STOP('atm_advance_scalars_mono [ACC_data_xfer]') ! ! Runge Kutta integration, so we compute fluxes from scalar_new values, update starts from scalar_old @@ -3415,50 +3644,83 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, num_scala call mpas_log_write('Error: rho_zz_int not supplied to atm_advance_scalars_mono_work( ) when advance_density=.true.', messageType=MPAS_LOG_CRIT) end if + !$acc parallel + ! begin with update of density + + !$acc loop gang worker do iCell=cellSolveStart,cellSolveEnd - rho_zz_int(:,iCell) = 0.0 + + !$acc loop vector + do k=1,nVertLevels + rho_zz_int(k,iCell) = 0.0_RKIND + end do + + !$acc loop seq do i=1,nEdgesOnCell(iCell) iEdge = edgesOnCell(i,iCell) -!DIR$ IVDEP + !$acc loop vector do k=1,nVertLevels - rho_zz_int(k,iCell) = rho_zz_int(k,iCell) - edgesOnCell_sign(i,iCell) * uhAvg(k,iEdge) * dvEdge(iEdge) * invAreaCell(iCell) + rho_zz_int(k,iCell) = rho_zz_int(k,iCell) - edgesOnCell_sign(i,iCell) & + * uhAvg(k,iEdge) * dvEdge(iEdge) * invAreaCell(iCell) end do end do end do + + !$acc loop gang worker do iCell=cellSolveStart,cellSolveEnd -!DIR$ IVDEP + + !$acc loop vector do k=1,nVertLevels - rho_zz_int(k,iCell) = rho_zz_old(k,iCell) + dt*( rho_zz_int(k,iCell) - rdnw(k)*(wwAvg(k+1,iCell)-wwAvg(k,iCell)) ) + rho_zz_int(k,iCell) = rho_zz_old(k,iCell) + dt*(rho_zz_int(k,iCell) - rdnw(k)*(wwAvg(k+1,iCell)-wwAvg(k,iCell))) end do end do + + !$acc end parallel + !$OMP BARRIER + end if - ! next, do one scalar at a time + MPAS_ACC_TIMER_START('atm_advance_scalars_mono [ACC_data_xfer]') + if (.not. local_advance_density) then + !$acc enter data copyin(rho_zz_new) + end if + !$acc enter data copyin(scalars_new, fnm, fnp) + !$acc enter data create(scalar_old, scalar_new, scale_arr, s_min, s_max, & + !$acc flux_arr, flux_tmp, flux_upwind_tmp, wdtn) + MPAS_ACC_TIMER_STOP('atm_advance_scalars_mono [ACC_data_xfer]') do iScalar = 1, num_scalars + !$acc parallel + + !$acc loop gang worker do iCell=cellStart,cellEnd -!DIR$ IVDEP + + !$acc loop vector do k=1,nVertLevels scalar_old(k,iCell) = scalars_old(iScalar,k,iCell) scalar_new(k,iCell) = scalars_new(iScalar,k,iCell) end do end do -! ***** TEMPORARY TEST ******* WCS 20161012 - do k=1,nVertLevels - scalar_old(k,nCells+1) = 0. - scalar_new(k,nCells+1) = 0. - end do +#ifndef MPAS_OPENACC + do k=1,nVertLevels + scalar_old(k,nCells+1) = 0.0_RKIND + scalar_new(k,nCells+1) = 0.0_RKIND + end do +#endif + !$acc end parallel !$OMP BARRIER #ifdef DEBUG_TRANSPORT + !$acc update self(scalar_old) + scmin = scalar_old(1,1) scmax = scalar_old(1,1) do iCell = 1, nCells @@ -3469,6 +3731,8 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, num_scala end do call mpas_log_write(' scmin, scmin old in $r $r', realArgs=(/scmin,scmax/)) + !$acc update self(scalar_new) + scmin = scalar_new(1,1) scmax = scalar_new(1,1) do iCell = 1, nCells @@ -3480,15 +3744,17 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, num_scala call mpas_log_write(' scmin, scmin new in ', realArgs=(/scmin,scmax/)) #endif + !$acc parallel ! ! vertical flux divergence, and min and max bounds for flux limiter ! + !$acc loop gang worker do iCell=cellSolveStart,cellSolveEnd ! zero flux at top and bottom - wdtn(1,iCell) = 0.0 - wdtn(nVertLevels+1,iCell) = 0.0 + wdtn(1,iCell) = 0.0_RKIND + wdtn(nVertLevels+1,iCell) = 0.0_RKIND k = 1 s_max(k,iCell) = max(scalar_old(1,iCell),scalar_old(2,iCell)) @@ -3499,7 +3765,7 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, num_scala s_max(k,iCell) = max(scalar_old(k-1,iCell),scalar_old(k,iCell),scalar_old(k+1,iCell)) s_min(k,iCell) = min(scalar_old(k-1,iCell),scalar_old(k,iCell),scalar_old(k+1,iCell)) -!DIR$ IVDEP + !$acc loop vector do k=3,nVertLevels-1 wdtn(k,iCell) = flux3( scalar_new(k-2,iCell),scalar_new(k-1,iCell), & scalar_new(k ,iCell),scalar_new(k+1,iCell), & @@ -3521,7 +3787,7 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, num_scala ! original code retained in select "default" case select case(nEdgesOnCell(iCell)) case(6) -!DIR$ IVDEP + !$acc loop vector do k=1, nVertLevels s_max(k,iCell) = max(s_max(k,iCell), & scalar_old(k, cellsOnCell(1,iCell)), & @@ -3537,11 +3803,13 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, num_scala scalar_old(k, cellsOnCell(4,iCell)), & scalar_old(k, cellsOnCell(5,iCell)), & scalar_old(k, cellsOnCell(6,iCell))) - enddo + end do case default + !$acc loop seq do i=1, nEdgesOnCell(iCell) -!DIR$ IVDEP + + !$acc loop vector do k=1, nVertLevels s_max(k,iCell) = max(s_max(k,iCell),scalar_old(k, cellsOnCell(i,iCell))) s_min(k,iCell) = min(s_min(k,iCell),scalar_old(k, cellsOnCell(i,iCell))) @@ -3551,12 +3819,16 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, num_scala end do + !$acc end parallel + !$OMP BARRIER + !$acc parallel + ! ! horizontal flux divergence ! - + !$acc loop gang worker private(ica, swa) do iEdge=edgeStart,edgeEnd cell1 = cellsOnEdge(1,iEdge) @@ -3569,11 +3841,14 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, num_scala ! be sure to see additional declarations near top of subroutine select case(nAdvCellsForEdge(iEdge)) case(10) + !$acc loop vector do jj=1,10 ica(jj) = advCellsForEdge(jj,iEdge) swa(jj,1) = adv_coefs(jj,iEdge) + adv_coefs_3rd(jj,iEdge) swa(jj,2) = adv_coefs(jj,iEdge) - adv_coefs_3rd(jj,iEdge) - enddo + end do + + !$acc loop vector do k=1,nVertLevels ii = merge(1, 2, uhAvg(k,iEdge) > 0) flux_arr(k,iEdge) = uhAvg(k,iEdge)*( & @@ -3582,15 +3857,19 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, num_scala swa(5,ii)*scalar_new(k,ica(5)) + swa(6,ii)*scalar_new(k,ica(6)) + & swa(7,ii)*scalar_new(k,ica(7)) + swa(8,ii)*scalar_new(k,ica(8)) + & swa(9,ii)*scalar_new(k,ica(9)) + swa(10,ii)*scalar_new(k,ica(10))) - enddo + end do case default + !$acc loop vector do k=1,nVertLevels flux_arr(k,iEdge) = 0.0_RKIND - enddo + end do + + !$acc loop seq do i=1,nAdvCellsForEdge(iEdge) iCell = advCellsForEdge(i,iEdge) -!DIR$ IVDEP + + !$acc loop vector do k=1,nVertLevels scalar_weight = uhAvg(k,iEdge)*(adv_coefs(i,iEdge) + sign(1.0_RKIND,uhAvg(k,iEdge))*adv_coefs_3rd(i,iEdge)) flux_arr(k,iEdge) = flux_arr(k,iEdge) + scalar_weight* scalar_new(k,iCell) @@ -3599,43 +3878,55 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, num_scala end select else - flux_arr(:,iEdge) = 0.0_RKIND + + !$acc loop vector + do k=1,nVertLevels + flux_arr(k,iEdge) = 0.0_RKIND + end do + end if end do + !$acc end parallel + !$OMP BARRIER + !$acc parallel + ! ! vertical flux divergence for upwind update, we will put upwind update into scalar_new, and put factor of dt in fluxes ! + !$acc loop gang worker private(flux_upwind_arr) do iCell=cellSolveStart,cellSolveEnd k = 1 scalar_new(k,iCell) = scalar_old(k,iCell) * rho_zz_old(k,iCell) -!DIR$ IVDEP + !$acc loop vector do k = 2, nVertLevels scalar_new(k,iCell) = scalar_old(k,iCell)*rho_zz_old(k,iCell) flux_upwind_arr(k) = dt*(max(0.0_RKIND,wwAvg(k,iCell))*scalar_old(k-1,iCell) + min(0.0_RKIND,wwAvg(k,iCell))*scalar_old(k,iCell)) end do + + !$acc loop vector do k = 1, nVertLevels-1 scalar_new(k,iCell) = scalar_new(k,iCell) - flux_upwind_arr(k+1)*rdnw(k) end do -!DIR$ IVDEP + + !$acc loop vector do k = 2, nVertLevels scalar_new(k ,iCell) = scalar_new(k ,iCell) + flux_upwind_arr(k)*rdnw(k) wdtn(k,iCell) = dt*wdtn(k,iCell) - flux_upwind_arr(k) end do - ! ! scale_arr(SCALE_IN,:,:) and scale_arr(SCALE_OUT:,:) are used here to store the incoming and outgoing perturbation flux ! contributions to the update: first the vertical flux component, then the horizontal ! -!DIR$ IVDEP + !$acc loop vector do k=1,nVertLevels scale_arr(k,SCALE_IN, iCell) = - rdnw(k)*(min(0.0_RKIND,wdtn(k+1,iCell))-max(0.0_RKIND,wdtn(k,iCell))) scale_arr(k,SCALE_OUT,iCell) = - rdnw(k)*(max(0.0_RKIND,wdtn(k+1,iCell))-min(0.0_RKIND,wdtn(k,iCell))) @@ -3648,28 +3939,43 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, num_scala ! ! upwind flux computation + !$acc loop gang worker do iEdge=edgeStart,edgeEnd + cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) -!DIR$ IVDEP - do k=1, nVertLevels + + !$acc loop vector + do k=1,nVertLevels flux_upwind_tmp(k,iEdge) = dvEdge(iEdge) * dt * & (max(0.0_RKIND,uhAvg(k,iEdge))*scalar_old(k,cell1) + min(0.0_RKIND,uhAvg(k,iEdge))*scalar_old(k,cell2)) flux_tmp(k,iEdge) = dt * flux_arr(k,iEdge) - flux_upwind_tmp(k,iEdge) end do if( config_apply_lbcs .and. (bdyMaskEdge(iEdge) == nRelaxZone) .or. (bdyMaskEdge(iEdge) == nRelaxZone-1) ) then - flux_tmp(:,iEdge) = 0. - flux_arr(:,iEdge) = flux_upwind_tmp(:,iEdge) + !$acc loop vector + do k=1,nVertLevels + flux_tmp(k,iEdge) = 0.0_RKIND + flux_arr(k,iEdge) = flux_upwind_tmp(k,iEdge) + end do end if end do + + !$acc end parallel + !$OMP BARRIER + + !$acc parallel + + !$acc loop gang worker do iCell=cellSolveStart,cellSolveEnd + + !$acc loop seq do i=1,nEdgesOnCell(iCell) iEdge = edgesOnCell(i,iCell) -!DIR$ IVDEP + !$acc loop vector do k=1, nVertLevels scalar_new(k,iCell) = scalar_new(k,iCell) - edgesOnCell_sign(i,iCell) * flux_upwind_tmp(k,iEdge) * invAreaCell(iCell) @@ -3682,6 +3988,7 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, num_scala end do end do + ! ! next, the limiter ! @@ -3689,51 +3996,69 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, num_scala ! simplification of limiter calculations ! worked through algebra and found equivalent form ! added benefit that it should address ifort single prec overflow issue - if (local_advance_density) then - do iCell=cellSolveStart,cellSolveEnd -!DIR$ IVDEP - do k = 1, nVertLevels + if (local_advance_density) then + !$acc loop gang worker + do iCell=cellSolveStart,cellSolveEnd - scale_factor = (s_max(k,iCell)*rho_zz_int(k,iCell) - scalar_new(k,iCell)) / & - (scale_arr(k,SCALE_IN,iCell) + eps) - scale_arr(k,SCALE_IN,iCell) = min( 1.0_RKIND, max( 0.0_RKIND, scale_factor) ) + !$acc loop vector + do k = 1, nVertLevels + scale_factor = (s_max(k,iCell)*rho_zz_int(k,iCell) - scalar_new(k,iCell)) / & + (scale_arr(k,SCALE_IN,iCell) + eps) + scale_arr(k,SCALE_IN,iCell) = min( 1.0_RKIND, max( 0.0_RKIND, scale_factor) ) - scale_factor = (s_min(k,iCell)*rho_zz_int(k,iCell) - scalar_new(k,iCell)) / & - (scale_arr(k,SCALE_OUT,iCell) - eps) - scale_arr(k,SCALE_OUT,iCell) = min( 1.0_RKIND, max( 0.0_RKIND, scale_factor) ) + scale_factor = (s_min(k,iCell)*rho_zz_int(k,iCell) - scalar_new(k,iCell)) / & + (scale_arr(k,SCALE_OUT,iCell) - eps) + scale_arr(k,SCALE_OUT,iCell) = min( 1.0_RKIND, max( 0.0_RKIND, scale_factor) ) + end do end do - end do - else - do iCell=cellSolveStart,cellSolveEnd -!DIR$ IVDEP - do k = 1, nVertLevels + else + !$acc loop gang worker + do iCell=cellSolveStart,cellSolveEnd - scale_factor = (s_max(k,iCell)*rho_zz_new(k,iCell) - scalar_new(k,iCell)) / & - (scale_arr(k,SCALE_IN,iCell) + eps) - scale_arr(k,SCALE_IN,iCell) = min( 1.0_RKIND, max( 0.0_RKIND, scale_factor) ) + !$acc loop vector + do k = 1, nVertLevels + scale_factor = (s_max(k,iCell)*rho_zz_new(k,iCell) - scalar_new(k,iCell)) / & + (scale_arr(k,SCALE_IN,iCell) + eps) + scale_arr(k,SCALE_IN,iCell) = min( 1.0_RKIND, max( 0.0_RKIND, scale_factor) ) - scale_factor = (s_min(k,iCell)*rho_zz_new(k,iCell) - scalar_new(k,iCell)) / & - (scale_arr(k,SCALE_OUT,iCell) - eps) - scale_arr(k,SCALE_OUT,iCell) = min( 1.0_RKIND, max( 0.0_RKIND, scale_factor) ) + scale_factor = (s_min(k,iCell)*rho_zz_new(k,iCell) - scalar_new(k,iCell)) / & + (scale_arr(k,SCALE_OUT,iCell) - eps) + scale_arr(k,SCALE_OUT,iCell) = min( 1.0_RKIND, max( 0.0_RKIND, scale_factor) ) + end do end do - end do - end if + end if + + !$acc end parallel ! ! communicate scale factors here. ! communicate only first halo row in these next two exchanges ! + + MPAS_ACC_TIMER_START('atm_advance_scalars_mono [ACC_data_xfer]') + !$acc update self(scale_arr) + MPAS_ACC_TIMER_STOP('atm_advance_scalars_mono [ACC_data_xfer]') + !$OMP BARRIER !$OMP MASTER call exchange_halo_group(block % domain, 'dynamics:scale') !$OMP END MASTER !$OMP BARRIER + MPAS_ACC_TIMER_START('atm_advance_scalars_mono [ACC_data_xfer]') + !$acc update device(scale_arr) + MPAS_ACC_TIMER_STOP('atm_advance_scalars_mono [ACC_data_xfer]') + + !$acc parallel + + !$acc loop gang worker do iEdge=edgeStart,edgeEnd cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) + if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then ! only for owned cells -!DIR$ IVDEP + + !$acc loop vector do k=1, nVertLevels flux_upwind = dvEdge(iEdge) * dt * & (max(0.0_RKIND,uhAvg(k,iEdge))*scalar_old(k,cell1) + min(0.0_RKIND,uhAvg(k,iEdge))*scalar_old(k,cell2)) @@ -3741,7 +4066,10 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, num_scala end do if( config_apply_lbcs .and. (bdyMaskEdge(iEdge) == nRelaxZone) .or. (bdyMaskEdge(iEdge) == nRelaxZone-1) ) then - flux_arr(:,iEdge) = 0. + !$acc loop vector + do k=1,nVertLevels + flux_arr(k,iEdge) = 0.0_RKIND + end do end if end if @@ -3753,11 +4081,14 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, num_scala ! moved assignment to scalar_new from separate loop (see commented code below) ! into the following loops. Avoids having to save elements of flux array + !$acc loop gang worker do iEdge=edgeStart,edgeEnd cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) + if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then -!DIR$ IVDEP + + !$acc loop vector do k = 1, nVertLevels flux = flux_arr(k,iEdge) flux = max(0.0_RKIND,flux) * min(scale_arr(k,SCALE_OUT,cell1), scale_arr(k,SCALE_IN, cell2)) & @@ -3766,14 +4097,21 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, num_scala end do end if end do - - ! - ! rescale the vertical flux - ! + + !$acc end parallel + + ! + ! rescale the vertical flux + ! + !$OMP BARRIER + + !$acc parallel + !$acc loop gang worker do iCell=cellSolveStart,cellSolveEnd -!DIR$ IVDEP + + !$acc loop vector do k = 2, nVertLevels flux = wdtn(k,iCell) flux = max(0.0_RKIND,flux) * min(scale_arr(k-1,SCALE_OUT,iCell), scale_arr(k ,SCALE_IN,iCell)) & @@ -3782,33 +4120,42 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, num_scala end do end do - ! ! do the scalar update now that we have the fluxes ! + !$acc loop gang worker do iCell=cellSolveStart,cellSolveEnd + + !$acc loop seq do i=1,nEdgesOnCell(iCell) iEdge = edgesOnCell(i,iCell) -!DIR$ IVDEP + + !$acc loop vector do k=1,nVertLevels scalar_new(k,iCell) = scalar_new(k,iCell) - edgesOnCell_sign(i,iCell)*flux_arr(k,iEdge) * invAreaCell(iCell) end do end do - if (local_advance_density) then -!DIR$ IVDEP - do k=1,nVertLevels - scalar_new(k,iCell) = ( scalar_new(k,iCell) + (-rdnw(k)*(wdtn(k+1,iCell)-wdtn(k,iCell)) ) )/rho_zz_int(k,iCell) - end do - else -!DIR$ IVDEP - do k=1,nVertLevels - scalar_new(k,iCell) = ( scalar_new(k,iCell) + (-rdnw(k)*(wdtn(k+1,iCell)-wdtn(k,iCell)) ) )/rho_zz_new(k,iCell) - end do - end if + if (local_advance_density) then + !$acc loop vector + do k=1,nVertLevels + scalar_new(k,iCell) = (scalar_new(k,iCell) + (-rdnw(k)*(wdtn(k+1,iCell)-wdtn(k,iCell)) ) )/rho_zz_int(k,iCell) + end do + else + !$acc loop vector + do k=1,nVertLevels + scalar_new(k,iCell) = (scalar_new(k,iCell) + (-rdnw(k)*(wdtn(k+1,iCell)-wdtn(k,iCell)) ) )/rho_zz_new(k,iCell) + end do + end if end do + !$acc end parallel + #ifdef DEBUG_TRANSPORT + !$acc update self(scalar_new) + !$acc update self(s_max) + !$acc update self(s_min) + scmin = scalar_new(1,1) scmax = scalar_new(1,1) do iCell = 1, nCellsSolve @@ -3831,16 +4178,36 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, num_scala ! hence the enforcement of PD in the copy back to the model state. !$OMP BARRIER + !$acc parallel + + !$acc loop gang worker do iCell=cellStart,cellEnd if(bdyMaskCell(iCell) <= nSpecZone) then ! regional_MPAS does spec zone update after transport. - do k=1, nVertLevels + !$acc loop vector + do k=1,nVertLevels scalars_new(iScalar,k,iCell) = max(0.0_RKIND,scalar_new(k,iCell)) end do end if end do + !$acc end parallel + end do ! loop over scalars + MPAS_ACC_TIMER_START('atm_advance_scalars_mono [ACC_data_xfer]') + if (local_advance_density) then + !$acc exit data copyout(rho_zz_int) + else + !$acc exit data delete(rho_zz_new) + end if + !$acc exit data copyout(scalars_new) + !$acc exit data delete(scalars_old, scalar_old, scalar_new, scale_arr, s_min, s_max, & + !$acc rho_zz_old, flux_arr, flux_tmp, flux_upwind_tmp, wdtn, wwAvg, & + !$acc uhAvg, fnm, fnp, rdnw) + + !$acc end data + MPAS_ACC_TIMER_STOP('atm_advance_scalars_mono [ACC_data_xfer]') + end subroutine atm_advance_scalars_mono_work diff --git a/src/core_atmosphere/mpas_atm_core.F b/src/core_atmosphere/mpas_atm_core.F index 138035d4d2..997d7ca8ba 100644 --- a/src/core_atmosphere/mpas_atm_core.F +++ b/src/core_atmosphere/mpas_atm_core.F @@ -392,7 +392,9 @@ subroutine atm_mpas_init_block(dminfo, stream_manager, block, mesh, dt) type (mpas_pool_type), pointer :: tend type (mpas_pool_type), pointer :: sfc_input type (mpas_pool_type), pointer :: diag_physics + type (mpas_pool_type), pointer :: diag_physics_noahmp type (mpas_pool_type), pointer :: atm_input + type (mpas_pool_type), pointer :: output_noahmp integer :: iCell,iEdge,iVertex @@ -551,14 +553,16 @@ subroutine atm_mpas_init_block(dminfo, stream_manager, block, mesh, dt) !initialization of some input variables in registry: call mpas_pool_get_subpool(block % structs, 'tend', tend) call mpas_pool_get_subpool(block % structs, 'diag_physics', diag_physics) + call mpas_pool_get_subpool(block % structs, 'diag_physics_noahmp', diag_physics_noahmp) call mpas_pool_get_subpool(block % structs, 'atm_input', atm_input) + call mpas_pool_get_subpool(block % structs, 'output_noahmp', output_noahmp) call physics_tables_init(dminfo, block % configs) call physics_registry_init(mesh, block % configs, sfc_input) call physics_run_init(block % configs, mesh, state, clock, stream_manager) !initialization of all physics: call physics_init(dminfo, clock, block % configs, mesh, diag, tend, state, 1, diag_physics, & - atm_input, sfc_input) + diag_physics_noahmp, atm_input, sfc_input, output_noahmp) endif #endif diff --git a/src/core_atmosphere/mpas_atm_core_interface.F b/src/core_atmosphere/mpas_atm_core_interface.F index af7a9d7ee3..c8db24ceac 100644 --- a/src/core_atmosphere/mpas_atm_core_interface.F +++ b/src/core_atmosphere/mpas_atm_core_interface.F @@ -262,9 +262,7 @@ function atm_setup_log(logInfo, domain, unitNumbers) result(iErr)!{{{ use mpas_derived_types, only : mpas_log_type, domain_type use mpas_log, only : mpas_log_init, mpas_log_open -#ifdef MPAS_OPENMP - use mpas_threading, only : mpas_threading_get_num_threads -#endif + use mpas_framework, only : mpas_framework_report_settings implicit none @@ -293,53 +291,8 @@ function atm_setup_log(logInfo, domain, unitNumbers) result(iErr)!{{{ call mpas_log_write('') call mpas_log_write('MPAS-Atmosphere Version '//trim(domain % core % modelVersion)) call mpas_log_write('') - call mpas_log_write('') - call mpas_log_write('Output from ''git describe --dirty'': '//trim(domain % core % git_version)) - call mpas_log_write('') - call mpas_log_write('Compile-time options:') - call mpas_log_write(' Build target: '//trim(domain % core % build_target)) - call mpas_log_write(' OpenMP support: ' // & -#ifdef MPAS_OPENMP - 'yes') -#else - 'no') -#endif - call mpas_log_write(' OpenACC support: ' // & -#ifdef MPAS_OPENACC - 'yes') -#else - 'no') -#endif - call mpas_log_write(' Default real precision: ' // & -#ifdef SINGLE_PRECISION - 'single') -#else - 'double') -#endif - call mpas_log_write(' Compiler flags: ' // & -#ifdef MPAS_DEBUG - 'debug') -#else - 'optimize') -#endif - call mpas_log_write(' I/O layer: ' // & -#ifdef MPAS_PIO_SUPPORT -#ifdef USE_PIO2 - 'PIO 2.x') -#else - 'PIO 1.x') -#endif -#else - 'SMIOL') -#endif - call mpas_log_write('') - call mpas_log_write('Run-time settings:') - call mpas_log_write(' MPI task count: $i', intArgs=[domain % dminfo % nprocs]) -#ifdef MPAS_OPENMP - call mpas_log_write(' OpenMP max threads: $i', intArgs=[mpas_threading_get_max_threads()]) -#endif - call mpas_log_write('') + call mpas_framework_report_settings(domain) end function atm_setup_log!}}} diff --git a/src/core_atmosphere/mpas_atm_halos.F b/src/core_atmosphere/mpas_atm_halos.F index 633b5582a7..df02ee30a2 100644 --- a/src/core_atmosphere/mpas_atm_halos.F +++ b/src/core_atmosphere/mpas_atm_halos.F @@ -26,7 +26,6 @@ subroutine halo_exchange_routine(domain, halo_group, ierr) end subroutine halo_exchange_routine end interface - character(len=StrKIND), pointer, private :: config_halo_exch_method procedure (halo_exchange_routine), pointer :: exchange_halo_group @@ -56,9 +55,14 @@ subroutine atm_build_halo_groups(domain, ierr) use mpas_halo, only : mpas_halo_init, mpas_halo_exch_group_create, mpas_halo_exch_group_add_field, & mpas_halo_exch_group_complete, mpas_halo_exch_group_full_halo_exch + ! Arguments type (domain_type), intent(inout) :: domain integer, intent(inout) :: ierr + ! Local variables + character(len=StrKIND), pointer :: config_halo_exch_method + + ! ! Determine from the namelist option config_halo_exch_method which halo exchange method to employ ! @@ -350,9 +354,15 @@ subroutine atm_destroy_halo_groups(domain, ierr) use mpas_dmpar, only : mpas_dmpar_exch_group_destroy use mpas_halo, only : mpas_halo_exch_group_destroy, mpas_halo_finalize + ! Arguments type (domain_type), intent(inout) :: domain integer, intent(inout) :: ierr + ! Local variables + character(len=StrKIND), pointer :: config_halo_exch_method + + + call mpas_pool_get_config(domain % blocklist % configs, 'config_halo_exch_method', config_halo_exch_method) if (trim(config_halo_exch_method) == 'mpas_dmpar') then ! diff --git a/src/core_atmosphere/physics/.gitignore b/src/core_atmosphere/physics/.gitignore index e0d3d1a002..f27a16f144 100644 --- a/src/core_atmosphere/physics/.gitignore +++ b/src/core_atmosphere/physics/.gitignore @@ -1,3 +1,4 @@ *.f90 physics_wrf/*.f90 physics_wrf/files/ +physics_mmm diff --git a/src/core_atmosphere/physics/Makefile b/src/core_atmosphere/physics/Makefile index 39f7230f4b..70ae1e3064 100644 --- a/src/core_atmosphere/physics/Makefile +++ b/src/core_atmosphere/physics/Makefile @@ -4,13 +4,15 @@ ifeq ($(CORE),atmosphere) COREDEF = -Dmpas endif -all: lookup_tables core_physics_init core_physics_mmm core_physics_wrf core_physics +all: + ./../tools/manage_externals/checkout_externals --externals ./../Externals.cfg + $(MAKE) lookup_tables core_physics_init core_physics_mmm core_physics_wrf core_physics_noahmp core_physics dummy: echo "****** compiling physics ******" OBJS_init = \ - ccpp_kinds.o \ + ccpp_kind_types.o \ mpas_atmphys_constants.o \ mpas_atmphys_date_time.o \ mpas_atmphys_functions.o \ @@ -24,6 +26,7 @@ OBJS = \ mpas_atmphys_driver_convection.o \ mpas_atmphys_driver_gwdo.o \ mpas_atmphys_driver_lsm.o \ + mpas_atmphys_driver_lsm_noahmp.o \ mpas_atmphys_driver_microphysics.o \ mpas_atmphys_driver_oml.o \ mpas_atmphys_driver_pbl.o \ @@ -37,6 +40,8 @@ OBJS = \ mpas_atmphys_interface.o \ mpas_atmphys_landuse.o \ mpas_atmphys_lsm_noahinit.o \ + mpas_atmphys_lsm_noahmpinit.o \ + mpas_atmphys_lsm_noahmpfinalize.o \ mpas_atmphys_lsm_shared.o \ mpas_atmphys_manager.o \ mpas_atmphys_o3climatology.o \ @@ -52,17 +57,26 @@ lookup_tables: ./checkout_data_files.sh core_physics_mmm: core_physics_init - (cd physics_mmm; $(MAKE) all) + (cd physics_mmm; $(MAKE) -f Makefile.mpas all) core_physics_wrf: core_physics_init core_physics_mmm (cd physics_wrf; $(MAKE) all COREDEF="$(COREDEF)") +core_physics_noahmp: + (cd physics_noahmp/utility; $(MAKE) all COREDEF="$(COREDEF)") + (cd physics_noahmp/src; $(MAKE) all COREDEF="$(COREDEF)") + (cd physics_noahmp/drivers/mpas; $(MAKE) all COREDEF="$(COREDEF)") + core_physics_init: $(OBJS_init) - ar -ru libphys.a $(OBJS_init) -core_physics: core_physics_wrf +core_physics: core_physics_wrf core_physics_noahmp ($(MAKE) phys_interface COREDEF="$(COREDEF)") - ar -ru libphys.a $(OBJS) + ar -ru libphys.a $(OBJS_init) $(OBJS) + ($(MAKE) -C ./physics_mmm -f Makefile.mpas physics_mmm_lib) + ($(MAKE) -C ./physics_wrf physics_wrf_lib) + ($(MAKE) -C ./physics_noahmp/drivers/mpas driver_lib) + ($(MAKE) -C ./physics_noahmp/src src_lib) + ($(MAKE) -C ./physics_noahmp/utility utility_lib) phys_interface: $(OBJS) @@ -80,6 +94,7 @@ mpas_atmphys_driver.o: \ mpas_atmphys_driver_convection.o \ mpas_atmphys_driver_gwdo.o \ mpas_atmphys_driver_lsm.o \ + mpas_atmphys_driver_lsm_noahmp.o \ mpas_atmphys_driver_pbl.o \ mpas_atmphys_driver_radiation_lw.o \ mpas_atmphys_driver_radiation_sw.o \ @@ -109,6 +124,11 @@ mpas_atmphys_driver_lsm.o: \ mpas_atmphys_lsm_noahinit.o \ mpas_atmphys_vars.o +mpas_atmphys_driver_lsm_noahmp.o: \ + mpas_atmphys_constants.o \ + mpas_atmphys_manager.o \ + mpas_atmphys_vars.o + mpas_atmphys_driver_microphysics.o: \ mpas_atmphys_constants.o \ mpas_atmphys_init_microphysics.o \ @@ -139,10 +159,18 @@ mpas_atmphys_driver_radiation_sw.o: \ mpas_atmphys_rrtmg_swinit.o \ mpas_atmphys_vars.o +mpas_atmphys_driver_seaice.o: \ + mpas_atmphys_constants.o \ + mpas_atmphys_lsm_shared.o \ + mpas_atmphys_vars.o + mpas_atmphys_driver_sfclayer.o: \ mpas_atmphys_constants.o \ mpas_atmphys_vars.o +mpas_atmphys_finalize.o: \ + mpas_atmphys_lsm_noahmpfinalize.o + mpas_atmphys_init.o: \ mpas_atmphys_driver_convection.o \ mpas_atmphys_driver_lsm.o \ @@ -151,6 +179,7 @@ mpas_atmphys_init.o: \ mpas_atmphys_driver_radiation_lw.o \ mpas_atmphys_driver_radiation_sw.o \ mpas_atmphys_driver_sfclayer.o \ + mpas_atmphys_lsm_noahmpinit.o \ mpas_atmphys_landuse.o \ mpas_atmphys_o3climatology.o \ mpas_atmphys_vars.o @@ -167,6 +196,10 @@ mpas_atmphys_lsm_noahinit.o: \ mpas_atmphys_constants.o \ mpas_atmphys_utilities.o +mpas_atmphys_lsm_noahmpinit.o: \ + mpas_atmphys_utilities.o \ + mpas_atmphys_vars.o + mpas_atmphys_manager.o: \ mpas_atmphys_constants.o \ mpas_atmphys_o3climatology.o \ @@ -187,11 +220,6 @@ mpas_atmphys_rrtmg_swinit.o: \ mpas_atmphys_constants.o \ mpas_atmphys_utilities.o -mpas_atmphys_driver_seaice.o: \ - mpas_atmphys_constants.o \ - mpas_atmphys_lsm_shared.o \ - mpas_atmphys_vars.o - mpas_atmphys_todynamics.o: \ mpas_atmphys_constants.o \ mpas_atmphys_vars.o @@ -208,7 +236,10 @@ mpas_atmphys_update.o: \ clean: $(RM) *.o *.mod *.f90 libphys.a ( cd physics_wrf; $(MAKE) clean ) - ( cd physics_mmm; $(MAKE) clean ) + ( if [ -d physics_mmm ]; then cd physics_mmm; $(MAKE) -f Makefile.mpas clean; fi; ) + ( cd physics_noahmp/drivers/mpas; $(MAKE) clean ) + ( cd physics_noahmp/src; $(MAKE) clean ) + ( cd physics_noahmp/utility; $(MAKE) clean ) @# Certain systems with intel compilers generate *.i files @# This removes them during the clean process $(RM) *.i @@ -217,7 +248,7 @@ clean: $(RM) $@ $*.mod ifeq "$(GEN_F90)" "true" $(CPP) $(CPPFLAGS) $(COREDEF) $(HYDROSTATIC) $(CPPINCLUDES) $< > $*.f90 - $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I./physics_mmm -I./physics_wrf -I.. -I../../framework -I../../external/esmf_time_f90 + $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I./physics_mmm -I./physics_wrf -I./physics_noahmp -I./physics_noahmp/utility -I./physics_noahmp/drivers/mpas -I./physics_noahmp/src -I.. -I../../framework -I../../external/esmf_time_f90 else - $(FC) $(CPPFLAGS) $(COREDEF) $(HYDROSATIC) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I./physics_mmm -I./physics_wrf -I.. -I../../framework -I../../external/esmf_time_f90 + $(FC) $(CPPFLAGS) $(COREDEF) $(HYDROSATIC) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I./physics_mmm -I./physics_wrf -I./physics_noahmp -I./physics_noahmp/utility -I./physics_noahmp/drivers/mpas -I./physics_noahmp/src -I.. -I../../framework -I../../external/esmf_time_f90 endif diff --git a/src/core_atmosphere/physics/Registry_noahmp.xml b/src/core_atmosphere/physics/Registry_noahmp.xml new file mode 100644 index 0000000000..2e489d442c --- /dev/null +++ b/src/core_atmosphere/physics/Registry_noahmp.xml @@ -0,0 +1,624 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/src/core_atmosphere/physics/ccpp_kind_types.F b/src/core_atmosphere/physics/ccpp_kind_types.F new file mode 100644 index 0000000000..cdc75ccfa8 --- /dev/null +++ b/src/core_atmosphere/physics/ccpp_kind_types.F @@ -0,0 +1,4 @@ +module ccpp_kind_types + use mpas_kind_types,only: kind_phys => RKIND, kind_phys8 => R8KIND + contains +end module ccpp_kind_types diff --git a/src/core_atmosphere/physics/ccpp_kinds.F b/src/core_atmosphere/physics/ccpp_kinds.F deleted file mode 100644 index af633a84ee..0000000000 --- a/src/core_atmosphere/physics/ccpp_kinds.F +++ /dev/null @@ -1,4 +0,0 @@ -module ccpp_kinds - use mpas_kind_types,only: kind_phys => RKIND - contains -end module ccpp_kinds diff --git a/src/core_atmosphere/physics/checkout_data_files.sh b/src/core_atmosphere/physics/checkout_data_files.sh index 55043fee70..b5ad45bcef 100755 --- a/src/core_atmosphere/physics/checkout_data_files.sh +++ b/src/core_atmosphere/physics/checkout_data_files.sh @@ -23,7 +23,7 @@ ################################################################################ -mpas_vers="8.0" +mpas_vers="8.2" github_org="MPAS-Dev" # GitHub organization where the MPAS-Data repository is found. # For physics development, it can be helpful for a developer diff --git a/src/core_atmosphere/physics/mpas_atmphys_control.F b/src/core_atmosphere/physics/mpas_atmphys_control.F index b37a512a2e..5c77875911 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_control.F +++ b/src/core_atmosphere/physics/mpas_atmphys_control.F @@ -72,10 +72,17 @@ module mpas_atmphys_control ! * modified logic in subroutine physics_tables_init so that the Thompson microphysics tables are read in each ! MPI task. ! Laura D. Fowler (laura@ucar.edu) / 2016-12-30. +! * added the option mp_thompson_aerosols. +! Laura D. Fowler (laura@ucar.edu) / 2018-01-31. ! * added the option sf_monin_obukhov_rev to run the revised surface layer scheme with the YSU PBL scheme. ! Laura D. Fowler (laura@ucar.edu) / 2023-05-15. ! * replaced the option "noah" with "sf_noah" to run the NOAH land surface scheme. ! Laura D. Fowler (laura@ucar.edu) / 2022-02-18. +! * added the option "sf_noahmp" to run the NOAH-MP land surface scheme. +! Laura D. Fowler (laura@ucar.edu) / 2022-07-15. +! * in the mesoscale_reference suite, replaced the MM5 surface layer scheme with the MM5 revised surface layer +! scheme as the default option for config_sfclayer_scheme. +! Laura D. Fowler (laura@ucar.edu) / 2024-06-18. contains @@ -130,7 +137,7 @@ subroutine physics_namelist_check(configs) if (trim(config_radt_lw_scheme) == 'suite') config_radt_lw_scheme = 'rrtmg_lw' if (trim(config_radt_sw_scheme) == 'suite') config_radt_sw_scheme = 'rrtmg_sw' if (trim(config_radt_cld_scheme) == 'suite') config_radt_cld_scheme = 'cld_fraction' - if (trim(config_sfclayer_scheme) == 'suite') config_sfclayer_scheme = 'sf_monin_obukhov' + if (trim(config_sfclayer_scheme) == 'suite') config_sfclayer_scheme = 'sf_monin_obukhov_rev' if (trim(config_lsm_scheme) == 'suite') config_lsm_scheme = 'sf_noah' else if (trim(config_physics_suite) == 'convection_permitting') then @@ -166,12 +173,13 @@ subroutine physics_namelist_check(configs) end if !cloud microphysics scheme: - if(.not. (config_microp_scheme .eq. 'off' .or. & - config_microp_scheme .eq. 'mp_kessler' .or. & - config_microp_scheme .eq. 'mp_thompson' .or. & + if(.not. (config_microp_scheme .eq. 'off' .or. & + config_microp_scheme .eq. 'mp_kessler' .or. & + config_microp_scheme .eq. 'mp_thompson' .or. & + config_microp_scheme .eq. 'mp_thompson_aerosols' .or. & config_microp_scheme .eq. 'mp_wsm6')) then - write(mpas_err_message,'(A,A10)') 'illegal value for config_microp_scheme:', & + write(mpas_err_message,'(A,A20)') 'illegal value for config_microp_scheme:', & trim(config_microp_scheme) call physics_error_fatal(mpas_err_message) @@ -184,7 +192,7 @@ subroutine physics_namelist_check(configs) config_convection_scheme .eq. 'cu_tiedtke' .or. & config_convection_scheme .eq. 'cu_ntiedtke')) then - write(mpas_err_message,'(A,A10)') 'illegal value for config_convection_scheme: ', & + write(mpas_err_message,'(A,A20)') 'illegal value for config_convection_scheme: ', & trim(config_convection_scheme) call physics_error_fatal(mpas_err_message) @@ -195,7 +203,7 @@ subroutine physics_namelist_check(configs) config_pbl_scheme .eq. 'bl_mynn' .or. & config_pbl_scheme .eq. 'bl_ysu')) then - write(mpas_err_message,'(A,A10)') 'illegal value for pbl_scheme: ', & + write(mpas_err_message,'(A,A20)') 'illegal value for pbl_scheme: ', & trim(config_pbl_scheme) call physics_error_fatal(mpas_err_message) @@ -205,7 +213,7 @@ subroutine physics_namelist_check(configs) if(.not. (config_gwdo_scheme .eq. 'off' .or. & config_gwdo_scheme .eq. 'bl_ysu_gwdo')) then - write(mpas_err_message,'(A,A10)') 'illegal value for gwdo_scheme: ', & + write(mpas_err_message,'(A,A20)') 'illegal value for gwdo_scheme: ', & trim(config_gwdo_scheme) call physics_error_fatal(mpas_err_message) @@ -216,7 +224,7 @@ subroutine physics_namelist_check(configs) config_radt_lw_scheme .eq. 'cam_lw' .or. & config_radt_lw_scheme .eq. 'rrtmg_lw')) then - write(mpas_err_message,'(A,A10)') 'illegal value for longwave radiation scheme: ', & + write(mpas_err_message,'(A,A20)') 'illegal value for longwave radiation scheme: ', & trim(config_radt_lw_scheme) call physics_error_fatal(mpas_err_message) @@ -227,7 +235,7 @@ subroutine physics_namelist_check(configs) config_radt_sw_scheme .eq. 'cam_sw' .or. & config_radt_sw_scheme .eq. 'rrtmg_sw')) then - write(mpas_err_message,'(A,A10)') 'illegal value for shortwave radiation _scheme: ', & + write(mpas_err_message,'(A,A20)') 'illegal value for shortwave radiation _scheme: ', & trim(config_radt_sw_scheme) call physics_error_fatal(mpas_err_message) @@ -239,7 +247,7 @@ subroutine physics_namelist_check(configs) config_radt_cld_scheme .eq. 'cld_fraction' .or. & config_radt_cld_scheme .eq. 'cld_fraction_thompson')) then - write(mpas_err_message,'(A,A10)') 'illegal value for calculation of cloud fraction: ', & + write(mpas_err_message,'(A,A20)') 'illegal value for calculation of cloud fraction: ', & trim(config_radt_cld_scheme) call physics_error_fatal(mpas_err_message) @@ -248,10 +256,10 @@ subroutine physics_namelist_check(configs) (config_radt_sw_scheme.ne.'off' .and. config_radt_cld_scheme.eq.'off')) then call mpas_log_write('') - write(mpas_err_message,'(A,A10)') & + write(mpas_err_message,'(A,A20)') & ' config_radt_cld_scheme is not set for radiation calculation' call physics_message(mpas_err_message) - write(mpas_err_message,'(A,A10)') & + write(mpas_err_message,'(A,A20)') & ' switch calculation of cloud fraction to config_radt_cld_scheme = cld_incidence' call physics_message(mpas_err_message) config_radt_cld_scheme = "cld_incidence" @@ -264,7 +272,7 @@ subroutine physics_namelist_check(configs) config_sfclayer_scheme .eq. 'sf_monin_obukhov' .or. & config_sfclayer_scheme .eq. 'sf_monin_obukhov_rev')) then - write(mpas_err_message,'(A,A10)') 'illegal value for surface layer scheme: ', & + write(mpas_err_message,'(A,A20)') 'illegal value for surface layer scheme: ', & trim(config_sfclayer_scheme) call physics_error_fatal(mpas_err_message) else @@ -273,7 +281,7 @@ subroutine physics_namelist_check(configs) elseif(config_pbl_scheme == 'bl_ysu') then if(config_sfclayer_scheme /= 'sf_monin_obukhov' .and. & config_sfclayer_scheme /= 'sf_monin_obukhov_rev') then - write(mpas_err_message,'(A,A10)') 'wrong choice for surface layer scheme with YSU PBL: ', & + write(mpas_err_message,'(A,A20)') 'wrong choice for surface layer scheme with YSU PBL: ', & trim(config_sfclayer_scheme) call physics_error_fatal(mpas_err_message) endif @@ -287,10 +295,11 @@ subroutine physics_namelist_check(configs) call physics_error_fatal('land surface scheme: ' // & 'set config_sfclayer_scheme different than off') - elseif(.not. (config_lsm_scheme .eq. 'off ' .or. & - config_lsm_scheme .eq. 'sf_noah')) then + elseif(.not. (config_lsm_scheme .eq. 'off ' .or. & + config_lsm_scheme .eq. 'sf_noah' .or. & + config_lsm_scheme .eq. 'sf_noahmp')) then - write(mpas_err_message,'(A,A10)') 'illegal value for land surface scheme: ', & + write(mpas_err_message,'(A,A20)') 'illegal value for land surface scheme: ', & trim(config_lsm_scheme) call physics_error_fatal(mpas_err_message) @@ -359,7 +368,7 @@ subroutine physics_registry_init(mesh,configs,sfc_input) lsm_select: select case(trim(config_lsm_scheme)) - case("sf_noah") + case("sf_noah","sf_noahmp") !initialize the thickness of the soil layers for the Noah scheme: do iCell = 1, nCells dzs(1,iCell) = 0.10_RKIND @@ -398,7 +407,8 @@ subroutine physics_tables_init(dminfo,configs) if(dminfo % my_proc_id == IO_NODE) then call mpas_pool_get_config(configs,'config_microp_scheme',config_microp_scheme) - if(config_microp_scheme /= "mp_thompson") return + if(config_microp_scheme /= "mp_thompson" .or. & + config_microp_scheme /= "mp_thompson_aerosols") return l_qr_acr_qg = .false. l_qr_acr_qs = .false. diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver.F b/src/core_atmosphere/physics/mpas_atmphys_driver.F index 64a50efca4..402517e98f 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver.F @@ -14,6 +14,7 @@ module mpas_atmphys_driver use mpas_atmphys_driver_convection use mpas_atmphys_driver_gwdo use mpas_atmphys_driver_lsm + use mpas_atmphys_driver_lsm_noahmp use mpas_atmphys_driver_pbl use mpas_atmphys_driver_radiation_lw use mpas_atmphys_driver_radiation_sw @@ -98,6 +99,8 @@ module mpas_atmphys_driver ! * modified call to driver_cloudiness to accomodate the calculation of the cloud fraction with the Thompson ! cloud microphysics scheme. ! Laura D. Fowler (laura@ucar.edu) / 2016-06-04. +! * added call to the Noah-MP land surface scheme. +! Laura D. Fowler (laura@ucar.edu) / 2024-03-11. contains @@ -115,13 +118,15 @@ subroutine physics_driver(domain,itimestep,xtime_s) type(domain_type),intent(inout):: domain !local pointers: - type(mpas_pool_type),pointer:: configs, & - mesh, & - state, & - diag, & - diag_physics, & - tend_physics, & - atm_input, & + type(mpas_pool_type),pointer:: configs, & + mesh, & + state, & + diag, & + diag_physics, & + diag_physics_noahmp, & + output_noahmp, & + tend_physics, & + atm_input, & sfc_input logical,pointer:: config_frac_seaice @@ -175,18 +180,20 @@ subroutine physics_driver(domain,itimestep,xtime_s) block => domain % blocklist do while(associated(block)) - call mpas_pool_get_subpool(block%structs,'mesh' ,mesh ) - call mpas_pool_get_subpool(block%structs,'state' ,state ) - call mpas_pool_get_subpool(block%structs,'diag' ,diag ) - call mpas_pool_get_subpool(block%structs,'diag_physics',diag_physics) - call mpas_pool_get_subpool(block%structs,'atm_input' ,atm_input ) - call mpas_pool_get_subpool(block%structs,'sfc_input' ,sfc_input ) - call mpas_pool_get_subpool(block%structs,'tend_physics',tend_physics) + call mpas_pool_get_subpool(block%structs,'mesh' ,mesh ) + call mpas_pool_get_subpool(block%structs,'state' ,state ) + call mpas_pool_get_subpool(block%structs,'diag' ,diag ) + call mpas_pool_get_subpool(block%structs,'diag_physics' ,diag_physics ) + call mpas_pool_get_subpool(block%structs,'diag_physics_noahmp',diag_physics_noahmp) + call mpas_pool_get_subpool(block%structs,'output_noahmp' ,output_noahmp ) + call mpas_pool_get_subpool(block%structs,'atm_input' ,atm_input ) + call mpas_pool_get_subpool(block%structs,'sfc_input' ,sfc_input ) + call mpas_pool_get_subpool(block%structs,'tend_physics' ,tend_physics ) - call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) + call mpas_pool_get_dimension(block%dimensions,'nThreads',nThreads) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadStart', cellSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadEnd', cellSolveThreadEnd) + call mpas_pool_get_dimension(block%dimensions,'cellSolveThreadStart',cellSolveThreadStart) + call mpas_pool_get_dimension(block%dimensions,'cellSolveThreadEnd',cellSolveThreadEnd) !allocate arrays shared by all physics parameterizations: call allocate_forall_physics(block%configs) @@ -197,7 +204,7 @@ subroutine physics_driver(domain,itimestep,xtime_s) !$OMP PARALLEL DO do thread=1,nThreads call MPAS_to_physics(block%configs,mesh,state,time_lev,diag,diag_physics, & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread)) + cellSolveThreadStart(thread),cellSolveThreadEnd(thread)) end do !$OMP END PARALLEL DO @@ -220,7 +227,7 @@ subroutine physics_driver(domain,itimestep,xtime_s) do thread=1,nThreads call driver_radiation_sw(itimestep,block%configs,mesh,state,time_lev,diag_physics, & atm_input,sfc_input,tend_physics,xtime_s, & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread)) + cellSolveThreadStart(thread),cellSolveThreadEnd(thread)) end do !$OMP END PARALLEL DO endif @@ -233,7 +240,7 @@ subroutine physics_driver(domain,itimestep,xtime_s) do thread=1,nThreads call driver_radiation_lw(xtime_s,block%configs,mesh,state,time_lev,diag_physics, & atm_input,sfc_input,tend_physics, & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread)) + cellSolveThreadStart(thread),cellSolveThreadEnd(thread)) end do !$OMP END PARALLEL DO endif @@ -243,7 +250,7 @@ subroutine physics_driver(domain,itimestep,xtime_s) !$OMP PARALLEL DO do thread=1,nThreads call update_radiation_diagnostics(block%configs,mesh,diag_physics, & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread)) + cellSolveThreadStart(thread),cellSolveThreadEnd(thread)) end do !$OMP END PARALLEL DO endif @@ -260,26 +267,35 @@ subroutine physics_driver(domain,itimestep,xtime_s) !$OMP PARALLEL DO do thread=1,nThreads call driver_sfclayer(itimestep,block%configs,mesh,diag_physics,sfc_input, & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread)) + cellSolveThreadStart(thread),cellSolveThreadEnd(thread)) end do !$OMP END PARALLEL DO call deallocate_sfclayer(block%configs) endif !call to 1d ocean mixed-layer model - if(config_oml1d) call driver_oml1d(block%configs, mesh, diag, diag_physics, sfc_input) + if(config_oml1d) call driver_oml1d(block%configs,mesh,diag,diag_physics,sfc_input) !call to land-surface scheme: if(config_lsm_scheme .ne. 'off') then - call allocate_lsm + if(config_lsm_scheme == 'sf_noah') then + call allocate_lsm !$OMP PARALLEL DO - do thread=1,nThreads - call driver_lsm(itimestep,block%configs,mesh,diag_physics,sfc_input, & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread)) - end do + do thread=1,nThreads + call driver_lsm(itimestep,block%configs,mesh,diag_physics,sfc_input, & + cellSolveThreadStart(thread),cellSolveThreadEnd(thread)) + end do !$OMP END PARALLEL DO call deallocate_lsm + elseif(config_lsm_scheme == 'sf_noahmp') then + do thread=1,nThreads + call driver_lsm_noahmp(block%configs,mesh,state,time_lev,diag,diag_physics, & + diag_physics_noahmp,output_noahmp,sfc_input,itimestep, & + cellSolveThreadStart(thread),cellSolveThreadEnd(thread)) + enddo + endif + call allocate_seaice !$OMP PARALLEL DO do thread=1,nThreads @@ -327,7 +343,7 @@ subroutine physics_driver(domain,itimestep,xtime_s) !$OMP PARALLEL DO do thread=1,nThreads call driver_convection(itimestep,block%configs,mesh,sfc_input,diag_physics,tend_physics, & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread)) + cellSolveThreadStart(thread),cellSolveThreadEnd(thread)) end do !$OMP END PARALLEL DO call deallocate_convection(block%configs) diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_noahmp.F b/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_noahmp.F new file mode 100644 index 0000000000..8bbec89911 --- /dev/null +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_noahmp.F @@ -0,0 +1,1094 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!================================================================================================================= + module mpas_atmphys_driver_lsm_noahmp + use mpas_kind_types + use mpas_log + use mpas_pool_routines + use mpas_timer,only: mpas_timer_start, mpas_timer_stop + + use mpas_atmphys_constants,only: R_d,R_v + use mpas_atmphys_manager,only : year,curr_julday,month,day + use mpas_atmphys_vars,only : mpas_noahmp,xice_threshold + + + use NoahmpIOVarType + use NoahmpDriverMainMod,only: NoahmpDriverMain + + implicit none + private + public:: driver_lsm_noahmp + + + contains + + +!================================================================================================================= + subroutine lsm_noahmp_fromMPAS(configs,mesh,diag,diag_physics,diag_physics_noahmp,output_noahmp,sfc_input, & + state,time_lev,itimestep) +!================================================================================================================= + +!--- input arguments: + type(mpas_pool_type),intent(in):: configs + type(mpas_pool_type),intent(in):: mesh + type(mpas_pool_type),intent(in):: diag + type(mpas_pool_type),intent(in):: state + + integer,intent(in):: time_lev + integer,intent(in):: itimestep + + +!--- inout arguments: + type(mpas_pool_type),intent(in):: diag_physics + type(mpas_pool_type),intent(in):: diag_physics_noahmp + type(mpas_pool_type),intent(in):: output_noahmp + type(mpas_pool_type),intent(in):: sfc_input + + +!--- local variables and arrays: + logical,pointer:: do_restart + + character(len=StrKIND),pointer:: microp_scheme, & + convection_scheme + + integer:: i,its,ite + integer:: n,ns,nsoil,nsnow,nzsnow + integer,dimension(:),pointer:: isltyp,ivgtyp + + real(kind=RKIND),dimension(:),pointer:: latCell,lonCell + real(kind=RKIND),dimension(:),pointer:: shdmax,shdmin,vegfra,tmn,xice,xland + + real(kind=RKIND),dimension(:),pointer:: coszr,glw,gsw,swddir,swddif + real(kind=RKIND),dimension(:),pointer:: graupelncv,raincv,rainncv,snowncv,sr + + +!--- local INOUT pointers (with generic LSM equivalent as defined in WRF): + real(kind=RKIND),dimension(:),pointer:: acsnom,acsnow,canwat,hfx,qfx,qsfc,lh,grdflx,sfc_albedo,sfc_emiss, & + sfcrunoff,skintemp,smstav,smstot,udrunoff,snow,snowc,snowh,lai,z0, & + znt + real(kind=RKIND),dimension(:,:),pointer:: sh2o,smois,tslb + + +!--- local INOUT pointers (with no Noah LSM equivalent as defined in WRF): + integer,dimension(:),pointer:: isnowxy + real(kind=RKIND),dimension(:),pointer:: tvxy,tgxy,canicexy,canliqxy,eahxy,tahxy,cmxy,chxy,fwetxy,sneqvoxy, & + alboldxy,qsnowxy,qrainxy,wslakexy,zwtxy,waxy,wtxy,deeprechxy, & + rechxy,lfmassxy,rtmassxy,stmassxy,woodxy,grainxy,gddxy,stblcpxy, & + fastcpxy,xsaixy,taussxy + real(kind=RKIND),dimension(:,:),pointer:: tsnoxy,zsnsoxy,snicexy,snliqxy + + +!--- local OUT pointers (with no Noah LSM equivalent as defined in WRF): + real(kind=RKIND),dimension(:),pointer:: t2mvxy,t2mbxy,q2mvxy,q2mbxy,tradxy,neexy,gppxy,nppxy,fvegxy,runsfxy, & + runsbxy,ecanxy,edirxy,etranxy,fsaxy,firaxy,aparxy,psnxy,savxy,sagxy, & + rssunxy,rsshaxy,bgapxy,wgapxy,tgvxy,tgbxy,chvxy,chbxy,shgxy,shcxy, & + shbxy,evgxy,evbxy,ghvxy,ghbxy,irgxy,ircxy,irbxy,trxy,evcxy,chleafxy, & + chucxy,chv2xy,chb2xy,rs,qtdrain + + +!--- local OUT additional variables: + real(kind=RKIND),dimension(:),pointer:: pahxy,pahgxy,pahbxy,pahvxy,qintsxy,qintrxy,qdripsxy,qdriprxy, & + qthrosxy,qthrorxy,qsnsubxy,qmeltxy,qsnfroxy,qsubcxy,qfrocxy, & + qevacxy,qdewcxy,qfrzcxy,qmeltcxy,qsnbotxy,pondingxy,fpicexy, & + rainlsm,snowlsm,forctlsm,forcqlsm,forcplsm,forczlsm,forcwlsm, & + acc_ssoilxy,acc_qinsurxy,acc_qsevaxy,eflxbxy,soilenergy,snowenergy, & + canhsxy,acc_dwaterxy,acc_prcpxy,acc_ecanxy,acc_etranxy,acc_edirxy + real(kind=RKIND),dimension(:,:),pointer:: acc_etranixy + +!----------------------------------------------------------------------------------------------------------------- +!call mpas_log_write('--- enter subroutine lsm_noahmp_fromMPAS: itimestep = $i',intArgs=(/itimestep/)) + + call mpas_pool_get_config(configs,'config_do_restart',do_restart) + + call mpas_pool_get_config(configs,'config_convection_scheme',convection_scheme) + call mpas_pool_get_config(configs,'config_microp_scheme' ,microp_scheme ) + + +!--- initialization of local dimensions: + its = mpas_noahmp%its + ite = mpas_noahmp%ite + nsoil = mpas_noahmp%nsoil + nsnow = mpas_noahmp%nsnow + nzsnow = nsnow + nsoil + + +!--- initialization of time-varying variables: + mpas_noahmp%restart_flag = do_restart + + mpas_noahmp%soiltstep = 0 + mpas_noahmp%itimestep = itimestep + mpas_noahmp%yr = year + mpas_noahmp%month = month + mpas_noahmp%day = day + mpas_noahmp%julian = curr_julday + + +!--- initialization of xice_threshold: + mpas_noahmp%xice_threshold = xice_threshold + + +!--- initialization of INPUT surface variables: + call mpas_pool_get_array(sfc_input,'shdmax',shdmax) + call mpas_pool_get_array(sfc_input,'shdmin',shdmin) + call mpas_pool_get_array(sfc_input,'vegfra',vegfra) + call mpas_pool_get_array(sfc_input,'tmn' ,tmn ) + call mpas_pool_get_array(sfc_input,'xice' ,xice ) + call mpas_pool_get_array(sfc_input,'xland' ,xland ) + + call mpas_pool_get_array(diag_physics,'coszr' ,coszr ) + call mpas_pool_get_array(diag_physics,'glw' ,glw ) + call mpas_pool_get_array(diag_physics,'gsw' ,gsw ) + call mpas_pool_get_array(diag_physics,'sfc_albedo',sfc_albedo) + call mpas_pool_get_array(diag_physics,'swddir' ,swddir ) + call mpas_pool_get_array(diag_physics,'swddif' ,swddif ) + call mpas_pool_get_array(diag_physics,'sr' ,sr ) + call mpas_pool_get_array(diag_physics,'raincv' ,raincv ) + call mpas_pool_get_array(diag_physics,'rainncv' ,rainncv ) + call mpas_pool_get_array(diag_physics,'snowncv' ,snowncv ) + call mpas_pool_get_array(diag_physics,'graupelncv',graupelncv) + + do i = its,ite + mpas_noahmp%coszen(i) = coszr(i) + mpas_noahmp%gvfmax(i) = shdmax(i) + mpas_noahmp%gvfmin(i) = shdmin(i) + mpas_noahmp%vegfra(i) = vegfra(i) + mpas_noahmp%tmn(i) = tmn(i) + mpas_noahmp%xland(i) = xland(i) + mpas_noahmp%xice(i) = xice(i) + mpas_noahmp%swdown(i) = gsw(i) / (1.-sfc_albedo(i)) + mpas_noahmp%swddir(i) = swddir(i) + mpas_noahmp%swddif(i) = swddif(i) + mpas_noahmp%glw(i) = glw(i) + mpas_noahmp%rainbl(i) = 0. + mpas_noahmp%snowbl(i) = 0. + mpas_noahmp%rainshv(i) = 0. + mpas_noahmp%hailncv(i) = 0. + mpas_noahmp%mp_hail(i) = 0. + mpas_noahmp%mp_shcv(i) = 0. + mpas_noahmp%seaice(i) = 0. + enddo + +!--- calculation of the instantaneous precipitation rates of rain and snow: + if(microp_scheme .ne. 'off') then + do i = its,ite + mpas_noahmp%sr(i) = sr(i) + mpas_noahmp%rainncv(i) = rainncv(i) + mpas_noahmp%snowncv(i) = snowncv(i) + mpas_noahmp%graupelncv(i) = graupelncv(i) + mpas_noahmp%rainbl(i) = mpas_noahmp%rainbl(i) + mpas_noahmp%rainncv(i) + mpas_noahmp%snowbl(i) = mpas_noahmp%snowbl(i) + mpas_noahmp%snowncv(i) + + mpas_noahmp%mp_rainnc(i) = rainncv(i) + mpas_noahmp%mp_snow(i) = snowncv(i) + mpas_noahmp%mp_graup(i) = graupelncv(i) + enddo + else + do i = its,ite + mpas_noahmp%sr(i) = 0. + mpas_noahmp%rainncv(i) = 0. + mpas_noahmp%snowncv(i) = 0. + mpas_noahmp%graupelncv(i) = 0. + + mpas_noahmp%mp_rainnc(i) = 0. + mpas_noahmp%mp_snow(i) = 0. + mpas_noahmp%mp_graup(i) = 0. + enddo + endif + if(convection_scheme .ne. 'off') then + do i = its,ite + mpas_noahmp%raincv(i) = raincv(i) + mpas_noahmp%rainbl(i) = mpas_noahmp%rainbl(i) + mpas_noahmp%raincv(i) + mpas_noahmp%raincv(i) = raincv(i) + + mpas_noahmp%mp_rainc(i) = raincv(i) + enddo + else + do i = its,ite + mpas_noahmp%raincv(i) = 0. + mpas_noahmp%mp_rainc(i) = 0. + enddo + endif + +!--- calculation of the incidence of fractional seaice: + do i = its,ite + mpas_noahmp%seaice(i) = 0. + if(mpas_noahmp%xice(i) .ge. xice_threshold) mpas_noahmp%seaice(i) = 1. + enddo + + +!--- initialization of INPUT sounding variables: + call lsm_noahmp_sounding_fromMPAS(mesh,state,time_lev,diag) + + +!--- initialization of INOUT variables (with generic LSM equivalent as defined in WRF), i.e. +! see lines 162-184 in module NoahmpIOVarType.F90): + call mpas_pool_get_array(sfc_input,'skintemp',skintemp) + call mpas_pool_get_array(sfc_input,'snowc' ,snowc ) + call mpas_pool_get_array(sfc_input,'snow' ,snow ) + call mpas_pool_get_array(sfc_input,'snowh' ,snowh ) + call mpas_pool_get_array(sfc_input,'sh2o' ,sh2o ) + call mpas_pool_get_array(sfc_input,'smois' ,smois ) + call mpas_pool_get_array(sfc_input,'tslb' ,tslb ) + + call mpas_pool_get_array(diag_physics,'hfx' ,hfx ) + call mpas_pool_get_array(diag_physics,'qfx' ,qfx ) + call mpas_pool_get_array(diag_physics,'lh ' ,lh ) + call mpas_pool_get_array(diag_physics,'grdflx' ,grdflx ) + call mpas_pool_get_array(diag_physics,'smstav' ,smstav ) + call mpas_pool_get_array(diag_physics,'smstot' ,smstot ) + call mpas_pool_get_array(diag_physics,'sfcrunoff' ,sfcrunoff ) + call mpas_pool_get_array(diag_physics,'udrunoff' ,udrunoff ) + call mpas_pool_get_array(diag_physics,'canwat' ,canwat ) + call mpas_pool_get_array(diag_physics,'acsnom' ,acsnom ) + call mpas_pool_get_array(diag_physics,'acsnow' ,acsnow ) + call mpas_pool_get_array(diag_physics,'sfc_emiss' ,sfc_emiss ) + call mpas_pool_get_array(diag_physics,'qsfc' ,qsfc ) + call mpas_pool_get_array(diag_physics,'lai' ,lai ) + call mpas_pool_get_array(diag_physics,'z0' ,z0 ) + call mpas_pool_get_array(diag_physics,'znt' ,znt ) + + + do i = its,ite + mpas_noahmp%tsk(i) = skintemp(i) + mpas_noahmp%hfx(i) = hfx(i) + mpas_noahmp%qfx(i) = qfx(i) + mpas_noahmp%lh(i) = lh(i) + mpas_noahmp%grdflx(i) = grdflx(i) + mpas_noahmp%smstav(i) = smstav(i) + mpas_noahmp%smstot(i) = smstot(i) + mpas_noahmp%sfcrunoff(i) = sfcrunoff(i) + mpas_noahmp%udrunoff(i) = udrunoff(i) + mpas_noahmp%albedo(i) = sfc_albedo(i) + mpas_noahmp%snowc(i) = snowc(i) + mpas_noahmp%snow(i) = snow(i) + mpas_noahmp%snowh(i) = snowh(i) + mpas_noahmp%canwat(i) = canwat(i) + mpas_noahmp%acsnom(i) = acsnom(i) + mpas_noahmp%acsnow(i) = acsnow(i) + mpas_noahmp%emiss(i) = sfc_emiss(i) + mpas_noahmp%qsfc(i) = qsfc(i) + mpas_noahmp%lai(i) = lai(i) + mpas_noahmp%z0(i) = z0(i) + mpas_noahmp%znt(i) = znt(i) + enddo + + do ns = 1,nsoil + do i = its,ite + mpas_noahmp%sh2o(i,ns) = sh2o(ns,i) + mpas_noahmp%smois(i,ns) = smois(ns,i) + mpas_noahmp%tslb(i,ns) = tslb(ns,i) + enddo + enddo + + +!--- initialization of INOUT variables (with no Noah LSM equivalent as defined in WRF), i.e. +! see lines 186-222 in module NoahmpIOVarType.F90: + call mpas_pool_get_array(diag_physics_noahmp,'isnowxy' ,isnowxy ) + call mpas_pool_get_array(diag_physics_noahmp,'tvxy' ,tvxy ) + call mpas_pool_get_array(diag_physics_noahmp,'tgxy' ,tgxy ) + call mpas_pool_get_array(diag_physics_noahmp,'canicexy' ,canicexy ) + call mpas_pool_get_array(diag_physics_noahmp,'canliqxy' ,canliqxy ) + call mpas_pool_get_array(diag_physics_noahmp,'eahxy' ,eahxy ) + call mpas_pool_get_array(diag_physics_noahmp,'tahxy' ,tahxy ) + call mpas_pool_get_array(diag_physics_noahmp,'cmxy' ,cmxy ) + call mpas_pool_get_array(diag_physics_noahmp,'chxy' ,chxy ) + call mpas_pool_get_array(diag_physics_noahmp,'fwetxy' ,fwetxy ) + call mpas_pool_get_array(diag_physics_noahmp,'sneqvoxy' ,sneqvoxy ) + call mpas_pool_get_array(diag_physics_noahmp,'alboldxy' ,alboldxy ) + call mpas_pool_get_array(diag_physics_noahmp,'qsnowxy' ,qsnowxy ) + call mpas_pool_get_array(diag_physics_noahmp,'qrainxy' ,qrainxy ) + call mpas_pool_get_array(diag_physics_noahmp,'wslakexy' ,wslakexy ) + call mpas_pool_get_array(diag_physics_noahmp,'zwtxy' ,zwtxy ) + call mpas_pool_get_array(diag_physics_noahmp,'waxy' ,waxy ) + call mpas_pool_get_array(diag_physics_noahmp,'wtxy' ,wtxy ) + call mpas_pool_get_array(diag_physics_noahmp,'deeprechxy',deeprechxy ) + call mpas_pool_get_array(diag_physics_noahmp,'rechxy' ,rechxy ) + call mpas_pool_get_array(diag_physics_noahmp,'tsnoxy' ,tsnoxy ) + call mpas_pool_get_array(diag_physics_noahmp,'zsnsoxy' ,zsnsoxy ) + call mpas_pool_get_array(diag_physics_noahmp,'snicexy' ,snicexy ) + call mpas_pool_get_array(diag_physics_noahmp,'snliqxy' ,snliqxy ) + call mpas_pool_get_array(diag_physics_noahmp,'lfmassxy' ,lfmassxy ) + call mpas_pool_get_array(diag_physics_noahmp,'rtmassxy' ,rtmassxy ) + call mpas_pool_get_array(diag_physics_noahmp,'stmassxy' ,stmassxy ) + call mpas_pool_get_array(diag_physics_noahmp,'woodxy' ,woodxy ) + call mpas_pool_get_array(diag_physics_noahmp,'grainxy' ,grainxy ) + call mpas_pool_get_array(diag_physics_noahmp,'gddxy' ,gddxy ) + call mpas_pool_get_array(diag_physics_noahmp,'stblcpxy' ,stblcpxy ) + call mpas_pool_get_array(diag_physics_noahmp,'fastcpxy' ,fastcpxy ) + call mpas_pool_get_array(diag_physics_noahmp,'xsaixy' ,xsaixy ) + call mpas_pool_get_array(diag_physics_noahmp,'taussxy' ,taussxy ) + + do i = its,ite + mpas_noahmp%isnowxy(i) = isnowxy(i) + mpas_noahmp%tvxy(i) = tvxy(i) + mpas_noahmp%tgxy(i) = tgxy(i) + mpas_noahmp%canicexy(i) = canicexy(i) + mpas_noahmp%canliqxy(i) = canliqxy(i) + mpas_noahmp%eahxy(i) = eahxy(i) + mpas_noahmp%tahxy(i) = tahxy(i) + mpas_noahmp%cmxy(i) = cmxy(i) + mpas_noahmp%chxy(i) = chxy(i) + mpas_noahmp%fwetxy(i) = fwetxy(i) + mpas_noahmp%sneqvoxy(i) = sneqvoxy(i) + mpas_noahmp%alboldxy(i) = alboldxy(i) + mpas_noahmp%qsnowxy(i) = qsnowxy(i) + mpas_noahmp%qrainxy(i) = qrainxy(i) + mpas_noahmp%wslakexy(i) = wslakexy(i) + mpas_noahmp%zwtxy(i) = zwtxy(i) + mpas_noahmp%waxy(i) = waxy(i) + mpas_noahmp%wtxy(i) = wtxy(i) + mpas_noahmp%deeprechxy(i) = deeprechxy(i) + mpas_noahmp%rechxy(i) = rechxy(i) + mpas_noahmp%lfmassxy(i) = lfmassxy(i) + mpas_noahmp%rtmassxy(i) = rtmassxy(i) + mpas_noahmp%stmassxy(i) = stmassxy(i) + mpas_noahmp%woodxy(i) = woodxy(i) + mpas_noahmp%grainxy(i) = grainxy(i) + mpas_noahmp%gddxy(i) = gddxy(i) + mpas_noahmp%stblcpxy(i) = stblcpxy(i) + mpas_noahmp%fastcpxy(i) = fastcpxy(i) + mpas_noahmp%xsaixy(i) = xsaixy(i) + mpas_noahmp%taussxy(i) = taussxy(i) + enddo + + do ns = 1,nsnow + n = ns - nsnow + do i = its,ite + mpas_noahmp%tsnoxy(i,n) = tsnoxy(ns,i) + mpas_noahmp%snicexy(i,n) = snicexy(ns,i) + mpas_noahmp%snliqxy(i,n) = snliqxy(ns,i) + mpas_noahmp%zsnsoxy(i,n) = zsnsoxy(ns,i) + enddo + enddo + do ns = nsnow+1,nzsnow + n = ns - nsnow + do i = its,ite + mpas_noahmp%zsnsoxy(i,n) = zsnsoxy(ns,i) + enddo + enddo + + +!--- initialization of OUT (with no Noah LSM equivalent as defined in WRF), i.e. +! see lines 242-290 in module NoahmpIOVarType.F90): + call mpas_pool_get_array(output_noahmp,'t2mvxy' ,t2mvxy ) + call mpas_pool_get_array(output_noahmp,'t2mbxy' ,t2mbxy ) + call mpas_pool_get_array(output_noahmp,'q2mvxy' ,q2mvxy ) + call mpas_pool_get_array(output_noahmp,'q2mbxy' ,q2mbxy ) + call mpas_pool_get_array(output_noahmp,'tradxy' ,tradxy ) + call mpas_pool_get_array(output_noahmp,'neexy' ,neexy ) + call mpas_pool_get_array(output_noahmp,'gppxy' ,gppxy ) + call mpas_pool_get_array(output_noahmp,'nppxy' ,nppxy ) + call mpas_pool_get_array(output_noahmp,'fvegxy' ,fvegxy ) + call mpas_pool_get_array(output_noahmp,'runsfxy' ,runsfxy ) + call mpas_pool_get_array(output_noahmp,'runsbxy' ,runsbxy ) + call mpas_pool_get_array(output_noahmp,'ecanxy' ,ecanxy ) + call mpas_pool_get_array(output_noahmp,'edirxy' ,edirxy ) + call mpas_pool_get_array(output_noahmp,'etranxy' ,etranxy ) + call mpas_pool_get_array(output_noahmp,'fsaxy' ,fsaxy ) + call mpas_pool_get_array(output_noahmp,'firaxy' ,firaxy ) + call mpas_pool_get_array(output_noahmp,'aparxy' ,aparxy ) + call mpas_pool_get_array(output_noahmp,'psnxy' ,psnxy ) + call mpas_pool_get_array(output_noahmp,'savxy' ,savxy ) + call mpas_pool_get_array(output_noahmp,'sagxy' ,sagxy ) + call mpas_pool_get_array(output_noahmp,'rssunxy' ,rssunxy ) + call mpas_pool_get_array(output_noahmp,'rsshaxy' ,rsshaxy ) + call mpas_pool_get_array(output_noahmp,'bgapxy' ,bgapxy ) + call mpas_pool_get_array(output_noahmp,'wgapxy' ,wgapxy ) + call mpas_pool_get_array(output_noahmp,'tgvxy' ,tgvxy ) + call mpas_pool_get_array(output_noahmp,'tgbxy' ,tgbxy ) + call mpas_pool_get_array(output_noahmp,'chvxy' ,chvxy ) + call mpas_pool_get_array(output_noahmp,'chbxy' ,chbxy ) + call mpas_pool_get_array(output_noahmp,'shgxy' ,shgxy ) + call mpas_pool_get_array(output_noahmp,'shcxy' ,shcxy ) + call mpas_pool_get_array(output_noahmp,'shbxy' ,shbxy ) + call mpas_pool_get_array(output_noahmp,'evgxy' ,evgxy ) + call mpas_pool_get_array(output_noahmp,'evbxy' ,evbxy ) + call mpas_pool_get_array(output_noahmp,'ghvxy' ,ghvxy ) + call mpas_pool_get_array(output_noahmp,'ghbxy' ,ghbxy ) + call mpas_pool_get_array(output_noahmp,'irgxy' ,irgxy ) + call mpas_pool_get_array(output_noahmp,'ircxy' ,ircxy ) + call mpas_pool_get_array(output_noahmp,'irbxy' ,irbxy ) + call mpas_pool_get_array(output_noahmp,'trxy' ,trxy ) + call mpas_pool_get_array(output_noahmp,'evcxy' ,evcxy ) + call mpas_pool_get_array(output_noahmp,'chleafxy',chleafxy) + call mpas_pool_get_array(output_noahmp,'chucxy' ,chucxy ) + call mpas_pool_get_array(output_noahmp,'chv2xy' ,chv2xy ) + call mpas_pool_get_array(output_noahmp,'chb2xy' ,chb2xy ) + call mpas_pool_get_array(output_noahmp,'rs' ,rs ) + call mpas_pool_get_array(output_noahmp,'qtdrain',qtdrain ) + + do i = its,ite + mpas_noahmp%t2mvxy(i) = t2mvxy(i) + mpas_noahmp%t2mbxy(i) = t2mbxy(i) + mpas_noahmp%q2mvxy(i) = q2mvxy(i) + mpas_noahmp%q2mbxy(i) = q2mbxy(i) + mpas_noahmp%tradxy(i) = tradxy(i) + mpas_noahmp%neexy(i) = neexy(i) + mpas_noahmp%gppxy(i) = gppxy(i) + mpas_noahmp%nppxy(i) = nppxy(i) + mpas_noahmp%fvegxy(i) = fvegxy(i) + mpas_noahmp%runsfxy(i) = runsfxy(i) + mpas_noahmp%runsbxy(i) = runsbxy(i) + mpas_noahmp%ecanxy(i) = ecanxy(i) + mpas_noahmp%edirxy(i) = edirxy(i) + mpas_noahmp%etranxy(i) = etranxy(i) + mpas_noahmp%fsaxy(i) = fsaxy(i) + mpas_noahmp%firaxy(i) = firaxy(i) + mpas_noahmp%aparxy(i) = aparxy(i) + mpas_noahmp%psnxy(i) = psnxy(i) + mpas_noahmp%savxy(i) = savxy(i) + mpas_noahmp%sagxy(i) = sagxy(i) + mpas_noahmp%rssunxy(i) = rssunxy(i) + mpas_noahmp%rsshaxy(i) = rsshaxy(i) + mpas_noahmp%bgapxy(i) = bgapxy(i) + mpas_noahmp%wgapxy(i) = wgapxy(i) + mpas_noahmp%tgvxy(i) = tgvxy(i) + mpas_noahmp%tgbxy(i) = tgbxy(i) + mpas_noahmp%chvxy(i) = chvxy(i) + mpas_noahmp%chbxy(i) = chbxy(i) + mpas_noahmp%shgxy(i) = shgxy(i) + mpas_noahmp%shcxy(i) = shcxy(i) + mpas_noahmp%shbxy(i) = shbxy(i) + mpas_noahmp%evgxy(i) = evgxy(i) + mpas_noahmp%evbxy(i) = evbxy(i) + mpas_noahmp%ghvxy(i) = ghvxy(i) + mpas_noahmp%ghbxy(i) = ghbxy(i) + mpas_noahmp%irgxy(i) = irgxy(i) + mpas_noahmp%ircxy(i) = ircxy(i) + mpas_noahmp%irbxy(i) = irbxy(i) + mpas_noahmp%trxy(i) = trxy(i) + mpas_noahmp%evcxy(i) = evcxy(i) + mpas_noahmp%chleafxy(i) = chleafxy(i) + mpas_noahmp%chucxy(i) = chucxy(i) + mpas_noahmp%chv2xy(i) = chv2xy(i) + mpas_noahmp%chb2xy(i) = chb2xy(i) + mpas_noahmp%rs(i) = rs(i) + mpas_noahmp%qtdrain(i) = qtdrain(i) + enddo + + + !--- update of OUT additional variables, i.e. see lines 292-334 in module NoahmpIOVarType.F90: + call mpas_pool_get_array(output_noahmp,'pahxy' ,pahxy ) + call mpas_pool_get_array(output_noahmp,'pahgxy' ,pahgxy ) + call mpas_pool_get_array(output_noahmp,'pahbxy' ,pahbxy ) + call mpas_pool_get_array(output_noahmp,'pahvxy' ,pahvxy ) + call mpas_pool_get_array(output_noahmp,'qintsxy' ,qintsxy ) + call mpas_pool_get_array(output_noahmp,'qintrxy' ,qintrxy ) + call mpas_pool_get_array(output_noahmp,'qdripsxy' ,qdripsxy ) + call mpas_pool_get_array(output_noahmp,'qdriprxy' ,qdriprxy ) + call mpas_pool_get_array(output_noahmp,'qthrosxy' ,qthrosxy ) + call mpas_pool_get_array(output_noahmp,'qthrorxy' ,qthrorxy ) + call mpas_pool_get_array(output_noahmp,'qsnsubxy' ,qsnsubxy ) + call mpas_pool_get_array(output_noahmp,'qmeltxy' ,qmeltxy ) + call mpas_pool_get_array(output_noahmp,'qsnfroxy' ,qsnfroxy ) + call mpas_pool_get_array(output_noahmp,'qsubcxy' ,qsubcxy ) + call mpas_pool_get_array(output_noahmp,'qfrocxy' ,qfrocxy ) + call mpas_pool_get_array(output_noahmp,'qevacxy' ,qevacxy ) + call mpas_pool_get_array(output_noahmp,'qdewcxy' ,qdewcxy ) + call mpas_pool_get_array(output_noahmp,'qfrzcxy' ,qfrzcxy ) + call mpas_pool_get_array(output_noahmp,'qmeltcxy' ,qmeltcxy ) + call mpas_pool_get_array(output_noahmp,'qsnbotxy' ,qsnbotxy ) + call mpas_pool_get_array(output_noahmp,'pondingxy' ,pondingxy ) + call mpas_pool_get_array(output_noahmp,'fpicexy' ,fpicexy ) + call mpas_pool_get_array(output_noahmp,'rainlsm' ,rainlsm ) + call mpas_pool_get_array(output_noahmp,'snowlsm' ,snowlsm ) + call mpas_pool_get_array(output_noahmp,'forctlsm' ,forctlsm ) + call mpas_pool_get_array(output_noahmp,'forcqlsm' ,forcqlsm ) + call mpas_pool_get_array(output_noahmp,'forcplsm' ,forcplsm ) + call mpas_pool_get_array(output_noahmp,'forczlsm' ,forczlsm ) + call mpas_pool_get_array(output_noahmp,'forcwlsm' ,forcwlsm ) + call mpas_pool_get_array(output_noahmp,'acc_ssoilxy' ,acc_ssoilxy ) + call mpas_pool_get_array(output_noahmp,'acc_qinsurxy',acc_qinsurxy ) + call mpas_pool_get_array(output_noahmp,'acc_qsevaxy' ,acc_qsevaxy ) + call mpas_pool_get_array(output_noahmp,'eflxbxy' ,eflxbxy ) + call mpas_pool_get_array(output_noahmp,'soilenergy' ,soilenergy ) + call mpas_pool_get_array(output_noahmp,'snowenergy' ,snowenergy ) + call mpas_pool_get_array(output_noahmp,'canhsxy' ,canhsxy ) + call mpas_pool_get_array(output_noahmp,'acc_dwaterxy',acc_dwaterxy ) + call mpas_pool_get_array(output_noahmp,'acc_prcpxy' ,acc_prcpxy ) + call mpas_pool_get_array(output_noahmp,'acc_ecanxy' ,acc_ecanxy ) + call mpas_pool_get_array(output_noahmp,'acc_etranxy' ,acc_etranxy ) + call mpas_pool_get_array(output_noahmp,'acc_edirxy' ,acc_edirxy ) + call mpas_pool_get_array(output_noahmp,'acc_etranixy',acc_etranixy ) + + do i = its,ite + mpas_noahmp%pahxy(i) = pahxy(i) + mpas_noahmp%pahgxy(i) = pahgxy(i) + mpas_noahmp%pahbxy(i) = pahbxy(i) + mpas_noahmp%pahvxy(i) = pahvxy(i) + mpas_noahmp%qintsxy(i) = qintsxy(i) + mpas_noahmp%qintrxy(i) = qintrxy(i) + mpas_noahmp%qdripsxy(i) = qdripsxy(i) + mpas_noahmp%qdriprxy(i) = qdriprxy(i) + mpas_noahmp%qthrosxy(i) = qthrosxy(i) + mpas_noahmp%qthrorxy(i) = qthrorxy(i) + mpas_noahmp%qsnsubxy(i) = qsnsubxy(i) + mpas_noahmp%qmeltxy(i) = qmeltxy(i) + mpas_noahmp%qsnfroxy(i) = qsnfroxy(i) + mpas_noahmp%qsubcxy(i) = qsubcxy(i) + mpas_noahmp%qfrocxy(i) = qfrocxy(i) + mpas_noahmp%qevacxy(i) = qevacxy(i) + mpas_noahmp%qdewcxy(i) = qdewcxy(i) + mpas_noahmp%qfrzcxy(i) = qfrzcxy(i) + mpas_noahmp%qmeltcxy(i) = qmeltcxy(i) + mpas_noahmp%qsnbotxy(i) = qsnbotxy(i) + mpas_noahmp%pondingxy(i) = pondingxy(i) + mpas_noahmp%fpicexy(i) = fpicexy(i) + mpas_noahmp%rainlsm(i) = rainlsm(i) + mpas_noahmp%snowlsm(i) = snowlsm(i) + mpas_noahmp%forctlsm(i) = forctlsm(i) + mpas_noahmp%forcqlsm(i) = forcqlsm(i) + mpas_noahmp%forcplsm(i) = forcplsm(i) + mpas_noahmp%forczlsm(i) = forczlsm(i) + mpas_noahmp%forcwlsm(i) = forcwlsm(i) + mpas_noahmp%acc_ssoilxy(i) = acc_ssoilxy(i) + mpas_noahmp%acc_qinsurxy(i) = acc_qinsurxy(i) + mpas_noahmp%acc_qsevaxy(i) = acc_qsevaxy(i) + mpas_noahmp%eflxbxy(i) = eflxbxy(i) + mpas_noahmp%soilenergy(i) = soilenergy(i) + mpas_noahmp%snowenergy(i) = snowenergy(i) + mpas_noahmp%canhsxy(i) = canhsxy(i) + mpas_noahmp%acc_dwaterxy(i) = acc_dwaterxy(i) + mpas_noahmp%acc_prcpxy(i) = acc_prcpxy(i) + mpas_noahmp%acc_ecanxy(i) = acc_ecanxy(i) + mpas_noahmp%acc_etranxy(i) = acc_etranxy(i) + mpas_noahmp%acc_edirxy(i) = acc_edirxy(i) +! real(kind=kind_noahmp), allocatable, dimension(:,:) :: acc_etranixy + enddo + +!call mpas_log_write('--- end subroutine lsm_noahmp_fromMPAS.') + + end subroutine lsm_noahmp_fromMPAS + +!================================================================================================================= + subroutine lsm_noahmp_sounding_fromMPAS(mesh,state,time_lev,diag) +!================================================================================================================= + +!--- input arguments: + type(mpas_pool_type),intent(in):: mesh + type(mpas_pool_type),intent(in):: diag + type(mpas_pool_type),intent(in):: state + + integer,intent(in):: time_lev + + +!--- local variables and arrays: + integer:: i,its,ite,k,kts,kte + integer,pointer:: index_qv + + real(kind=RKIND),dimension(:,:),pointer:: zgrid + real(kind=RKIND),dimension(:,:),pointer:: qv,theta_m,u,v + real(kind=RKIND),dimension(:,:),pointer:: exner,pressure_b,pressure_p + real(kind=RKIND),dimension(:,:,:),pointer:: scalars + + real(kind=RKIND):: fzm,fzp,mult,totm,totp + real(kind=RKIND):: w1,w2,z0,z1,z2 + +!----------------------------------------------------------------------------------------------------------------- +!call mpas_log_write('--- enter subroutine lsm_noahmp_sounding_fromMPAS: $i',intArgs=(/time_lev/)) + + +!--- initialization of local dimensions: + its = mpas_noahmp%its + ite = mpas_noahmp%ite + kts = mpas_noahmp%kts + kte = mpas_noahmp%kte + + +!--- initialization of input sounding variables: + call mpas_pool_get_array(mesh,'zgrid',zgrid) + + call mpas_pool_get_array(diag,'exner' ,exner ) + call mpas_pool_get_array(diag,'pressure_base' ,pressure_b) + call mpas_pool_get_array(diag,'pressure_p' ,pressure_p) + call mpas_pool_get_array(diag,'uReconstructZonal' ,u ) + call mpas_pool_get_array(diag,'uReconstructMeridional',v ) + + call mpas_pool_get_array(state,'theta_m',theta_m,time_lev) + call mpas_pool_get_array(state,'scalars',scalars,time_lev) + + call mpas_pool_get_dimension(state,'index_qv',index_qv) + qv => scalars(index_qv,:,:) + + do i = its,ite + do k = kts,kte + mpas_noahmp%dz8w(i,k) = zgrid(k+1,i)-zgrid(k,i) + mpas_noahmp%qv_curr(i,k) = qv(k,i) + mpas_noahmp%t_phy(i,k) = (theta_m(k,i)/(1.+R_v/R_d*qv(k,i)))*exner(k,i) + mpas_noahmp%u_phy(i,k) = u(k,i) + mpas_noahmp%v_phy(i,k) = v(k,i) + enddo + enddo + + +!--- initialization of pressure at interface between layers: + do i = its,ite + k = kts + z0 = zgrid(k,i) + z1 = 0.5*(zgrid(k,i)+zgrid(k+1,i)) + z2 = 0.5*(zgrid(k+1,i)+zgrid(k+2,i)) + w1 = (z0-z2)/(z1-z2) + w2 = 1.-w1 + totm = pressure_p(k,i)+pressure_b(k,i) + totp = pressure_p(k+1,i)+pressure_b(k+1,i) + mpas_noahmp%p8w(i,k) = w1*totm + w2*totp + + do k = kts+1,kte + totm = pressure_p(k-1,i)+pressure_b(k-1,i) + totp = pressure_p(k,i)+pressure_b(k,i) + mult = 1./(zgrid(k+1,i)-zgrid(k-1,i)) + fzm = mult*(zgrid(k,i)-zgrid(k-1,i)) + fzp = mult*(zgrid(k+1,i)-zgrid(k,i)) + mpas_noahmp%p8w(i,k) = fzm*totp + fzp*totm + enddo + enddo + +!call mpas_log_write('--- end subroutine lsm_noahmp_sounding_fromMPAS:') + + end subroutine lsm_noahmp_sounding_fromMPAS + +!================================================================================================================= + subroutine lsm_noahmp_toMPAS(diag_physics,diag_physics_noahmp,output_noahmp,sfc_input) +!================================================================================================================= + +!--- input arguments: + type(mpas_pool_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: diag_physics_noahmp + type(mpas_pool_type),intent(inout):: output_noahmp + type(mpas_pool_type),intent(inout):: sfc_input + + +!--- local variables and arrays: + integer:: i,its,ite + integer:: n,ns,nsoil,nsnow,nzsnow + + +!--- local INOUT pointers (with generic LSM equivalent as defined in WRF): + real(kind=RKIND),dimension(:),pointer:: acsnom,acsnow,canwat,hfx,qfx,qsfc,lh,grdflx,sfc_albedo,sfc_emiss, & + sfcrunoff,skintemp,smstav,smstot,udrunoff,snow,snowc,snowh,lai,z0, & + znt + real(kind=RKIND),dimension(:,:),pointer:: sh2o,smois,tslb + + + !--- local INOUT pointers (with no Noah LSM equivalent as defined in WRF): + integer,dimension(:),pointer:: isnowxy + real(kind=RKIND),dimension(:),pointer:: tvxy,tgxy,canicexy,canliqxy,eahxy,tahxy,cmxy,chxy,fwetxy,sneqvoxy, & + alboldxy,qsnowxy,qrainxy,wslakexy,zwtxy,waxy,wtxy,deeprechxy, & + rechxy,lfmassxy,rtmassxy,stmassxy,woodxy,grainxy,gddxy,stblcpxy, & + fastcpxy,xsaixy,taussxy + real(kind=RKIND),dimension(:,:),pointer:: tsnoxy,zsnsoxy,snicexy,snliqxy + + +!--- local OUT pointers (with no Noah LSM equivalent as defined in WRF): + real(kind=RKIND),dimension(:),pointer:: t2mvxy,t2mbxy,q2mvxy,q2mbxy,tradxy,neexy,gppxy,nppxy,fvegxy,runsfxy, & + runsbxy,ecanxy,edirxy,etranxy,fsaxy,firaxy,aparxy,psnxy,savxy,sagxy, & + rssunxy,rsshaxy,bgapxy,wgapxy,tgvxy,tgbxy,chvxy,chbxy,shgxy,shcxy, & + shbxy,evgxy,evbxy,ghvxy,ghbxy,irgxy,ircxy,irbxy,trxy,evcxy,chleafxy, & + chucxy,chv2xy,chb2xy,rs,qtdrain + + +!--- local OUT additional variables: + real(kind=RKIND),dimension(:),pointer:: pahxy,pahgxy,pahbxy,pahvxy,qintsxy,qintrxy,qdripsxy,qdriprxy, & + qthrosxy,qthrorxy,qsnsubxy,qmeltxy,qsnfroxy,qsubcxy,qfrocxy, & + qevacxy,qdewcxy,qfrzcxy,qmeltcxy,qsnbotxy,pondingxy,fpicexy, & + rainlsm,snowlsm,forctlsm,forcqlsm,forcplsm,forczlsm,forcwlsm, & + acc_ssoilxy,acc_qinsurxy,acc_qsevaxy,eflxbxy,soilenergy,snowenergy, & + canhsxy,acc_dwaterxy,acc_prcpxy,acc_ecanxy,acc_etranxy,acc_edirxy + real(kind=RKIND),dimension(:,:),pointer:: acc_etranixy + +!----------------------------------------------------------------------------------------------------------------- +!call mpas_log_write('--- enter subroutine lsm_noahmp_toMPAS:') + + +!--- initialization of local dimensions: + its = mpas_noahmp%its + ite = mpas_noahmp%ite + nsoil = mpas_noahmp%nsoil + nsnow = mpas_noahmp%nsnow + nzsnow = nsnow + nsoil + + +!--- update of INOUT variables (with generic LSM equivalent as defined in WRF), i.e. see +! lines 162-184 in module NoahmpIOVarType.F90): + call mpas_pool_get_array(sfc_input,'skintemp',skintemp) + call mpas_pool_get_array(sfc_input,'snowc' ,snowc ) + call mpas_pool_get_array(sfc_input,'snow' ,snow ) + call mpas_pool_get_array(sfc_input,'snowh' ,snowh ) + call mpas_pool_get_array(sfc_input,'sh2o' ,sh2o ) + call mpas_pool_get_array(sfc_input,'smois' ,smois ) + call mpas_pool_get_array(sfc_input,'tslb' ,tslb ) + + call mpas_pool_get_array(diag_physics,'hfx' ,hfx ) + call mpas_pool_get_array(diag_physics,'qfx' ,qfx ) + call mpas_pool_get_array(diag_physics,'lh ' ,lh ) + call mpas_pool_get_array(diag_physics,'grdflx' ,grdflx ) + call mpas_pool_get_array(diag_physics,'smstav' ,smstav ) + call mpas_pool_get_array(diag_physics,'smstot' ,smstot ) + call mpas_pool_get_array(diag_physics,'sfcrunoff' ,sfcrunoff ) + call mpas_pool_get_array(diag_physics,'udrunoff' ,udrunoff ) + call mpas_pool_get_array(diag_physics,'sfc_albedo',sfc_albedo) + call mpas_pool_get_array(diag_physics,'canwat' ,canwat ) + call mpas_pool_get_array(diag_physics,'acsnom' ,acsnom ) + call mpas_pool_get_array(diag_physics,'acsnow' ,acsnow ) + call mpas_pool_get_array(diag_physics,'sfc_emiss' ,sfc_emiss ) + call mpas_pool_get_array(diag_physics,'qsfc' ,qsfc ) + call mpas_pool_get_array(diag_physics,'lai' ,lai ) + call mpas_pool_get_array(diag_physics,'z0' ,z0 ) + call mpas_pool_get_array(diag_physics,'znt' ,znt ) + + + do i = its,ite + skintemp(i) = mpas_noahmp%tsk(i) + hfx(i) = mpas_noahmp%hfx(i) + qfx(i) = mpas_noahmp%qfx(i) + lh(i) = mpas_noahmp%lh(i) + grdflx(i) = mpas_noahmp%grdflx(i) + smstav(i) = mpas_noahmp%smstav(i) + smstot(i) = mpas_noahmp%smstot(i) + sfcrunoff(i) = mpas_noahmp%sfcrunoff(i) + udrunoff(i) = mpas_noahmp%udrunoff(i) + sfc_albedo(i) = mpas_noahmp%albedo(i) + snowc(i) = mpas_noahmp%snowc(i) + snow(i) = mpas_noahmp%snow(i) + snowh(i) = mpas_noahmp%snowh(i) + canwat(i) = mpas_noahmp%canwat(i) + acsnom(i) = mpas_noahmp%acsnom(i) + acsnow(i) = mpas_noahmp%acsnow(i) + sfc_emiss(i) = mpas_noahmp%emiss(i) + qsfc(i) = mpas_noahmp%qsfc(i) + lai(i) = mpas_noahmp%lai(i) + z0(i) = mpas_noahmp%z0(i) + znt(i) = mpas_noahmp%znt(i) + enddo + + do ns = 1,nsoil + do i = its,ite + sh2o(ns,i) = mpas_noahmp%sh2o(i,ns) + smois(ns,i) = mpas_noahmp%smois(i,ns) + tslb(ns,i) = mpas_noahmp%tslb(i,ns) + enddo + enddo + + +!--- update of INOUT variables (with no Noah LSM equivalent as defined in WRF), i.e. see +! lines 186-222 in module NoahmpIOVarType.F90: + call mpas_pool_get_array(diag_physics_noahmp,'isnowxy' ,isnowxy ) + call mpas_pool_get_array(diag_physics_noahmp,'tvxy' ,tvxy ) + call mpas_pool_get_array(diag_physics_noahmp,'tgxy' ,tgxy ) + call mpas_pool_get_array(diag_physics_noahmp,'canicexy' ,canicexy ) + call mpas_pool_get_array(diag_physics_noahmp,'canliqxy' ,canliqxy ) + call mpas_pool_get_array(diag_physics_noahmp,'eahxy' ,eahxy ) + call mpas_pool_get_array(diag_physics_noahmp,'tahxy' ,tahxy ) + call mpas_pool_get_array(diag_physics_noahmp,'cmxy' ,cmxy ) + call mpas_pool_get_array(diag_physics_noahmp,'chxy' ,chxy ) + call mpas_pool_get_array(diag_physics_noahmp,'fwetxy' ,fwetxy ) + call mpas_pool_get_array(diag_physics_noahmp,'sneqvoxy' ,sneqvoxy ) + call mpas_pool_get_array(diag_physics_noahmp,'alboldxy' ,alboldxy ) + call mpas_pool_get_array(diag_physics_noahmp,'qsnowxy' ,qsnowxy ) + call mpas_pool_get_array(diag_physics_noahmp,'qrainxy' ,qrainxy ) + call mpas_pool_get_array(diag_physics_noahmp,'wslakexy' ,wslakexy ) + call mpas_pool_get_array(diag_physics_noahmp,'zwtxy' ,zwtxy ) + call mpas_pool_get_array(diag_physics_noahmp,'waxy' ,waxy ) + call mpas_pool_get_array(diag_physics_noahmp,'wtxy' ,wtxy ) + call mpas_pool_get_array(diag_physics_noahmp,'deeprechxy',deeprechxy ) + call mpas_pool_get_array(diag_physics_noahmp,'rechxy' ,rechxy ) + call mpas_pool_get_array(diag_physics_noahmp,'tsnoxy' ,tsnoxy ) + call mpas_pool_get_array(diag_physics_noahmp,'zsnsoxy' ,zsnsoxy ) + call mpas_pool_get_array(diag_physics_noahmp,'snicexy' ,snicexy ) + call mpas_pool_get_array(diag_physics_noahmp,'snliqxy' ,snliqxy ) + call mpas_pool_get_array(diag_physics_noahmp,'lfmassxy' ,lfmassxy ) + call mpas_pool_get_array(diag_physics_noahmp,'rtmassxy' ,rtmassxy ) + call mpas_pool_get_array(diag_physics_noahmp,'stmassxy' ,stmassxy ) + call mpas_pool_get_array(diag_physics_noahmp,'woodxy' ,woodxy ) + call mpas_pool_get_array(diag_physics_noahmp,'grainxy' ,grainxy ) + call mpas_pool_get_array(diag_physics_noahmp,'gddxy' ,gddxy ) + call mpas_pool_get_array(diag_physics_noahmp,'stblcpxy' ,stblcpxy ) + call mpas_pool_get_array(diag_physics_noahmp,'fastcpxy' ,fastcpxy ) + call mpas_pool_get_array(diag_physics_noahmp,'xsaixy' ,xsaixy ) + call mpas_pool_get_array(diag_physics_noahmp,'taussxy' ,taussxy ) + + do i = its,ite + isnowxy(i) = mpas_noahmp%isnowxy(i) + tvxy(i) = mpas_noahmp%tvxy(i) + tgxy(i) = mpas_noahmp%tgxy(i) + canicexy(i) = mpas_noahmp%canicexy(i) + canliqxy(i) = mpas_noahmp%canliqxy(i) + eahxy(i) = mpas_noahmp%eahxy(i) + tahxy(i) = mpas_noahmp%tahxy(i) + cmxy(i) = mpas_noahmp%cmxy(i) + chxy(i) = mpas_noahmp%chxy(i) + fwetxy(i) = mpas_noahmp%fwetxy(i) + sneqvoxy(i) = mpas_noahmp%sneqvoxy(i) + alboldxy(i) = mpas_noahmp%alboldxy(i) + qsnowxy(i) = mpas_noahmp%qsnowxy(i) + qrainxy(i) = mpas_noahmp%qrainxy(i) + wslakexy(i) = mpas_noahmp%wslakexy(i) + zwtxy(i) = mpas_noahmp%zwtxy(i) + waxy(i) = mpas_noahmp%waxy(i) + wtxy(i) = mpas_noahmp%wtxy(i) + deeprechxy(i) = mpas_noahmp%deeprechxy(i) + rechxy(i) = mpas_noahmp%rechxy(i) + lfmassxy(i) = mpas_noahmp%lfmassxy(i) + rtmassxy(i) = mpas_noahmp%rtmassxy(i) + stmassxy(i) = mpas_noahmp%stmassxy(i) + woodxy(i) = mpas_noahmp%woodxy(i) + grainxy(i) = mpas_noahmp%grainxy(i) + gddxy(i) = mpas_noahmp%gddxy(i) + stblcpxy(i) = mpas_noahmp%stblcpxy(i) + fastcpxy(i) = mpas_noahmp%fastcpxy(i) + xsaixy(i) = mpas_noahmp%xsaixy(i) + taussxy(i) = mpas_noahmp%taussxy(i) + + do ns = 1,nsnow + n = ns - nsnow + tsnoxy(ns,i) = mpas_noahmp%tsnoxy(i,n) + snicexy(ns,i) = mpas_noahmp%snicexy(i,n) + snliqxy(ns,i) = mpas_noahmp%snliqxy(i,n) + enddo + do ns = 1,nsnow + n = ns - nsnow + zsnsoxy(ns,i) = mpas_noahmp%zsnsoxy(i,n) + enddo + do ns = nsnow+1,nzsnow + n = ns - nsoil + 1 + zsnsoxy(ns,i) = mpas_noahmp%zsnsoxy(i,n) + enddo + enddo + + +!--- update of OUT (with no Noah LSM equivalent as defined in WRF), i.e. see +! lines 242-290 in module NoahmpIOVarType.F90: + call mpas_pool_get_array(output_noahmp,'t2mvxy' ,t2mvxy ) + call mpas_pool_get_array(output_noahmp,'t2mbxy' ,t2mbxy ) + call mpas_pool_get_array(output_noahmp,'q2mvxy' ,q2mvxy ) + call mpas_pool_get_array(output_noahmp,'q2mbxy' ,q2mbxy ) + call mpas_pool_get_array(output_noahmp,'tradxy' ,tradxy ) + call mpas_pool_get_array(output_noahmp,'neexy' ,neexy ) + call mpas_pool_get_array(output_noahmp,'gppxy' ,gppxy ) + call mpas_pool_get_array(output_noahmp,'nppxy' ,nppxy ) + call mpas_pool_get_array(output_noahmp,'fvegxy' ,fvegxy ) + call mpas_pool_get_array(output_noahmp,'runsfxy' ,runsfxy ) + call mpas_pool_get_array(output_noahmp,'runsbxy' ,runsbxy ) + call mpas_pool_get_array(output_noahmp,'ecanxy' ,ecanxy ) + call mpas_pool_get_array(output_noahmp,'edirxy' ,edirxy ) + call mpas_pool_get_array(output_noahmp,'etranxy' ,etranxy ) + call mpas_pool_get_array(output_noahmp,'fsaxy' ,fsaxy ) + call mpas_pool_get_array(output_noahmp,'firaxy' ,firaxy ) + call mpas_pool_get_array(output_noahmp,'aparxy' ,aparxy ) + call mpas_pool_get_array(output_noahmp,'psnxy' ,psnxy ) + call mpas_pool_get_array(output_noahmp,'savxy' ,savxy ) + call mpas_pool_get_array(output_noahmp,'sagxy' ,sagxy ) + call mpas_pool_get_array(output_noahmp,'rssunxy' ,rssunxy ) + call mpas_pool_get_array(output_noahmp,'rsshaxy' ,rsshaxy ) + call mpas_pool_get_array(output_noahmp,'bgapxy' ,bgapxy ) + call mpas_pool_get_array(output_noahmp,'wgapxy' ,wgapxy ) + call mpas_pool_get_array(output_noahmp,'tgvxy' ,tgvxy ) + call mpas_pool_get_array(output_noahmp,'tgbxy' ,tgbxy ) + call mpas_pool_get_array(output_noahmp,'chvxy' ,chvxy ) + call mpas_pool_get_array(output_noahmp,'chbxy' ,chbxy ) + call mpas_pool_get_array(output_noahmp,'shgxy' ,shgxy ) + call mpas_pool_get_array(output_noahmp,'shcxy' ,shcxy ) + call mpas_pool_get_array(output_noahmp,'shbxy' ,shbxy ) + call mpas_pool_get_array(output_noahmp,'evgxy' ,evgxy ) + call mpas_pool_get_array(output_noahmp,'evbxy' ,evbxy ) + call mpas_pool_get_array(output_noahmp,'ghvxy' ,ghvxy ) + call mpas_pool_get_array(output_noahmp,'ghbxy' ,ghbxy ) + call mpas_pool_get_array(output_noahmp,'irgxy' ,irgxy ) + call mpas_pool_get_array(output_noahmp,'ircxy' ,ircxy ) + call mpas_pool_get_array(output_noahmp,'irbxy' ,irbxy ) + call mpas_pool_get_array(output_noahmp,'trxy' ,trxy ) + call mpas_pool_get_array(output_noahmp,'evcxy' ,evcxy ) + call mpas_pool_get_array(output_noahmp,'chleafxy',chleafxy) + call mpas_pool_get_array(output_noahmp,'chucxy' ,chucxy ) + call mpas_pool_get_array(output_noahmp,'chv2xy' ,chv2xy ) + call mpas_pool_get_array(output_noahmp,'chb2xy' ,chb2xy ) + call mpas_pool_get_array(output_noahmp,'rs' ,rs ) + call mpas_pool_get_array(output_noahmp,'qtdrain',qtdrain ) + + do i = its,ite + t2mvxy(i) = mpas_noahmp%t2mvxy(i) + t2mbxy(i) = mpas_noahmp%t2mbxy(i) + q2mvxy(i) = mpas_noahmp%q2mvxy(i) + q2mbxy(i) = mpas_noahmp%q2mbxy(i) + tradxy(i) = mpas_noahmp%tradxy(i) + neexy(i) = mpas_noahmp%neexy(i) + gppxy(i) = mpas_noahmp%gppxy(i) + nppxy(i) = mpas_noahmp%nppxy(i) + fvegxy(i) = mpas_noahmp%fvegxy(i) + runsfxy(i) = mpas_noahmp%runsfxy(i) + runsbxy(i) = mpas_noahmp%runsbxy(i) + ecanxy(i) = mpas_noahmp%ecanxy(i) + edirxy(i) = mpas_noahmp%edirxy(i) + etranxy(i) = mpas_noahmp%etranxy(i) + fsaxy(i) = mpas_noahmp%fsaxy(i) + firaxy(i) = mpas_noahmp%firaxy(i) + aparxy(i) = mpas_noahmp%aparxy(i) + psnxy(i) = mpas_noahmp%psnxy(i) + savxy(i) = mpas_noahmp%savxy(i) + sagxy(i) = mpas_noahmp%sagxy(i) + rssunxy(i) = mpas_noahmp%rssunxy(i) + rsshaxy(i) = mpas_noahmp%rsshaxy(i) + bgapxy(i) = mpas_noahmp%bgapxy(i) + wgapxy(i) = mpas_noahmp%wgapxy(i) + tgvxy(i) = mpas_noahmp%tgvxy(i) + tgbxy(i) = mpas_noahmp%tgbxy(i) + chvxy(i) = mpas_noahmp%chvxy(i) + chbxy(i) = mpas_noahmp%chbxy(i) + shgxy(i) = mpas_noahmp%shgxy(i) + shcxy(i) = mpas_noahmp%shcxy(i) + shbxy(i) = mpas_noahmp%shbxy(i) + evgxy(i) = mpas_noahmp%evgxy(i) + evbxy(i) = mpas_noahmp%evbxy(i) + ghvxy(i) = mpas_noahmp%ghvxy(i) + ghbxy(i) = mpas_noahmp%ghbxy(i) + irgxy(i) = mpas_noahmp%irgxy(i) + ircxy(i) = mpas_noahmp%ircxy(i) + irbxy(i) = mpas_noahmp%irbxy(i) + trxy(i) = mpas_noahmp%trxy(i) + evcxy(i) = mpas_noahmp%evcxy(i) + chleafxy(i) = mpas_noahmp%chleafxy(i) + chucxy(i) = mpas_noahmp%chucxy(i) + chv2xy(i) = mpas_noahmp%chv2xy(i) + chb2xy(i) = mpas_noahmp%chb2xy(i) + rs(i) = mpas_noahmp%rs(i) + qtdrain(i) = mpas_noahmp%qtdrain(i) + enddo + + +!--- update of OUT additional variables, i.e. see lines 292-334 in module NoahmpIOVarType.F90: + call mpas_pool_get_array(output_noahmp,'pahxy' ,pahxy ) + call mpas_pool_get_array(output_noahmp,'pahgxy' ,pahgxy ) + call mpas_pool_get_array(output_noahmp,'pahbxy' ,pahbxy ) + call mpas_pool_get_array(output_noahmp,'pahvxy' ,pahvxy ) + call mpas_pool_get_array(output_noahmp,'qintsxy' ,qintsxy ) + call mpas_pool_get_array(output_noahmp,'qintrxy' ,qintrxy ) + call mpas_pool_get_array(output_noahmp,'qdripsxy' ,qdripsxy ) + call mpas_pool_get_array(output_noahmp,'qdriprxy' ,qdriprxy ) + call mpas_pool_get_array(output_noahmp,'qthrosxy' ,qthrosxy ) + call mpas_pool_get_array(output_noahmp,'qthrorxy' ,qthrorxy ) + call mpas_pool_get_array(output_noahmp,'qsnsubxy' ,qsnsubxy ) + call mpas_pool_get_array(output_noahmp,'qmeltxy' ,qmeltxy ) + call mpas_pool_get_array(output_noahmp,'qsnfroxy' ,qsnfroxy ) + call mpas_pool_get_array(output_noahmp,'qsubcxy' ,qsubcxy ) + call mpas_pool_get_array(output_noahmp,'qfrocxy' ,qfrocxy ) + call mpas_pool_get_array(output_noahmp,'qevacxy' ,qevacxy ) + call mpas_pool_get_array(output_noahmp,'qdewcxy' ,qdewcxy ) + call mpas_pool_get_array(output_noahmp,'qfrzcxy' ,qfrzcxy ) + call mpas_pool_get_array(output_noahmp,'qmeltcxy' ,qmeltcxy ) + call mpas_pool_get_array(output_noahmp,'qsnbotxy' ,qsnbotxy ) + call mpas_pool_get_array(output_noahmp,'pondingxy' ,pondingxy ) + call mpas_pool_get_array(output_noahmp,'fpicexy' ,fpicexy ) + call mpas_pool_get_array(output_noahmp,'rainlsm' ,rainlsm ) + call mpas_pool_get_array(output_noahmp,'snowlsm' ,snowlsm ) + call mpas_pool_get_array(output_noahmp,'forctlsm' ,forctlsm ) + call mpas_pool_get_array(output_noahmp,'forcqlsm' ,forcqlsm ) + call mpas_pool_get_array(output_noahmp,'forcplsm' ,forcplsm ) + call mpas_pool_get_array(output_noahmp,'forczlsm' ,forczlsm ) + call mpas_pool_get_array(output_noahmp,'forcwlsm' ,forcwlsm ) + call mpas_pool_get_array(output_noahmp,'acc_ssoilxy' ,acc_ssoilxy ) + call mpas_pool_get_array(output_noahmp,'acc_qinsurxy',acc_qinsurxy ) + call mpas_pool_get_array(output_noahmp,'acc_qsevaxy' ,acc_qsevaxy ) + call mpas_pool_get_array(output_noahmp,'eflxbxy' ,eflxbxy ) + call mpas_pool_get_array(output_noahmp,'soilenergy' ,soilenergy ) + call mpas_pool_get_array(output_noahmp,'snowenergy' ,snowenergy ) + call mpas_pool_get_array(output_noahmp,'canhsxy' ,canhsxy ) + call mpas_pool_get_array(output_noahmp,'acc_dwaterxy',acc_dwaterxy ) + call mpas_pool_get_array(output_noahmp,'acc_prcpxy' ,acc_prcpxy ) + call mpas_pool_get_array(output_noahmp,'acc_ecanxy' ,acc_ecanxy ) + call mpas_pool_get_array(output_noahmp,'acc_etranxy' ,acc_etranxy ) + call mpas_pool_get_array(output_noahmp,'acc_edirxy' ,acc_edirxy ) + call mpas_pool_get_array(output_noahmp,'acc_etranixy',acc_etranixy ) + + do i = its,ite + pahxy(i) = mpas_noahmp%pahxy(i) + pahgxy(i) = mpas_noahmp%pahgxy(i) + pahbxy(i) = mpas_noahmp%pahbxy(i) + pahvxy(i) = mpas_noahmp%pahvxy(i) + qintsxy(i) = mpas_noahmp%qintsxy(i) + qintrxy(i) = mpas_noahmp%qintrxy(i) + qdripsxy(i) = mpas_noahmp%qdripsxy(i) + qdriprxy(i) = mpas_noahmp%qdriprxy(i) + qthrosxy(i) = mpas_noahmp%qthrosxy(i) + qthrorxy(i) = mpas_noahmp%qthrorxy(i) + qsnsubxy(i) = mpas_noahmp%qsnsubxy(i) + qmeltxy(i) = mpas_noahmp%qmeltxy(i) + qsnfroxy(i) = mpas_noahmp%qsnfroxy(i) + qsubcxy(i) = mpas_noahmp%qsubcxy(i) + qfrocxy(i) = mpas_noahmp%qfrocxy(i) + qevacxy(i) = mpas_noahmp%qevacxy(i) + qdewcxy(i) = mpas_noahmp%qdewcxy(i) + qfrzcxy(i) = mpas_noahmp%qfrzcxy(i) + qmeltcxy(i) = mpas_noahmp%qmeltcxy(i) + qsnbotxy(i) = mpas_noahmp%qsnbotxy(i) + pondingxy(i) = mpas_noahmp%pondingxy(i) + fpicexy(i) = mpas_noahmp%fpicexy(i) + rainlsm(i) = mpas_noahmp%rainlsm(i) + snowlsm(i) = mpas_noahmp%snowlsm(i) + forctlsm(i) = mpas_noahmp%forctlsm(i) + forcqlsm(i) = mpas_noahmp%forcqlsm(i) + forcplsm(i) = mpas_noahmp%forcplsm(i) + forczlsm(i) = mpas_noahmp%forczlsm(i) + forcwlsm(i) = mpas_noahmp%forcwlsm(i) + acc_ssoilxy(i) = mpas_noahmp%acc_ssoilxy(i) + acc_qinsurxy(i) = mpas_noahmp%acc_qinsurxy(i) + acc_qsevaxy(i) = mpas_noahmp%acc_qsevaxy(i) + eflxbxy(i) = mpas_noahmp%eflxbxy(i) + soilenergy(i) = mpas_noahmp%soilenergy(i) + snowenergy(i) = mpas_noahmp%snowenergy(i) + canhsxy(i) = mpas_noahmp%canhsxy(i) + acc_dwaterxy(i) = mpas_noahmp%acc_dwaterxy(i) + acc_prcpxy(i) = mpas_noahmp%acc_prcpxy(i) + acc_ecanxy(i) = mpas_noahmp%acc_ecanxy(i) + acc_etranxy(i) = mpas_noahmp%acc_etranxy(i) + acc_edirxy(i) = mpas_noahmp%acc_edirxy(i) +! real(kind=kind_noahmp), allocatable, dimension(:,:) :: acc_etranixy + enddo + +!call mpas_log_write('--- end subroutine lsm_noahmp_toMPAS:') + + end subroutine lsm_noahmp_toMPAS + +!================================================================================================================= + subroutine driver_lsm_noahmp(configs,mesh,state,time_lev,diag,diag_physics,diag_physics_noahmp,output_noahmp, & + sfc_input,itimestep,its,ite) +!================================================================================================================= + +!--- input arguments: + type(mpas_pool_type),intent(in):: configs + type(mpas_pool_type),intent(in):: mesh + type(mpas_pool_type),intent(in):: diag + type(mpas_pool_type),intent(in):: state + + integer,intent(in):: itimestep,its,ite + integer,intent(in):: time_lev + +!--- inout arguments: + type(mpas_pool_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: diag_physics_noahmp + type(mpas_pool_type),intent(inout):: output_noahmp + type(mpas_pool_type),intent(inout):: sfc_input + + +!----------------------------------------------------------------------------------------------------------------- +!call mpas_log_write(' ') +!call mpas_log_write('--- enter subroutine driver_lsm_noahmp:') + + call lsm_noahmp_fromMPAS(configs,mesh,diag,diag_physics,diag_physics_noahmp,output_noahmp,sfc_input, & + state,time_lev,itimestep) + + call NoahmpDriverMain(mpas_noahmp) + + call lsm_noahmp_toMPAS(diag_physics,diag_physics_noahmp,output_noahmp,sfc_input) + +!call mpas_log_write('--- end subroutine driver_lsm_noahmp:') + + end subroutine driver_lsm_noahmp + +!================================================================================================================= + end module mpas_atmphys_driver_lsm_noahmp +!================================================================================================================= diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_microphysics.F b/src/core_atmosphere/physics/mpas_atmphys_driver_microphysics.F index bdc5ac863d..90b4d9292f 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_microphysics.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_microphysics.F @@ -28,7 +28,7 @@ module mpas_atmphys_driver_microphysics public:: allocate_microphysics, & deallocate_microphysics, & driver_microphysics, & - microphysics_init + init_microphysics !MPAS driver for parameterization of cloud microphysics processes. @@ -109,30 +109,29 @@ subroutine allocate_microphysics(configs) call mpas_pool_get_config(configs,'config_microp_scheme',microp_scheme) !sounding variables: - if(.not.allocated(rho_p) ) allocate(rho_p(ims:ime,kms:kme,jms:jme) ) - if(.not.allocated(th_p) ) allocate(th_p(ims:ime,kms:kme,jms:jme) ) - if(.not.allocated(pi_p) ) allocate(pi_p(ims:ime,kms:kme,jms:jme) ) - if(.not.allocated(pres_p) ) allocate(pres_p(ims:ime,kms:kme,jms:jme)) - if(.not.allocated(z_p) ) allocate(z_p(ims:ime,kms:kme,jms:jme) ) - if(.not.allocated(dz_p) ) allocate(dz_p(ims:ime,kms:kme,jms:jme) ) - if(.not.allocated(w_p) ) allocate(w_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(rho_p) ) allocate(rho_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(th_p) ) allocate(th_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(pi_p) ) allocate(pi_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(pres_p)) allocate(pres_p(ims:ime,kms:kme,jms:jme)) + if(.not.allocated(z_p) ) allocate(z_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(dz_p) ) allocate(dz_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(w_p) ) allocate(w_p(ims:ime,kms:kme,jms:jme) ) !mass mixing ratios: - if(.not.allocated(qv_p) ) allocate(qv_p(ims:ime,kms:kme,jms:jme)) - if(.not.allocated(qc_p) ) allocate(qc_p(ims:ime,kms:kme,jms:jme)) - if(.not.allocated(qr_p) ) allocate(qr_p(ims:ime,kms:kme,jms:jme)) + if(.not.allocated(qv_p)) allocate(qv_p(ims:ime,kms:kme,jms:jme)) + if(.not.allocated(qc_p)) allocate(qc_p(ims:ime,kms:kme,jms:jme)) + if(.not.allocated(qr_p)) allocate(qr_p(ims:ime,kms:kme,jms:jme)) !surface precipitation: if(.not.allocated(rainnc_p) ) allocate(rainnc_p(ims:ime,jms:jme) ) if(.not.allocated(rainncv_p)) allocate(rainncv_p(ims:ime,jms:jme)) - microp_select: select case(microp_scheme) - - case ("mp_thompson","mp_wsm6") + microp_select: select case(trim(microp_scheme)) + case ("mp_thompson","mp_thompson_aerosols","mp_wsm6") !mass mixing ratios: - if(.not.allocated(qi_p) ) allocate(qi_p(ims:ime,kms:kme,jms:jme)) - if(.not.allocated(qs_p) ) allocate(qs_p(ims:ime,kms:kme,jms:jme)) - if(.not.allocated(qg_p) ) allocate(qg_p(ims:ime,kms:kme,jms:jme)) + if(.not.allocated(qi_p)) allocate(qi_p(ims:ime,kms:kme,jms:jme)) + if(.not.allocated(qs_p)) allocate(qs_p(ims:ime,kms:kme,jms:jme)) + if(.not.allocated(qg_p)) allocate(qg_p(ims:ime,kms:kme,jms:jme)) !surface precipitation: if(.not.allocated(sr_p) ) allocate(sr_p(ims:ime,jms:jme) ) @@ -142,28 +141,36 @@ subroutine allocate_microphysics(configs) if(.not.allocated(graupelncv_p)) allocate(graupelncv_p(ims:ime,jms:jme)) !cloud water,cloud ice,and snow effective radii: - if(.not.allocated(recloud_p) ) allocate(recloud_p(ims:ime,kms:kme,jms:jme)) - if(.not.allocated(reice_p) ) allocate(reice_p(ims:ime,kms:kme,jms:jme) ) - if(.not.allocated(resnow_p) ) allocate(resnow_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(recloud_p)) allocate(recloud_p(ims:ime,kms:kme,jms:jme)) + if(.not.allocated(reice_p) ) allocate(reice_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(resnow_p) ) allocate(resnow_p(ims:ime,kms:kme,jms:jme) ) - microp2_select: select case(microp_scheme) + !precipitation flux: + if(.not.allocated(rainprod_p)) allocate(rainprod_p(ims:ime,kms:kme,jms:jme)) + if(.not.allocated(evapprod_p)) allocate(evapprod_p(ims:ime,kms:kme,jms:jme)) - case("mp_thompson") - !number concentrations: + microp2_select: select case(trim(microp_scheme)) + case("mp_thompson","mp_thompson_aerosols") if(.not.allocated(ntc_p)) allocate(ntc_p(ims:ime,jms:jme)) if(.not.allocated(muc_p)) allocate(muc_p(ims:ime,jms:jme)) if(.not.allocated(ni_p) ) allocate(ni_p(ims:ime,kms:kme,jms:jme)) if(.not.allocated(nr_p) ) allocate(nr_p(ims:ime,kms:kme,jms:jme)) - if(.not.allocated(rainprod_p)) allocate(rainprod_p(ims:ime,kms:kme,jms:jme)) - if(.not.allocated(evapprod_p)) allocate(evapprod_p(ims:ime,kms:kme,jms:jme)) + microp3_select: select case(trim(microp_scheme)) + case("mp_thompson_aerosols") + if(.not.allocated(nifa2d_p)) allocate(nifa2d_p(ims:ime,jms:jme)) + if(.not.allocated(nwfa2d_p)) allocate(nwfa2d_p(ims:ime,jms:jme)) + if(.not.allocated(nc_p) ) allocate(nc_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(nifa_p) ) allocate(nifa_p(ims:ime,kms:kme,jms:jme)) + if(.not.allocated(nwfa_p) ) allocate(nwfa_p(ims:ime,kms:kme,jms:jme)) - case default + case default + end select microp3_select + case default end select microp2_select case default - end select microp_select end subroutine allocate_microphysics @@ -183,67 +190,74 @@ subroutine deallocate_microphysics(configs) call mpas_pool_get_config(configs,'config_microp_scheme',microp_scheme) !sounding variables: - if(allocated(rho_p) ) deallocate(rho_p ) - if(allocated(th_p) ) deallocate(th_p ) - if(allocated(pi_p) ) deallocate(pi_p ) - if(allocated(pres_p) ) deallocate(pres_p ) - if(allocated(z_p) ) deallocate(z_p ) - if(allocated(dz_p) ) deallocate(dz_p ) - if(allocated(w_p) ) deallocate(w_p ) + if(allocated(rho_p) ) deallocate(rho_p ) + if(allocated(th_p) ) deallocate(th_p ) + if(allocated(pi_p) ) deallocate(pi_p ) + if(allocated(pres_p)) deallocate(pres_p) + if(allocated(z_p) ) deallocate(z_p ) + if(allocated(dz_p) ) deallocate(dz_p ) + if(allocated(w_p) ) deallocate(w_p ) !mass mixing ratios: - if(allocated(qv_p) ) deallocate(qv_p ) - if(allocated(qc_p) ) deallocate(qc_p ) - if(allocated(qr_p) ) deallocate(qr_p ) + if(allocated(qv_p)) deallocate(qv_p) + if(allocated(qc_p)) deallocate(qc_p) + if(allocated(qr_p)) deallocate(qr_p) !surface precipitation: - if(allocated(rainnc_p) ) deallocate(rainnc_p ) - if(allocated(rainncv_p) ) deallocate(rainncv_p ) - - microp_select: select case(microp_scheme) + if(allocated(rainnc_p) ) deallocate(rainnc_p ) + if(allocated(rainncv_p)) deallocate(rainncv_p) - case ("mp_thompson","mp_wsm6") + microp_select: select case(trim(microp_scheme)) + case ("mp_thompson","mp_thompson_aerosols","mp_wsm6") !mass mixing ratios: - if(allocated(qi_p) ) deallocate(qi_p ) - if(allocated(qs_p) ) deallocate(qs_p ) - if(allocated(qg_p) ) deallocate(qg_p ) + if(allocated(qi_p)) deallocate(qi_p) + if(allocated(qs_p)) deallocate(qs_p) + if(allocated(qg_p)) deallocate(qg_p) !surface precipitation: - if(allocated(sr_p) ) deallocate(sr_p ) - if(allocated(snownc_p) ) deallocate(snownc_p ) - if(allocated(snowncv_p) ) deallocate(snowncv_p ) - if(allocated(graupelnc_p) ) deallocate(graupelnc_p ) - if(allocated(graupelncv_p) ) deallocate(graupelncv_p ) + if(allocated(sr_p) ) deallocate(sr_p ) + if(allocated(snownc_p) ) deallocate(snownc_p ) + if(allocated(snowncv_p) ) deallocate(snowncv_p ) + if(allocated(graupelnc_p) ) deallocate(graupelnc_p ) + if(allocated(graupelncv_p)) deallocate(graupelncv_p) !cloud water,cloud ice,and snow effective radii: - if(allocated(recloud_p) ) deallocate(recloud_p ) - if(allocated(reice_p) ) deallocate(reice_p ) - if(allocated(resnow_p) ) deallocate(resnow_p ) + if(allocated(recloud_p)) deallocate(recloud_p) + if(allocated(reice_p) ) deallocate(reice_p ) + if(allocated(resnow_p) ) deallocate(resnow_p ) - microp2_select: select case(microp_scheme) + !precipitation flux: + if(allocated(rainprod_p)) deallocate(rainprod_p) + if(allocated(evapprod_p)) deallocate(evapprod_p) - case("mp_thompson") - !number concentrations: + microp2_select: select case(trim(microp_scheme)) + case("mp_thompson","mp_thompson_aerosols") if(allocated(ntc_p)) deallocate(ntc_p) if(allocated(muc_p)) deallocate(muc_p) if(allocated(ni_p) ) deallocate(ni_p ) if(allocated(nr_p) ) deallocate(nr_p ) - if(allocated(rainprod_p)) deallocate(rainprod_p) - if(allocated(evapprod_p)) deallocate(evapprod_p) + microp3_select: select case(trim(microp_scheme)) + case("mp_thompson_aerosols") + if(allocated(nifa2d_p)) deallocate(nifa2d_p) + if(allocated(nwfa2d_p)) deallocate(nwfa2d_p) + if(allocated(nc_p) ) deallocate(nc_p ) + if(allocated(nifa_p) ) deallocate(nifa_p ) + if(allocated(nwfa_p) ) deallocate(nwfa_p ) - case default + case default + end select microp3_select + case default end select microp2_select case default - end select microp_select end subroutine deallocate_microphysics !================================================================================================================= - subroutine microphysics_init(dminfo,configs,mesh,sfc_input,diag_physics) + subroutine init_microphysics(dminfo,configs,mesh,state,time_lev,sfc_input,diag_physics) !================================================================================================================= !input arguments: @@ -251,11 +265,14 @@ subroutine microphysics_init(dminfo,configs,mesh,sfc_input,diag_physics) type(mpas_pool_type),intent(in):: configs type(mpas_pool_type),intent(in):: mesh type(mpas_pool_type),intent(in):: sfc_input + integer,intent(in):: time_lev !inout arguments: type(mpas_pool_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: state !local pointer: + logical,pointer:: do_restart character(len=StrKIND),pointer:: microp_scheme !CCPP-compliant flags: @@ -263,31 +280,41 @@ subroutine microphysics_init(dminfo,configs,mesh,sfc_input,diag_physics) integer:: errflg !----------------------------------------------------------------------------------------------------------------- +!call mpas_log_write(' ') +!call mpas_log_write('--- enter subroutine init_microphysics:') !initialization of CCPP-compliant flags: errmsg = ' ' errflg = 0 call mpas_pool_get_config(configs,'config_microp_scheme',microp_scheme) + call mpas_pool_get_config(configs,'config_do_restart' ,do_restart ) + + microp_select: select case(trim(microp_scheme)) + case("mp_thompson","mp_thompson_aerosols") + call thompson_init(l_mp_tables) + call init_thompson_clouddroplets_forMPAS(mesh,sfc_input,diag_physics) - microp_select: select case(microp_scheme) + microp2_select: select case(trim(microp_scheme)) + case("mp_thompson_aerosols") + call init_thompson_aerosols_forMPAS(do_restart,dminfo,mesh,state,time_lev,diag_physics) - case("mp_thompson") - call thompson_init(l_mp_tables) - call init_thompson_clouddroplets_forMPAS(mesh,sfc_input,diag_physics) + case default + end select microp2_select - case("mp_wsm6") - call mp_wsm6_init(den0=rho_a,denr=rho_r,dens=rho_s,cl=cliq,cpv=cpv, & - hail_opt=hail_opt,errmsg=errmsg,errflg=errflg) + case("mp_wsm6") + call mp_wsm6_init(den0=rho_a,denr=rho_r,dens=rho_s,cl=cliq,cpv=cpv, & + hail_opt=hail_opt,errmsg=errmsg,errflg=errflg) - case default + case default + end select microp_select - end select microp_select +!call mpas_log_write('--- end subroutine init_microphysics:') - end subroutine microphysics_init + end subroutine init_microphysics !================================================================================================================= - subroutine driver_microphysics(configs,mesh,state,time_lev,diag,diag_physics,tend,itimestep,its,ite) + subroutine driver_microphysics(configs,mesh,state,time_lev,diag,diag_physics,tend_physics,tend,itimestep,its,ite) !================================================================================================================= use mpas_constants, only : rvord @@ -304,6 +331,7 @@ subroutine driver_microphysics(configs,mesh,state,time_lev,diag,diag_physics,ten type(mpas_pool_type),intent(inout):: state type(mpas_pool_type),intent(inout):: diag type(mpas_pool_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: tend_physics type(mpas_pool_type),intent(inout):: tend !local pointers: @@ -336,13 +364,12 @@ subroutine driver_microphysics(configs,mesh,state,time_lev,diag,diag_physics,ten call precip_from_MPAS(configs,diag_physics,its,ite) !... initialization of soundings for non-hydrostatic dynamical cores. - call microphysics_from_MPAS(configs,mesh,state,time_lev,diag,diag_physics,its,ite) + call microphysics_from_MPAS(configs,mesh,state,time_lev,diag,diag_physics,tend_physics,its,ite) !... call to different cloud microphysics schemes: - microp_select: select case(microp_scheme) - + microp_select: select case(trim(microp_scheme)) case ("mp_kessler") - call mpas_timer_start('Kessler') + call mpas_timer_start('mp_kessler') call kessler( & t = th_p , qv = qv_p , qc = qc_p , & qr = qr_p , rho = rho_p , pii = pi_p , & @@ -355,11 +382,11 @@ subroutine driver_microphysics(configs,mesh,state,time_lev,diag,diag_physics,ten ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , & its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte & ) - call mpas_timer_stop('Kessler') + call mpas_timer_stop('mp_kessler') case ("mp_thompson") + call mpas_timer_start('mp_thompson') istep = 1 - call mpas_timer_start('Thompson') do while (istep .le. n_microp) call mp_gt_driver( & th = th_p , qv = qv_p , qc = qc_p , & @@ -372,14 +399,40 @@ subroutine driver_microphysics(configs,mesh,state,time_lev,diag,diag_physics,ten sr = sr_p , rainprod = rainprod_p , evapprod = evapprod_p , & re_cloud = recloud_p , re_ice = reice_p , re_snow = resnow_p , & has_reqc = has_reqc , has_reqi = has_reqi , has_reqs = has_reqs , & - ntc = ntc_p , muc = muc_p , & + ntc = ntc_p , muc = muc_p , & 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 & ) istep = istep + 1 enddo - call mpas_timer_stop('Thompson') + call mpas_timer_stop('mp_thompson') + + case ("mp_thompson_aerosols") + call mpas_timer_start('mp_thompson_aerosols') + istep = 1 + do while (istep .le. n_microp) + call mp_gt_driver( & + th = th_p , qv = qv_p , qc = qc_p , & + qr = qr_p , qi = qi_p , qs = qs_p , & + qg = qg_p , ni = ni_p , nr = nr_p , & + pii = pi_p , p = pres_p , dz = dz_p , & + w = w_p , dt_in = dt_microp , itimestep = itimestep , & + rainnc = rainnc_p , rainncv = rainncv_p , snownc = snownc_p , & + snowncv = snowncv_p , graupelnc = graupelnc_p , graupelncv = graupelncv_p , & + sr = sr_p , rainprod = rainprod_p , evapprod = evapprod_p , & + re_cloud = recloud_p , re_ice = reice_p , re_snow = resnow_p , & + has_reqc = has_reqc , has_reqi = has_reqi , has_reqs = has_reqs , & + nc = nc_p , nifa = nifa_p , nwfa = nwfa_p , & + nifa2d = nifa2d_p , nwfa2d = nwfa2d_p , ntc = ntc_p , & + muc = muc_p , & + 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 & + ) + istep = istep + 1 + enddo + call mpas_timer_stop('mp_thompson_aerosols') case ("mp_wsm6") call mpas_timer_start('mp_wsm6') @@ -408,16 +461,15 @@ subroutine driver_microphysics(configs,mesh,state,time_lev,diag,diag_physics,ten call mpas_timer_stop('mp_wsm6') case default - end select microp_select !... calculate the 10cm radar reflectivity and relative humidity, if needed: if (l_diags) then - !ensure that we only call compute_radar_reflectivity() if we are using an MPS that supports !the computation of simulated radar reflectivity: if(trim(microp_scheme) == "mp_wsm6" .or. & - trim(microp_scheme) == "mp_thompson") then + trim(microp_scheme) == "mp_thompson" .or. & + trim(microp_scheme) == "mp_thompson_aerosols") then call compute_radar_reflectivity(configs,diag_physics,its,ite) else call mpas_log_write('*** NOTICE: NOT computing simulated radar reflectivity') @@ -427,7 +479,6 @@ subroutine driver_microphysics(configs,mesh,state,time_lev,diag,diag_physics,ten !calculate the relative humidity over water if the temperature is strictly greater than 0.C, !over ice otherwise. call compute_relhum(diag,its,ite) - end if !... copy updated precipitation from the wrf-physics grid back to the geodesic-dynamics grid: @@ -435,7 +486,7 @@ subroutine driver_microphysics(configs,mesh,state,time_lev,diag,diag_physics,ten !... copy updated cloud microphysics variables from the wrf-physics grid back to the geodesic- ! dynamics grid: - call microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,tend,itimestep,its,ite) + call microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,tend_physics,tend,its,ite) !... deallocation of all microphysics arrays: !$OMP BARRIER @@ -489,9 +540,8 @@ subroutine precip_from_MPAS(configs,diag_physics,its,ite) enddo !variables specific to different cloud microphysics schemes: - microp_select: select case(microp_scheme) - - case ("mp_thompson","mp_wsm6") + microp_select: select case(trim(microp_scheme)) + case ("mp_thompson","mp_thompson_aerosols","mp_wsm6") do j = jts, jte do i = its, ite snowncv_p(i,j) = 0._RKIND @@ -509,7 +559,6 @@ subroutine precip_from_MPAS(configs,diag_physics,its,ite) enddo case default - end select microp_select end subroutine precip_from_MPAS @@ -583,9 +632,8 @@ subroutine precip_to_MPAS(configs,diag_physics,its,ite) enddo !variables specific to different cloud microphysics schemes: - microp_select_init: select case(microp_scheme) - - case ("mp_thompson","mp_wsm6") + microp_select: select case(trim(microp_scheme)) + case ("mp_thompson","mp_thompson_aerosols","mp_wsm6") do j = jts,jte do i = its,ite !time-step precipitation: @@ -600,8 +648,7 @@ subroutine precip_to_MPAS(configs,diag_physics,its,ite) enddo case default - - end select microp_select_init + end select microp_select end subroutine precip_to_MPAS @@ -633,8 +680,7 @@ subroutine compute_radar_reflectivity(configs,diag_physics,its,ite) call mpas_pool_get_array(diag_physics,'refl10cm_1km',refl10cm_1km) call mpas_pool_get_array(diag_physics,'refl10cm_1km_max',refl10cm_1km_max) - microp_select: select case(microp_scheme) - + microp_select: select case(trim(microp_scheme)) case ("mp_kessler") call physics_error_fatal('--- calculation of radar reflectivity is not available' // & 'with kessler cloud microphysics') @@ -686,7 +732,7 @@ subroutine compute_radar_reflectivity(configs,diag_physics,its,ite) if(allocated(dBz1d)) deallocate(dBZ1d) if(allocated(zp) ) deallocate(zp ) - case ("mp_thompson") + case ("mp_thompson","mp_thompson_aerosols") if(.not.allocated(p1d) ) allocate(p1d(kts:kte) ) if(.not.allocated(t1d) ) allocate(t1d(kts:kte) ) if(.not.allocated(qv1d) ) allocate(qv1d(kts:kte) ) @@ -740,7 +786,6 @@ subroutine compute_radar_reflectivity(configs,diag_physics,its,ite) if(allocated(zp) ) deallocate(zp ) case default - end select microp_select end subroutine compute_radar_reflectivity diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_pbl.F b/src/core_atmosphere/physics/mpas_atmphys_driver_pbl.F index 6969ff6e5b..72a411aeba 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_pbl.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_pbl.F @@ -127,60 +127,61 @@ subroutine allocate_pbl(configs) case("bl_ysu") !from surface-layer model: - if(.not.allocated(br_p) ) allocate(br_p(ims:ime,jms:jme) ) - if(.not.allocated(ctopo_p) ) allocate(ctopo_p(ims:ime,jms:jme) ) - if(.not.allocated(ctopo2_p) ) allocate(ctopo2_p(ims:ime,jms:jme) ) - if(.not.allocated(delta_p) ) allocate(delta_p(ims:ime,jms:jme) ) - if(.not.allocated(psih_p) ) allocate(psih_p(ims:ime,jms:jme) ) - if(.not.allocated(psim_p) ) allocate(psim_p(ims:ime,jms:jme) ) - if(.not.allocated(u10_p) ) allocate(u10_p(ims:ime,jms:jme) ) - if(.not.allocated(v10_p) ) allocate(v10_p(ims:ime,jms:jme) ) - if(.not.allocated(exch_p) ) allocate(exch_p(ims:ime,kms:kme,jms:jme) ) - if(.not.allocated(wstar_p) ) allocate(wstar_p(ims:ime,jms:jme) ) + if(.not.allocated(br_p) ) allocate(br_p(ims:ime,jms:jme) ) + if(.not.allocated(ctopo_p) ) allocate(ctopo_p(ims:ime,jms:jme) ) + if(.not.allocated(ctopo2_p)) allocate(ctopo2_p(ims:ime,jms:jme) ) + if(.not.allocated(delta_p) ) allocate(delta_p(ims:ime,jms:jme) ) + if(.not.allocated(psih_p) ) allocate(psih_p(ims:ime,jms:jme) ) + if(.not.allocated(psim_p) ) allocate(psim_p(ims:ime,jms:jme) ) + if(.not.allocated(u10_p) ) allocate(u10_p(ims:ime,jms:jme) ) + if(.not.allocated(v10_p) ) allocate(v10_p(ims:ime,jms:jme) ) + if(.not.allocated(exch_p) ) allocate(exch_p(ims:ime,kms:kme,jms:jme)) + if(.not.allocated(wstar_p) ) allocate(wstar_p(ims:ime,jms:jme) ) case("bl_mynn") - if(.not.allocated(kbl_plume_p) ) allocate(kbl_plume_p(ims:ime,jms:jme) ) - - if(.not.allocated(dx_p) ) allocate(dx_p(ims:ime,jms:jme) ) - if(.not.allocated(ch_p) ) allocate(ch_p(ims:ime,jms:jme) ) - if(.not.allocated(qsfc_p) ) allocate(qsfc_p(ims:ime,jms:jme) ) - if(.not.allocated(rmol_p) ) allocate(rmol_p(ims:ime,jms:jme) ) - if(.not.allocated(tsk_p) ) allocate(tsk_p(ims:ime,jms:jme) ) - if(.not.allocated(maxwidthbl_p) ) allocate(maxwidthbl_p(ims:ime,jms:jme) ) - if(.not.allocated(maxmfbl_p) ) allocate(maxmfbl_p(ims:ime,jms:jme) ) - if(.not.allocated(zbl_plume_p) ) allocate(zbl_plume_p(ims:ime,jms:jme) ) - - if(.not.allocated(cov_p) ) allocate(cov_p(ims:ime,kms:kme,jms:jme) ) - if(.not.allocated(qke_p) ) allocate(qke_p(ims:ime,kms:kme,jms:jme) ) - if(.not.allocated(qsq_p) ) allocate(qsq_p(ims:ime,kms:kme,jms:jme) ) - if(.not.allocated(tsq_p) ) allocate(tsq_p(ims:ime,kms:kme,jms:jme) ) - if(.not.allocated(qkeadv_p) ) allocate(qkeadv_p(ims:ime,kms:kme,jms:jme) ) - if(.not.allocated(elpbl_p) ) allocate(elpbl_p(ims:ime,kms:kme,jms:jme) ) - if(.not.allocated(tkepbl_p) ) allocate(tkepbl_p(ims:ime,kms:kme,jms:jme) ) - if(.not.allocated(sh3d_p) ) allocate(sh3d_p(ims:ime,kms:kme,jms:jme) ) - if(.not.allocated(sm3d_p) ) allocate(sm3d_p(ims:ime,kms:kme,jms:jme) ) - if(.not.allocated(dqke_p) ) allocate(dqke_p(ims:ime,kms:kme,jms:jme) ) - if(.not.allocated(qbuoy_p) ) allocate(qbuoy_p(ims:ime,kms:kme,jms:jme) ) - if(.not.allocated(qdiss_p) ) allocate(qdiss_p(ims:ime,kms:kme,jms:jme) ) - if(.not.allocated(qshear_p) ) allocate(qshear_p(ims:ime,kms:kme,jms:jme) ) - if(.not.allocated(qwt_p) ) allocate(qwt_p(ims:ime,kms:kme,jms:jme) ) - if(.not.allocated(qcbl_p) ) allocate(qcbl_p(ims:ime,kms:kme,jms:jme) ) - if(.not.allocated(qibl_p) ) allocate(qibl_p(ims:ime,kms:kme,jms:jme) ) - if(.not.allocated(cldfrabl_p) ) allocate(cldfrabl_p(ims:ime,kms:kme,jms:jme) ) - if(.not.allocated(edmfa_p) ) allocate(edmfa_p(ims:ime,kms:kme,jms:jme) ) - if(.not.allocated(edmfw_p) ) allocate(edmfw_p(ims:ime,kms:kme,jms:jme) ) - if(.not.allocated(edmfqt_p) ) allocate(edmfqt_p(ims:ime,kms:kme,jms:jme) ) - if(.not.allocated(edmfthl_p) ) allocate(edmfthl_p(ims:ime,kms:kme,jms:jme) ) - if(.not.allocated(edmfent_p) ) allocate(edmfent_p(ims:ime,kms:kme,jms:jme) ) - if(.not.allocated(edmfqc_p) ) allocate(edmfqc_p(ims:ime,kms:kme,jms:jme) ) - if(.not.allocated(subthl_p) ) allocate(subthl_p(ims:ime,kms:kme,jms:jme) ) - if(.not.allocated(subqv_p) ) allocate(subqv_p(ims:ime,kms:kme,jms:jme) ) - if(.not.allocated(detthl_p) ) allocate(detthl_p(ims:ime,kms:kme,jms:jme) ) - if(.not.allocated(detqv_p) ) allocate(detqv_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(kbl_plume_p) ) allocate(kbl_plume_p(ims:ime,jms:jme) ) + if(.not.allocated(dx_p) ) allocate(dx_p(ims:ime,jms:jme) ) + if(.not.allocated(ch_p) ) allocate(ch_p(ims:ime,jms:jme) ) + if(.not.allocated(qsfc_p) ) allocate(qsfc_p(ims:ime,jms:jme) ) + if(.not.allocated(rmol_p) ) allocate(rmol_p(ims:ime,jms:jme) ) + if(.not.allocated(tsk_p) ) allocate(tsk_p(ims:ime,jms:jme) ) + if(.not.allocated(maxwidthbl_p)) allocate(maxwidthbl_p(ims:ime,jms:jme) ) + if(.not.allocated(maxmfbl_p) ) allocate(maxmfbl_p(ims:ime,jms:jme) ) + if(.not.allocated(zbl_plume_p) ) allocate(zbl_plume_p(ims:ime,jms:jme) ) + if(.not.allocated(cov_p) ) allocate(cov_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(qke_p) ) allocate(qke_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(qsq_p) ) allocate(qsq_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(tsq_p) ) allocate(tsq_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(qkeadv_p) ) allocate(qkeadv_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(elpbl_p) ) allocate(elpbl_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(tkepbl_p) ) allocate(tkepbl_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(sh3d_p) ) allocate(sh3d_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(sm3d_p) ) allocate(sm3d_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(dqke_p) ) allocate(dqke_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(qbuoy_p) ) allocate(qbuoy_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(qdiss_p) ) allocate(qdiss_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(qshear_p) ) allocate(qshear_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(qwt_p) ) allocate(qwt_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(qcbl_p) ) allocate(qcbl_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(qibl_p) ) allocate(qibl_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(cldfrabl_p) ) allocate(cldfrabl_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(edmfa_p) ) allocate(edmfa_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(edmfw_p) ) allocate(edmfw_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(edmfqt_p) ) allocate(edmfqt_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(edmfthl_p) ) allocate(edmfthl_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(edmfent_p) ) allocate(edmfent_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(edmfqc_p) ) allocate(edmfqc_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(subthl_p) ) allocate(subthl_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(subqv_p) ) allocate(subqv_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(detthl_p) ) allocate(detthl_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(detqv_p) ) allocate(detqv_p(ims:ime,kms:kme,jms:jme) ) !additional tendencies: - if(.not.allocated(rqsblten_p) ) allocate(rqsblten_p(ims:ime,kms:kme,jms:jme) ) - if(.not.allocated(rniblten_p) ) allocate(rniblten_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(rqsblten_p) ) allocate(rqsblten_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(rncblten_p) ) allocate(rncblten_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(rniblten_p) ) allocate(rniblten_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(rnifablten_p)) allocate(rnifablten_p(ims:ime,kms:kme,jms:jme)) + if(.not.allocated(rnwfablten_p)) allocate(rnwfablten_p(ims:ime,kms:kme,jms:jme)) !allocation of additional arrays: if(.not.allocated(pattern_spp_pbl)) allocate(pattern_spp_pbl(ims:ime,kms:kme,jms:jme)) @@ -235,60 +236,62 @@ subroutine deallocate_pbl(configs) case("bl_ysu") !from surface-layer model: - if(allocated(br_p) ) deallocate(br_p ) - if(allocated(ctopo_p) ) deallocate(ctopo_p ) - if(allocated(ctopo2_p) ) deallocate(ctopo2_p ) - if(allocated(delta_p) ) deallocate(delta_p ) - if(allocated(psih_p) ) deallocate(psih_p ) - if(allocated(psim_p) ) deallocate(psim_p ) - if(allocated(u10_p) ) deallocate(u10_p ) - if(allocated(v10_p) ) deallocate(v10_p ) - if(allocated(exch_p) ) deallocate(exch_p ) - if(allocated(wstar_p) ) deallocate(wstar_p ) + if(allocated(br_p) ) deallocate(br_p ) + if(allocated(ctopo_p) ) deallocate(ctopo_p ) + if(allocated(ctopo2_p)) deallocate(ctopo2_p) + if(allocated(delta_p) ) deallocate(delta_p ) + if(allocated(psih_p) ) deallocate(psih_p ) + if(allocated(psim_p) ) deallocate(psim_p ) + if(allocated(u10_p) ) deallocate(u10_p ) + if(allocated(v10_p) ) deallocate(v10_p ) + if(allocated(exch_p) ) deallocate(exch_p ) + if(allocated(wstar_p) ) deallocate(wstar_p ) case("bl_mynn") - if(allocated(kbl_plume_p) ) deallocate(kbl_plume_p ) - - if(allocated(dx_p) ) deallocate(dx_p ) - if(allocated(ch_p) ) deallocate(ch_p ) - if(allocated(qsfc_p) ) deallocate(qsfc_p ) - if(allocated(rmol_p) ) deallocate(rmol_p ) - if(allocated(tsk_p) ) deallocate(tsk_p ) - if(allocated(maxwidthbl_p) ) deallocate(maxwidthbl_p ) - if(allocated(maxmfbl_p) ) deallocate(maxmfbl_p ) - if(allocated(zbl_plume_p) ) deallocate(zbl_plume_p ) - - if(allocated(cov_p) ) deallocate(cov_p ) - if(allocated(qke_p) ) deallocate(qke_p ) - if(allocated(qsq_p) ) deallocate(qsq_p ) - if(allocated(tsq_p) ) deallocate(tsq_p ) - if(allocated(qkeadv_p) ) deallocate(qkeadv_p ) - if(allocated(elpbl_p) ) deallocate(elpbl_p ) - if(allocated(tkepbl_p) ) deallocate(tkepbl_p ) - if(allocated(sh3d_p) ) deallocate(sh3d_p ) - if(allocated(sm3d_p) ) deallocate(sm3d_p ) - if(allocated(dqke_p) ) deallocate(dqke_p ) - if(allocated(qbuoy_p) ) deallocate(qbuoy_p ) - if(allocated(qdiss_p) ) deallocate(qdiss_p ) - if(allocated(qshear_p) ) deallocate(qshear_p ) - if(allocated(qwt_p) ) deallocate(qwt_p ) - if(allocated(qcbl_p) ) deallocate(qcbl_p ) - if(allocated(qibl_p) ) deallocate(qibl_p ) - if(allocated(cldfrabl_p) ) deallocate(cldfrabl_p ) - if(allocated(edmfa_p) ) deallocate(edmfa_p ) - if(allocated(edmfw_p) ) deallocate(edmfw_p ) - if(allocated(edmfqt_p) ) deallocate(edmfqt_p ) - if(allocated(edmfthl_p) ) deallocate(edmfthl_p ) - if(allocated(edmfent_p) ) deallocate(edmfent_p ) - if(allocated(edmfqc_p) ) deallocate(edmfqc_p ) - if(allocated(subthl_p) ) deallocate(subthl_p ) - if(allocated(subqv_p) ) deallocate(subqv_p ) - if(allocated(detthl_p) ) deallocate(detthl_p ) - if(allocated(detqv_p) ) deallocate(detqv_p ) + if(allocated(kbl_plume_p) ) deallocate(kbl_plume_p ) + if(allocated(dx_p) ) deallocate(dx_p ) + if(allocated(ch_p) ) deallocate(ch_p ) + if(allocated(qsfc_p) ) deallocate(qsfc_p ) + if(allocated(rmol_p) ) deallocate(rmol_p ) + if(allocated(tsk_p) ) deallocate(tsk_p ) + if(allocated(maxwidthbl_p)) deallocate(maxwidthbl_p) + if(allocated(maxmfbl_p) ) deallocate(maxmfbl_p ) + if(allocated(zbl_plume_p) ) deallocate(zbl_plume_p ) + + if(allocated(cov_p) ) deallocate(cov_p ) + if(allocated(qke_p) ) deallocate(qke_p ) + if(allocated(qsq_p) ) deallocate(qsq_p ) + if(allocated(tsq_p) ) deallocate(tsq_p ) + if(allocated(qkeadv_p) ) deallocate(qkeadv_p ) + if(allocated(elpbl_p) ) deallocate(elpbl_p ) + if(allocated(tkepbl_p) ) deallocate(tkepbl_p ) + if(allocated(sh3d_p) ) deallocate(sh3d_p ) + if(allocated(sm3d_p) ) deallocate(sm3d_p ) + if(allocated(dqke_p) ) deallocate(dqke_p ) + if(allocated(qbuoy_p) ) deallocate(qbuoy_p ) + if(allocated(qdiss_p) ) deallocate(qdiss_p ) + if(allocated(qshear_p) ) deallocate(qshear_p ) + if(allocated(qwt_p) ) deallocate(qwt_p ) + if(allocated(qcbl_p) ) deallocate(qcbl_p ) + if(allocated(qibl_p) ) deallocate(qibl_p ) + if(allocated(cldfrabl_p) ) deallocate(cldfrabl_p ) + if(allocated(edmfa_p) ) deallocate(edmfa_p ) + if(allocated(edmfw_p) ) deallocate(edmfw_p ) + if(allocated(edmfqt_p) ) deallocate(edmfqt_p ) + if(allocated(edmfthl_p) ) deallocate(edmfthl_p ) + if(allocated(edmfent_p) ) deallocate(edmfent_p ) + if(allocated(edmfqc_p) ) deallocate(edmfqc_p ) + if(allocated(subthl_p) ) deallocate(subthl_p ) + if(allocated(subqv_p) ) deallocate(subqv_p ) + if(allocated(detthl_p) ) deallocate(detthl_p ) + if(allocated(detqv_p) ) deallocate(detqv_p ) !additional tendencies: - if(allocated(rqsblten_p) ) deallocate(rqsblten_p ) - if(allocated(rniblten_p) ) deallocate(rniblten_p ) + if(allocated(rqsblten_p) ) deallocate(rqsblten_p ) + if(allocated(rncblten_p) ) deallocate(rncblten_p ) + if(allocated(rniblten_p) ) deallocate(rniblten_p ) + if(allocated(rnifablten_p)) deallocate(rnifablten_p) + if(allocated(rnwfablten_p)) deallocate(rnwfablten_p) !deallocation of additional arrays: if(allocated(pattern_spp_pbl)) deallocate(pattern_spp_pbl) @@ -485,8 +488,11 @@ subroutine pbl_from_MPAS(configs,mesh,sfc_input,diag_physics,tend_physics,its,it qshear_p(i,k,j) = 0._RKIND qwt_p(i,k,j) = 0._RKIND - rqsblten_p(i,k,j) = 0._RKIND - rniblten_p(i,k,j) = 0._RKIND + rqsblten_p(i,k,j) = 0._RKIND + rncblten_p(i,k,j) = 0._RKIND + rniblten_p(i,k,j) = 0._RKIND + rnifablten_p(i,k,j) = 0._RKIND + rnwfablten_p(i,k,j) = 0._RKIND pattern_spp_pbl(i,k,j) = 0._RKIND enddo @@ -546,7 +552,7 @@ subroutine pbl_to_MPAS(configs,diag_physics,tend_physics,its,ite) real(kind=RKIND),dimension(:),pointer :: hpbl real(kind=RKIND),dimension(:,:),pointer:: kzh,kzm,kzq real(kind=RKIND),dimension(:,:),pointer:: rublten,rvblten,rthblten,rqvblten,rqcblten,rqiblten,rqsblten - real(kind=RKIND),dimension(:,:),pointer:: rniblten + real(kind=RKIND),dimension(:,:),pointer:: rncblten,rniblten,rnifablten,rnwfablten !local pointers for YSU scheme: real(kind=RKIND),dimension(:,:),pointer:: exch_h @@ -649,7 +655,6 @@ subroutine pbl_to_MPAS(configs,diag_physics,tend_physics,its,ite) call mpas_pool_get_array(diag_physics,'det_qv' ,det_qv ) call mpas_pool_get_array(tend_physics,'rqsblten' ,rqsblten ) - call mpas_pool_get_array(tend_physics,'rniblten' ,rniblten ) do j = jts,jte do k = kts,kte @@ -683,11 +688,35 @@ subroutine pbl_to_MPAS(configs,diag_physics,tend_physics,its,ite) qwt(k,i) = qwt_p(i,k,j) rqsblten(k,i) = rqsblten_p(i,k,j) - rniblten(k,i) = rniblten_p(i,k,j) enddo enddo enddo + if(f_ni) then + call mpas_pool_get_array(tend_physics,'rniblten',rniblten) + do j = jts,jte + do k = kts,kte + do i = its,ite + rniblten(k,i) = rniblten_p(i,k,j) + enddo + enddo + enddo + endif + if(f_nc .and. f_nifa .and. f_nwfa) then + call mpas_pool_get_array(tend_physics,'rncblten' ,rncblten ) + call mpas_pool_get_array(tend_physics,'rnifablten',rnifablten) + call mpas_pool_get_array(tend_physics,'rnwfablten',rnwfablten) + do j = jts,jte + do k = kts,kte + do i = its,ite + rncblten(k,i) = rncblten_p(i,k,j) + rnifablten(k,i) = rnifablten_p(i,k,j) + rnwfablten(k,i) = rnwfablten_p(i,k,j) + enddo + enddo + enddo + endif + case default end select pbl_select @@ -713,10 +742,10 @@ subroutine init_pbl(configs) pbl_select: select case (trim(pbl_scheme)) case("bl_mynn") - call mpas_log_write('--- enter subroutine bl_mynn_init:') +! call mpas_log_write('--- enter subroutine bl_mynn_init:') call bl_mynn_init(cp,cpv,cice,cliq,ep_1,ep_2,gravity,karman,P0,R_d,R_v,svp1,svp2,svp3,svpt0, & xlf,xls,xlv,errmsg,errflg) - call mpas_log_write('--- end subroutine bl_mynn_mpas_init:') +! call mpas_log_write('--- end subroutine bl_mynn_init:') case default @@ -873,58 +902,60 @@ subroutine driver_pbl(itimestep,configs,mesh,sfc_input,diag_physics,tend_physics call mpas_timer_start('bl_mynn') call mynn_bl_driver( & - f_qc = f_qc , f_qi = f_qi , f_qs = f_qs , & - f_qoz = f_qoz , f_nc = f_nc , f_ni = f_ni , & - f_nifa = f_nifa , f_nwfa = f_nwfa , f_nbca = f_nbca , & - icloud_bl = icloud_bl , delt = dt_pbl , dx = dx_p , & - xland = xland_p , ps = psfc_p , ts = tsk_p , & - qsfc = qsfc_p , ust = ust_p , ch = ch_p , & - hfx = hfx_p , qfx = qfx_p , rmol = rmol_p , & - wspd = wspd_p , znt = znt_p , uoce = uoce_p , & - voce = voce_p , dz = dz_p , u = u_p , & - v = v_p , w = w_p , th = th_p , & - tt = t_p , p = pres_hyd_p , exner = pi_p , & - rho = rho_p , qv = qv_p , qc = qc_p , & - qi = qi_p , qs = qs_p , ni = ni_p , & - rthraten = rthraten_p , pblh = hpbl_p , kpbl = kpbl_p , & - cldfra_bl = cldfrabl_p , qc_bl = qcbl_p , qi_bl = qibl_p , & - maxwidth = maxwidthbl_p , maxmf = maxmfbl_p , ktop_plume = kbl_plume_p , & - ztop_plume = zbl_plume_p , dqke = dqke_p , qke_adv = qkeadv_p , & - tsq = tsq_p , qsq = qsq_p , cov = cov_p , & - el_pbl = elpbl_p , rublten = rublten_p , rvblten = rvblten_p , & - rthblten = rthblten_p , rqvblten = rqvblten_p , rqcblten = rqcblten_p , & - rqiblten = rqiblten_p , rqsblten = rqsblten_p , rniblten = rniblten_p , & - edmf_a = edmfa_p , edmf_w = edmfw_p , edmf_qt = edmfqt_p , & - edmf_thl = edmfthl_p , edmf_ent = edmfent_p , edmf_qc = edmfqc_p , & - sub_thl = subthl_p , sub_sqv = subqv_p , det_thl = detthl_p , & - det_sqv = detqv_p , exch_h = kzh_p , exch_m = kzm_p , & - qke = qke_p , qwt = qwt_p , qshear = qshear_p , & - qbuoy = qbuoy_p , qdiss = qdiss_p , sh3d = sh3d_p , & - sm3d = sm3d_p , spp_pbl = spp_pbl , pattern_spp = pattern_spp_pbl , & - do_restart = config_do_restart , & - do_DAcycling = config_do_DAcycling , & - initflag = initflag , & - bl_mynn_tkeadvect = bl_mynn_tkeadvect , & - bl_mynn_tkebudget = bl_mynn_tkebudget , & - bl_mynn_cloudpdf = bl_mynn_cloudpdf , & - bl_mynn_mixlength = bl_mynn_mixlength , & - bl_mynn_closure = bl_mynn_closure , & - bl_mynn_stfunc = bl_mynn_stfunc , & - bl_mynn_topdown = bl_mynn_topdown , & - bl_mynn_scaleaware = bl_mynn_scaleaware , & - bl_mynn_dheat_opt = bl_mynn_dheat_opt , & - bl_mynn_edmf = bl_mynn_edmf , & - bl_mynn_edmf_dd = bl_mynn_edmf_dd , & - bl_mynn_edmf_mom = bl_mynn_edmf_mom , & - bl_mynn_edmf_tke = bl_mynn_edmf_tke , & - bl_mynn_output = bl_mynn_edmf_output , & - bl_mynn_mixscalars = bl_mynn_mixscalars , & - bl_mynn_cloudmix = bl_mynn_cloudmix , & - bl_mynn_mixqt = bl_mynn_mixqt , & - 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 , & - errmsg = errmsg , errflg = errflg & + f_qc = f_qc , f_qi = f_qi , f_qs = f_qs , & + f_qoz = f_qoz , f_nc = f_nc , f_ni = f_ni , & + f_nifa = f_nifa , f_nwfa = f_nwfa , f_nbca = f_nbca , & + icloud_bl = icloud_bl , delt = dt_pbl , dx = dx_p , & + xland = xland_p , ps = psfc_p , ts = tsk_p , & + qsfc = qsfc_p , ust = ust_p , ch = ch_p , & + hfx = hfx_p , qfx = qfx_p , rmol = rmol_p , & + wspd = wspd_p , znt = znt_p , uoce = uoce_p , & + voce = voce_p , dz = dz_p , u = u_p , & + v = v_p , w = w_p , th = th_p , & + tt = t_p , p = pres_hyd_p , exner = pi_p , & + rho = rho_p , qv = qv_p , qc = qc_p , & + qi = qi_p , qs = qs_p , nc = nc_p , & + ni = ni_p , nifa = nifa_p , nwfa = nwfa_p , & + rthraten = rthraten_p , pblh = hpbl_p , kpbl = kpbl_p , & + cldfra_bl = cldfrabl_p , qc_bl = qcbl_p , qi_bl = qibl_p , & + maxwidth = maxwidthbl_p , maxmf = maxmfbl_p , ktop_plume = kbl_plume_p , & + ztop_plume = zbl_plume_p , dqke = dqke_p , qke_adv = qkeadv_p , & + tsq = tsq_p , qsq = qsq_p , cov = cov_p , & + el_pbl = elpbl_p , rublten = rublten_p , rvblten = rvblten_p , & + rthblten = rthblten_p , rqvblten = rqvblten_p , rqcblten = rqcblten_p , & + rqiblten = rqiblten_p , rqsblten = rqsblten_p , rncblten = rncblten_p , & + rniblten = rniblten_p , rnifablten = rnifablten_p , rnwfablten = rnwfablten_p , & + edmf_a = edmfa_p , edmf_w = edmfw_p , edmf_qt = edmfqt_p , & + edmf_thl = edmfthl_p , edmf_ent = edmfent_p , edmf_qc = edmfqc_p , & + sub_thl = subthl_p , sub_sqv = subqv_p , det_thl = detthl_p , & + det_sqv = detqv_p , exch_h = kzh_p , exch_m = kzm_p , & + qke = qke_p , qwt = qwt_p , qshear = qshear_p , & + qbuoy = qbuoy_p , qdiss = qdiss_p , sh3d = sh3d_p , & + sm3d = sm3d_p , spp_pbl = spp_pbl , pattern_spp = pattern_spp_pbl , & + do_restart = config_do_restart , & + do_DAcycling = config_do_DAcycling , & + initflag = initflag , & + bl_mynn_tkeadvect = bl_mynn_tkeadvect , & + bl_mynn_tkebudget = bl_mynn_tkebudget , & + bl_mynn_cloudpdf = bl_mynn_cloudpdf , & + bl_mynn_mixlength = bl_mynn_mixlength , & + bl_mynn_closure = bl_mynn_closure , & + bl_mynn_stfunc = bl_mynn_stfunc , & + bl_mynn_topdown = bl_mynn_topdown , & + bl_mynn_scaleaware = bl_mynn_scaleaware , & + bl_mynn_dheat_opt = bl_mynn_dheat_opt , & + bl_mynn_edmf = bl_mynn_edmf , & + bl_mynn_edmf_dd = bl_mynn_edmf_dd , & + bl_mynn_edmf_mom = bl_mynn_edmf_mom , & + bl_mynn_edmf_tke = bl_mynn_edmf_tke , & + bl_mynn_output = bl_mynn_edmf_output , & + bl_mynn_mixscalars = bl_mynn_mixscalars , & + bl_mynn_cloudmix = bl_mynn_cloudmix , & + bl_mynn_mixqt = bl_mynn_mixqt , & + 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 , & + errmsg = errmsg , errflg = errflg & ) call mpas_timer_stop('bl_mynn') ! call mpas_log_write('--- exit subroutine mynn_bl_driver:') diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_lw.F b/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_lw.F index 60dbebb3e5..d4d271e50d 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_lw.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_lw.F @@ -9,7 +9,7 @@ module mpas_atmphys_driver_radiation_lw use mpas_kind_types use mpas_pool_routines - use mpas_timer, only : mpas_timer_start, mpas_timer_stop + use mpas_timer,only: mpas_timer_start,mpas_timer_stop use mpas_atmphys_driver_radiation_sw, only: radconst use mpas_atmphys_constants @@ -138,7 +138,6 @@ subroutine allocate_radiation_lw(configs,xtime_s) if(.not.allocated(rthratenlw_p) ) allocate(rthratenlw_p(ims:ime,kms:kme,jms:jme) ) radiation_lw_select: select case (trim(radt_lw_scheme)) - case("rrtmg_lw") if(.not.allocated(recloud_p) ) allocate(recloud_p(ims:ime,kms:kme,jms:jme) ) @@ -202,7 +201,6 @@ subroutine allocate_radiation_lw(configs,xtime_s) endif case default - end select radiation_lw_select end subroutine allocate_radiation_lw @@ -243,7 +241,6 @@ subroutine deallocate_radiation_lw(configs) if(allocated(rthratenlw_p) ) deallocate(rthratenlw_p ) radiation_lw_select: select case (trim(radt_lw_scheme)) - case("rrtmg_lw") if(allocated(recloud_p) ) deallocate(recloud_p ) if(allocated(reice_p) ) deallocate(reice_p ) @@ -292,7 +289,6 @@ subroutine deallocate_radiation_lw(configs) if(allocated(aerosolcp_p) ) deallocate(aerosolcp_p ) case default - end select radiation_lw_select end subroutine deallocate_radiation_lw @@ -320,9 +316,9 @@ subroutine radiation_lw_from_MPAS(xtime_s,configs,mesh,state,time_lev,diag_physi !local pointers: logical,pointer:: config_o3climatology + logical,pointer:: config_microp_re character(len=StrKIND),pointer:: radt_lw_scheme character(len=StrKIND),pointer:: microp_scheme - logical,pointer:: config_microp_re real(kind=RKIND),dimension(:),pointer :: latCell,lonCell real(kind=RKIND),dimension(:),pointer :: skintemp,snow,xice,xland @@ -339,10 +335,10 @@ subroutine radiation_lw_from_MPAS(xtime_s,configs,mesh,state,time_lev,diag_physi !----------------------------------------------------------------------------------------------------------------- + call mpas_pool_get_config(configs,'config_microp_re' ,config_microp_re ) call mpas_pool_get_config(configs,'config_o3climatology' ,config_o3climatology) call mpas_pool_get_config(configs,'config_radt_lw_scheme',radt_lw_scheme ) call mpas_pool_get_config(configs,'config_microp_scheme' ,microp_scheme ) - call mpas_pool_get_config(configs,'config_microp_re' ,config_microp_re ) call mpas_pool_get_array(mesh,'latCell',latCell) call mpas_pool_get_array(mesh,'lonCell',lonCell) @@ -415,10 +411,9 @@ subroutine radiation_lw_from_MPAS(xtime_s,configs,mesh,state,time_lev,diag_physi enddo radiation_lw_select: select case (trim(radt_lw_scheme)) - case("rrtmg_lw") microp_select: select case(microp_scheme) - case("mp_thompson","mp_wsm6") + case("mp_thompson","mp_thompson_aerosols","mp_wsm6") if(config_microp_re) then call mpas_pool_get_array(diag_physics,'re_cloud',re_cloud) call mpas_pool_get_array(diag_physics,'re_ice' ,re_ice ) @@ -610,7 +605,6 @@ subroutine radiation_lw_from_MPAS(xtime_s,configs,mesh,state,time_lev,diag_physi enddo case default - end select radiation_lw_select end subroutine radiation_lw_from_MPAS @@ -629,9 +623,9 @@ subroutine radiation_lw_to_MPAS(configs,diag_physics,tend_physics,its,ite) integer,intent(in):: its,ite !local pointers: + logical,pointer:: config_microp_re character(len=StrKIND),pointer:: radt_lw_scheme character(len=StrKIND),pointer:: microp_scheme - logical,pointer:: config_microp_re real(kind=RKIND),dimension(:),pointer :: glw,lwcf,lwdnb,lwdnbc,lwdnt,lwdntc,lwupb,lwupbc, & lwupt,lwuptc,olrtoa @@ -645,9 +639,9 @@ subroutine radiation_lw_to_MPAS(configs,diag_physics,tend_physics,its,ite) !----------------------------------------------------------------------------------------------------------------- - call mpas_pool_get_config(configs,'config_radt_lw_scheme',radt_lw_scheme ) - call mpas_pool_get_config(configs,'config_microp_scheme' ,microp_scheme ) call mpas_pool_get_config(configs,'config_microp_re' ,config_microp_re) + call mpas_pool_get_config(configs,'config_microp_scheme' ,microp_scheme ) + call mpas_pool_get_config(configs,'config_radt_lw_scheme',radt_lw_scheme ) call mpas_pool_get_array(diag_physics,'glw' ,glw ) call mpas_pool_get_array(diag_physics,'lwcf' ,lwcf ) @@ -690,7 +684,7 @@ subroutine radiation_lw_to_MPAS(configs,diag_physics,tend_physics,its,ite) case("rrtmg_lw") microp_select: select case(microp_scheme) - case("mp_thompson","mp_wsm6") + case("mp_thompson","mp_thompson_aerosols","mp_wsm6") call mpas_pool_get_array(diag_physics,'rre_cloud',rre_cloud) call mpas_pool_get_array(diag_physics,'rre_ice' ,rre_ice ) call mpas_pool_get_array(diag_physics,'rre_snow' ,rre_snow ) @@ -795,7 +789,6 @@ subroutine init_radiation_lw(dminfo,configs,mesh,atm_input,diag,diag_physics,sta call mpas_pool_get_config(configs,'config_radt_lw_scheme',radt_lw_scheme) radiation_lw_select: select case (trim(radt_lw_scheme)) - case ("rrtmg_lw") call rrtmg_initlw_forMPAS(dminfo) @@ -803,7 +796,6 @@ subroutine init_radiation_lw(dminfo,configs,mesh,atm_input,diag,diag_physics,sta call camradinit(dminfo,mesh,atm_input,diag,diag_physics,state,time_lev) case default - end select radiation_lw_select end subroutine init_radiation_lw @@ -847,12 +839,11 @@ subroutine driver_radiation_lw(xtime_s,configs,mesh,state,time_lev,diag_physics, !call to longwave radiation scheme: radiation_lw_select: select case (trim(radt_lw_scheme)) - case ("rrtmg_lw") o3input = 0 if(config_o3climatology) o3input = 2 - call mpas_timer_start('RRTMG_lw') + call mpas_timer_start('rrtmg_lwrad') call rrtmg_lwrad( & p3d = pres_hyd_p , p8w = pres2_hyd_p , pi3d = pi_p , & t3d = t_p , t8w = t2_p , dz8w = dz_p , & @@ -874,7 +865,7 @@ subroutine driver_radiation_lw(xtime_s,configs,mesh,state,time_lev,diag_physics, ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , & its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte & ) - call mpas_timer_stop('RRTMG_lw') + call mpas_timer_stop('rrtmg_lwrad') case ("cam_lw") xtime_m = xtime_s/60. @@ -941,7 +932,6 @@ subroutine driver_radiation_lw(xtime_s,configs,mesh,state,time_lev,diag_physics, call mpas_timer_stop('CAMRAD_lw') case default - end select radiation_lw_select !copy local arrays to MPAS grid: diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_sw.F b/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_sw.F index f4b76d8fe8..0b5353481a 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_sw.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_sw.F @@ -9,7 +9,7 @@ module mpas_atmphys_driver_radiation_sw use mpas_kind_types use mpas_pool_routines - use mpas_timer, only : mpas_timer_start, mpas_timer_stop + use mpas_timer,only: mpas_timer_start,mpas_timer_stop use mpas_atmphys_constants use mpas_atmphys_manager, only: gmt,curr_julday,julday,year @@ -18,6 +18,8 @@ module mpas_atmphys_driver_radiation_sw use mpas_atmphys_vars !wrf physics: + use module_mp_thompson_aerosols + use module_ra_rrtmg_sw_aerosols use module_ra_cam use module_ra_rrtmg_sw @@ -87,6 +89,14 @@ module mpas_atmphys_driver_radiation_sw ! Laura D. Fowler (laura@ucar.edu) / 2023-04-21. ! * removed the variables f_qv and f_qg in the call to subroutine camrad. ! Laura D. Fowler (laura@ucar.edu) / 2024-02-13. +! * in subroutine radiation_sw_from_MPAS, added the calculation of the optical properties of "water-friendly" and +! "ice-friendly" aerosols from the Thompson cloud microphysics scheme for use in the RRTMG short-wave radiation +! code. +! Laura D. Fowler (laura@ucar.edu) / 2024-05-16. +! * in subroutine driver_radiation_sw, modified the argument list in the call to subroutine rrtmg_sw to include +! the optical properties of "water-friendly" and "ice-friendly" aerosols from the Thompson cloud microphysics +! scheme. +! Laura D. Fowler (laura@ucar.edu) / 2024-05-16. contains @@ -101,10 +111,12 @@ subroutine allocate_radiation_sw(configs,xtime_s) real(kind=RKIND),intent(in):: xtime_s !local pointers: - character(len=StrKIND),pointer:: radt_sw_scheme + character(len=StrKIND),pointer:: mp_scheme, & + radt_sw_scheme !----------------------------------------------------------------------------------------------------------------- + call mpas_pool_get_config(configs,'config_microp_scheme' ,mp_scheme ) call mpas_pool_get_config(configs,'config_radt_sw_scheme',radt_sw_scheme) if(.not.allocated(f_ice) ) allocate(f_ice(ims:ime,kms:kme,jms:jme) ) @@ -134,7 +146,6 @@ subroutine allocate_radiation_sw(configs,xtime_s) if(.not.allocated(rthratensw_p) ) allocate(rthratensw_p(ims:ime,kms:kme,jms:jme) ) radiation_sw_select: select case (trim(radt_sw_scheme)) - case("rrtmg_sw") if(.not.allocated(recloud_p) ) allocate(recloud_p(ims:ime,kms:kme,jms:jme) ) if(.not.allocated(reice_p) ) allocate(reice_p(ims:ime,kms:kme,jms:jme) ) @@ -161,6 +172,20 @@ subroutine allocate_radiation_sw(configs,xtime_s) if(.not.allocated(pin_p) ) allocate(pin_p(num_oznlevels) ) if(.not.allocated(o3clim_p) ) allocate(o3clim_p(ims:ime,1:num_oznlevels,jms:jme)) + if(.not.allocated(tauaer_p) ) allocate(tauaer_p(ims:ime,kms:kme,jms:jme,nbndsw) ) + if(.not.allocated(ssaaer_p) ) allocate(ssaaer_p(ims:ime,kms:kme,jms:jme,nbndsw) ) + if(.not.allocated(asyaer_p) ) allocate(asyaer_p(ims:ime,kms:kme,jms:jme,nbndsw) ) + + aerosol_select: select case(mp_scheme) + case("mp_thompson_aerosols") + if(.not.allocated(ht_p) ) allocate(ht_p(ims:ime,jms:jme) ) + if(.not.allocated(taer_type_p)) allocate(taer_type_p(ims:ime,jms:jme)) + if(.not.allocated(taod5502d_p)) allocate(taod5502d_p(ims:ime,jms:jme)) + if(.not.allocated(taod5503d_p)) allocate(taod5503d_p(ims:ime,kms:kme,jms:jme)) + + case default + end select aerosol_select + case("cam_sw") if(.not.allocated(glw_p) ) allocate(glw_p(ims:ime,jms:jme) ) if(.not.allocated(lwcf_p) ) allocate(lwcf_p(ims:ime,jms:jme) ) @@ -217,10 +242,12 @@ subroutine deallocate_radiation_sw(configs) type(mpas_pool_type),intent(in):: configs !local pointers: - character(len=StrKIND),pointer:: radt_sw_scheme + character(len=StrKIND),pointer:: mp_scheme, & + radt_sw_scheme !----------------------------------------------------------------------------------------------------------------- + call mpas_pool_get_config(configs,'config_microp_scheme' ,mp_scheme ) call mpas_pool_get_config(configs,'config_radt_sw_scheme',radt_sw_scheme) if(allocated(f_ice) ) deallocate(f_ice ) @@ -247,7 +274,6 @@ subroutine deallocate_radiation_sw(configs) if(allocated(rthratensw_p) ) deallocate(rthratensw_p ) radiation_sw_select: select case (trim(radt_sw_scheme)) - case("rrtmg_sw") if(allocated(recloud_p) ) deallocate(recloud_p ) if(allocated(reice_p) ) deallocate(reice_p ) @@ -274,6 +300,21 @@ subroutine deallocate_radiation_sw(configs) if(allocated(pin_p) ) deallocate(pin_p ) if(allocated(o3clim_p) ) deallocate(o3clim_p ) + if(allocated(taod5503d_p) ) deallocate(taod5503d_p ) + if(allocated(tauaer_p) ) deallocate(tauaer_p ) + if(allocated(ssaaer_p) ) deallocate(ssaaer_p ) + if(allocated(asyaer_p) ) deallocate(asyaer_p ) + + aerosol_select: select case(mp_scheme) + case("mp_thompson","mp_thompson_aerosols") + if(allocated(ht_p) ) deallocate(ht_p ) + if(allocated(taer_type_p)) deallocate(taer_type_p) + if(allocated(taod5502d_p)) deallocate(taod5502d_p) + if(allocated(taod5503d_p)) deallocate(taod5503d_p) + + case default + end select aerosol_select + case("cam_sw") if(allocated(pin_p) ) deallocate(pin_p ) if(allocated(m_hybi_p) ) deallocate(m_hybi_p ) @@ -334,24 +375,27 @@ subroutine radiation_sw_from_MPAS(configs,mesh,state,time_lev,diag_physics,atm_i !local pointers: logical,pointer:: config_o3climatology + logical,pointer:: config_microp_re character(len=StrKIND),pointer:: radt_sw_scheme character(len=StrKIND),pointer:: microp_scheme - logical,pointer:: config_microp_re real(kind=RKIND),dimension(:),pointer :: latCell,lonCell real(kind=RKIND),dimension(:),pointer :: skintemp,snow,xice,xland real(kind=RKIND),dimension(:),pointer :: m_ps,pin real(kind=RKIND),dimension(:),pointer :: sfc_albedo,sfc_emiss + real(kind=RKIND),dimension(:),pointer :: taod5502d + real(kind=RKIND),dimension(:,:),pointer :: zgrid real(kind=RKIND),dimension(:,:),pointer :: cldfrac,m_hybi,o3clim real(kind=RKIND),dimension(:,:),pointer :: re_cloud,re_ice,re_snow + real(kind=RKIND),dimension(:,:),pointer :: taod5503d real(kind=RKIND),dimension(:,:,:),pointer:: aerosols,ozmixm !----------------------------------------------------------------------------------------------------------------- + call mpas_pool_get_config(configs,'config_microp_re' ,config_microp_re ) call mpas_pool_get_config(configs,'config_o3climatology' ,config_o3climatology) call mpas_pool_get_config(configs,'config_radt_sw_scheme',radt_sw_scheme ) call mpas_pool_get_config(configs,'config_microp_scheme' ,microp_scheme ) - call mpas_pool_get_config(configs,'config_microp_re' ,config_microp_re ) call mpas_pool_get_array(mesh,'latCell',latCell) call mpas_pool_get_array(mesh,'lonCell',lonCell) @@ -428,12 +472,24 @@ subroutine radiation_sw_from_MPAS(configs,mesh,state,time_lev,diag_physics,atm_i enddo enddo + aer_opt = 0 + do n = 1,nbndsw + do j = jts,jte + do k = kts,kte + do i = its,ite + tauaer_p(i,k,j,n) = 0._RKIND + ssaaer_p(i,k,j,n) = 1._RKIND + asyaer_p(i,k,j,n) = 0._RKIND + enddo + enddo + enddo + enddo + radiation_sw_select: select case (trim(radt_sw_scheme)) case("rrtmg_sw") - microp_select: select case(microp_scheme) - case("mp_thompson","mp_wsm6") + case("mp_thompson","mp_thompson_aerosols","mp_wsm6") if(config_microp_re) then call mpas_pool_get_array(diag_physics,'re_cloud',re_cloud) call mpas_pool_get_array(diag_physics,'re_ice' ,re_ice ) @@ -467,6 +523,63 @@ subroutine radiation_sw_from_MPAS(configs,mesh,state,time_lev,diag_physics,atm_i case default end select microp_select + aerosol_select: select case(microp_scheme) + case("mp_thompson_aerosols") + call mpas_pool_get_array(mesh,'zgrid',zgrid) + call mpas_pool_get_array(diag_physics,'taod5502d',taod5502d) + call mpas_pool_get_array(diag_physics,'taod5503d',taod5503d) + + aer_opt = 3 + do j = jts,jte + do i = its,ite + ht_p(i,j) = zgrid(1,i) + if(xland_p(i,j)==1._RKIND) then + taer_type_p(i,j) = 1 + elseif(xland_p(i,j)==2._RKIND) then + taer_type_p(i,j) = 3 + endif + enddo + enddo + + !--- calculation of the 550 nm optical depth of the water- and ice-friendly aerosols: + call gt_aod( & + p_phy = pres_hyd_p , dz8w = dz_p , t_phy = t_p , qvapor = qv_p , & + nwfa = nwfa_p , nifa = nifa_p , taod5503d = taod5503d_p , & + ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , & + its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte & + ) + + do j = jts,jte + do i = its,ite + taod5502d_p(i,j) = 0._RKIND + do k = kts,kte + taod5502d_p(i,j) = taod5502d_p(i,j) + taod5503d_p(i,k,j) + taod5503d(k,i) = taod5503d_p(i,k,j) + enddo + taod5502d(i) = taod5502d_p(i,j) + enddo + enddo + + !--- calculation of the spectral optical depth, single-scattering albedo, and asymmetry factor + !as a function of the 550 nm optical depth of the water- and ice-friendly aerosols: + call calc_aerosol_rrtmg_sw( & + ht = ht_p , dz8w = dz_p , & + p = pres_hyd_p , t3d = t_p , & + qv3d = qv_p , tauaer = tauaer_p , & + ssaaer = ssaaer_p , asyaer = asyaer_p , & + aod5502d = taod5502d_p , aod5503d = taod5503d_p , & + aer_type = taer_type_p , & + aer_aod550_opt = taer_aod550_opt , aer_angexp_opt = taer_angexp_opt , & + aer_ssa_opt = taer_ssa_opt , aer_asy_opt = taer_asy_opt , & + aer_aod550_val = aer_aod550_val , aer_angexp_val = aer_angexp_val , & + aer_ssa_val = aer_ssa_val , aer_asy_val = aer_asy_val , & + 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 default + end select aerosol_select + do j = jts,jte do k = kts,kte+2 do i = its,ite @@ -588,7 +701,6 @@ subroutine radiation_sw_from_MPAS(configs,mesh,state,time_lev,diag_physics,atm_i enddo case default - end select radiation_sw_select end subroutine radiation_sw_from_MPAS @@ -690,7 +802,6 @@ subroutine init_radiation_sw(dminfo,configs,mesh,atm_input,diag,diag_physics,sta !call to shortwave radiation scheme: radiation_sw_select: select case (trim(radt_sw_scheme)) - case ("rrtmg_sw") call rrtmg_initsw_forMPAS(dminfo) @@ -698,7 +809,6 @@ subroutine init_radiation_sw(dminfo,configs,mesh,atm_input,diag,diag_physics,sta call camradinit(dminfo,mesh,atm_input,diag,diag_physics,state,time_lev) case default - end select radiation_sw_select end subroutine init_radiation_sw @@ -766,12 +876,11 @@ subroutine driver_radiation_sw(itimestep,configs,mesh,state,time_lev,diag_physic !call to shortwave radiation scheme: radiation_sw_select: select case (trim(radt_sw_scheme)) - case ("rrtmg_sw") o3input = 0 if(config_o3climatology) o3input = 2 - call mpas_timer_start('RRTMG_sw') + call mpas_timer_start('rrtmg_swrad') call rrtmg_swrad( & p3d = pres_hyd_p , p8w = pres2_hyd_p , pi3d = pi_p , & t3d = t_p , t8w = t2_p , dz8w = dz_p , & @@ -788,18 +897,20 @@ subroutine driver_radiation_sw(itimestep,configs,mesh,state,time_lev,diag_physic o3clim = o3clim_p , gsw = gsw_p , swcf = swcf_p , & rthratensw = rthratensw_p , has_reqc = has_reqc , has_reqi = has_reqi , & has_reqs = has_reqs , re_cloud = recloud_p , re_ice = reice_p , & - re_snow = resnow_p , swupt = swupt_p , swuptc = swuptc_p , & - swdnt = swdnt_p , swdntc = swdntc_p , swupb = swupb_p , & - swupbc = swupbc_p , swdnb = swdnb_p , swdnbc = swdnbc_p , & - swddir = swddir_p , swddni = swddni_p , swddif = swddif_p , & + re_snow = resnow_p , aer_opt = aer_opt , tauaer3d = tauaer_p , & + ssaaer3d = ssaaer_p , asyaer3d = asyaer_p , swupt = swupt_p , & + swuptc = swuptc_p , swdnt = swdnt_p , swdntc = swdntc_p , & + swupb = swupb_p , swupbc = swupbc_p , swdnb = swdnb_p , & + swdnbc = swdnbc_p , swddir = swddir_p , swddni = swddni_p , & + swddif = swddif_p , & 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 & ) - call mpas_timer_stop('RRTMG_sw') + call mpas_timer_stop('rrtmg_swrad') case ("cam_sw") - call mpas_timer_start('CAMRAD_sw') + call mpas_timer_start('camrad_sw') call camrad( dolw = .false. , dosw = .true. , & p_phy = pres_hyd_p , p8w = pres2_hyd_p , & pi_phy = pi_p , t_phy = t_p , & @@ -847,10 +958,9 @@ subroutine driver_radiation_sw(itimestep,configs,mesh,state,time_lev,diag_physic ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , & its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte & ) - call mpas_timer_stop('CAMRAD_sw') + call mpas_timer_stop('camrad_sw') case default - end select radiation_sw_select !copy local arrays to MPAS grid: diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F b/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F index eaac82d38f..4b5a603543 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F @@ -952,66 +952,64 @@ subroutine driver_sfclayer(itimestep,configs,mesh,diag_physics,sfc_input,its,ite call mpas_timer_start('sf_monin_obukhov_rev') call mpas_log_write('--- enter subroutine sfclayrev:') call sfclayrev( & - p3d = pres_hyd_p , psfc = psfc_p , t3d = t_p , & - u3d = u_p , v3d = v_p , qv3d = qv_p , & - dz8w = dz_p , cp = cp , g = gravity , & - rovcp = rcp , R = R_d , xlv = xlv , & - chs = chs_p , chs2 = chs2_p , cqs2 = cqs2_p , & - cpm = cpm_p , znt = znt_p , ust = ust_p , & - pblh = hpbl_p , mavail = mavail_p , zol = zol_p , & - mol = mol_p , regime = regime_p , psim = psim_p , & - psih = psih_p , fm = fm_p , fh = fh_p , & - xland = xland_p , hfx = hfx_p , qfx = qfx_p , & - lh = lh_p , tsk = tsk_p , flhc = flhc_p , & - flqc = flqc_p , qgh = qgh_p , qsfc = qsfc_p , & - rmol = rmol_p , u10 = u10_p , v10 = v10_p , & - th2 = th2m_p , t2 = t2m_p , q2 = q2_p , & - gz1oz0 = gz1oz0_p , wspd = wspd_p , br = br_p , & - isfflx = isfflx , dx = dx_p , svp1 = svp1 , & - svp2 = svp2 , svp3 = svp3 , svpt0 = svpt0 , & - ep1 = ep_1 , ep2 = ep_2 , karman = karman , & - eomeg = eomeg , stbolt = stbolt , P1000mb = P0 , & - ustm = ustm_p , ck = ck_p , cka = cka_p , & - cd = cd_p , cda = cda_p , isftcflx = isftcflx , & - iz0tlnd = iz0tlnd , shalwater_z0 = shalwater_flag , shalwater_depth = shalwater_depth , & - water_depth = waterdepth_p , scm_force_flux = scm_force_flux , & - errmsg = errmsg , errflg = errflg , & - 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 & + p3d = pres_hyd_p , psfc = psfc_p , t3d = t_p , & + u3d = u_p , v3d = v_p , qv3d = qv_p , & + dz8w = dz_p , cp = cp , g = gravity , & + rovcp = rcp , R = R_d , xlv = xlv , & + chs = chs_p , chs2 = chs2_p , cqs2 = cqs2_p , & + cpm = cpm_p , znt = znt_p , ust = ust_p , & + pblh = hpbl_p , mavail = mavail_p , zol = zol_p , & + mol = mol_p , regime = regime_p , psim = psim_p , & + psih = psih_p , fm = fm_p , fh = fh_p , & + xland = xland_p , hfx = hfx_p , qfx = qfx_p , & + lh = lh_p , tsk = tsk_p , flhc = flhc_p , & + flqc = flqc_p , qgh = qgh_p , qsfc = qsfc_p , & + rmol = rmol_p , u10 = u10_p , v10 = v10_p , & + th2 = th2m_p , t2 = t2m_p , q2 = q2_p , & + gz1oz0 = gz1oz0_p , wspd = wspd_p , br = br_p , & + isfflx = isfflx , dx = dx_p , svp1 = svp1 , & + svp2 = svp2 , svp3 = svp3 , svpt0 = svpt0 , & + ep1 = ep_1 , ep2 = ep_2 , karman = karman , & + p1000mb = P0 , lakemask = lakemask_p , ustm = ustm_p , & + ck = ck_p , cka = cka_p , cd = cd_p , & + cda = cda_p , isftcflx = isftcflx , iz0tlnd = iz0tlnd , & + shalwater_z0 = shalwater_flag , water_depth = waterdepth_p , scm_force_flux = scm_force_flux , & + errmsg = errmsg , errflg = errflg , & + 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 & ) call mpas_log_write('--- end subroutine sfclayrev:') if(config_frac_seaice) then call mpas_log_write('--- enter subroutine sfclayrev seaice:') call sfclayrev( & - p3d = pres_hyd_p , psfc = psfc_p , t3d = t_p , & - u3d = u_p , v3d = v_p , qv3d = qv_p , & - dz8w = dz_p , cp = cp , g = gravity , & - rovcp = rcp , R = R_d , xlv = xlv , & - chs = chs_sea , chs2 = chs2_sea , cqs2 = cqs2_sea , & - cpm = cpm_sea , znt = znt_sea , ust = ust_sea , & - pblh = hpbl_p , mavail = mavail_sea , zol = zol_sea , & - mol = mol_sea , regime = regime_sea , psim = psim_sea , & - psih = psih_sea , fm = fm_sea , fh = fh_sea , & - xland = xland_sea , hfx = hfx_sea , qfx = qfx_sea , & - lh = lh_sea , tsk = tsk_sea , flhc = flhc_sea , & - flqc = flqc_sea , qgh = qgh_sea , qsfc = qsfc_sea , & - rmol = rmol_sea , u10 = u10_sea , v10 = v10_sea , & - th2 = th2m_sea , t2 = t2m_sea , q2 = q2_sea , & - gz1oz0 = gz1oz0_sea , wspd = wspd_sea , br = br_sea , & - isfflx = isfflx , dx = dx_p , svp1 = svp1 , & - svp2 = svp2 , svp3 = svp3 , svpt0 = svpt0 , & - ep1 = ep_1 , ep2 = ep_2 , karman = karman , & - eomeg = eomeg , stbolt = stbolt , P1000mb = P0 , & - ustm = ustm_sea , ck = ck_sea , cka = cka_sea , & - cd = cd_sea , cda = cda_sea , isftcflx = isftcflx , & - iz0tlnd = iz0tlnd , shalwater_z0 = shalwater_flag , shalwater_depth = shalwater_depth , & - water_depth = waterdepth_p , scm_force_flux = scm_force_flux , & - errmsg = errmsg , errflg = errflg , & - 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 & + p3d = pres_hyd_p , psfc = psfc_p , t3d = t_p , & + u3d = u_p , v3d = v_p , qv3d = qv_p , & + dz8w = dz_p , cp = cp , g = gravity , & + rovcp = rcp , R = R_d , xlv = xlv , & + chs = chs_sea , chs2 = chs2_sea , cqs2 = cqs2_sea , & + cpm = cpm_sea , znt = znt_sea , ust = ust_sea , & + pblh = hpbl_p , mavail = mavail_sea , zol = zol_sea , & + mol = mol_sea , regime = regime_sea , psim = psim_sea , & + psih = psih_sea , fm = fm_sea , fh = fh_sea , & + xland = xland_sea , hfx = hfx_sea , qfx = qfx_sea , & + lh = lh_sea , tsk = tsk_sea , flhc = flhc_sea , & + flqc = flqc_sea , qgh = qgh_sea , qsfc = qsfc_sea , & + rmol = rmol_sea , u10 = u10_sea , v10 = v10_sea , & + th2 = th2m_sea , t2 = t2m_sea , q2 = q2_sea , & + gz1oz0 = gz1oz0_sea , wspd = wspd_sea , br = br_sea , & + isfflx = isfflx , dx = dx_p , svp1 = svp1 , & + svp2 = svp2 , svp3 = svp3 , svpt0 = svpt0 , & + ep1 = ep_1 , ep2 = ep_2 , karman = karman , & + p1000mb = P0 , lakemask = lakemask_p , ustm = ustm_sea , & + ck = ck_sea , cka = cka_sea , cd = cd_sea , & + cda = cda_sea , isftcflx = isftcflx , iz0tlnd = iz0tlnd , & + shalwater_z0 = shalwater_flag , water_depth = waterdepth_p , scm_force_flux = scm_force_flux , & + errmsg = errmsg , errflg = errflg , & + 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 & ) call mpas_log_write('--- end subroutine sfclayrev seaice:') endif diff --git a/src/core_atmosphere/physics/mpas_atmphys_finalize.F b/src/core_atmosphere/physics/mpas_atmphys_finalize.F index 8ad9248196..903042246e 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_finalize.F +++ b/src/core_atmosphere/physics/mpas_atmphys_finalize.F @@ -9,6 +9,7 @@ module mpas_atmphys_finalize use mpas_pool_routines + use mpas_atmphys_lsm_noahmpfinalize,only: sf_noahmp_deallocate use module_mp_thompson implicit none @@ -37,14 +38,21 @@ subroutine atmphys_finalize(configs) type(mpas_pool_type),intent(in):: configs !local variables and pointers: - character(len=StrKIND),pointer:: config_microp_scheme + character(len=StrKIND),pointer:: config_lsm_scheme, & + config_microp_scheme !----------------------------------------------------------------------------------------------------------------- + call mpas_pool_get_config(configs,'config_lsm_scheme' ,config_lsm_scheme ) call mpas_pool_get_config(configs,'config_microp_scheme',config_microp_scheme) - if(trim(config_microp_scheme) == 'mp_thompson') & + if(trim(config_lsm_scheme) == 'sf_noahmp') & + call sf_noahmp_deallocate + + if(trim(config_microp_scheme) == 'mp_thompson' .or. & + trim(config_microp_scheme) == 'mp_thompson_aerosols') then call mp_thompson_deallocate + endif end subroutine atmphys_finalize diff --git a/src/core_atmosphere/physics/mpas_atmphys_init.F b/src/core_atmosphere/physics/mpas_atmphys_init.F index 8145cdb98f..ce767fb6b3 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_init.F +++ b/src/core_atmosphere/physics/mpas_atmphys_init.F @@ -11,17 +11,18 @@ module mpas_atmphys_init use mpas_pool_routines use mpas_timekeeping - use mpas_atmphys_driver_convection, only: init_convection + use mpas_atmphys_driver_convection,only: init_convection use mpas_atmphys_driver_lsm,only: init_lsm - use mpas_atmphys_driver_microphysics + use mpas_atmphys_driver_microphysics,only: init_microphysics use mpas_atmphys_driver_pbl,only: init_pbl - use mpas_atmphys_driver_radiation_lw, only: init_radiation_lw - use mpas_atmphys_driver_radiation_sw, only: init_radiation_sw - use mpas_atmphys_driver_sfclayer + use mpas_atmphys_driver_radiation_lw,only: init_radiation_lw + use mpas_atmphys_driver_radiation_sw,only: init_radiation_sw + use mpas_atmphys_driver_sfclayer,only: init_sfclayer use mpas_atmphys_vars,only: f_qc,f_qr,f_qi,f_qs,f_qg,f_qoz,f_nc,f_ni,f_nifa,f_nwfa,f_nbca use mpas_atmphys_landuse use mpas_atmphys_o3climatology + use mpas_atmphys_lsm_noahmpinit,only: init_lsm_noahmp implicit none private @@ -68,14 +69,16 @@ module mpas_atmphys_init ! Laura D. Fowler (laura@ucar.edu) / 2016-10-18. ! * added the subroutine init_physics_flags to initialize f_qc,f_qr,f_qi,f_qs,f_qg,f_nc,and f_ni. ! Laura D. Fowler (laura@ucar.edu) / 2024-02-14. +! * added call to subroutine init_lsm_noahmp to initialize the Noah-MP land surface scheme. +! Laura D. Fowler (laura@ucar.edu) / 2024-03-11. contains !================================================================================================================= - subroutine physics_init(dminfo,clock,configs,mesh,diag,tend,state,time_lev,diag_physics, & - atm_input,sfc_input) + subroutine physics_init(dminfo,clock,configs,mesh,diag,tend,state,time_lev,diag_physics,diag_physics_noahmp, & + atm_input,sfc_input,output_noahmp) !================================================================================================================= !input arguments: @@ -91,12 +94,15 @@ subroutine physics_init(dminfo,clock,configs,mesh,diag,tend,state,time_lev,diag_ type(mpas_pool_type),intent(inout):: diag type(mpas_pool_type),intent(inout):: tend type(mpas_pool_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: diag_physics_noahmp type(mpas_pool_type),intent(inout):: atm_input type(mpas_pool_type),intent(inout):: sfc_input + type(mpas_pool_type),intent(inout):: output_noahmp !local pointers: - logical,pointer:: config_do_restart, & - config_o3climatology + logical,pointer:: config_do_restart, & + config_o3climatology, & + config_oml1d character(len=StrKIND),pointer:: & config_convection_scheme, & @@ -108,39 +114,35 @@ subroutine physics_init(dminfo,clock,configs,mesh,diag,tend,state,time_lev,diag_ config_radt_sw_scheme integer,pointer:: nCellsSolve,nLags - integer,dimension(:),pointer :: i_rainc,i_rainnc - integer,dimension(:),pointer :: i_acswdnb,i_acswdnbc,i_acswdnt,i_acswdntc, & - i_acswupb,i_acswupbc,i_acswupt,i_acswuptc, & - i_aclwdnb,i_aclwdnbc,i_aclwdnt,i_aclwdntc, & - i_aclwupb,i_aclwupbc,i_aclwupt,i_aclwuptc - - real(kind=RKIND),dimension(:),pointer :: acswdnb,acswdnbc,acswdnt,acswdntc, & - acswupb,acswupbc,acswupt,acswuptc, & - aclwdnb,aclwdnbc,aclwdnt,aclwdntc, & - aclwupb,aclwupbc,aclwupt,aclwuptc - real(kind=RKIND),dimension(:),pointer :: nsteps_accum,ndays_accum,tday_accum, & - tyear_accum,tyear_mean - real(kind=RKIND),dimension(:),pointer :: sst,sstsk,tmn,xice,xicem + integer,dimension(:),pointer:: i_rainc,i_rainnc + integer,dimension(:),pointer:: i_acswdnb,i_acswdnbc,i_acswdnt,i_acswdntc, & + i_acswupb,i_acswupbc,i_acswupt,i_acswuptc, & + i_aclwdnb,i_aclwdnbc,i_aclwdnt,i_aclwdntc, & + i_aclwupb,i_aclwupbc,i_aclwupt,i_aclwuptc + + real(kind=RKIND),dimension(:),pointer:: acswdnb,acswdnbc,acswdnt,acswdntc, & + acswupb,acswupbc,acswupt,acswuptc, & + aclwdnb,aclwdnbc,aclwdnt,aclwdntc, & + aclwupb,aclwupbc,aclwupt,aclwuptc + real(kind=RKIND),dimension(:),pointer:: nsteps_accum,ndays_accum,tday_accum, & + tyear_accum,tyear_mean + real(kind=RKIND),dimension(:),pointer:: sst,sstsk,tmn,xice,xicem real(kind=RKIND),dimension(:,:),pointer:: tlag - real(kind=RKIND),dimension(:),pointer :: t_oml, t_oml_initial, t_oml_200m_initial - real(kind=RKIND),dimension(:),pointer :: h_oml, h_oml_initial, hu_oml, hv_oml - real(kind=RKIND), pointer :: config_oml_hml0 - integer,pointer:: nCells - logical,pointer:: config_oml1d - - + real(kind=RKIND),pointer:: config_oml_hml0 + real(kind=RKIND),dimension(:),pointer:: t_oml,t_oml_initial,t_oml_200m_initial + real(kind=RKIND),dimension(:),pointer:: h_oml,h_oml_initial,hu_oml,hv_oml !local variables and arrays: type(MPAS_Time_Type):: currTime logical:: init_done integer:: ierr,julday - integer:: iCell,iLag,iEdge,nEdges_m + integer:: iCell,iLag !----------------------------------------------------------------------------------------------------------------- -! call mpas_log_write('') -! call mpas_log_write('--- enter subroutine physics_init:') +!call mpas_log_write('') +!call mpas_log_write('--- enter subroutine physics_init:') call mpas_pool_get_config(configs,'config_do_restart' ,config_do_restart ) call mpas_pool_get_config(configs,'config_o3climatology' ,config_o3climatology ) @@ -211,7 +213,6 @@ subroutine physics_init(dminfo,clock,configs,mesh,diag,tend,state,time_lev,diag_ call mpas_pool_get_array(diag_physics,'hv_oml' ,hv_oml) call mpas_pool_get_config(configs,'config_oml1d' ,config_oml1d ) call mpas_pool_get_config(configs,'config_oml_hml0' ,config_oml_hml0 ) - call mpas_pool_get_dimension(mesh,'nCells',nCells) currTime = mpas_get_clock_time(clock,MPAS_NOW,ierr) call mpas_get_time(curr_time=currTime,DoY=julday,ierr=ierr) @@ -284,7 +285,7 @@ subroutine physics_init(dminfo,clock,configs,mesh,diag,tend,state,time_lev,diag_ !initialization of xicem: if(.not.config_do_restart) then -! call mpas_log_write('--- initialization of xicem:') +! call mpas_log_write('--- initialization of xicem:') do iCell = 1, nCellsSolve xicem(iCell) = xice(iCell) enddo @@ -294,47 +295,47 @@ subroutine physics_init(dminfo,clock,configs,mesh,diag,tend,state,time_lev,diag_ !sea-surface temperature is applied. This avoids having the array sstsk equal to !zero over land: if(.not. config_do_restart) then -! call mpas_log_write('--- initialization of sstsk:') +! call mpas_log_write('--- initialization of sstsk:') do iCell = 1, nCellsSolve sstsk(iCell) = sst(iCell) enddo endif -! initialized the 1D ocean mixed-layer model (code from wrf module_sf_oml) - if (config_oml1d) then - if (.not. config_do_restart) then - call mpas_log_write('--- initialization of 1D ocean mixed layer model ') - do iCell = 1, nCellsSolve - t_oml(iCell) = sst(iCell) - t_oml_initial(iCell) = sst(iCell) - end do - if (config_oml_hml0 .gt. 0) then - do iCell = 1, nCellsSolve - h_oml(iCell) = config_oml_hml0 - h_oml_initial(iCell) = config_oml_hml0 - hu_oml(iCell) = 0. - hv_oml(iCell) = 0. - t_oml_200m_initial(iCell) = sst(iCell) - 5. - end do - else if (config_oml_hml0 .eq. 0) then -! initializing with climatological mixed layer depth only - do iCell = 1, nCellsSolve - h_oml(iCell) = h_oml_initial(iCell) - hu_oml(iCell) = 0. - hv_oml(iCell) = 0. - t_oml_200m_initial(iCell) = sst(iCell) - 5. - end do - else - do iCell = 1, nCellsSolve - h_oml(iCell) = h_oml_initial(iCell) - ! WRF COMMENT: - ! fill in near coast area with SST: 200 K was set as missing value in ocean pre-processing code - if( (t_oml_200m_initial(iCell) > 200.) .and. (t_oml_200m_initial(iCell) <= 200.) ) & - t_oml_200m_initial(iCell) = sst(iCell) - end do - end if - end if - end if +!initialized the 1D ocean mixed-layer model (code from wrf module_sf_oml): + if(config_oml1d) then + if(.not. config_do_restart) then + call mpas_log_write('--- initialization of 1D ocean mixed layer model ') + do iCell = 1, nCellsSolve + t_oml(iCell) = sst(iCell) + t_oml_initial(iCell) = sst(iCell) + enddo + if(config_oml_hml0 .gt. 0) then + do iCell = 1, nCellsSolve + h_oml(iCell) = config_oml_hml0 + h_oml_initial(iCell) = config_oml_hml0 + hu_oml(iCell) = 0. + hv_oml(iCell) = 0. + t_oml_200m_initial(iCell) = sst(iCell) - 5. + enddo + elseif(config_oml_hml0 .eq. 0) then +! initializing with climatological mixed layer depth only: + do iCell = 1, nCellsSolve + h_oml(iCell) = h_oml_initial(iCell) + hu_oml(iCell) = 0. + hv_oml(iCell) = 0. + t_oml_200m_initial(iCell) = sst(iCell) - 5. + enddo + else + do iCell = 1, nCellsSolve + h_oml(iCell) = h_oml_initial(iCell) + ! WRF COMMENT: + ! fill in near coast area with SST: 200 K was set as missing value in ocean pre-processing code + if( (t_oml_200m_initial(iCell) > 200.) .and. (t_oml_200m_initial(iCell) <= 200.) ) & + t_oml_200m_initial(iCell) = sst(iCell) + enddo + endif + endif + endif !initialization of temperatures needed for updating the deep soil temperature: if(.not. config_do_restart) then @@ -363,7 +364,7 @@ subroutine physics_init(dminfo,clock,configs,mesh,diag,tend,state,time_lev,diag_ !initialization of cloud microphysics processes: if(config_microp_scheme .ne. 'off') & - call microphysics_init(dminfo,configs,mesh,sfc_input,diag_physics) + call init_microphysics(dminfo,configs,mesh,state,time_lev,sfc_input,diag_physics) !initialization of PBL processes: if(config_pbl_scheme .ne. 'off') call init_pbl(configs) @@ -372,10 +373,13 @@ subroutine physics_init(dminfo,clock,configs,mesh,diag,tend,state,time_lev,diag_ if(config_sfclayer_scheme .ne. 'off') call init_sfclayer(configs) !initialization of land-surface model: -!if(.not. config_do_restart) then -! if(config_lsm_scheme .ne. 'off') call init_lsm(dminfo,mesh,configs,diag_physics,sfc_input) -!endif - if(config_lsm_scheme .ne. 'off') call init_lsm(dminfo,mesh,configs,diag_physics,sfc_input) + if(config_lsm_scheme .ne. 'off') then + if(config_lsm_scheme .eq. 'sf_noah') then + call init_lsm(dminfo,mesh,configs,diag_physics,sfc_input) + elseif(config_lsm_scheme .eq. 'sf_noahmp') then + call init_lsm_noahmp(configs,mesh,diag_physics,diag_physics_noahmp,output_noahmp,sfc_input) + endif + endif !initialization of shortwave radiation processes: init_done = .false. @@ -423,7 +427,7 @@ subroutine init_physics_flags(state,f_qc,f_qr,f_qi,f_qs,f_qg,f_qoz,f_nc,f_ni,f_n !local pointers: integer,pointer:: index_qc,index_qr,index_qi,index_qs,index_qg - integer,pointer:: index_ni + integer,pointer:: index_nc,index_ni,index_nifa,index_nwfa !----------------------------------------------------------------------------------------------------------------- @@ -447,15 +451,20 @@ subroutine init_physics_flags(state,f_qc,f_qr,f_qi,f_qs,f_qg,f_qoz,f_nc,f_ni,f_n if(index_qg .gt. -1) f_qg = .true. !initializes the logical assigned to number concentrations: - f_nc = .false. !nc is not defined in Registry.xml - therefore f_nc is initialized to false. + f_nc = .false. f_ni = .false. - f_nifa = .false. !nifa is not defined in Registry.xml - therefore f_nc is initialized to false. - f_nwfa = .false. !nwfa is not defined in Registry.xml - therefore f_nc is initialized to false. + f_nifa = .false. + f_nwfa = .false. f_nbca = .false. !nbca is not defined in Registry.xml - therefore f_nc is initialized to false. - - call mpas_pool_get_dimension(state,'index_ni',index_ni) - - if(index_ni .gt. -1) f_ni = .true. + call mpas_pool_get_dimension(state,'index_nc' ,index_nc ) + call mpas_pool_get_dimension(state,'index_ni' ,index_ni ) + call mpas_pool_get_dimension(state,'index_nifa',index_nifa) + call mpas_pool_get_dimension(state,'index_nwfa',index_nwfa) + + if(index_nc .gt. -1) f_nc = .true. + if(index_ni .gt. -1) f_ni = .true. + if(index_nifa .gt. -1) f_nifa = .true. + if(index_nwfa .gt. -1) f_nwfa = .true. end subroutine init_physics_flags diff --git a/src/core_atmosphere/physics/mpas_atmphys_init_microphysics.F b/src/core_atmosphere/physics/mpas_atmphys_init_microphysics.F index 99db47ced6..17ec774f65 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_init_microphysics.F +++ b/src/core_atmosphere/physics/mpas_atmphys_init_microphysics.F @@ -5,20 +5,23 @@ ! Additional copyright and license information can be found in the LICENSE file ! distributed with this code, or at http://mpas-dev.github.com/license.html ! +#define DM_BCAST_MACRO(A) call mpas_dmpar_bcast_reals(dminfo,size(A),A) !================================================================================================================= module mpas_atmphys_init_microphysics use mpas_dmpar use mpas_kind_types + use mpas_log use mpas_pool_routines use mpas_atmphys_utilities -!use module_mp_thompson, only: is_aerosol_aware,naCCN0,naCCN1,naIN0,naIN1,ntb_arc,ntb_arw,ntb_art,ntb_arr, & -! ntb_ark,tnccn_act + use module_mp_thompson, only: is_aerosol_aware,naCCN0,naCCN1,naIN0,naIN1,ntb_arc,ntb_arw,ntb_art,ntb_arr, & + ntb_ark,tnccn_act implicit none private - public:: init_thompson_clouddroplets_forMPAS + public:: init_thompson_clouddroplets_forMPAS, & + init_thompson_aerosols_forMPAS !MPAS main initialization of the Thompson parameterization of cloud microphysics with nucleation of cloud !droplets based on distributions of CCNs and INs (aerosol-aware parameterization). @@ -29,6 +32,15 @@ module mpas_atmphys_init_microphysics ! ---------------------------------------- ! * added "use mpas_dmpar" at the top of the module. ! Laura D. Fowler (laura@ucar.edu) / 2016-04-04. +! * modified the initialization of nifa and nwfa.If nifa and nwfa are already available in the initial conditions +! using the climatological GOCART data,do not recalculate nifa and nwfa using an exponential profile of CCN and +! IN as a function of height. +! Laura D. Fowler (laura@ucar.edu) / 2016-05-27. +! * modified the subroutine init_thompson_aerosols_forMPAS for exact restartibility when using the microphysics +! option "mp_thompson_aerosols". +! Laura D. Fowler (laura@ucar.edu) / 2018-02-23. +! * changed the definition of DM_BCAST_MACRO to compile table_ccnAct with the default DOUBLE PRECISION. +! Laura D. Fowler (laura@ucar.edu) / 2018-03-07. contains @@ -80,8 +92,225 @@ subroutine init_thompson_clouddroplets_forMPAS(mesh,sfc_input,diag_physics) end subroutine init_thompson_clouddroplets_forMPAS !================================================================================================================= - end module mpas_atmphys_init_microphysics + subroutine init_thompson_aerosols_forMPAS(do_restart,dminfo,mesh,state,time_lev,diag_physics) +!================================================================================================================= + +!input variables: + type(dm_info),intent(in):: dminfo + type(mpas_pool_type),intent(in):: mesh + logical,intent(in):: do_restart + integer,intent(in):: time_lev + +!inout variables: + type(mpas_pool_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: state + +!local variables and pointers: + integer,pointer:: nCellsSolve,nVertLevels + integer,pointer:: index_nifa,index_nwfa + + real(kind=RKIND),dimension(:),pointer :: areaCell + real(kind=RKIND),dimension(:),pointer :: nifa2d,nwfa2d + real(kind=RKIND),dimension(:,:),pointer :: zgrid,zz + real(kind=RKIND),dimension(:,:),pointer :: rho_zz,nifa,nwfa + real(kind=RKIND),dimension(:,:,:),pointer:: scalars + + character(len=StrKIND):: mess + + integer:: iCell, k + + real(kind=RKIND):: max_test + real(kind=RKIND):: airmass + real(kind=RKIND):: h_01 + real(kind=RKIND):: niIN3,niCCN3 + real(kind=RKIND):: nifa_max,nifa_min,global_nifa_max,global_nifa_min + real(kind=RKIND):: nwfa_max,nwfa_min,global_nwfa_max,global_nwfa_min + real(kind=RKIND),dimension(:,:),allocatable:: hgt + +!----------------------------------------------------------------------------------------------------------------- +!call mpas_log_write('--- enter subroutine init_thompson_aerosols_forMPAS:') + + is_aerosol_aware = .true. + +!... 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. + call table_ccnAct(dminfo) + call mpas_log_write('--- end read table_ccnAct:') + +!... if do_restart is true, then we do not need to check the initialization of nwfa, nifa, and nwfa2d. If false, +! then, we proceed with the initialization: + if(do_restart) return + + call mpas_pool_get_dimension(mesh,'nCellsSolve',nCellsSolve) + call mpas_pool_get_dimension(mesh,'nVertLevels',nVertLevels) + + call mpas_pool_get_array(mesh,'areaCell',areaCell) + call mpas_pool_get_array(mesh,'zgrid' ,zgrid ) + call mpas_pool_get_array(mesh,'zz' ,zz ) + + call mpas_pool_get_array(diag_physics,'nifa2d',nifa2d) + call mpas_pool_get_array(diag_physics,'nwfa2d',nwfa2d) + + call mpas_pool_get_dimension(state,'index_nifa' ,index_nifa ) + call mpas_pool_get_dimension(state,'index_nwfa' ,index_nwfa ) + + call mpas_pool_get_array(state,'scalars',scalars,time_lev) + nifa => scalars(index_nifa,:,:) + nwfa => scalars(index_nwfa,:,:) + + call mpas_pool_get_array(state,'rho_zz',rho_zz,time_lev) + + if(.not.allocated(hgt)) allocate(hgt(1:nVertLevels,1:nCellsSolve)) + do iCell = 1, nCellsSolve + do k = 1, nVertLevels + hgt(k,iCell) = 0.5_RKIND * (zgrid(k,iCell)+zgrid(k+1,iCell)) + enddo + enddo + +!... initialize the distribution of hygroscopic ("water friendly") aerosols if not already initialized using +! GOCART data: + global_nwfa_min = 0._RKIND + global_nwfa_max = 0._RKIND + nwfa_min = minval(nwfa(:,1:nCellsSolve)) + nwfa_max = maxval(nwfa(:,1:nCellsSolve)) + call mpas_dmpar_min_real(dminfo,nwfa_min,global_nwfa_min) + call mpas_dmpar_max_real(dminfo,nwfa_max,global_nwfa_max) + call mpas_log_write('--- global_nwfa_min = $r',realArgs=(/global_nwfa_min/)) + call mpas_log_write('--- global_nwfa_max = $r',realArgs=(/global_nwfa_max/)) + + if(global_nwfa_min == 0._RKIND .and. global_nwfa_max == 0._RKIND) then + call mpas_log_write('--- initialize nwfa using an exponential distribution of CCN as a function of height.') + do iCell = 1, nCellsSolve + if(hgt(1,iCell).le.1000.0) then + h_01 = 0.8 + elseif(hgt(1,iCell).ge.2500.0) then + h_01 = 0.01 + else + h_01 = 0.8*cos(hgt(1,iCell)*0.001 - 1.0) + endif + niCCN3 = -1.0*ALOG(naCCN1/naCCN0)/h_01 + nwfa(1,iCell) = naCCN1+naCCN0*exp(-((hgt(2,iCell)-hgt(1,iCell))/1000.)*niCCN3) + do k = 2, nVertLevels + nwfa(k,iCell) = naCCN1+naCCN0*exp(-((hgt(k,iCell)-hgt(1,iCell))/1000.)*niCCN3) + enddo + enddo + else + call mpas_log_write('--- initialize nwfa using the climatological GOCART data.') + endif + +!... initialize the distribution of nonhygroscopic ("ice friendly") aerosols if not already initialized using +! GOCART data: + global_nifa_min = 0._RKIND + global_nifa_max = 0._RKIND + nifa_min = minval(nifa(:,1:nCellsSolve)) + nifa_max = maxval(nifa(:,1:nCellsSolve)) + call mpas_dmpar_min_real(dminfo,nifa_min,global_nifa_min) + call mpas_dmpar_max_real(dminfo,nifa_max,global_nifa_max) + call mpas_log_write('--- global_nifa_min = $r',realArgs=(/global_nifa_min/)) + call mpas_log_write('--- global_nifa_max = $r',realArgs=(/global_nifa_max/)) + + if(global_nifa_min == 0._RKIND .and. global_nifa_max == 0._RKIND) then + call mpas_log_write('--- initialize nifa using an exponential distribution of IN as a function of height.') + do iCell = 1, nCellsSolve + if(hgt(1,iCell).le.1000.0) then + h_01 = 0.8 + elseif(hgt(1,iCell).ge.2500.0) then + h_01 = 0.01 + else + h_01 = 0.8*cos(hgt(1,iCell)*0.001 - 1.0) + endif + niIN3 = -1.0*ALOG(naIN1/naIN0)/h_01 + nifa(1,iCell) = naIN1+naIN0*exp(-((hgt(2,iCell)-hgt(1,iCell))/1000.)*niIN3) + do k = 2, nVertLevels + nifa(k,iCell) = naIN1+naIN0*exp(-((hgt(k,iCell)-hgt(1,iCell))/1000.)*niIN3) + enddo + enddo + else + call mpas_log_write('--- initialize nifa using the climatological GOCART data.') + endif + +!... scale the lowest level aerosol data into an emissions rate. This is very far from ideal, but +!... need higher emissions where larger amount of (climo) existing and lesser emissions where there +!... exists fewer to begin as a first-order simplistic approach. Later, proper connection to emission +!... inventory would be better, but, for now, scale like this: +!... where: Nwfa=50 per cc, emit 0.875E4 aerosols per second per grid box unit +!... that was tested as ~(20kmx20kmx50m = 2.E10 m**3). + + k = 1 + do iCell = 1, nCellsSolve + airmass = rho_zz(k,iCell)*zz(k,iCell) + airmass = airmass*(zgrid(k+1,iCell)-zgrid(k,iCell))*areaCell(iCell) ! (in kg) + nwfa2d(iCell) = nwfa(k,iCell)*0.000196*airmass*0.5e-10 + nifa2d(iCell) = 0._RKIND +! call mpas_log_write('$i $r $r $r',intArgs=(/iCell/),realArgs=(/airmass,nwfa2d(iCell),nifa2d(iCell)/)) + enddo + +!... deallocate local arrays: + if(allocated(hgt)) deallocate(hgt) + +!call mpas_log_write('--- end subroutine init_thompson_aerosols_forMPAS.') + + end subroutine init_thompson_aerosols_forMPAS + !================================================================================================================= + subroutine table_ccnAct(dminfo) +!================================================================================================================= + +!input variables: + type(dm_info),intent(in):: dminfo - - +!local variables: + logical:: opened + integer:: ccn_unit,i,istat + character(len=StrKIND):: errmess +!----------------------------------------------------------------------------------------------------------------- + + if(.not.allocated(tnccn_act)) allocate(tnccn_act(ntb_arc,ntb_arw,ntb_art,ntb_arr,ntb_ark)) + +!get a unit to open binary file: + istat = -999 + if(dminfo % my_proc_id == IO_NODE) then + do i = 10,99 + inquire(i,opened = opened,iostat=istat) + if(.not. opened ) then + ccn_unit = i + exit + endif + enddo + if(istat /= 0) & + call physics_error_fatal('mpas_atmphys_init_microphysics table_ccnAct: Can not '// & + 'find unused fortran unit to read in lookup table.' ) + endif + +!distribute unit to other processors: + call mpas_dmpar_bcast_int(dminfo,ccn_unit) + +!open binary file: + istat = -999 + if(dminfo % my_proc_id == IO_NODE) then + open(ccn_unit,file='CCN_ACTIVATE_DATA',form='UNFORMATTED',status='OLD',iostat=istat) + if(istat /= 0) then + write(errmess,'(A,I4)') 'mpas_atmphys_init_microphysics table_ccnAct:: '// & + 'error opening CCN_ACTIVATE_DATA on unit', ccn_unit + call physics_error_fatal(errmess) + endif + endif + +!read and broadcast data to all nodes: + istat = -999 + if(dminfo % my_proc_id == IO_NODE) then + read(ccn_unit,iostat=istat) tnccn_act + if(istat /= 0) then + write(errmess,'(A,I4)') 'mpas_atmphys_init_microphysics table_ccnAct:: '// & + 'error reading tnccn_act on unit', ccn_unit + call physics_error_fatal(errmess) + endif + endif + + DM_BCAST_MACRO(tnccn_act) + + end subroutine table_ccnAct + +!================================================================================================================= + end module mpas_atmphys_init_microphysics +!================================================================================================================= diff --git a/src/core_atmosphere/physics/mpas_atmphys_interface.F b/src/core_atmosphere/physics/mpas_atmphys_interface.F index 5da88ebc29..b467bb09b8 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_interface.F +++ b/src/core_atmosphere/physics/mpas_atmphys_interface.F @@ -77,11 +77,12 @@ subroutine allocate_forall_physics(configs) type(mpas_pool_type),intent(in):: configs !local pointers: - character(len=StrKIND),pointer:: pbl_scheme + character(len=StrKIND),pointer:: microp_scheme,pbl_scheme !----------------------------------------------------------------------------------------------------------------- - call mpas_pool_get_config(configs,'config_pbl_scheme',pbl_scheme) + call mpas_pool_get_config(configs,'config_microp_scheme',microp_scheme) + call mpas_pool_get_config(configs,'config_pbl_scheme' ,pbl_scheme ) if(.not.allocated(psfc_p) ) allocate(psfc_p(ims:ime,jms:jme) ) if(.not.allocated(ptop_p) ) allocate(ptop_p(ims:ime,jms:jme) ) @@ -114,12 +115,20 @@ subroutine allocate_forall_physics(configs) if(.not.allocated(qs_p) ) allocate(qs_p(ims:ime,kms:kme,jms:jme) ) if(.not.allocated(qg_p) ) allocate(qg_p(ims:ime,kms:kme,jms:jme) ) - pbl_select: select case (trim(pbl_scheme)) + microp_select: select case(trim(microp_scheme)) + case("mp_thompson_aerosols") + if(.not.allocated(nifa_p)) allocate(nifa_p(ims:ime,kms:kme,jms:jme)) + if(.not.allocated(nwfa_p)) allocate(nwfa_p(ims:ime,kms:kme,jms:jme)) + + case default + end select microp_select + + pbl_select: select case(trim(pbl_scheme)) case("bl_mynn") + if(.not.allocated(nc_p)) allocate(nc_p(ims:ime,kms:kme,jms:jme)) if(.not.allocated(ni_p)) allocate(ni_p(ims:ime,kms:kme,jms:jme)) case default - end select pbl_select !... arrays used for calculating the hydrostatic pressure and exner function: @@ -141,11 +150,12 @@ subroutine deallocate_forall_physics(configs) type(mpas_pool_type),intent(in):: configs !local pointers: - character(len=StrKIND),pointer:: pbl_scheme + character(len=StrKIND),pointer:: microp_scheme,pbl_scheme !----------------------------------------------------------------------------------------------------------------- - call mpas_pool_get_config(configs,'config_pbl_scheme',pbl_scheme) + call mpas_pool_get_config(configs,'config_microp_scheme',microp_scheme) + call mpas_pool_get_config(configs,'config_pbl_scheme' ,pbl_scheme ) if(allocated(psfc_p) ) deallocate(psfc_p ) if(allocated(ptop_p) ) deallocate(ptop_p ) @@ -178,12 +188,20 @@ subroutine deallocate_forall_physics(configs) if(allocated(qs_p) ) deallocate(qs_p ) if(allocated(qg_p) ) deallocate(qg_p ) - pbl_select: select case (trim(pbl_scheme)) + microp_select: select case(trim(microp_scheme)) + case("mp_thompson_aerosols") + if(allocated(nifa_p)) deallocate(nifa_p) + if(allocated(nwfa_p)) deallocate(nwfa_p) + + case default + end select microp_select + + pbl_select: select case(trim(pbl_scheme)) case("bl_mynn") + if(allocated(nc_p)) deallocate(nc_p) if(allocated(ni_p)) deallocate(ni_p) case default - end select pbl_select if(allocated(psfc_hyd_p) ) deallocate(psfc_hyd_p ) @@ -213,10 +231,10 @@ subroutine MPAS_to_physics(configs,mesh,state,time_lev,diag,diag_physics,its,ite type(mpas_pool_type),intent(inout):: diag_physics !local pointers: - character(len=StrKIND),pointer:: pbl_scheme + character(len=StrKIND),pointer:: microp_scheme,pbl_scheme integer,pointer:: index_qv,index_qc,index_qr,index_qi,index_qs,index_qg - integer,pointer:: index_ni + integer,pointer:: index_nc,index_ni,index_nifa,index_nwfa real(kind=RKIND),dimension(:),pointer :: latCell,lonCell real(kind=RKIND),dimension(:),pointer :: fzm,fzp,rdzw @@ -225,7 +243,7 @@ subroutine MPAS_to_physics(configs,mesh,state,time_lev,diag,diag_physics,its,ite real(kind=RKIND),dimension(:,:),pointer :: zz,exner,pressure_b,rtheta_p,rtheta_b real(kind=RKIND),dimension(:,:),pointer :: rho_zz,theta_m,pressure_p,u,v,w real(kind=RKIND),dimension(:,:),pointer :: qv,qc,qr,qi,qs,qg - real(kind=RKIND),dimension(:,:),pointer :: ni + real(kind=RKIND),dimension(:,:),pointer :: nc,ni,nifa,nwfa real(kind=RKIND),dimension(:,:,:),pointer:: scalars !local variables: @@ -246,7 +264,8 @@ subroutine MPAS_to_physics(configs,mesh,state,time_lev,diag,diag_physics,its,ite !call mpas_log_write('kts=$i kte=$i',intArgs=(/kts,kte/)) !initialization: - call mpas_pool_get_config(configs,'config_pbl_scheme',pbl_scheme) + call mpas_pool_get_config(configs,'config_microp_scheme',microp_scheme) + call mpas_pool_get_config(configs,'config_pbl_scheme' ,pbl_scheme ) call mpas_pool_get_array(mesh,'latCell',latCell) call mpas_pool_get_array(mesh,'lonCell',lonCell) @@ -318,21 +337,64 @@ subroutine MPAS_to_physics(configs,mesh,state,time_lev,diag,diag_physics,its,ite enddo enddo - pbl_select: select case (trim(pbl_scheme)) - case("bl_mynn") - call mpas_pool_get_dimension(state,'index_ni',index_ni) - ni => scalars(index_ni,:,:) - + microp_select: select case(trim(microp_scheme)) + case("mp_thompson_aerosols") + nullify(nifa) + nullify(nwfa) + call mpas_pool_get_dimension(state,'index_nifa',index_nifa) + call mpas_pool_get_dimension(state,'index_nwfa',index_nwfa) + nifa => scalars(index_nifa,:,:) + nwfa => scalars(index_nwfa,:,:) do j = jts,jte - do k = kts,kte - do i = its,ite - ni_p(i,k,j) = max(0.,ni(k,i)) - enddo - enddo + do k = kts,kte + do i = its,ite + nifa_p(i,k,j) = max(0.,nifa(k,i)) + nwfa_p(i,k,j) = max(0.,nwfa(k,i)) + enddo + enddo enddo case default + end select microp_select + + pbl_select: select case(trim(pbl_scheme)) + case("bl_mynn") + do j = jts,jte + do k = kts,kte + do i = its,ite + nc_p(i,k,j) = 0._RKIND + ni_p(i,k,j) = 0._RKIND + enddo + enddo + enddo + !initializes ni_p when running the options "mp_thompson" or "mp_thompson_aerosols": + if(f_ni) then + nullify(ni) + call mpas_pool_get_dimension(state,'index_ni',index_ni) + ni => scalars(index_ni,:,:) + do j = jts,jte + do k = kts,kte + do i = its,ite + ni_p(i,k,j) = max(0.,ni(k,i)) + enddo + enddo + enddo + endif + !initializes nc_p, nifa_p, and nwfa_p when running the option "mp_thompson_aerosols": + if(f_nc) then + nullify(nc) + call mpas_pool_get_dimension(state,'index_nc',index_nc) + nc => scalars(index_nc,:,:) + do j = jts,jte + do k = kts,kte + do i = its,ite + nc_p(i,k,j) = max(0.,nc(k,i) ) + enddo + enddo + enddo + endif + case default end select pbl_select !calculation of the surface pressure using hydrostatic assumption down to the surface:: @@ -470,7 +532,7 @@ subroutine MPAS_to_physics(configs,mesh,state,time_lev,diag,diag_physics,its,ite end subroutine MPAS_to_physics !================================================================================================================= - subroutine microphysics_from_MPAS(configs,mesh,state,time_lev,diag,diag_physics,its,ite) + subroutine microphysics_from_MPAS(configs,mesh,state,time_lev,diag,diag_physics,tend_physics,its,ite) !================================================================================================================= !input variables: @@ -483,18 +545,23 @@ subroutine microphysics_from_MPAS(configs,mesh,state,time_lev,diag,diag_physics, integer,intent(in):: its,ite integer:: time_lev +!inout variables: + type(mpas_pool_type),intent(inout):: tend_physics + !local pointers: - character(len=StrKIND),pointer:: microp_scheme + character(len=StrKIND),pointer:: mp_scheme integer,pointer:: index_qv,index_qc,index_qr,index_qi,index_qs,index_qg - integer,pointer:: index_ni,index_nr - real(kind=RKIND),dimension(:),pointer :: nt_c,mu_c + integer,pointer:: index_nc,index_ni,index_nr,index_nifa,index_nwfa + real(kind=RKIND),dimension(:),pointer :: nifa2d,nwfa2d,nt_c,mu_c real(kind=RKIND),dimension(:,:),pointer :: zgrid,w real(kind=RKIND),dimension(:,:),pointer :: zz,exner,pressure_b real(kind=RKIND),dimension(:,:),pointer :: rho_zz,theta_m,pressure_p real(kind=RKIND),dimension(:,:),pointer :: qv,qc,qr,qi,qs,qg - real(kind=RKIND),dimension(:,:),pointer :: ni,nr + real(kind=RKIND),dimension(:,:),pointer :: nc,ni,nr,nifa,nwfa real(kind=RKIND),dimension(:,:),pointer :: rainprod,evapprod real(kind=RKIND),dimension(:,:),pointer :: re_cloud,re_ice,re_snow + real(kind=RKIND),dimension(:,:),pointer :: rthmpten,rqvmpten,rqcmpten,rqrmpten,rqimpten,rqsmpten,rqgmpten + real(kind=RKIND),dimension(:,:),pointer :: rncmpten,rnimpten,rnrmpten,rnifampten,rnwfampten real(kind=RKIND),dimension(:,:,:),pointer:: scalars !local variables: @@ -502,7 +569,7 @@ subroutine microphysics_from_MPAS(configs,mesh,state,time_lev,diag,diag_physics, !----------------------------------------------------------------------------------------------------------------- - call mpas_pool_get_config(configs,'config_microp_scheme',microp_scheme) + call mpas_pool_get_config(configs,'config_microp_scheme',mp_scheme) call mpas_pool_get_array(mesh,'zgrid',zgrid) call mpas_pool_get_array(mesh,'zz' ,zz ) @@ -511,31 +578,17 @@ subroutine microphysics_from_MPAS(configs,mesh,state,time_lev,diag,diag_physics, call mpas_pool_get_array(diag,'pressure_base',pressure_b) call mpas_pool_get_array(diag,'pressure_p' ,pressure_p) - call mpas_pool_get_array(diag_physics,'nt_c' ,nt_c ) - call mpas_pool_get_array(diag_physics,'mu_c' ,mu_c ) - call mpas_pool_get_array(diag_physics,'rainprod',rainprod) - call mpas_pool_get_array(diag_physics,'evapprod',evapprod) - call mpas_pool_get_array(diag_physics,'re_cloud',re_cloud) - call mpas_pool_get_array(diag_physics,'re_ice' ,re_ice ) - call mpas_pool_get_array(diag_physics,'re_snow' ,re_snow ) - call mpas_pool_get_array(state,'rho_zz' ,rho_zz ,time_lev) call mpas_pool_get_array(state,'theta_m',theta_m,time_lev) call mpas_pool_get_array(state,'w' ,w ,time_lev) - call mpas_pool_get_dimension(state,'index_qv' ,index_qv ) - call mpas_pool_get_dimension(state,'index_qc' ,index_qc ) - call mpas_pool_get_dimension(state,'index_qr' ,index_qr ) - call mpas_pool_get_dimension(state,'index_qi' ,index_qi ) - call mpas_pool_get_dimension(state,'index_qs' ,index_qs ) - call mpas_pool_get_dimension(state,'index_qg' ,index_qg ) - call mpas_pool_get_dimension(state,'index_ni' ,index_ni ) - call mpas_pool_get_dimension(state,'index_nr' ,index_nr ) - + call mpas_pool_get_dimension(state,'index_qv',index_qv) + call mpas_pool_get_dimension(state,'index_qc',index_qc) + call mpas_pool_get_dimension(state,'index_qr',index_qr) call mpas_pool_get_array(state,'scalars',scalars,time_lev) - qv => scalars(index_qv,:,:) - qc => scalars(index_qc,:,:) - qr => scalars(index_qr,:,:) + qv => scalars(index_qv,:,:) + qc => scalars(index_qc,:,:) + qr => scalars(index_qr,:,:) !initialize variables needed in the cloud microphysics schemes: do j = jts, jte @@ -558,13 +611,21 @@ subroutine microphysics_from_MPAS(configs,mesh,state,time_lev,diag,diag_physics, enddo enddo -!additional initialization as function of cloud microphysics scheme: - microp_select_init: select case(microp_scheme) - - case ("mp_thompson","mp_wsm6") - qi => scalars(index_qi,:,:) - qs => scalars(index_qs,:,:) - qg => scalars(index_qg,:,:) +!initialize cloud water species and aerosols as function of cloud microphysics scheme: + mp_select: select case(trim(mp_scheme)) + case("mp_thompson","mp_thompson_aerosols","mp_wsm6") + call mpas_pool_get_dimension(state,'index_qi',index_qi) + call mpas_pool_get_dimension(state,'index_qs',index_qs) + call mpas_pool_get_dimension(state,'index_qg',index_qg) + qi => scalars(index_qi,:,:) + qs => scalars(index_qs,:,:) + qg => scalars(index_qg,:,:) + + call mpas_pool_get_array(diag_physics,'rainprod',rainprod) + call mpas_pool_get_array(diag_physics,'evapprod',evapprod) + call mpas_pool_get_array(diag_physics,'re_cloud',re_cloud) + call mpas_pool_get_array(diag_physics,'re_ice' ,re_ice ) + call mpas_pool_get_array(diag_physics,'re_snow' ,re_snow ) do j = jts, jte do k = kts, kte @@ -572,77 +633,168 @@ subroutine microphysics_from_MPAS(configs,mesh,state,time_lev,diag,diag_physics, qi_p(i,k,j) = qi(k,i) qs_p(i,k,j) = qs(k,i) qg_p(i,k,j) = qg(k,i) - recloud_p(i,k,j) = re_cloud(k,i) - reice_p(i,k,j) = re_ice(k,i) - resnow_p(i,k,j) = re_snow(k,i) + + rainprod_p(i,k,j) = rainprod(k,i) + evapprod_p(i,k,j) = evapprod(k,k) + recloud_p(i,k,j) = re_cloud(k,i) + reice_p(i,k,j) = re_ice(k,i) + resnow_p(i,k,j) = re_snow(k,i) enddo enddo enddo - microp2_select: select case(microp_scheme) - - case("mp_thompson") - ni => scalars(index_ni,:,:) - nr => scalars(index_nr,:,:) + mp2_select: select case(trim(mp_scheme)) + case("mp_thompson","mp_thompson_aerosols") + call mpas_pool_get_dimension(state,'index_ni',index_ni) + call mpas_pool_get_dimension(state,'index_nr',index_nr) + ni => scalars(index_ni,:,:) + nr => scalars(index_nr,:,:) + + call mpas_pool_get_array(diag_physics,'nt_c',nt_c) + call mpas_pool_get_array(diag_physics,'mu_c',mu_c) + do j = jts,jte + do i = its,ite + muc_p(i,j) = mu_c(i) + ntc_p(i,j) = nt_c(i) + enddo + do k = kts, kte + do i = its, ite + ni_p(i,k,j) = ni(k,i) + nr_p(i,k,j) = nr(k,i) + enddo + enddo + enddo + + mp3_select: select case(trim(mp_scheme)) + case("mp_thompson_aerosols") + call mpas_pool_get_dimension(state,'index_nc' ,index_nc ) + call mpas_pool_get_dimension(state,'index_nifa',index_nifa) + call mpas_pool_get_dimension(state,'index_nwfa',index_nwfa) + nc => scalars(index_nc,:,:) + nifa => scalars(index_nifa,:,:) + nwfa => scalars(index_nwfa,:,:) + + call mpas_pool_get_array(diag_physics,'nifa2d',nifa2d) + call mpas_pool_get_array(diag_physics,'nwfa2d',nwfa2d) + do j = jts,jte + do i = its,ite + nifa2d_p(i,j) = nifa2d(i) + nwfa2d_p(i,j) = nwfa2d(i) + enddo + do k = kts, kte + do i = its, ite + nc_p(i,k,j) = nc(k,i) + nifa_p(i,k,j) = nifa(k,i) + nwfa_p(i,k,j) = nwfa(k,i) + enddo + enddo + enddo + + case default + end select mp3_select + + case default + end select mp2_select - do j = jts,jte - do i = its,ite - muc_p(i,j) = mu_c(i) - ntc_p(i,j) = nt_c(i) - enddo - enddo - do j = jts, jte - do k = kts, kte - do i = its, ite - ni_p(i,k,j) = ni(k,i) - nr_p(i,k,j) = nr(k,i) - rainprod_p(i,k,j) = rainprod(k,i) - evapprod_p(i,k,j) = evapprod(k,i) - enddo - enddo - enddo + case default + end select mp_select + +!begin calculation of cloud microphysics tendencies: + mp_tend_select: select case(trim(mp_scheme)) + case("mp_thompson","mp_thompson_aerosols","mp_wsm6") + call mpas_pool_get_array(tend_physics,'rthmpten',rthmpten) + call mpas_pool_get_array(tend_physics,'rqvmpten',rqvmpten) + call mpas_pool_get_array(tend_physics,'rqcmpten',rqcmpten) + call mpas_pool_get_array(tend_physics,'rqrmpten',rqrmpten) + call mpas_pool_get_array(tend_physics,'rqimpten',rqimpten) + call mpas_pool_get_array(tend_physics,'rqsmpten',rqsmpten) + call mpas_pool_get_array(tend_physics,'rqgmpten',rqgmpten) - case default + do k = kts,kte + do i = its,ite + rthmpten(k,i) = theta_m(k,i)/(1._RKIND+R_v/R_d*max(0._RKIND,qv(k,i))) + rqvmpten(k,i) = qv(k,i) + rqcmpten(k,i) = qc(k,i) + rqrmpten(k,i) = qr(k,i) + rqimpten(k,i) = qi(k,i) + rqsmpten(k,i) = qs(k,i) + rqgmpten(k,i) = qg(k,i) + enddo + enddo - end select microp2_select + mp2_tend_select: select case(trim(mp_scheme)) + case("mp_thompson","mp_thompson_aerosols") + call mpas_pool_get_array(tend_physics,'rnimpten',rnimpten) + call mpas_pool_get_array(tend_physics,'rnrmpten',rnrmpten) + + do k = kts,kte + do i = its,ite + rnimpten(k,i) = ni(k,i) + rnrmpten(k,i) = nr(k,i) + enddo + enddo + + mp3_tend_select: select case(trim(mp_scheme)) + case("mp_thompson_aerosols") + call mpas_pool_get_array(tend_physics,'rncmpten',rncmpten) + call mpas_pool_get_array(tend_physics,'rnifampten',rnifampten) + call mpas_pool_get_array(tend_physics,'rnwfampten',rnwfampten) + + do k = kts,kte + do i = its,ite + rncmpten(k,i) = nc(k,i) + rnifampten(k,i) = nifa(k,i) + rnwfampten(k,i) = nwfa(k,i) + enddo + enddo + + case default + end select mp3_tend_select + + case default + end select mp2_tend_select case default - - end select microp_select_init + end select mp_tend_select end subroutine microphysics_from_MPAS !================================================================================================================= - subroutine microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,tend,itimestep,its,ite) + subroutine microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,tend_physics,tend,its,ite) !================================================================================================================= !input variables: type(mpas_pool_type),intent(in):: configs type(mpas_pool_type),intent(in):: mesh - integer,intent(in):: itimestep,time_lev + integer,intent(in):: time_lev integer,intent(in):: its,ite -!output variables: +!inout variables: type(mpas_pool_type),intent(inout):: state type(mpas_pool_type),intent(inout):: diag type(mpas_pool_type),intent(inout):: tend type(mpas_pool_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: tend_physics + !local pointers: - character(len=StrKIND),pointer:: microp_scheme + character(len=StrKIND),pointer:: mp_scheme integer,pointer:: index_qv,index_qc,index_qr,index_qi,index_qs,index_qg - integer,pointer:: index_ni,index_nr + integer,pointer:: index_nc,index_ni,index_nr,index_nifa,index_nwfa real(kind=RKIND),dimension(:),pointer :: surface_pressure,tend_sfc_pressure + real(kind=RKIND),dimension(:),pointer :: nifa2d,nwfa2d real(kind=RKIND),dimension(:,:),pointer :: zgrid real(kind=RKIND),dimension(:,:),pointer :: zz,exner,exner_b,pressure_b,rtheta_p,rtheta_b real(kind=RKIND),dimension(:,:),pointer :: rho_zz,theta_m,pressure_p real(kind=RKIND),dimension(:,:),pointer :: rt_diabatic_tend real(kind=RKIND),dimension(:,:),pointer :: dtheta_dt_mp real(kind=RKIND),dimension(:,:),pointer :: qv,qc,qr,qi,qs,qg - real(kind=RKIND),dimension(:,:),pointer :: ni,nr + real(kind=RKIND),dimension(:,:),pointer :: nc,ni,nr,nifa,nwfa real(kind=RKIND),dimension(:,:),pointer :: rainprod,evapprod real(kind=RKIND),dimension(:,:),pointer :: re_cloud,re_ice,re_snow + real(kind=RKIND),dimension(:,:),pointer :: rthmpten,rqvmpten,rqcmpten,rqrmpten,rqimpten,rqsmpten,rqgmpten + real(kind=RKIND),dimension(:,:),pointer :: rncmpten,rnimpten,rnrmpten,rnifampten,rnwfampten real(kind=RKIND),dimension(:,:,:),pointer:: scalars !local variables: @@ -652,7 +804,7 @@ subroutine microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,te !----------------------------------------------------------------------------------------------------------------- - call mpas_pool_get_config(configs,'config_microp_scheme',microp_scheme) + call mpas_pool_get_config(configs,'config_microp_scheme',mp_scheme) call mpas_pool_get_array(mesh,'zz' ,zz ) call mpas_pool_get_array(mesh,'zgrid',zgrid) @@ -666,12 +818,6 @@ subroutine microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,te call mpas_pool_get_array(diag,'surface_pressure',surface_pressure) call mpas_pool_get_array(diag,'dtheta_dt_mp' ,dtheta_dt_mp ) - call mpas_pool_get_array(diag_physics,'rainprod',rainprod) - call mpas_pool_get_array(diag_physics,'evapprod',evapprod) - call mpas_pool_get_array(diag_physics,'re_cloud',re_cloud) - call mpas_pool_get_array(diag_physics,'re_ice' ,re_ice ) - call mpas_pool_get_array(diag_physics,'re_snow' ,re_snow ) - call mpas_pool_get_array(tend,'tend_sfc_pressure',tend_sfc_pressure) call mpas_pool_get_array(state,'rho_zz' ,rho_zz ,time_lev) @@ -680,12 +826,6 @@ subroutine microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,te call mpas_pool_get_dimension(state,'index_qv' ,index_qv ) call mpas_pool_get_dimension(state,'index_qc' ,index_qc ) call mpas_pool_get_dimension(state,'index_qr' ,index_qr ) - call mpas_pool_get_dimension(state,'index_qi' ,index_qi ) - call mpas_pool_get_dimension(state,'index_qs' ,index_qs ) - call mpas_pool_get_dimension(state,'index_qg' ,index_qg ) - call mpas_pool_get_dimension(state,'index_ni' ,index_ni ) - call mpas_pool_get_dimension(state,'index_nr' ,index_nr ) - call mpas_pool_get_array(state,'scalars',scalars,time_lev) qv => scalars(index_qv,:,:) qc => scalars(index_qc,:,:) @@ -727,7 +867,7 @@ subroutine microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,te enddo enddo -!updates the surface pressure and calculates the surface pressure tendency: +!update surface pressure and calculates the surface pressure tendency: do j = jts,jte do i = its,ite tem1 = zgrid(2,i)-zgrid(1,i) @@ -745,20 +885,31 @@ subroutine microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,te enddo enddo -!variables specific to different cloud microphysics schemes: - microp_select_init: select case(microp_scheme) +!update cloud water species and aerosols as functions of cloud microphysics schemes: + mp_select: select case(trim(mp_scheme)) + case("mp_thompson","mp_thompson_aerosols","mp_wsm6") + call mpas_pool_get_dimension(state,'index_qi',index_qi) + call mpas_pool_get_dimension(state,'index_qs',index_qs) + call mpas_pool_get_dimension(state,'index_qg',index_qg) + qi => scalars(index_qi,:,:) + qs => scalars(index_qs,:,:) + qg => scalars(index_qg,:,:) + + call mpas_pool_get_array(diag_physics,'rainprod',rainprod) + call mpas_pool_get_array(diag_physics,'evapprod',evapprod) + call mpas_pool_get_array(diag_physics,'re_cloud',re_cloud) + call mpas_pool_get_array(diag_physics,'re_ice' ,re_ice ) + call mpas_pool_get_array(diag_physics,'re_snow' ,re_snow ) - case ("mp_thompson","mp_wsm6") - qi => scalars(index_qi,:,:) - qs => scalars(index_qs,:,:) - qg => scalars(index_qg,:,:) - - do j = jts, jte - do k = kts, kte - do i = its, ite + do j = jts,jte + do k = kts,kte + do i = its,ite qi(k,i) = qi_p(i,k,j) qs(k,i) = qs_p(i,k,j) qg(k,i) = qg_p(i,k,j) + + rainprod(k,i) = rainprod_p(i,k,j) + evapprod(k,i) = evapprod_p(i,k,j) re_cloud(k,i) = recloud_p(i,k,j) re_ice(k,i) = reice_p(i,k,j) re_snow(k,i) = resnow_p(i,k,j) @@ -766,30 +917,113 @@ subroutine microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,te enddo enddo - microp2_select: select case(microp_scheme) + mp2_select: select case(trim(mp_scheme)) + case("mp_thompson","mp_thompson_aerosols") + call mpas_pool_get_dimension(state,'index_ni',index_ni) + call mpas_pool_get_dimension(state,'index_nr',index_nr) + ni => scalars(index_ni,:,:) + nr => scalars(index_nr,:,:) + + do j = jts,jte + do k = kts,kte + do i = its,ite + ni(k,i) = ni_p(i,k,j) + nr(k,i) = nr_p(i,k,j) + enddo + enddo + enddo + + mp3_select: select case(trim(mp_scheme)) + case("mp_thompson_aerosols") + call mpas_pool_get_dimension(state,'index_nc' ,index_nc ) + call mpas_pool_get_dimension(state,'index_nifa',index_nifa) + call mpas_pool_get_dimension(state,'index_nwfa',index_nwfa) + nc => scalars(index_nc,:,:) + nifa => scalars(index_nifa,:,:) + nwfa => scalars(index_nwfa,:,:) + + call mpas_pool_get_array(diag_physics,'nifa2d',nifa2d) + call mpas_pool_get_array(diag_physics,'nwfa2d',nwfa2d) + do j = jts,jte + do i = its,ite + nifa2d(i) = nifa2d_p(i,j) + nwfa2d(i) = nwfa2d_p(i,j) + enddo + do k = kts, kte + do i = its, ite + nc(k,i) = nc_p(i,k,j) + nifa(k,i) = nifa_p(i,k,j) + nwfa(k,i) = nwfa_p(i,k,j) + enddo + enddo + enddo + + case default + end select mp3_select + + case default + end select mp2_select - case("mp_thompson") - ni => scalars(index_ni,:,:) - nr => scalars(index_nr,:,:) - - do j = jts, jte - do k = kts, kte - do i = its, ite - ni(k,i) = ni_p(i,k,j) - nr(k,i) = nr_p(i,k,j) - rainprod(k,i) = rainprod_p(i,k,j) - evapprod(k,i) = evapprod_p(i,k,j) - enddo - enddo - enddo + case default + end select mp_select + +!end calculation of cloud microphysics tendencies: + mp_tend_select: select case(trim(mp_scheme)) + case("mp_thompson","mp_thompson_aerosols","mp_wsm6") + call mpas_pool_get_array(tend_physics,'rthmpten',rthmpten) + call mpas_pool_get_array(tend_physics,'rqvmpten',rqvmpten) + call mpas_pool_get_array(tend_physics,'rqcmpten',rqcmpten) + call mpas_pool_get_array(tend_physics,'rqrmpten',rqrmpten) + call mpas_pool_get_array(tend_physics,'rqimpten',rqimpten) + call mpas_pool_get_array(tend_physics,'rqsmpten',rqsmpten) + call mpas_pool_get_array(tend_physics,'rqgmpten',rqgmpten) - case default + do k = kts,kte + do i = its,ite + rthmpten(k,i) = (theta_m(k,i)/(1._RKIND+R_v/R_d*max(0._RKIND,qv(k,i)))-rthmpten(k,i))/dt_dyn + rqvmpten(k,i) = (qv(k,i)-rqvmpten(k,i))/dt_dyn + rqcmpten(k,i) = (qc(k,i)-rqcmpten(k,i))/dt_dyn + rqrmpten(k,i) = (qr(k,i)-rqrmpten(k,i))/dt_dyn + rqimpten(k,i) = (qi(k,i)-rqimpten(k,i))/dt_dyn + rqsmpten(k,i) = (qs(k,i)-rqsmpten(k,i))/dt_dyn + rqgmpten(k,i) = (qg(k,i)-rqgmpten(k,i))/dt_dyn + enddo + enddo - end select microp2_select + mp2_tend_select: select case(trim(mp_scheme)) + case("mp_thompson","mp_thompson_aerosols") + call mpas_pool_get_array(tend_physics,'rnimpten',rnimpten) + call mpas_pool_get_array(tend_physics,'rnrmpten',rnrmpten) + + do k = kts,kte + do i = its,ite + rnimpten(k,i) = (ni(k,i)-rnimpten(k,i))/dt_dyn + rnrmpten(k,i) = (nr(k,i)-rnrmpten(k,i))/dt_dyn + enddo + enddo + + mp3_tend_select: select case(trim(mp_scheme)) + case("mp_thompson_aerosols") + call mpas_pool_get_array(tend_physics,'rncmpten',rncmpten) + call mpas_pool_get_array(tend_physics,'rnifampten',rnifampten) + call mpas_pool_get_array(tend_physics,'rnwfampten',rnwfampten) + + do k = kts,kte + do i = its,ite + rncmpten(k,i) = (nc(k,i)-rncmpten(k,i))/dt_dyn + rnifampten(k,i) = (nifa(k,i)-rnifampten(k,i))/dt_dyn + rnwfampten(k,i) = (nwfa(k,i)-rnwfampten(k,i))/dt_dyn + enddo + enddo + + case default + end select mp3_tend_select + + case default + end select mp2_tend_select case default - - end select microp_select_init + end select mp_tend_select end subroutine microphysics_to_MPAS diff --git a/src/core_atmosphere/physics/mpas_atmphys_lsm_noahmpfinalize.F b/src/core_atmosphere/physics/mpas_atmphys_lsm_noahmpfinalize.F new file mode 100644 index 0000000000..5e6f999b44 --- /dev/null +++ b/src/core_atmosphere/physics/mpas_atmphys_lsm_noahmpfinalize.F @@ -0,0 +1,40 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!================================================================================================================= + module mpas_atmphys_lsm_noahmpfinalize + use mpas_log,only: mpas_log_write + + use mpas_atmphys_vars,only: mpas_noahmp + use NoahmpIOVarFinalizeMod,only: NoahmpIOVarFinalizeDefault + + + private + public:: sf_noahmp_deallocate + + + contains + +!================================================================================================================= + subroutine sf_noahmp_deallocate( ) +!================================================================================================================= +!----------------------------------------------------------------------------------------------------------------- +!call mpas_log_write(' ') +!call mpas_log_write('--- enter subroutine sf_noahmp_deallocate:') + + +!--- deallocate Noahmp arrays: + call NoahmpIOVarFinalizeDefault(mpas_noahmp) + + +!call mpas_log_write('--- end subroutine sf_noahmp_deallocate:') + + end subroutine sf_noahmp_deallocate + +!================================================================================================================= + end module mpas_atmphys_lsm_noahmpfinalize +!================================================================================================================= diff --git a/src/core_atmosphere/physics/mpas_atmphys_lsm_noahmpinit.F b/src/core_atmosphere/physics/mpas_atmphys_lsm_noahmpinit.F new file mode 100644 index 0000000000..da1cead2c0 --- /dev/null +++ b/src/core_atmosphere/physics/mpas_atmphys_lsm_noahmpinit.F @@ -0,0 +1,501 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!================================================================================================================= + module mpas_atmphys_lsm_noahmpinit + use mpas_log + use mpas_pool_routines + + use mpas_atmphys_utilities,only: physics_error_fatal + use mpas_atmphys_vars,only : mpas_noahmp + + use NoahmpInitMainMod,only : NoahmpInitMain + use NoahmpIOVarInitMod,only: NoahmpIOVarInitDefault + use NoahmpIOVarType + use NoahmpReadNamelistMod + use NoahmpReadTableMod,only: NoahmpReadTable + + + private + public:: init_lsm_noahmp + + + contains + + +!================================================================================================================= + subroutine init_lsm_noahmp(configs,mesh,diag_physics,diag_physics_noahmp,output_noahmp,sfc_input) +!================================================================================================================= + +!--- input arguments: + type(mpas_pool_type),intent(in):: configs + type(mpas_pool_type),intent(in):: mesh + +!--- inout arguments: + type(mpas_pool_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: diag_physics_noahmp + type(mpas_pool_type),intent(inout):: output_noahmp + type(mpas_pool_type),intent(inout):: sfc_input + +!--- local variables and arrays: + character(len=StrKIND),pointer:: mminlu + + integer:: ns + +!----------------------------------------------------------------------------------------------------------------- +!call mpas_log_write(' ') +!call mpas_log_write('--- enter subroutine init_lsm_noahmp:') + + +!--- initialize dimensions: + call noahmp_read_dimensions(mesh) + + +!--- initialize namelist options: + call noahmp_read_namelist(configs) + + +!--- allocate Noahmp arrays: +!call mpas_log_write(' ') +!call mpas_log_write('--- enter subroutine NoahmpIOVarInitDefault:') + call NoahmpIOVarInitDefault(mpas_noahmp) +!call mpas_log_write('--- end subroutine NoahmpIOVarInitDefault:') + + +!--- read NoahmpTable.TBL: + call mpas_pool_get_array(sfc_input,'mminlu',mminlu) + mpas_noahmp%llanduse = mminlu + +!call mpas_log_write(' ') +!call mpas_log_write('--- enter subroutine NoahmpReadTable:') + call NoahmpReadTable(mpas_noahmp) +!call mpas_log_write('--- isbarren_table = $i',intArgs=(/mpas_noahmp%isbarren_table/)) +!call mpas_log_write('--- isice_table = $i',intArgs=(/mpas_noahmp%isice_table/) ) +!call mpas_log_write('--- iswater_table = $i',intArgs=(/mpas_noahmp%iswater_table/) ) +!call mpas_log_write('--- isurban_table = $i',intArgs=(/mpas_noahmp%isurban_table/) ) +!call mpas_log_write('--- urbtype_beg = $i',intArgs=(/mpas_noahmp%urbtype_beg/) ) +!call mpas_log_write('--- slcats_table = $i',intArgs=(/mpas_noahmp%slcats_table/) ) +!call mpas_log_write(' ') +!do ns = 1,mpas_noahmp%slcats_table +! call mpas_log_write('--- BEXP,SMCMAX,PSISAT: $i $r $r $r',intArgs=(/ns/),realArgs= & +! (/mpas_noahmp%bexp_table(ns),mpas_noahmp%smcmax_table(ns),mpas_noahmp%psisat_table(ns)/)) +!enddo +!call mpas_log_write('--- end subroutine NoahmpReadTable:') + + +!--- initialize noahmp: + call noahmp_init(configs,mesh,diag_physics,diag_physics_noahmp,output_noahmp,sfc_input) + + +!call mpas_log_write('--- end subroutine init_lsm_noahmp:') +!call mpas_log_write(' ') + + end subroutine init_lsm_noahmp + +!================================================================================================================= + subroutine noahmp_read_dimensions(mesh) +!================================================================================================================= + +!--- input arguments: + type(mpas_pool_type),intent(in):: mesh + +!--- local variables and pointers: + integer,pointer:: nCellsSolve,nVertLevels + integer,pointer:: nSoilLevels,nSnowLevels + +!----------------------------------------------------------------------------------------------------------------- +!call mpas_log_write('--- enter subroutine noahmp_read_dimensions:') + + + call mpas_pool_get_dimension(mesh,'nCellsSolve',nCellsSolve) + call mpas_pool_get_dimension(mesh,'nVertLevels',nVertLevels) + call mpas_pool_get_dimension(mesh,'nSoilLevels',nSoilLevels) + call mpas_pool_get_dimension(mesh,'nSnowLevels',nSnowLevels) + + mpas_noahmp%its = 1 + mpas_noahmp%ite = nCellsSolve + mpas_noahmp%kts = 1 + mpas_noahmp%kte = nVertLevels + + mpas_noahmp%nsoil = nSoilLevels + mpas_noahmp%nsnow = nSnowLevels + +!call mpas_log_write(' its = $i ite = $i', intArgs=(/mpas_noahmp%its,mpas_noahmp%ite/)) +!call mpas_log_write(' kts = $i kte = $i', intArgs=(/mpas_noahmp%kts,mpas_noahmp%kte/)) +!call mpas_log_write(' ') +!call mpas_log_write(' nSoilLevels = $i',intArgs=(/mpas_noahmp%nsoil/)) +!call mpas_log_write(' nSnowLevels = $i',intArgs=(/mpas_noahmp%nsnow/)) + + +!call mpas_log_write('--- end subroutine noahmp_read_dimensions:') + + end subroutine noahmp_read_dimensions + +!================================================================================================================= + subroutine noahmp_read_namelist(configs) +!================================================================================================================= + +!--- input arguments: + type(mpas_pool_type),intent(in):: configs + + +!--- local variables and pointers: + integer,pointer:: iopt_dveg , iopt_crs , iopt_btr , iopt_runsrf , iopt_runsub , iopt_sfc , iopt_frz , & + iopt_inf , iopt_rad , iopt_alb , iopt_snf , iopt_tksno , iopt_tbot , iopt_stc , & + iopt_gla , iopt_rsf , iopt_soil , iopt_pedo , iopt_crop , iopt_irr , iopt_irrm , & + iopt_infdv , iopt_tdrn + +!----------------------------------------------------------------------------------------------------------------- +!call mpas_log_write(' ') +!call mpas_log_write('--- enter subroutine noahmp_read_namelist:') + + call mpas_pool_get_config(configs,'config_noahmp_iopt_dveg' ,iopt_dveg ) + call mpas_pool_get_config(configs,'config_noahmp_iopt_crs' ,iopt_crs ) + call mpas_pool_get_config(configs,'config_noahmp_iopt_btr' ,iopt_btr ) + call mpas_pool_get_config(configs,'config_noahmp_iopt_runsrf',iopt_runsrf) + call mpas_pool_get_config(configs,'config_noahmp_iopt_runsub',iopt_runsub) + call mpas_pool_get_config(configs,'config_noahmp_iopt_sfc' ,iopt_sfc ) + call mpas_pool_get_config(configs,'config_noahmp_iopt_frz' ,iopt_frz ) + call mpas_pool_get_config(configs,'config_noahmp_iopt_inf' ,iopt_inf ) + call mpas_pool_get_config(configs,'config_noahmp_iopt_rad' ,iopt_rad ) + call mpas_pool_get_config(configs,'config_noahmp_iopt_alb' ,iopt_alb ) + call mpas_pool_get_config(configs,'config_noahmp_iopt_snf' ,iopt_snf ) + call mpas_pool_get_config(configs,'config_noahmp_iopt_tksno' ,iopt_tksno ) + call mpas_pool_get_config(configs,'config_noahmp_iopt_tbot' ,iopt_tbot ) + call mpas_pool_get_config(configs,'config_noahmp_iopt_stc' ,iopt_stc ) + call mpas_pool_get_config(configs,'config_noahmp_iopt_gla' ,iopt_gla ) + call mpas_pool_get_config(configs,'config_noahmp_iopt_rsf' ,iopt_rsf ) + call mpas_pool_get_config(configs,'config_noahmp_iopt_soil' ,iopt_soil ) + call mpas_pool_get_config(configs,'config_noahmp_iopt_pedo' ,iopt_pedo ) + call mpas_pool_get_config(configs,'config_noahmp_iopt_crop' ,iopt_crop ) + call mpas_pool_get_config(configs,'config_noahmp_iopt_irr' ,iopt_irr ) + call mpas_pool_get_config(configs,'config_noahmp_iopt_irrm' ,iopt_irrm ) + call mpas_pool_get_config(configs,'config_noahmp_iopt_infdv' ,iopt_infdv ) + call mpas_pool_get_config(configs,'config_noahmp_iopt_tdrn' ,iopt_tdrn ) + + mpas_noahmp%iopt_dveg = iopt_dveg + mpas_noahmp%iopt_crs = iopt_crs + mpas_noahmp%iopt_btr = iopt_btr + mpas_noahmp%iopt_runsrf = iopt_runsrf + mpas_noahmp%iopt_runsub = iopt_runsub + mpas_noahmp%iopt_sfc = iopt_sfc + mpas_noahmp%iopt_frz = iopt_frz + mpas_noahmp%iopt_inf = iopt_inf + mpas_noahmp%iopt_rad = iopt_rad + mpas_noahmp%iopt_alb = iopt_alb + mpas_noahmp%iopt_snf = iopt_snf + mpas_noahmp%iopt_tksno = iopt_tksno + mpas_noahmp%iopt_tbot = iopt_tbot + mpas_noahmp%iopt_stc = iopt_stc + mpas_noahmp%iopt_gla = iopt_gla + mpas_noahmp%iopt_rsf = iopt_rsf + mpas_noahmp%iopt_soil = iopt_soil + mpas_noahmp%iopt_pedo = iopt_pedo + mpas_noahmp%iopt_crop = iopt_crop + mpas_noahmp%iopt_irr = iopt_irr + mpas_noahmp%iopt_irrm = iopt_irrm + mpas_noahmp%iopt_infdv = iopt_infdv + mpas_noahmp%iopt_tdrn = iopt_tdrn + +!--- check options that are not available in MPAS: + if(iopt_soil == 4) call physics_error_fatal("NOAHmp: iopt_soil = 4 is not an available option") + if(iopt_crop > 0 ) call physics_error_fatal("NOAHmp: crop model is not an available option. set iopt_crop = 0") + if(iopt_irr > 0 ) call physics_error_fatal("NOAHmp: irrigation is not an available option. set iopt_irr = 0" ) + if(iopt_irrm > 0 ) call physics_error_fatal("NOAHmp: irrigation is not an available option. set iopt_irrm = 0") + if(iopt_tdrn > 0 ) call physics_error_fatal("NOAHmp: drainage is not an available option. set iopt_tdrn = 0" ) + +!call mpas_log_write('--- end subroutine noahmp_read_namelist:') + + end subroutine noahmp_read_namelist + +!================================================================================================================= + subroutine noahmp_init(configs,mesh,diag_physics,diag_physics_noahmp,output_noahmp,sfc_input) +!================================================================================================================= + +!--- input arguments: + type(mpas_pool_type),intent(in):: configs + type(mpas_pool_type),intent(in):: mesh + +!--- inout arguments: + type(mpas_pool_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: diag_physics_noahmp + type(mpas_pool_type),intent(inout):: output_noahmp + type(mpas_pool_type),intent(inout):: sfc_input + +!local pointers: + logical,pointer:: urban_physics + + integer,pointer:: nsoilcomps + integer,dimension(:),pointer:: isltyp,ivgtyp + integer,dimension(:),pointer:: isnowxy + integer,dimension(:),pointer:: irnumsi,irnummi,irnumfi + + real(kind=RKIND),pointer:: dt + + real(kind=RKIND),dimension(:),pointer:: soilcl1,soilcl2,soilcl3,soilcl4 + real(kind=RKIND),dimension(:,:),pointer:: soilcomp + + real(kind=RKIND),dimension(:),pointer:: areaCell,latCell,lonCell + real(kind=RKIND),dimension(:),pointer:: canwat,lai,skintemp,snow,snowc,snowh,tmn,xice,xland + real(kind=RKIND),dimension(:),pointer:: alboldxy,canicexy,canliqxy,chxy,cmxy,eahxy,fastcpxy,fwetxy,gddxy, & + grainxy,lfmassxy,qrainxy,qsnowxy,rtmassxy,sneqvoxy,stblcpxy,stmassxy, & + tahxy,tgxy,tvxy,xsaixy,waxy,woodxy,wslakexy,wtxy,zwtxy + real(kind=RKIND),dimension(:),pointer:: irwatsi,ireloss,irrsplh,irwatmi,irmivol,irwatfi,irfivol + real(kind=RKIND),dimension(:),pointer:: qtdrain,t2mbxy,t2mvxy + + real(kind=RKIND),dimension(:,:),pointer:: dzs,sh2o,smois,tslb + real(kind=RKIND),dimension(:,:),pointer:: snicexy,snliqxy,tsnoxy,zsnsoxy + +!local variables and pointers: + logical,pointer:: do_restart + logical,parameter:: fndsnowh = .true. + integer:: i,its,ite,ns,nsoil,nsnow,nzsnow + +!----------------------------------------------------------------------------------------------------------------- +!call mpas_log_write(' ') +!call mpas_log_write('--- enter subroutine noahmp_init:') + + +!--- initialization of local dimensions: + its = mpas_noahmp%its + ite = mpas_noahmp%ite + nsoil = mpas_noahmp%nsoil + nsnow = mpas_noahmp%nsnow + nzsnow = nsnow + nsoil + + +!--- initialization of Noah-MP run parameters: + call mpas_pool_get_config(configs,'config_do_restart',do_restart) + call mpas_pool_get_config(configs,'config_urban_physics',urban_physics) + call mpas_pool_get_config(configs,'config_dt',dt) + + mpas_noahmp%restart_flag = do_restart + mpas_noahmp%sf_urban_physics = 0 + if(urban_physics) mpas_noahmp%sf_urban_physics = 1 + + mpas_noahmp%fndsnowh = fndsnowh + mpas_noahmp%dtbl = dt + + +!--- initialization of Noah-MP mesh variables: + call mpas_pool_get_dimension(mesh,'nSoilComps',nsoilcomps) + + call mpas_pool_get_array(mesh,'areaCell',areaCell) + call mpas_pool_get_array(mesh,'latCell' ,latCell ) + call mpas_pool_get_array(mesh,'lonCell' ,lonCell ) + call mpas_pool_get_array(mesh,'soilcomp',soilcomp) + call mpas_pool_get_array(mesh,'soilcl1' ,soilcl1 ) + call mpas_pool_get_array(mesh,'soilcl2' ,soilcl2 ) + call mpas_pool_get_array(mesh,'soilcl3' ,soilcl3 ) + call mpas_pool_get_array(mesh,'soilcl4' ,soilcl4 ) + + do i = its,ite + mpas_noahmp%areaxy(i) = areaCell(i) + mpas_noahmp%xlat(i) = latCell(i) + mpas_noahmp%xlong(i) = lonCell(i) + enddo + if(mpas_noahmp%iopt_soil > 1) then + do i = its,ite + mpas_noahmp%soilcl1(i) = soilcl1(i) + mpas_noahmp%soilcl2(i) = soilcl2(i) + mpas_noahmp%soilcl3(i) = soilcl3(i) + mpas_noahmp%soilcl4(i) = soilcl4(i) + do ns = 1,nsoilcomps + mpas_noahmp%soilcomp(i,ns) = soilcomp(ns,i) + enddo + enddo + endif + + +!--- initialization of time-invariant surface variables needed in subroutine NoahmpInitMain: + call mpas_pool_get_array(sfc_input,'dzs' ,dzs ) + call mpas_pool_get_array(sfc_input,'isltyp',isltyp) + call mpas_pool_get_array(sfc_input,'ivgtyp',ivgtyp) + + do i = its, ite + mpas_noahmp%isltyp(i) = isltyp(i) + mpas_noahmp%ivgtyp(i) = ivgtyp(i) + enddo + do ns = 1, nsoil + mpas_noahmp%dzs(ns) = dzs(ns,its) + enddo + + + if(mpas_noahmp%restart_flag) return + +!--- initialization of time-varying variables needed in subroutine NoahmpInitMain: + call mpas_pool_get_array(sfc_input,'skintemp',skintemp) + call mpas_pool_get_array(sfc_input,'snow' ,snow ) + call mpas_pool_get_array(sfc_input,'snowc' ,snowc ) + call mpas_pool_get_array(sfc_input,'snowh' ,snowh ) + call mpas_pool_get_array(sfc_input,'tmn' ,tmn ) + call mpas_pool_get_array(sfc_input,'xice' ,xice ) + call mpas_pool_get_array(sfc_input,'xland' ,xland ) + call mpas_pool_get_array(sfc_input,'sh2o' ,sh2o ) + call mpas_pool_get_array(sfc_input,'smois' ,smois ) + call mpas_pool_get_array(sfc_input,'tslb' ,tslb ) + + call mpas_pool_get_array(diag_physics,'canwat',canwat) + call mpas_pool_get_array(diag_physics,'lai',lai) + + call mpas_pool_get_array(diag_physics_noahmp,'alboldxy',alboldxy) + call mpas_pool_get_array(diag_physics_noahmp,'canicexy',canicexy) + call mpas_pool_get_array(diag_physics_noahmp,'canliqxy',canliqxy) + call mpas_pool_get_array(diag_physics_noahmp,'chxy' ,chxy ) + call mpas_pool_get_array(diag_physics_noahmp,'cmxy' ,cmxy ) + call mpas_pool_get_array(diag_physics_noahmp,'eahxy' ,eahxy ) + call mpas_pool_get_array(diag_physics_noahmp,'fastcpxy',fastcpxy) + call mpas_pool_get_array(diag_physics_noahmp,'fwetxy' ,fwetxy ) + call mpas_pool_get_array(diag_physics_noahmp,'gddxy' ,gddxy ) + call mpas_pool_get_array(diag_physics_noahmp,'grainxy' ,grainxy ) + call mpas_pool_get_array(diag_physics_noahmp,'lfmassxy',lfmassxy) + call mpas_pool_get_array(diag_physics_noahmp,'qrainxy' ,qrainxy ) + call mpas_pool_get_array(diag_physics_noahmp,'qsnowxy' ,qsnowxy ) + call mpas_pool_get_array(diag_physics_noahmp,'rtmassxy',rtmassxy) + call mpas_pool_get_array(diag_physics_noahmp,'sneqvoxy',sneqvoxy) + call mpas_pool_get_array(diag_physics_noahmp,'stblcpxy',stblcpxy) + call mpas_pool_get_array(diag_physics_noahmp,'stmassxy',stmassxy) + call mpas_pool_get_array(diag_physics_noahmp,'tahxy' ,tahxy ) + call mpas_pool_get_array(diag_physics_noahmp,'tgxy' ,tgxy ) + call mpas_pool_get_array(diag_physics_noahmp,'tvxy' ,tvxy ) + call mpas_pool_get_array(diag_physics_noahmp,'waxy' ,waxy ) + call mpas_pool_get_array(diag_physics_noahmp,'woodxy' ,woodxy ) + call mpas_pool_get_array(diag_physics_noahmp,'wslakexy',wslakexy) + call mpas_pool_get_array(diag_physics_noahmp,'wtxy' ,wtxy ) + call mpas_pool_get_array(diag_physics_noahmp,'xsaixy' ,xsaixy ) + call mpas_pool_get_array(diag_physics_noahmp,'zwtxy' ,zwtxy ) + + call mpas_pool_get_array(diag_physics_noahmp,'irnumsi' ,irnumsi ) + call mpas_pool_get_array(diag_physics_noahmp,'irwatsi' ,irwatsi ) + call mpas_pool_get_array(diag_physics_noahmp,'ireloss' ,ireloss ) + call mpas_pool_get_array(diag_physics_noahmp,'irrsplh' ,irrsplh ) + call mpas_pool_get_array(diag_physics_noahmp,'irnummi' ,irnummi ) + call mpas_pool_get_array(diag_physics_noahmp,'irwatmi' ,irwatmi ) + call mpas_pool_get_array(diag_physics_noahmp,'irmivol' ,irmivol ) + call mpas_pool_get_array(diag_physics_noahmp,'irnumfi' ,irnumfi ) + call mpas_pool_get_array(diag_physics_noahmp,'irwatfi' ,irwatfi ) + call mpas_pool_get_array(diag_physics_noahmp,'irfivol', irfivol ) + + call mpas_pool_get_array(diag_physics_noahmp,'isnowxy' ,isnowxy ) + call mpas_pool_get_array(diag_physics_noahmp,'snicexy' ,snicexy ) + call mpas_pool_get_array(diag_physics_noahmp,'snliqxy' ,snliqxy ) + call mpas_pool_get_array(diag_physics_noahmp,'tsnoxy' ,tsnoxy ) + call mpas_pool_get_array(diag_physics_noahmp,'zsnsoxy' ,zsnsoxy ) + + call mpas_pool_get_array(output_noahmp,'t2mbxy',t2mbxy ) + call mpas_pool_get_array(output_noahmp,'t2mvxy',t2mvxy ) + call mpas_pool_get_array(output_noahmp,'qtdrain',qtdrain) + + + do i = its,ite + mpas_noahmp%tmn(i) = tmn(i) + mpas_noahmp%tsk(i) = skintemp(i) + mpas_noahmp%xice(i) = xice(i) + mpas_noahmp%xland(i) = xland(i) + mpas_noahmp%snow(i) = snow(i) + mpas_noahmp%snowh(i) = snowh(i) + + do ns = 1,nsoil + mpas_noahmp%sh2o(i,ns) = sh2o(ns,i) + mpas_noahmp%smois(i,ns) = smois(ns,i) + mpas_noahmp%tslb(i,ns) = tslb(ns,i) + enddo + enddo + + + call NoahmpInitMain(mpas_noahmp) + + +!--- update of all time-varying Noah-MP variables: + do i = its,ite + isnowxy(i) = mpas_noahmp%isnowxy(i) + snow(i) = mpas_noahmp%snow(i) ! in mm (check unit in noahmp driver). + snowh(i) = mpas_noahmp%snowh(i) ! in m (check unit in noahmp driver). + snowc(i) = 0._RKIND + if(snow(i) .gt. 0._RKIND) snowc(i) = 1. + + do ns = 1,nsoil + mpas_noahmp%sh2o(i,ns) = sh2o(ns,i) + mpas_noahmp%smois(i,ns) = smois(ns,i) + mpas_noahmp%tslb(i,ns) = tslb(ns,i) + enddo + enddo + + do ns = 1,nsnow + n = ns - nsnow + do i = its,ite + tsnoxy(ns,i) = mpas_noahmp%tsnoxy(i,n) + snicexy(ns,i) = mpas_noahmp%snicexy(i,n) + snliqxy(ns,i) = mpas_noahmp%snliqxy(i,n) + zsnsoxy(ns,i) = mpas_noahmp%zsnsoxy(i,n) + enddo + enddo + do ns = nsnow+1,nzsnow + n = ns - nsnow + do i = its,ite + zsnsoxy(ns,i) = mpas_noahmp%zsnsoxy(i,n) + enddo + enddo + + do i = its,ite + canwat(i) = mpas_noahmp%canwat(i) + lai(i) = mpas_noahmp%lai(i) + + isnowxy(i) = mpas_noahmp%isnowxy(i) + alboldxy(i) = mpas_noahmp%alboldxy(i) + canicexy(i) = mpas_noahmp%canicexy(i) + canliqxy(i) = mpas_noahmp%canliqxy(i) + chxy(i) = mpas_noahmp%chxy(i) + cmxy(i) = mpas_noahmp%cmxy(i) + eahxy(i) = mpas_noahmp%eahxy(i) + fastcpxy(i) = mpas_noahmp%fastcpxy(i) + fwetxy(i) = mpas_noahmp%fwetxy(i) + gddxy(i) = mpas_noahmp%gddxy(i) + grainxy(i) = mpas_noahmp%grainxy(i) + lfmassxy(i) = mpas_noahmp%lfmassxy(i) + qrainxy(i) = mpas_noahmp%qrainxy(i) + qsnowxy(i) = mpas_noahmp%qsnowxy(i) + rtmassxy(i) = mpas_noahmp%rtmassxy(i) + sneqvoxy(i) = mpas_noahmp%sneqvoxy(i) + stblcpxy(i) = mpas_noahmp%stblcpxy(i) + stmassxy(i) = mpas_noahmp%stmassxy(i) + tahxy(i) = mpas_noahmp%tahxy(i) + tgxy(i) = mpas_noahmp%tgxy(i) + tvxy(i) = mpas_noahmp%tvxy(i) + waxy(i) = mpas_noahmp%waxy(i) + woodxy(i) = mpas_noahmp%woodxy(i) + wslakexy(i) = mpas_noahmp%wslakexy(i) + wtxy(i) = mpas_noahmp%wtxy(i) + xsaixy(i) = mpas_noahmp%xsaixy(i) + zwtxy(i) = mpas_noahmp%zwtxy(i) + + qtdrain(i) = mpas_noahmp%qtdrain(i) + t2mbxy(i) = mpas_noahmp%t2mbxy(i) + t2mvxy(i) = mpas_noahmp%t2mvxy(i) + enddo + + do i = its, ite + irnumsi(i) = mpas_noahmp%irnumsi(i) + irwatsi(i) = mpas_noahmp%irwatsi(i) + ireloss(i) = mpas_noahmp%ireloss(i) + irrsplh(i) = mpas_noahmp%irrsplh(i) + irnummi(i) = mpas_noahmp%irnummi(i) + irwatmi(i) = mpas_noahmp%irwatmi(i) + irmivol(i) = mpas_noahmp%irmivol(i) + irnumfi(i) = mpas_noahmp%irnumfi(i) + irwatfi(i) = mpas_noahmp%irwatfi(i) + irfivol(i) = mpas_noahmp%irfivol(i) + enddo + + +!call mpas_log_write('--- end subroutine noahmp_init:') + + end subroutine noahmp_init + +!================================================================================================================= + end module mpas_atmphys_lsm_noahmpinit +!================================================================================================================= diff --git a/src/core_atmosphere/physics/mpas_atmphys_manager.F b/src/core_atmosphere/physics/mpas_atmphys_manager.F index 1056896f8c..ef0f3dc154 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_manager.F +++ b/src/core_atmosphere/physics/mpas_atmphys_manager.F @@ -23,6 +23,8 @@ module mpas_atmphys_manager public:: physics_timetracker,physics_run_init integer, public:: year !Current year. + integer, public:: month !Current month. + integer, public:: day !Current day of the month. integer, public:: julday !Initial Julian day. real(kind=RKIND), public:: curr_julday !Current Julian day (= 0.0 at 0Z on January 1st). real(kind=RKIND), public:: gmt !Greenwich mean time hour of model start (hr) @@ -183,12 +185,12 @@ subroutine physics_timetracker(domain,dt,clock,itimestep,xtime_s) !call mpas_log_write('--- enter subroutine physics_timetracker: itimestep = $i', intArgs=(/itimestep/)) call mpas_pool_get_config(domain%blocklist%configs,'config_convection_scheme',config_convection_scheme) - call mpas_pool_get_config(domain%blocklist%configs,'config_radt_lw_scheme' ,config_radt_lw_scheme ) - call mpas_pool_get_config(domain%blocklist%configs,'config_radt_sw_scheme' ,config_radt_sw_scheme ) + call mpas_pool_get_config(domain%blocklist%configs,'config_radt_lw_scheme' ,config_radt_lw_scheme ) + call mpas_pool_get_config(domain%blocklist%configs,'config_radt_sw_scheme' ,config_radt_sw_scheme ) - call mpas_pool_get_config(domain%blocklist%configs,'config_conv_interval' ,config_conv_interval ) - call mpas_pool_get_config(domain%blocklist%configs,'config_radtlw_interval' ,config_radtlw_interval ) - call mpas_pool_get_config(domain%blocklist%configs,'config_radtsw_interval' ,config_radtsw_interval ) + call mpas_pool_get_config(domain%blocklist%configs,'config_conv_interval' ,config_conv_interval ) + call mpas_pool_get_config(domain%blocklist%configs,'config_radtlw_interval',config_radtlw_interval) + call mpas_pool_get_config(domain%blocklist%configs,'config_radtsw_interval',config_radtsw_interval) call mpas_pool_get_config(domain%blocklist%configs,'config_frac_seaice' ,config_frac_seaice ) call mpas_pool_get_config(domain%blocklist%configs,'config_o3climatology' ,config_o3climatology ) @@ -200,7 +202,7 @@ subroutine physics_timetracker(domain,dt,clock,itimestep,xtime_s) !update the current julian day and current year: currTime = mpas_get_clock_time(clock,MPAS_NOW,ierr) - call mpas_get_time(curr_time=currTime,dateTimeString=timeStamp,YYYY=yr,H=h,M=m, & + call mpas_get_time(curr_time=currTime,dateTimeString=timeStamp,YYYY=yr,MM=month,DD=day,H=h,M=m, & S=s,S_n=s_n,S_d=s_d,DoY=DoY,ierr=ierr) utc_h = real(h) + real(m) / 60.0 + real(s + s_n / s_d) / 3600.0 @@ -209,13 +211,13 @@ subroutine physics_timetracker(domain,dt,clock,itimestep,xtime_s) julday = DoY curr_julday = real(julday-1) + utc_h / 24.0 LeapYear = isLeapYear(year) -! call mpas_log_write(' YEAR =$i', intArgs=(/year/)) -! call mpas_log_write(' JULDAY =$i', intArgs=(/julday/)) -! call mpas_log_write(' GMT =$r', realArgs=(/gmt/)) -! call mpas_log_write(' UTC_H =$r', realArgs=(/utc_h/)) -! call mpas_log_write(' CURR_JULDAY =$r', realArgs=(/curr_julday/)) -! call mpas_log_write(' LEAP_YEAR =$l', logicArgs=(/LeapYear/)) -! call mpas_log_write(' TIME STAMP ='//trim(timeStamp)) +!call mpas_log_write(' YEAR = $i', intArgs=(/year/)) +!call mpas_log_write(' JULDAY = $i', intArgs=(/julday/)) +!call mpas_log_write(' GMT = $r', realArgs=(/gmt/)) +!call mpas_log_write(' UTC_H = $r', realArgs=(/utc_h/)) +!call mpas_log_write(' CURR_JULDAY = $r', realArgs=(/curr_julday/)) +!call mpas_log_write(' LEAP_YEAR = $l', logicArgs=(/LeapYear/)) +!call mpas_log_write(' TIME STAMP = '//trim(timeStamp)) block => domain % blocklist do while(associated(block)) @@ -266,7 +268,7 @@ subroutine physics_timetracker(domain,dt,clock,itimestep,xtime_s) elseif(config_radtlw_interval == "none") then l_radtlw = .true. endif - call mpas_log_write('--- time to run the LW radiation scheme L_RADLW =$l',logicArgs=(/l_radtlw/)) + call mpas_log_write('--- time to run the LW radiation scheme L_RADLW = $l',logicArgs=(/l_radtlw/)) endif if(trim(config_radt_sw_scheme) /= "off") then @@ -280,7 +282,7 @@ subroutine physics_timetracker(domain,dt,clock,itimestep,xtime_s) elseif(config_radtsw_interval == "none") then l_radtsw = .true. endif - call mpas_log_write('--- time to run the SW radiation scheme L_RADSW =$l',logicArgs=(/l_radtsw/)) + call mpas_log_write('--- time to run the SW radiation scheme L_RADSW = $l',logicArgs=(/l_radtsw/)) endif !check to see if it is time to run the parameterization of convection: @@ -295,7 +297,7 @@ subroutine physics_timetracker(domain,dt,clock,itimestep,xtime_s) elseif(config_conv_interval == "none") then l_conv = .true. endif - call mpas_log_write('--- time to run the convection scheme L_CONV =$l',logicArgs=(/l_conv/)) + call mpas_log_write('--- time to run the convection scheme L_CONV = $l',logicArgs=(/l_conv/)) endif !check to see if it is time to update ozone to the current julian day in the RRTMG radiation codes: @@ -334,7 +336,7 @@ subroutine physics_timetracker(domain,dt,clock,itimestep,xtime_s) call mpas_reset_clock_alarm(clock,camlwAlarmID,camlwTimeStep,ierr=ierr) l_camlw = .true. endif - call mpas_log_write('--- time to write local CAM arrays to MPAS arrays L_CAMLW =$l',logicArgs=(/l_camlw/)) + call mpas_log_write('--- time to write local CAM arrays to MPAS arrays L_CAMLW = $l',logicArgs=(/l_camlw/)) endif !check to see if it is time to apply limit to the accumulated rain due to cloud microphysics @@ -345,7 +347,7 @@ subroutine physics_timetracker(domain,dt,clock,itimestep,xtime_s) call mpas_reset_clock_alarm(clock,acrainAlarmID,acrainTimeStep,ierr=ierr) l_acrain = .true. endif - call mpas_log_write('--- time to apply limit to accumulated rainc and rainnc L_ACRAIN =$l',logicArgs=(/l_acrain/)) + call mpas_log_write('--- time to apply limit to accumulated rainc and rainnc L_ACRAIN = $l',logicArgs=(/l_acrain/)) endif !check to see if it is time to apply limit to the accumulated radiation diagnostics due to @@ -356,7 +358,7 @@ subroutine physics_timetracker(domain,dt,clock,itimestep,xtime_s) call mpas_reset_clock_alarm(clock,acradtAlarmID,acradtTimeStep,ierr=ierr) l_acradt = .true. endif - call mpas_log_write('--- time to apply limit to accumulated radiation diags. L_ACRADT =$l',logicArgs=(/l_acradt/)) + call mpas_log_write('--- time to apply limit to accumulated radiation diags. L_ACRADT = $l',logicArgs=(/l_acradt/)) endif !check to see if it is time to calculate additional physics diagnostics: @@ -368,7 +370,7 @@ subroutine physics_timetracker(domain,dt,clock,itimestep,xtime_s) if (mpas_is_alarm_ringing(clock,diagAlarmID,interval=dtInterval,ierr=ierr)) then l_diags = .true. end if - call mpas_log_write('--- time to calculate additional physics_diagnostics =$l',logicArgs=(/l_diags/)) + call mpas_log_write('--- time to calculate additional physics_diagnostics = $l',logicArgs=(/l_diags/)) end subroutine physics_timetracker @@ -384,18 +386,18 @@ subroutine physics_run_init(configs,mesh,state,clock,stream_manager) type (MPAS_streamManager_type), intent(inout) :: stream_manager !local pointers: - character(len=StrKIND),pointer:: config_convection_scheme, & - config_lsm_scheme, & - config_microp_scheme, & - config_radt_lw_scheme, & + character(len=StrKIND),pointer:: config_convection_scheme, & + config_lsm_scheme, & + config_microp_scheme, & + config_radt_lw_scheme, & config_radt_sw_scheme - character(len=StrKIND),pointer:: config_conv_interval, & - config_pbl_interval, & - config_radtlw_interval, & - config_radtsw_interval, & - config_bucket_update, & - config_camrad_abs_update, & + character(len=StrKIND),pointer:: config_conv_interval, & + config_pbl_interval, & + config_radtlw_interval, & + config_radtsw_interval, & + config_bucket_update, & + config_camrad_abs_update, & config_greeness_update logical,pointer:: config_sst_update @@ -642,10 +644,11 @@ subroutine physics_run_init(configs,mesh,state,clock,stream_manager) end if endif - call mpas_log_write(' DT_RADTLW =$r', realArgs=(/dt_radtlw/)) - call mpas_log_write(' DT_RADTSW =$r', realArgs=(/dt_radtsw/)) - call mpas_log_write(' DT_CU =$r', realArgs=(/dt_cu/)) - call mpas_log_write(' DT_PBL =$r', realArgs=(/dt_pbl/)) + call mpas_log_write(' ') + call mpas_log_write('DT_RADTLW = $r',realArgs=(/dt_radtlw/)) + call mpas_log_write('DT_RADTSW = $r',realArgs=(/dt_radtsw/)) + call mpas_log_write('DT_CU = $r',realArgs=(/dt_cu/)) + call mpas_log_write('DT_PBL = $r',realArgs=(/dt_pbl/)) !initialization of physics dimensions to mimic a rectangular grid: ims=1 ; ime = nCellsSolve @@ -660,15 +663,16 @@ subroutine physics_run_init(configs,mesh,state,clock,stream_manager) jts=jms ; jte = jme kts=kms ; kte = kme-1 - call mpas_log_write(' IMS =$i IME =$i', intArgs=(/ims,ime/)) - call mpas_log_write(' JMS =$i JME =$i', intArgs=(/jms,jme/)) - call mpas_log_write(' KMS =$i KME =$i', intArgs=(/kms,kme/)) - call mpas_log_write(' IDS =$i IDE =$i', intArgs=(/ids,ide/)) - call mpas_log_write(' JDS =$i JDE =$i', intArgs=(/jds,jde/)) - call mpas_log_write(' KDS =$i KDE =$i', intArgs=(/kds,kde/)) - call mpas_log_write(' ITS =$i ITE =$i', intArgs=(/its,ite/)) - call mpas_log_write(' JTS =$i JTE =$i', intArgs=(/jts,jte/)) - call mpas_log_write(' KTS =$i KTE =$i', intArgs=(/kts,kte/)) + call mpas_log_write(' ') + call mpas_log_write('IMS = $i IME = $i',intArgs=(/ims,ime/)) + call mpas_log_write('JMS = $i JME = $i',intArgs=(/jms,jme/)) + call mpas_log_write('KMS = $i KME = $i',intArgs=(/kms,kme/)) + call mpas_log_write('IDS = $i IDE = $i',intArgs=(/ids,ide/)) + call mpas_log_write('JDS = $i JDE = $i',intArgs=(/jds,jde/)) + call mpas_log_write('KDS = $i KDE = $i',intArgs=(/kds,kde/)) + call mpas_log_write('ITS = $i ITE = $i',intArgs=(/its,ite/)) + call mpas_log_write('JTS = $i JTE = $i',intArgs=(/jts,jte/)) + call mpas_log_write('KTS = $i KTE = $i',intArgs=(/kts,kte/)) !initialization local physics variables: num_months = nMonths @@ -682,12 +686,14 @@ subroutine physics_run_init(configs,mesh,state,clock,stream_manager) !... cloud microphysics: dt_microp = dt_dyn n_microp = 1 - if(trim(config_microp_scheme)=='mp_thompson') then + if(trim(config_microp_scheme)=='mp_thompson' .or. & + trim(config_microp_scheme)=='mp_thompson_aerosols') then dt_microp = 90._RKIND n_microp = max(nint(dt_dyn/dt_microp),1) dt_microp = dt_dyn / n_microp if(dt_dyn <= dt_microp) dt_microp = dt_dyn endif + call mpas_log_write(' ') call mpas_log_write('--- specifics on cloud microphysics option microp_scheme = '//trim(config_microp_scheme)) call mpas_log_write('--- dt_microp = $r', realArgs=(/dt_microp/)) call mpas_log_write('--- n_microp = $i', intArgs=(/n_microp/)) @@ -743,7 +749,8 @@ subroutine physics_run_init(configs,mesh,state,clock,stream_manager) has_reqi = 0 has_reqs = 0 if(config_microp_re) then - if(trim(config_microp_scheme)=='mp_thompson' .or. & + if(trim(config_microp_scheme)=='mp_thompson' .or. & + trim(config_microp_scheme)=='mp_thompson_aerosols' .or. & trim(config_microp_scheme)=='mp_wsm6') then if(trim(config_radt_lw_scheme)=='rrtmg_lw' .and. trim(config_radt_sw_scheme)=='rrtmg_sw') then has_reqc = 1 @@ -755,6 +762,7 @@ subroutine physics_run_init(configs,mesh,state,clock,stream_manager) call mpas_log_write('--- has_reqc = $i', intArgs=(/has_reqc/)) call mpas_log_write('--- has_reqi = $i', intArgs=(/has_reqi/)) call mpas_log_write('--- has_reqs = $i', intArgs=(/has_reqs/)) + call mpas_log_write(' ') end subroutine physics_run_init diff --git a/src/core_atmosphere/physics/mpas_atmphys_packages.F b/src/core_atmosphere/physics/mpas_atmphys_packages.F index ebbaabda3d..5d32cb297e 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_packages.F +++ b/src/core_atmosphere/physics/mpas_atmphys_packages.F @@ -36,9 +36,11 @@ function atmphys_setup_packages(configs,packages,iocontext) result(ierr) character(len=StrKIND),pointer:: config_microp_scheme character(len=StrKIND),pointer:: config_convection_scheme character(len=StrKIND),pointer:: config_pbl_scheme - logical,pointer:: mp_kessler_in,mp_thompson_in,mp_wsm6_in + character(len=StrKIND),pointer:: config_lsm_scheme + logical,pointer:: mp_kessler_in,mp_thompson_in,mp_thompson_aers_in,mp_wsm6_in logical,pointer:: cu_grell_freitas_in,cu_kain_fritsch_in,cu_ntiedtke_in logical,pointer:: bl_mynn_in,bl_ysu_in + logical,pointer:: sf_noahmp_in integer :: ierr @@ -61,11 +63,15 @@ function atmphys_setup_packages(configs,packages,iocontext) result(ierr) nullify(mp_thompson_in) call mpas_pool_get_package(packages,'mp_thompson_inActive',mp_thompson_in) + nullify(mp_thompson_aers_in) + call mpas_pool_get_package(packages,'mp_thompson_aers_inActive',mp_thompson_aers_in) + nullify(mp_wsm6_in) call mpas_pool_get_package(packages,'mp_wsm6_inActive',mp_wsm6_in) - if(.not.associated(mp_kessler_in) .or. & - .not.associated(mp_thompson_in) .or. & + if(.not.associated(mp_kessler_in ) .or. & + .not.associated(mp_thompson_in ) .or. & + .not.associated(mp_thompson_aers_in) .or. & .not.associated(mp_wsm6_in)) then call mpas_log_write('====================================================================================',messageType=MPAS_LOG_ERR) call mpas_log_write('* Error while setting up packages for cloud microphysics options in atmosphere core.',messageType=MPAS_LOG_ERR) @@ -74,20 +80,24 @@ function atmphys_setup_packages(configs,packages,iocontext) result(ierr) return endif - mp_kessler_in = .false. - mp_thompson_in = .false. - mp_wsm6_in = .false. + mp_kessler_in = .false. + mp_thompson_in = .false. + mp_thompson_aers_in = .false. + mp_wsm6_in = .false. if(config_microp_scheme == 'mp_kessler') then mp_kessler_in = .true. elseif(config_microp_scheme == 'mp_thompson') then mp_thompson_in = .true. + elseif(config_microp_scheme == 'mp_thompson_aerosols') then + mp_thompson_aers_in = .true. elseif(config_microp_scheme == 'mp_wsm6') then mp_wsm6_in = .true. endif call mpas_log_write(' mp_kessler_in = $l', logicArgs=(/mp_kessler_in/)) call mpas_log_write(' mp_thompson_in = $l', logicArgs=(/mp_thompson_in/)) + call mpas_log_write(' mp_thompson_aers_in = $l', logicArgs=(/mp_thompson_aers_in/)) call mpas_log_write(' mp_wsm6_in = $l', logicArgs=(/mp_wsm6_in/)) !--- initialization of all packages for parameterizations of convection: @@ -162,6 +172,29 @@ function atmphys_setup_packages(configs,packages,iocontext) result(ierr) call mpas_log_write(' bl_ysu_in = $l', logicArgs=(/bl_ysu_in/)) call mpas_log_write('') +!--- initialization of all packages for parameterizations of land surface processes: + + call mpas_pool_get_config(configs,'config_lsm_scheme',config_lsm_scheme) + + nullify(sf_noahmp_in) + call mpas_pool_get_package(packages,'sf_noahmp_inActive',sf_noahmp_in) + + if(.not.associated(sf_noahmp_in)) then + call mpas_log_write('====================================================================================',messageType=MPAS_LOG_ERR) + call mpas_log_write('* Error while setting up packages for land surface options in atmosphere core.' , messageType=MPAS_LOG_ERR) + call mpas_log_write('====================================================================================',messageType=MPAS_LOG_ERR) + ierr = 1 + return + endif + + if(config_lsm_scheme=='sf_noahmp') then + sf_noahmp_in = .true. + endif + + call mpas_log_write(' sf_noahmp_in = $l', logicArgs=(/sf_noahmp_in/)) + call mpas_log_write('') + + end function atmphys_setup_packages !================================================================================================================= diff --git a/src/core_atmosphere/physics/mpas_atmphys_todynamics.F b/src/core_atmosphere/physics/mpas_atmphys_todynamics.F index f8a04066c4..81100225a0 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_todynamics.F +++ b/src/core_atmosphere/physics/mpas_atmphys_todynamics.F @@ -10,6 +10,7 @@ module mpas_atmphys_todynamics use mpas_kind_types use mpas_pool_routines use mpas_dmpar + use mpas_atm_dimensions use mpas_atmphys_constants, only: R_d,R_v,degrad @@ -21,37 +22,29 @@ module mpas_atmphys_todynamics !Interface between the physics parameterizations and the non-hydrostatic dynamical core. !Laura D. Fowler (send comments to laura@ucar.edu). !2013-05-01. -! -! + + ! subroutines in mpas_atmphys_todynamics: ! --------------------------------------- -! physics_get_tend: add and mass-weigh tendencies before being added to dynamics tendencies. -! tend_toEdges : interpolate wind-tendencies from centers to edges of grid-cells. +! physics_get_tend : intermediate subroutine between the dynamical core and calculation of the total +! physics tendencies. +! physics_get_tend_work: add and mass-weigh physics tendencies before being added to dynamics tendencies. +! tend_toEdges : interpolate wind-tendencies from centers to edges of grid-cells. ! ! add-ons and modifications to sourcecode: ! ---------------------------------------- -! * added calculation of the advective tendency of the potential temperature due to horizontal -! and vertical advection, and horizontal mixing (diffusion). -! Laura D. Fowler (birch.mmm.ucar.edu) / 2013-11-19. -! * throughout the sourcecode, replaced all "var_struct" defined arrays by local pointers. -! Laura D. Fowler (laura@ucar.edu) / 2014-04-22. -! * modified sourcecode to use pools. -! Laura D. Fowler (laura@ucar.edu) / 2014-05-15. -! * renamed config_conv_deep_scheme to config_convection_scheme. -! Laura D. Fowler (laura@ucar.edu) / 2014-09-18. -! * renamed "tiedtke" with "cu_tiedtke". -! Laura D. Fowler (laura@ucar.edu) / 2016-03-22. -! * modified the sourcecode to accomodate the packages "cu_kain_fritsch_in" and "cu_ntiedtke_in". -! Laura D. Fowler (laura@ucar.edu) / 2016-03-24. -! * added the option bl_mynn for the calculation of the tendency for the cloud ice number concentration. -! Laura D. Fowler (laura@ucar.edu) / 2016-04-11. -! * in subroutine physics_get_tend_work, added the option cu_ntiedtke in the calculation of rucuten_Edge. -! Laura D. Fowler (laura@ucar.edu) / 2016-10-28. - - ! - ! Abstract interface for routine used to communicate halos of fields - ! in a named group - ! +! * cleaned-up subroutines physics_get_tend and physics_get_tend_work. +! Laura D. Fowler (laura@ucar.edu) / 2018-01-23. +! * removed the option bl_mynn_wrf390. +! Laura D. Fowler (laura@ucar.edu) / 2018-01-24. +! * added tendencies of cloud liquid water number concentration, and water-friendly and ice-friendly aerosol +! number concentrations due to PBL processes. +! Laura D. Fowler (laura@ucar.edu) / 2024-05-16. + +! +! Abstract interface for routine used to communicate halos of fields +! in a named group +! abstract interface subroutine halo_exchange_routine(domain, halo_group, ierr) @@ -69,379 +62,376 @@ end subroutine halo_exchange_routine !================================================================================================================= - subroutine physics_get_tend( block, mesh, state, diag, tend, tend_physics, configs, rk_step, dynamics_substep, & - tend_ru_physics, tend_rtheta_physics, tend_rho_physics, exchange_halo_group ) + subroutine physics_get_tend(block,mesh,state,diag,tend,tend_physics,configs,rk_step,dynamics_substep, & + tend_ru_physics,tend_rtheta_physics,tend_rho_physics,exchange_halo_group) !================================================================================================================= - - use mpas_atm_dimensions !input variables: type(block_type),intent(in),target:: block type(mpas_pool_type),intent(in):: mesh type(mpas_pool_type),intent(in):: state type(mpas_pool_type),intent(in):: configs - integer, intent(in):: rk_step - integer, intent(in):: dynamics_substep - procedure (halo_exchange_routine) :: exchange_halo_group + integer,intent(in):: rk_step + integer,intent(in):: dynamics_substep + procedure(halo_exchange_routine):: exchange_halo_group !inout variables: type(mpas_pool_type),intent(inout):: diag type(mpas_pool_type),intent(inout):: tend type(mpas_pool_type),intent(inout):: tend_physics - real(kind=RKIND),dimension(:,:) :: tend_ru_physics, tend_rtheta_physics, tend_rho_physics + real(kind=RKIND),intent(inout),dimension(:,:):: tend_ru_physics,tend_rtheta_physics,tend_rho_physics !local variables: - character(len=StrKIND), pointer :: config_pbl_scheme, config_convection_scheme, & - config_radt_lw_scheme, config_radt_sw_scheme + character(len=StrKIND),pointer:: pbl_scheme, & + convection_scheme, & + microp_scheme, & + radt_lw_scheme, & + radt_sw_scheme integer:: i,iCell,k,n - integer,pointer:: index_qv, index_qc, index_qr, index_qi, index_qs, index_qg - integer,pointer:: index_ni + integer,pointer:: index_qv,index_qc,index_qr,index_qi,index_qs + integer,pointer:: index_nc,index_ni,index_nifa,index_nwfa integer,pointer:: nCells,nCellsSolve,nEdges,nEdgesSolve real(kind=RKIND),dimension(:,:),pointer:: mass ! time level 2 rho_zz real(kind=RKIND),dimension(:,:),pointer:: mass_edge ! diag rho_edge real(kind=RKIND),dimension(:,:),pointer:: theta_m ! time level 1 real(kind=RKIND),dimension(:,:,:),pointer:: scalars + real(kind=RKIND),dimension(:,:),pointer:: rthblten,rqvblten,rqcblten, & rqiblten,rqsblten,rublten,rvblten - real(kind=RKIND),dimension(:,:),pointer:: rniblten + real(kind=RKIND),dimension(:,:),pointer:: rncblten,rniblten,rnifablten,rnwfablten real(kind=RKIND),dimension(:,:),pointer:: rthcuten,rqvcuten,rqccuten, & rqrcuten,rqicuten,rqscuten, & rucuten,rvcuten real(kind=RKIND),dimension(:,:),pointer:: rthratenlw,rthratensw real(kind=RKIND),dimension(:,:),pointer:: tend_u_phys !nick - real(kind=RKIND),dimension(:,:),pointer :: tend_theta,tend_theta_euler,tend_u real(kind=RKIND),dimension(:,:,:),pointer:: tend_scalars - real(kind=RKIND):: coeff - real(kind=RKIND):: tem real(kind=RKIND),dimension(:,:),pointer:: rublten_Edge,rucuten_Edge - real(kind=RKIND),dimension(:,:),allocatable:: theta,tend_th - + real(kind=RKIND),dimension(:,:),allocatable:: tend_th !================================================================================================================= - call mpas_pool_get_dimension(mesh, 'nCells', nCells) - call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) - call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) - call mpas_pool_get_dimension(mesh, 'nEdgesSolve', nEdgesSolve) - - call mpas_pool_get_config(configs, 'config_pbl_scheme', config_pbl_scheme) - call mpas_pool_get_config(configs, 'config_convection_scheme', config_convection_scheme) - call mpas_pool_get_config(configs, 'config_radt_lw_scheme', config_radt_lw_scheme) - call mpas_pool_get_config(configs, 'config_radt_sw_scheme', config_radt_sw_scheme) - - call mpas_pool_get_array(state, 'theta_m', theta_m, 1) - call mpas_pool_get_array(state, 'scalars', scalars, 1) - call mpas_pool_get_array(state, 'rho_zz', mass, 2) - call mpas_pool_get_array(diag , 'rho_edge', mass_edge) - - call mpas_pool_get_array(diag , 'tend_u_phys', tend_u_phys) !nick - - call mpas_pool_get_dimension(state, 'index_qv', index_qv) - call mpas_pool_get_dimension(state, 'index_qc', index_qc) - call mpas_pool_get_dimension(state, 'index_qr', index_qr) - call mpas_pool_get_dimension(state, 'index_qi', index_qi) - call mpas_pool_get_dimension(state, 'index_qs', index_qs) - call mpas_pool_get_dimension(state, 'index_qg', index_qg) - call mpas_pool_get_dimension(state, 'index_ni', index_ni) - - call mpas_pool_get_array(tend_physics, 'rublten', rublten) - call mpas_pool_get_array(tend_physics, 'rvblten', rvblten) - call mpas_pool_get_array(tend_physics, 'rublten_Edge', rublten_Edge) - call mpas_pool_get_array(tend_physics, 'rthblten', rthblten) - call mpas_pool_get_array(tend_physics, 'rqvblten', rqvblten) - call mpas_pool_get_array(tend_physics, 'rqcblten', rqcblten) - call mpas_pool_get_array(tend_physics, 'rqiblten', rqiblten) - call mpas_pool_get_array(tend_physics, 'rqsblten', rqsblten) - call mpas_pool_get_array(tend_physics, 'rniblten', rniblten) - - call mpas_pool_get_array(tend_physics, 'rucuten', rucuten) - call mpas_pool_get_array(tend_physics, 'rvcuten', rvcuten) - call mpas_pool_get_array(tend_physics, 'rucuten_Edge', rucuten_Edge) - call mpas_pool_get_array(tend_physics, 'rthcuten', rthcuten) - call mpas_pool_get_array(tend_physics, 'rqvcuten', rqvcuten) - call mpas_pool_get_array(tend_physics, 'rqccuten', rqccuten) - call mpas_pool_get_array(tend_physics, 'rqrcuten', rqrcuten) - call mpas_pool_get_array(tend_physics, 'rqicuten', rqicuten) - call mpas_pool_get_array(tend_physics, 'rqscuten', rqscuten) - - call mpas_pool_get_array(tend_physics, 'rthratenlw', rthratenlw) - call mpas_pool_get_array(tend_physics, 'rthratensw', rthratensw) - - call mpas_pool_get_array(tend,'u' , tend_u ) - call mpas_pool_get_array(tend,'theta_m' , tend_theta ) - call mpas_pool_get_array(tend,'theta_euler' ,tend_theta_euler) - call mpas_pool_get_array(tend,'scalars_tend',tend_scalars ) + + call mpas_pool_get_dimension(mesh,'nCells',nCells) + call mpas_pool_get_dimension(mesh,'nEdges',nEdges) + call mpas_pool_get_dimension(mesh,'nCellsSolve',nCellsSolve) + call mpas_pool_get_dimension(mesh,'nEdgesSolve',nEdgesSolve) + + call mpas_pool_get_config(configs,'config_convection_scheme',convection_scheme) + call mpas_pool_get_config(configs,'config_microp_scheme' ,microp_scheme ) + call mpas_pool_get_config(configs,'config_pbl_scheme' ,pbl_scheme ) + call mpas_pool_get_config(configs,'config_radt_lw_scheme' ,radt_lw_scheme ) + call mpas_pool_get_config(configs,'config_radt_sw_scheme' ,radt_sw_scheme ) + + call mpas_pool_get_array(state,'theta_m' ,theta_m,1) + call mpas_pool_get_array(state,'scalars' ,scalars,1) + call mpas_pool_get_array(state,'rho_zz' ,mass,2 ) + call mpas_pool_get_array(diag ,'rho_edge',mass_edge) + call mpas_pool_get_array(diag ,'tend_u_phys',tend_u_phys) + + call mpas_pool_get_dimension(state,'index_qv',index_qv) + call mpas_pool_get_dimension(state,'index_qc',index_qc) + call mpas_pool_get_dimension(state,'index_qr',index_qr) + call mpas_pool_get_dimension(state,'index_qi',index_qi) + call mpas_pool_get_dimension(state,'index_qs',index_qs) + call mpas_pool_get_dimension(state,'index_nc',index_nc) + call mpas_pool_get_dimension(state,'index_ni',index_ni) + call mpas_pool_get_dimension(state,'index_nifa',index_nifa) + call mpas_pool_get_dimension(state,'index_nwfa',index_nwfa) + + call mpas_pool_get_array(tend_physics,'rublten',rublten) + call mpas_pool_get_array(tend_physics,'rvblten',rvblten) + call mpas_pool_get_array(tend_physics,'rthblten',rthblten) + call mpas_pool_get_array(tend_physics,'rqvblten',rqvblten) + call mpas_pool_get_array(tend_physics,'rqcblten',rqcblten) + call mpas_pool_get_array(tend_physics,'rqiblten',rqiblten) + call mpas_pool_get_array(tend_physics,'rqsblten',rqsblten) + call mpas_pool_get_array(tend_physics,'rncblten',rncblten) + call mpas_pool_get_array(tend_physics,'rniblten',rniblten) + call mpas_pool_get_array(tend_physics,'rnifablten',rnifablten) + call mpas_pool_get_array(tend_physics,'rnwfablten',rnwfablten) + call mpas_pool_get_array(tend_physics,'rublten_Edge',rublten_Edge) + + call mpas_pool_get_array(tend_physics,'rucuten',rucuten) + call mpas_pool_get_array(tend_physics,'rvcuten',rvcuten) + call mpas_pool_get_array(tend_physics,'rthcuten',rthcuten) + call mpas_pool_get_array(tend_physics,'rqvcuten',rqvcuten) + call mpas_pool_get_array(tend_physics,'rqccuten',rqccuten) + call mpas_pool_get_array(tend_physics,'rqrcuten',rqrcuten) + call mpas_pool_get_array(tend_physics,'rqicuten',rqicuten) + call mpas_pool_get_array(tend_physics,'rqscuten',rqscuten) + call mpas_pool_get_array(tend_physics,'rucuten_Edge',rucuten_Edge) + + call mpas_pool_get_array(tend_physics,'rthratenlw',rthratenlw) + call mpas_pool_get_array(tend_physics,'rthratensw',rthratensw) + + call mpas_pool_get_array(tend,'scalars_tend',tend_scalars) + !initialize the tendency for the potential temperature and all scalars due to PBL, convection, !and longwave and shortwave radiation: -! allocate(theta(nVertLevels,nCellsSolve) ) allocate(tend_th(nVertLevels,nCellsSolve)) tend_th = 0._RKIND - tend_scalars(:,:,:) = 0._RKIND - - tend_ru_physics(:,:) = 0._RKIND + tend_scalars(:,:,:) = 0._RKIND + tend_ru_physics(:,:) = 0._RKIND tend_rtheta_physics(:,:) = 0._RKIND - tend_rho_physics(:,:) = 0._RKIND ! NB: rho tendency is not currently supplied by physics, but this - ! field may be later filled with IAU or other tendencies - - ! - ! In case some variables are not allocated due to their associated packages, - ! we need to make their pointers associated here to avoid triggering run-time - ! checks when calling physics_get_tend_work - ! - if (.not. associated(rublten)) allocate(rublten(0,0) ) - if (.not. associated(rvblten)) allocate(rvblten(0,0) ) - if (.not. associated(rthblten)) allocate(rthblten(0,0)) - if (.not. associated(rqvblten)) allocate(rqvblten(0,0)) - if (.not. associated(rqcblten)) allocate(rqcblten(0,0)) - if (.not. associated(rqiblten)) allocate(rqiblten(0,0)) - if (.not. associated(rqsblten)) allocate(rqsblten(0,0)) - if (.not. associated(rniblten)) allocate(rniblten(0,0)) - if (.not. associated(rucuten)) allocate(rucuten(0,0) ) - if (.not. associated(rvcuten)) allocate(rvcuten(0,0) ) - if (.not. associated(rthcuten)) allocate(rthcuten(0,0)) - if (.not. associated(rqvcuten)) allocate(rqvcuten(0,0)) - if (.not. associated(rqccuten)) allocate(rqccuten(0,0)) - if (.not. associated(rqicuten)) allocate(rqicuten(0,0)) - if (.not. associated(rqrcuten)) allocate(rqrcuten(0,0)) - if (.not. associated(rqscuten)) allocate(rqscuten(0,0)) - - call physics_get_tend_work(block, mesh, nCells, nEdges, nCellsSolve, nEdgesSolve, & - rk_step, dynamics_substep, & - config_pbl_scheme, config_convection_scheme, config_radt_lw_scheme, config_radt_sw_scheme, & - index_qv, index_qc, index_qr, index_qi, index_qs, index_ni, & - rublten, rvblten, mass_edge, rublten_Edge, & - tend_ru_physics, & - rucuten, rvcuten, rucuten_Edge, & - tend_th, tend_scalars, mass, rthblten, rqvblten, rqcblten, rqiblten, rqsblten, rniblten, & - rthcuten, rqvcuten, rqccuten, rqrcuten, rqicuten, rqscuten, & - rthratenlw, rthratensw, & - tend_u_phys, & - theta_m, scalars, & - tend_rtheta_physics, & - tend_theta_euler, & - exchange_halo_group & - ) - - ! - ! Clean up any pointers that were allocated with zero size before the call to - ! physics_get_tend_work - ! - if (size(rublten) == 0) deallocate(rublten ) - if (size(rvblten) == 0) deallocate(rvblten ) - if (size(rthblten) == 0) deallocate(rthblten) - if (size(rqvblten) == 0) deallocate(rqvblten) - if (size(rqcblten) == 0) deallocate(rqcblten) - if (size(rqiblten) == 0) deallocate(rqiblten) - if (size(rqsblten) == 0) deallocate(rqsblten) - if (size(rniblten) == 0) deallocate(rniblten) - if (size(rucuten) == 0) deallocate(rucuten ) - if (size(rvcuten) == 0) deallocate(rvcuten ) - if (size(rthcuten) == 0) deallocate(rthcuten) - if (size(rqvcuten) == 0) deallocate(rqvcuten) - if (size(rqccuten) == 0) deallocate(rqccuten) - if (size(rqicuten) == 0) deallocate(rqicuten) - if (size(rqrcuten) == 0) deallocate(rqrcuten) - if (size(rqscuten) == 0) deallocate(rqscuten) - -! deallocate(theta) - deallocate(tend_th) + tend_rho_physics(:,:) = 0._RKIND + + +!in case some variables are not allocated due to their associated packages. We need to make their pointers +!associated here to avoid triggering run-time. checks when calling physics_get_tend_work: + if(.not. associated(rucuten) ) allocate(rucuten(0,0) ) + if(.not. associated(rvcuten) ) allocate(rvcuten(0,0) ) + if(.not. associated(rthcuten)) allocate(rthcuten(0,0)) + if(.not. associated(rqvcuten)) allocate(rqvcuten(0,0)) + if(.not. associated(rqccuten)) allocate(rqccuten(0,0)) + if(.not. associated(rqicuten)) allocate(rqicuten(0,0)) + if(.not. associated(rqrcuten)) allocate(rqrcuten(0,0)) + if(.not. associated(rqscuten)) allocate(rqscuten(0,0)) + + if(.not. associated(rublten) ) allocate(rublten(0,0) ) + if(.not. associated(rvblten) ) allocate(rvblten(0,0) ) + if(.not. associated(rthblten)) allocate(rthblten(0,0)) + if(.not. associated(rqvblten)) allocate(rqvblten(0,0)) + if(.not. associated(rqcblten)) allocate(rqcblten(0,0)) + if(.not. associated(rqiblten)) allocate(rqiblten(0,0)) + if(.not. associated(rqsblten)) allocate(rqsblten(0,0)) + if(.not. associated(rncblten)) allocate(rncblten(0,0)) + if(.not. associated(rniblten)) allocate(rniblten(0,0)) + if(.not. associated(rnifablten)) allocate(rnifablten(0,0)) + if(.not. associated(rnwfablten)) allocate(rnwfablten(0,0)) + + call physics_get_tend_work( & + block,mesh,nCells,nEdges,nCellsSolve,nEdgesSolve,rk_step,dynamics_substep, & + pbl_scheme,convection_scheme,microp_scheme,radt_lw_scheme,radt_sw_scheme, & + index_qv,index_qc,index_qr,index_qi,index_qs, & + index_nc,index_ni,index_nifa,index_nwfa, & + mass,mass_edge,theta_m,scalars, & + rublten,rvblten,rthblten,rqvblten,rqcblten,rqiblten,rqsblten, & + rncblten,rniblten,rnifablten,rnwfablten, & + rucuten,rvcuten,rthcuten,rqvcuten,rqccuten,rqrcuten,rqicuten,rqscuten, & + rthratenlw,rthratensw,rublten_Edge,rucuten_Edge, & + tend_th,tend_rtheta_physics,tend_scalars,tend_ru_physics,tend_u_phys, & + exchange_halo_group) + +!clean up any pointers that were allocated with zero size before the call to physics_get_tend_work: + if(size(rucuten) == 0 ) deallocate(rucuten ) + if(size(rvcuten) == 0 ) deallocate(rvcuten ) + if(size(rthcuten) == 0) deallocate(rthcuten) + if(size(rqvcuten) == 0) deallocate(rqvcuten) + if(size(rqccuten) == 0) deallocate(rqccuten) + if(size(rqicuten) == 0) deallocate(rqicuten) + if(size(rqrcuten) == 0) deallocate(rqrcuten) + if(size(rqscuten) == 0) deallocate(rqscuten) + + if(size(rublten) == 0 ) deallocate(rublten ) + if(size(rvblten) == 0 ) deallocate(rvblten ) + if(size(rthblten) == 0) deallocate(rthblten) + if(size(rqvblten) == 0) deallocate(rqvblten) + if(size(rqcblten) == 0) deallocate(rqcblten) + if(size(rqiblten) == 0) deallocate(rqiblten) + if(size(rqsblten) == 0) deallocate(rqsblten) + if(size(rncblten) == 0) deallocate(rncblten) + if(size(rniblten) == 0) deallocate(rniblten) + if(size(rnifablten) == 0) deallocate(rnifablten) + if(size(rnwfablten) == 0) deallocate(rnwfablten) -! if(rk_step .eq. 3) then -! call mpas_log_write('') -! call mpas_log_write('--- enter subroutine physics_get_tend:') -! call mpas_log_write('max rthblten = $r',realArgs=(/maxval(rthblten(:,1:nCellsSolve))/)) -! call mpas_log_write('min rthblten = $r',realArgs=(/minval(rthblten(:,1:nCellsSolve))/)) -! call mpas_log_write('max rthcuten = $r',realArgs=(/maxval(rthcuten(:,1:nCellsSolve))/)) -! call mpas_log_write('min rthcuten = $r',realArgs=(/minval(rthcuten(:,1:nCellsSolve))/)) -! call mpas_log_write('max rthratenlw = $r',realArgs=(/maxval(rthratenlw(:,1:nCellsSolve))/)) -! call mpas_log_write('min rthratenlw = $r',realArgs=(/minval(rthratenlw(:,1:nCellsSolve))/)) -! call mpas_log_write('max rthratensw = $r',realArgs=(/maxval(rthratensw(:,1:nCellsSolve))/)) -! call mpas_log_write('min rthratensw = $r',realArgs=(/minval(rthratensw(:,1:nCellsSolve))/)) -! call mpas_log_write('--- end subroutine physics_get_tend') -! call mpas_log_write('') -! endif + deallocate(tend_th) end subroutine physics_get_tend - !================================================================================================== - subroutine physics_get_tend_work(block, mesh, nCells, nEdges, nCellsSolve, nEdgesSolve, & - rk_step, dynamics_substep, & - config_pbl_scheme, config_convection_scheme, config_radt_lw_scheme, config_radt_sw_scheme, & - index_qv, index_qc, index_qr, index_qi, index_qs, index_ni, & - rublten, rvblten, mass_edge, rublten_Edge, tend_u, & - rucuten, rvcuten, rucuten_Edge, & - tend_th, tend_scalars, mass, rthblten, rqvblten, rqcblten, rqiblten, rqsblten, rniblten, & - rthcuten, rqvcuten, rqccuten, rqrcuten, rqicuten, rqscuten, & - rthratenlw, rthratensw, & - tend_u_phys, & - theta_m, scalars, tend_theta, tend_theta_euler, & - exchange_halo_group & - ) -!================================================================================================== - - use mpas_atm_dimensions - - implicit none - - type(block_type), intent(in) :: block - type(mpas_pool_type), intent(in) :: mesh - integer, intent(in) :: nCells, nEdges, nCellsSolve, nEdgesSolve - integer, intent(in) :: rk_step, dynamics_substep - character(len=StrKIND), intent(in) :: config_pbl_scheme - character(len=StrKIND), intent(in) :: config_convection_scheme - character(len=StrKIND), intent(in) :: config_radt_lw_scheme - character(len=StrKIND), intent(in) :: config_radt_sw_scheme - integer, intent(in) :: index_qv, index_qc, index_qr, index_qi, index_qs, index_ni - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rublten - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rvblten - real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: mass_edge - real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(inout) :: rublten_Edge - real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(inout) :: tend_u - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rucuten - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rvcuten - real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(inout) :: rucuten_Edge - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout) :: tend_th - real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1), intent(inout) :: tend_scalars - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: mass - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rthblten - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rqvblten - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rqcblten - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rqiblten - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rqsblten - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rniblten - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rthcuten - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rqvcuten - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rqccuten - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rqrcuten - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rqicuten - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rqscuten - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rthratenlw - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rthratensw - real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(inout) :: tend_u_phys - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: theta_m - real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1), intent(in) :: scalars - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout) :: tend_theta - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: tend_theta_euler - procedure (halo_exchange_routine) :: exchange_halo_group - - integer :: i, k - real (kind=RKIND) :: coeff - - !add coupled tendencies due to PBL processes: - if (config_pbl_scheme .ne. 'off') then - if (rk_step == 1 .and. dynamics_substep == 1) then - call exchange_halo_group(block % domain, 'physics:blten') - call tend_toEdges(block,mesh,rublten,rvblten,rublten_Edge) - - !MGD for PV budget? should a similar line be in the cumulus section below? - tend_u_phys(1:nVertLevels,1:nEdges) = rublten_Edge(1:nVertLevels,1:nEdges) - end if - - do i = 1, nEdgesSolve - do k = 1, nVertLevels - tend_u(k,i)=tend_u(k,i)+rublten_Edge(k,i)*mass_edge(k,i) - enddo - enddo - - do i = 1, nCellsSolve - do k = 1, nVertLevels - tend_th(k,i) = tend_th(k,i) + rthblten(k,i)*mass(k,i) - tend_scalars(index_qv,k,i) = tend_scalars(index_qv,k,i) + rqvblten(k,i)*mass(k,i) - tend_scalars(index_qc,k,i) = tend_scalars(index_qc,k,i) + rqcblten(k,i)*mass(k,i) - tend_scalars(index_qi,k,i) = tend_scalars(index_qi,k,i) + rqiblten(k,i)*mass(k,i) - enddo - enddo - - pbl_select: select case (trim(config_pbl_scheme)) - - case("bl_mynn") - - do i = 1, nCellsSolve - do k = 1, nVertLevels - tend_scalars(index_qs,k,i) = tend_scalars(index_qs,k,i) + rqsblten(k,i)*mass(k,i) - tend_scalars(index_ni,k,i) = tend_scalars(index_ni,k,i) + rniblten(k,i)*mass(k,i) - enddo - enddo - - case default - - end select pbl_select - endif - - !add coupled tendencies due to convection: - if (config_convection_scheme .ne. 'off') then - - do i = 1, nCellsSolve - do k = 1, nVertLevels - tend_th(k,i) = tend_th(k,i) + rthcuten(k,i)*mass(k,i) - tend_scalars(index_qv,k,i) = tend_scalars(index_qv,k,i) + rqvcuten(k,i)*mass(k,i) - tend_scalars(index_qc,k,i) = tend_scalars(index_qc,k,i) + rqccuten(k,i)*mass(k,i) - tend_scalars(index_qi,k,i) = tend_scalars(index_qi,k,i) + rqicuten(k,i)*mass(k,i) - enddo - enddo - - convection_select: select case(config_convection_scheme) - - case('cu_kain_fritsch') - do i = 1, nCellsSolve - do k = 1, nVertLevels - tend_scalars(index_qr,k,i) = tend_scalars(index_qr,k,i) + rqrcuten(k,i)*mass(k,i) - tend_scalars(index_qs,k,i) = tend_scalars(index_qs,k,i) + rqscuten(k,i)*mass(k,i) - enddo - enddo - - case('cu_tiedtke','cu_ntiedtke') - if (rk_step == 1 .and. dynamics_substep == 1) then - call exchange_halo_group(block % domain, 'physics:cuten') - call tend_toEdges(block,mesh,rucuten,rvcuten,rucuten_Edge) - - tend_u_phys(1:nVertLevels,1:nEdges) = tend_u_phys(1:nVertLevels,1:nEdges) & - + rucuten_Edge(1:nVertLevels,1:nEdges) - end if - do i = 1, nEdgesSolve - do k = 1, nVertLevels - tend_u(k,i)=tend_u(k,i)+rucuten_Edge(k,i)*mass_edge(k,i) - enddo - enddo - - case default - end select convection_select - endif - - !add coupled tendencies due to longwave radiation: - if (config_radt_lw_scheme .ne. 'off') then - do i = 1, nCellsSolve - do k = 1, nVertLevels - tend_th(k,i) = tend_th(k,i) + rthratenlw(k,i)*mass(k,i) - enddo - enddo - endif - - !add coupled tendencies due to shortwave radiation: - if (config_radt_sw_scheme .ne. 'off') then - do i = 1, nCellsSolve - do k = 1, nVertLevels - tend_th(k,i) = tend_th(k,i) + rthratensw(k,i)*mass(k,i) - enddo - enddo - endif - - !if non-hydrostatic core, convert the tendency for the potential temperature to a - !tendency for the modified potential temperature: +!================================================================================================================= + subroutine physics_get_tend_work( & + block,mesh,nCells,nEdges,nCellsSolve,nEdgesSolve,rk_step,dynamics_substep, & + pbl_scheme,convection_scheme,microp_scheme,radt_lw_scheme,radt_sw_scheme, & + index_qv,index_qc,index_qr,index_qi,index_qs, & + index_nc,index_ni,index_nifa,index_nwfa, & + mass,mass_edge,theta_m,scalars, & + rublten,rvblten,rthblten,rqvblten,rqcblten,rqiblten,rqsblten, & + rncblten,rniblten,rnifablten,rnwfablten, & + rucuten,rvcuten,rthcuten,rqvcuten,rqccuten,rqrcuten,rqicuten,rqscuten, & + rthratenlw,rthratensw,rublten_Edge,rucuten_Edge, & + tend_th,tend_theta,tend_scalars,tend_u,tend_u_phys, & + exchange_halo_group) +!================================================================================================================= + +!input arguments: + procedure(halo_exchange_routine):: exchange_halo_group + + type(block_type),intent(in) :: block + type(mpas_pool_type),intent(in):: mesh + + character(len=StrKIND),intent(in):: convection_scheme + character(len=StrKIND),intent(in):: microp_scheme + character(len=StrKIND),intent(in):: pbl_scheme + character(len=StrKIND),intent(in):: radt_lw_scheme + character(len=StrKIND),intent(in):: radt_sw_scheme + + integer,intent(in):: nCells,nEdges,nCellsSolve,nEdgesSolve + integer,intent(in):: rk_step,dynamics_substep + integer,intent(in):: index_qv,index_qc,index_qr,index_qi,index_qs + integer,intent(in):: index_nc,index_ni,index_nifa,index_nwfa + + real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: mass + real(kind=RKIND),intent(in),dimension(nVertLevels,nEdges+1):: mass_edge + real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: theta_m + real(kind=RKIND),intent(in),dimension(num_scalars,nVertLevels,nCells+1):: scalars + + real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: rublten + real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: rvblten + real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: rthblten + real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: rqvblten + real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: rqcblten + real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: rqiblten + real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: rqsblten + real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: rncblten + real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: rniblten + real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: rnifablten + real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: rnwfablten + + real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: rucuten + real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: rvcuten + real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: rthcuten + real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: rqvcuten + real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: rqccuten + real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: rqrcuten + real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: rqicuten + real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: rqscuten + + real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: rthratenlw + real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: rthratensw + +!inout arguments: + real(kind=RKIND),intent(inout),dimension(nVertLevels,nEdges+1):: rublten_Edge + real(kind=RKIND),intent(inout),dimension(nVertLevels,nEdges+1):: rucuten_Edge + real(kind=RKIND),intent(inout),dimension(nVertLevels,nEdges+1):: tend_u + real(kind=RKIND),intent(inout),dimension(nVertLevels,nEdges+1):: tend_u_phys + + real(kind=RKIND),intent(inout),dimension(nVertLevels,nCells+1):: tend_th + real(kind=RKIND),intent(inout),dimension(nVertLevels,nCells+1):: tend_theta + + real(kind=RKIND),intent(inout),dimension(num_scalars,nVertLevels,nCells+1):: tend_scalars + +!local variables: + integer:: i,k + real(kind=RKIND):: coeff + +!----------------------------------------------------------------------------------------------------------------- + +!add coupled tendencies due to PBL processes: + if(pbl_scheme .ne. 'off') then + if(rk_step == 1 .and. dynamics_substep == 1) then + call exchange_halo_group(block%domain,'physics:blten') + call tend_toEdges(block,mesh,rublten,rvblten,rublten_Edge) + + tend_u_phys(1:nVertLevels,1:nEdges) = rublten_Edge(1:nVertLevels,1:nEdges) + end if + + do i = 1, nEdgesSolve + do k = 1, nVertLevels + tend_u(k,i)=tend_u(k,i)+rublten_Edge(k,i)*mass_edge(k,i) + enddo + enddo + + do i = 1, nCellsSolve + do k = 1, nVertLevels + tend_th(k,i) = tend_th(k,i) + rthblten(k,i)*mass(k,i) + tend_scalars(index_qv,k,i) = tend_scalars(index_qv,k,i) + rqvblten(k,i)*mass(k,i) + tend_scalars(index_qc,k,i) = tend_scalars(index_qc,k,i) + rqcblten(k,i)*mass(k,i) + tend_scalars(index_qi,k,i) = tend_scalars(index_qi,k,i) + rqiblten(k,i)*mass(k,i) + enddo + enddo + + pbl_select: select case(trim(pbl_scheme)) + case('bl_mynn') + do i = 1, nCellsSolve + do k = 1, nVertLevels + tend_scalars(index_qs,k,i) = tend_scalars(index_qs,k,i) + rqsblten(k,i)*mass(k,i) + tend_scalars(index_nc,k,i) = tend_scalars(index_nc,k,i) + rncblten(k,i)*mass(k,i) + tend_scalars(index_ni,k,i) = tend_scalars(index_ni,k,i) + rniblten(k,i)*mass(k,i) + tend_scalars(index_nifa,k,i) = tend_scalars(index_nifa,k,i) + rnifablten(k,i)*mass(k,i) + tend_scalars(index_nwfa,k,i) = tend_scalars(index_nwfa,k,i) + rnwfablten(k,i)*mass(k,i) + enddo + enddo + + case default + end select pbl_select + endif + + +!add coupled tendencies due to convection: + if(convection_scheme .ne. 'off') then + do i = 1, nCellsSolve + do k = 1, nVertLevels + tend_th(k,i) = tend_th(k,i) + rthcuten(k,i)*mass(k,i) + tend_scalars(index_qv,k,i) = tend_scalars(index_qv,k,i) + rqvcuten(k,i)*mass(k,i) + tend_scalars(index_qc,k,i) = tend_scalars(index_qc,k,i) + rqccuten(k,i)*mass(k,i) + tend_scalars(index_qi,k,i) = tend_scalars(index_qi,k,i) + rqicuten(k,i)*mass(k,i) + enddo + enddo + + cu_select: select case(trim(convection_scheme)) + case('cu_kain_fritsch') + do i = 1, nCellsSolve + do k = 1, nVertLevels + tend_scalars(index_qr,k,i) = tend_scalars(index_qr,k,i) + rqrcuten(k,i)*mass(k,i) + tend_scalars(index_qs,k,i) = tend_scalars(index_qs,k,i) + rqscuten(k,i)*mass(k,i) + enddo + enddo + + case('cu_tiedtke','cu_ntiedtke') + if(rk_step == 1 .and. dynamics_substep == 1) then + call exchange_halo_group(block%domain,'physics:cuten') + call tend_toEdges(block,mesh,rucuten,rvcuten,rucuten_Edge) + + tend_u_phys(1:nVertLevels,1:nEdges) = tend_u_phys(1:nVertLevels,1:nEdges) & + + rucuten_Edge(1:nVertLevels,1:nEdges) + endif + do i = 1, nEdgesSolve + do k = 1, nVertLevels + tend_u(k,i)=tend_u(k,i)+rucuten_Edge(k,i)*mass_edge(k,i) + enddo + enddo + + case default + end select cu_select + endif + + +!add coupled tendencies due to longwave radiation: + if(radt_lw_scheme .ne. 'off') then + do i = 1, nCellsSolve + do k = 1, nVertLevels + tend_th(k,i) = tend_th(k,i) + rthratenlw(k,i)*mass(k,i) + enddo + enddo + endif + + +!add coupled tendencies due to shortwave radiation: + if(radt_sw_scheme .ne. 'off') then do i = 1, nCellsSolve do k = 1, nVertLevels - coeff = (1. + R_v/R_d * scalars(index_qv,k,i)) - tend_th(k,i) = coeff * tend_th(k,i) + R_v/R_d * theta_m(k,i) * tend_scalars(index_qv,k,i) / coeff - tend_theta(k,i) = tend_theta(k,i) + tend_th(k,i) + tend_th(k,i) = tend_th(k,i) + rthratensw(k,i)*mass(k,i) enddo enddo + endif + + +!convert the tendency for the potential temperature to tendency for the modified potential temperature: + do i = 1, nCellsSolve + do k = 1, nVertLevels + coeff = (1. + R_v/R_d * scalars(index_qv,k,i)) + tend_th(k,i) = coeff * tend_th(k,i) + R_v/R_d * theta_m(k,i) * tend_scalars(index_qv,k,i) / coeff + tend_theta(k,i) = tend_theta(k,i) + tend_th(k,i) + enddo + enddo + end subroutine physics_get_tend_work @@ -465,20 +455,19 @@ subroutine tend_toEdges(block,mesh,Ux_tend,Uy_tend,U_tend) integer,pointer:: nCells,nCellsSolve,nEdges integer,dimension(:,:),pointer:: cellsOnEdge - real(kind=RKIND), dimension(:,:), pointer :: east, north, edgeNormalVectors - + real(kind=RKIND),dimension(:,:),pointer:: east,north,edgeNormalVectors !----------------------------------------------------------------------------------------------------------------- - call mpas_pool_get_dimension(mesh, 'nCells', nCells) - call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) - call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) + call mpas_pool_get_dimension(mesh,'nCells',nCells) + call mpas_pool_get_dimension(mesh,'nCellsSolve',nCellsSolve) + call mpas_pool_get_dimension(mesh,'nEdges',nEdges) - call mpas_pool_get_array(mesh, 'east', east) - call mpas_pool_get_array(mesh, 'north', north) - call mpas_pool_get_array(mesh, 'edgeNormalVectors', edgeNormalVectors) + call mpas_pool_get_array(mesh,'east',east) + call mpas_pool_get_array(mesh,'north',north) + call mpas_pool_get_array(mesh,'edgeNormalVectors',edgeNormalVectors) - call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(mesh,'cellsOnEdge',cellsOnEdge) do iEdge = 1, nEdges cell1 = cellsOnEdge(1,iEdge) @@ -487,14 +476,14 @@ subroutine tend_toEdges(block,mesh,Ux_tend,Uy_tend,U_tend) U_tend(:,iEdge) = Ux_tend(:,cell1) * 0.5 * (edgeNormalVectors(1,iEdge) * east(1,cell1) & + edgeNormalVectors(2,iEdge) * east(2,cell1) & + edgeNormalVectors(3,iEdge) * east(3,cell1)) & - + Uy_tend(:,cell1) * 0.5 * (edgeNormalVectors(1,iEdge) * north(1,cell1) & - + edgeNormalVectors(2,iEdge) * north(2,cell1) & - + edgeNormalVectors(3,iEdge) * north(3,cell1)) & + + Uy_tend(:,cell1) * 0.5 * (edgeNormalVectors(1,iEdge) * north(1,cell1) & + + edgeNormalVectors(2,iEdge) * north(2,cell1) & + + edgeNormalVectors(3,iEdge) * north(3,cell1)) & + Ux_tend(:,cell2) * 0.5 * (edgeNormalVectors(1,iEdge) * east(1,cell2) & + edgeNormalVectors(2,iEdge) * east(2,cell2) & + edgeNormalVectors(3,iEdge) * east(3,cell2)) & - + Uy_tend(:,cell2) * 0.5 * (edgeNormalVectors(1,iEdge) * north(1,cell2) & - + edgeNormalVectors(2,iEdge) * north(2,cell2) & + + Uy_tend(:,cell2) * 0.5 * (edgeNormalVectors(1,iEdge) * north(1,cell2) & + + edgeNormalVectors(2,iEdge) * north(2,cell2) & + edgeNormalVectors(3,iEdge) * north(3,cell2)) end do diff --git a/src/core_atmosphere/physics/mpas_atmphys_vars.F b/src/core_atmosphere/physics/mpas_atmphys_vars.F index 159bef2fca..5485f8fef8 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_vars.F +++ b/src/core_atmosphere/physics/mpas_atmphys_vars.F @@ -8,6 +8,8 @@ !================================================================================================================= module mpas_atmphys_vars use mpas_kind_types + + use NoahmpIOVarType implicit none public @@ -204,6 +206,7 @@ module mpas_atmphys_vars qg_p !graupel mixing ratio [kg/kg] real(kind=RKIND),dimension(:,:,:),allocatable:: & + nc_p, &!cloud water droplet number concentration [#/kg] ni_p, &!cloud ice crystal number concentration [#/kg] nr_p !rain drop number concentration [#/kg] @@ -247,7 +250,7 @@ module mpas_atmphys_vars f_qc, &!parameter set to true to include the cloud water mixing ratio. f_qr, &!parameter set to true to include the rain mixing ratio. f_qi, &!parameter set to true to include the cloud ice mixing ratio. - f_qs, &!parameter set to true to include the snow minxg ratio. + f_qs, &!parameter set to true to include the snow mixing ratio. f_qg, &!parameter set to true to include the graupel mixing ratio. f_qoz !parameter set to true to include the ozone mixing ratio. @@ -271,15 +274,11 @@ module mpas_atmphys_vars graupelncv_p, &! sr_p -!... added for the thompson and wsm6 cloud microphysics: integer:: & has_reqc, &! has_reqi, &! has_reqs - real(kind=RKIND),dimension(:,:),allocatable:: & - ntc_p, &! - muc_p ! real(kind=RKIND),dimension(:,:,:),allocatable:: & rainprod_p, &! evapprod_p, &! @@ -288,6 +287,17 @@ module mpas_atmphys_vars resnow_p, &! refl10cm_p ! +!... for Thompson cloud microphysics parameterization, including aerosol-aware option: + real(kind=RKIND),dimension(:,:),allocatable:: & + ntc_p, &! + muc_p, &! + nifa2d_p, &!surface emission of "ice-friendly" aerosols [#/kg-1/s] + nwfa2d_p !surface emission of "water-friendly" aerosols [#/kg-1/s] + + real(kind=RKIND),dimension(:,:,:),allocatable:: & + nifa_p, &!"ice-friendly" number concentration [#/kg] + nwfa_p !"water-friendly" number concentration [#/kg] + !================================================================================================================= !... variables and arrays related to parameterization of convection: !================================================================================================================= @@ -443,7 +453,10 @@ module mpas_atmphys_vars real(kind=RKIND),dimension(:,:,:),allocatable:: & rqsblten_p, &!tendency of snow mixing ratio due to PBL processes. - rniblten_p !tendency of cloud ice number concentration due to PBL processes. + rncblten_p, &!tendency of cloud liquid water number concentration due to PBL processes. + rniblten_p, &!tendency of cloud ice number concentration due to PBL processes. + rnifablten_p, &!tendency of ice-friendly aerosol number concentration due to PBL processes. + rnwfablten_p !tendency of water-friendly aerosol number concentration due to PBL processes. real(kind=RKIND),dimension(:,:,:),allocatable:: & pattern_spp_pbl !stochastic forcing for the MYMM PBL and surface layer schemes. @@ -587,6 +600,35 @@ module mpas_atmphys_vars snowsi_p, &!snow depth over seaice [m] icedepth_p !seaice thickness [m] +!================================================================================================================= +!... variables and arrays related to the calculation of the optical properties of aerosols: to date, the only kind +! of aerosols included in MPAS are the "water-friendly" and "ice-friendly" aerosols used in the Thompson cloud +! cloud microphysics scheme. +!================================================================================================================= + + integer,parameter:: taer_aod550_opt = 2!input option for nwfa, nifa optical depth at 500 nm. + integer,parameter:: taer_angexp_opt = 3!input option for nwfa, nifa aerosol Angstrom exponent. + integer,parameter:: taer_ssa_opt = 3!input option for nwfa, nifa aerosol single-scattering albedo. + integer,parameter:: taer_asy_opt = 3!input option for nwfa, nifa aerosol asymmetry factor. + + integer:: aer_opt !=[0,3] : 0 for no aerosols, 3 for "water-" and "ice-friendly" aerosols. + integer,dimension(:,:),allocatable:: & + taer_type_p !=[1,2,3]: 1 for rural, 2 is urban and 3 is maritime in WRF. In MPAS, + !aer_type is initialized as a function of landmask (=1 over land; =2 over + !oceans. + + real(kind=RKIND),parameter:: aer_aod550_val = 0.12 + real(kind=RKIND),parameter:: aer_angexp_val = 1.3 + real(kind=RKIND),parameter:: aer_ssa_val = 0.85 + real(kind=RKIND),parameter:: aer_asy_val = 0.9 + + real(kind=RKIND),dimension(:,:),allocatable :: taod5502d_p!total aerosol optical depth at 550 nm [-] + real(kind=RKIND),dimension(:,:,:),allocatable:: taod5503d_p!aerosol optical depth at 550 nm [-] + + real(kind=RKIND),dimension(:,:,:,:),allocatable:: tauaer_p !aerosol optical depth in RRTMG SW [-] + real(kind=RKIND),dimension(:,:,:,:),allocatable:: ssaaer_p !aerosol single scatterin albedo in RRTMG SW [-] + real(kind=RKIND),dimension(:,:,:,:),allocatable:: asyaer_p !aerosol asymmetry factor in RRTMG SW [-] + !================================================================================================================= !... variables and arrays related to parameterization of short-wave radiation: !================================================================================================================= @@ -800,6 +842,12 @@ module mpas_atmphys_vars frc_urb_p, &!urban fraction [-] ust_urb_p !urban u* in similarity theory [m/s] +!================================================================================================================= +!.. variables and arrays related to the Noahmp land-surface parameterization: +!================================================================================================================= + + type(NoahmpIO_type):: mpas_noahmp + !================================================================================================================= !.. variables and arrays related to surface characteristics: !================================================================================================================= diff --git a/src/core_atmosphere/physics/physics_mmm/Makefile b/src/core_atmosphere/physics/physics_mmm/Makefile deleted file mode 100644 index f02fb955a2..0000000000 --- a/src/core_atmosphere/physics/physics_mmm/Makefile +++ /dev/null @@ -1,54 +0,0 @@ -.SUFFIXES: .F .o - -all: dummy physics_mmm - -dummy: - echo "****** compiling physics_mmm ******" - -OBJS = \ - bl_gwdo.o \ - bl_mynn.o \ - bl_mynn_subroutines.o \ - bl_ysu.o \ - cu_ntiedtke.o \ - mp_radar.o \ - mp_wsm6_effectRad.o \ - mp_wsm6.o \ - mynn_shared.o \ - sf_mynn.o \ - sf_sfclayrev.o \ - module_libmassv.o - -physics_mmm: $(OBJS) - ar -ru ./../libphys.a $(OBJS) - -# DEPENDENCIES: -bl_mynn.o: \ - bl_mynn_subroutines.o - -bl_mynn_subroutines.o: \ - mynn_shared.o - -mp_wsm6_effectRad.o: \ - mp_wsm6.o - -mp_wsm6.o: \ - mp_radar.o \ - module_libmassv.o - -sf_mynn.o: \ - mynn_shared.o - -clean: - $(RM) *.f90 *.o *.mod - @# Certain systems with intel compilers generate *.i files - @# This removes them during the clean process - $(RM) *.i - -.F.o: -ifeq "$(GEN_F90)" "true" - $(CPP) $(CPPFLAGS) $(COREDEF) $(CPPINCLUDES) $< > $*.f90 - $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I.. -I../../../framework -I../../../external/esmf_time_f90 -else - $(FC) $(CPPFLAGS) $(COREDEF) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I.. -I../../../framework -I../../../external/esmf_time_f90 -endif diff --git a/src/core_atmosphere/physics/physics_mmm/bl_gwdo.F b/src/core_atmosphere/physics/physics_mmm/bl_gwdo.F deleted file mode 100644 index dfb337091c..0000000000 --- a/src/core_atmosphere/physics/physics_mmm/bl_gwdo.F +++ /dev/null @@ -1,659 +0,0 @@ -module bl_gwdo -use ccpp_kinds,only: kind_phys -!=============================================================================== - IMPLICIT NONE - PRIVATE - PUBLIC :: bl_gwdo_run - PUBLIC :: bl_gwdo_init - PUBLIC :: bl_gwdo_final - PUBLIC :: bl_gwdo_timestep_init - PUBLIC :: bl_gwdo_timestep_final - -contains -!------------------------------------------------------------------------------- -!------------------------------------------------------------------------------- - 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 -! -!------------------------------------------------------------------------------- - use ccpp_kinds, only: kind_phys - 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:ite) , intent(in ) :: dxmeter - real(kind=kind_phys), dimension(its:ite,kts:kte) , intent(inout) :: rublten, rvblten - real(kind=kind_phys), dimension(its:ite,kts:kte) , intent( out) :: dtaux3d, dtauy3d - real(kind=kind_phys), dimension(its:ite) , intent( out) :: dusfcg, dvsfcg - real(kind=kind_phys), dimension(its:ite) , intent(in ) :: sina, cosa - real(kind=kind_phys), dimension(its:ite,kts:kte) , intent(in ) :: uproj, vproj - real(kind=kind_phys), dimension(its:ite,kts:kte) , intent(in ) :: t1, q1, prslk, zl -! - real(kind=kind_phys), dimension(its:ite,kts:kte) , intent(in ) :: prsl - real(kind=kind_phys), dimension(its:ite,kts:kme) , intent(in ) :: prsi -! - real(kind=kind_phys), dimension(its:ite) , 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 - -!------------------------------------------------------------------------------- - subroutine bl_gwdo_init (errmsg, errflg) - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! This routine currently does nothing - - errmsg = '' - errflg = 0 - - end subroutine bl_gwdo_init - -!------------------------------------------------------------------------------- - subroutine bl_gwdo_final (errmsg, errflg) - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! This routine currently does nothing - - errmsg = '' - errflg = 0 - - end subroutine bl_gwdo_final - -!------------------------------------------------------------------------------- - subroutine bl_gwdo_timestep_init (errmsg, errflg) - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! This routine currently does nothing - - errmsg = '' - errflg = 0 - - end subroutine bl_gwdo_timestep_init - -!------------------------------------------------------------------------------- - subroutine bl_gwdo_timestep_final (errmsg, errflg) - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! This routine currently does nothing - - errmsg = '' - errflg = 0 - - end subroutine bl_gwdo_timestep_final - -!------------------------------------------------------------------------------- -end module bl_gwdo diff --git a/src/core_atmosphere/physics/physics_mmm/bl_mynn.F b/src/core_atmosphere/physics/physics_mmm/bl_mynn.F deleted file mode 100644 index b41b2c538b..0000000000 --- a/src/core_atmosphere/physics/physics_mmm/bl_mynn.F +++ /dev/null @@ -1,1244 +0,0 @@ -!================================================================================================================= - module bl_mynn - use mpas_kind_types,only: kind_phys => RKIND - - use bl_mynn_common,only: & - cp , cpv , cliq , cice , ep_1 , ep_2 , ep_3 , grav , karman , p1000mb , & - r_d , r_v , svp1 , svp2 , svp3 , svpt0 , xlf , xls , xlv , p608 , & - t0c , tref , tkmin , tv0 , gtr , xlvcp , xlscp , rvovrd , rcp , cphh_st , & - cphm_st , cphh_unst , cphm_unst , b1 , b2 , zero - use bl_mynn_subroutines - - - implicit none - private - public:: bl_mynn_init, & - bl_mynn_finalize, & - bl_mynn_run - - - contains - - -!================================================================================================================= - subroutine bl_mynn_init(con_cp,con_cpv,con_cice,con_cliq,con_ep1,con_ep2,con_grav,con_karman,con_p0, & - con_rd,con_rv,con_svp1,con_svp2,con_svp3,con_svpt0,con_xlf,con_xls,con_xlv, & - errmsg,errflg) -!================================================================================================================= - -!-- input arguments: - real(kind=kind_phys),intent(in):: & - con_cp, & - con_cpv, & - con_cice, & - con_cliq - - real(kind=kind_phys),intent(in):: & - con_ep1, & - con_ep2 - - real(kind=kind_phys),intent(in):: & - con_grav - - real(kind=kind_phys),intent(in):: & - con_karman - - real(kind=kind_phys),intent(in):: & - con_p0 - - real(kind=kind_phys),intent(in):: & - con_rd, & - con_rv - - real(kind=kind_phys),intent(in):: & - con_svp1, & - con_svp2, & - con_svp3, & - con_svpt0 - - real(kind=kind_phys),intent(in):: & - con_xlf, & - con_xls, & - con_xlv - - character(len=*),intent(out):: errmsg - integer,intent(out):: errflg - -!----------------------------------------------------------------------------------------------------------------- - -!--- initialization of physics constants needed in the MYNN PBL scheme and already available from MPAS: - cp = con_cp - cpv = con_cpv - cliq = con_cliq - cice = con_cice - ep_1 = con_ep1 - ep_2 = con_ep2 - grav = con_grav - karman = con_karman - p1000mb = con_p0 - r_d = con_rd - r_v = con_rv - rvovrd = r_v/r_d - svp1 = con_svp1 - svp2 = con_svp2 - svp3 = con_svp3 - svpt0 = con_svpt0 - xlf = con_xlf - xls = con_xls - xlv = con_xlv - -!--- initialization of derived physics constants needed in the MYNN PBL scheme: - ep_3 = 1.-ep_2 - gtr = grav/tref - p608 = ep_1 - rcp = r_d/cp - t0c = svpt0 - tv0 = p608*tref - xlscp = (xlv+xlf)/cp - xlvcp = xlv/cp - -!ev = xlv -!rk = cp/r_d -!svp11 = svp1*1.e3 -!tv1 = (1.+p608)*tref -!vk = karman - - errmsg = " " - errflg = 0 - - end subroutine bl_mynn_init - -!================================================================================================================= - subroutine bl_mynn_finalize(errmsg,errflg) -!================================================================================================================= - - character(len=*),intent(out):: errmsg - integer,intent(out):: errflg - -!----------------------------------------------------------------------------------------------------------------- -!note: this subroutine currently does nothing. - - errmsg = ' ' - errflg = 0 - - end subroutine bl_mynn_finalize - -!================================================================================================================= - subroutine bl_mynn_run & - (initflag , restart , cycling , & - delt , dz , dx , & - znt , u , v , & - w , th , sqv , & - sqc , sqi , sqs , & - qnc , qni , qnwfa , & - qnifa , qnbca , qozone , & - p , exner , rho , & - tt , xland , ts , & - qsfc , ps , ust , & - ch , hfx , qfx , & - rmol , wspd , uoce , & - voce , qke , qke_adv , & - tsq , qsq , cov , & - rublten , rvblten , rthblten , & - rqvblten , rqcblten , rqiblten , & - rqsblten , rqncblten , rqniblten , & - rqnwfablten , rqnifablten , rqnbcablten , & - rqozblten , exch_h , exch_m , & - pblh , kpbl , el_pbl , & - dqke , qwt , qshear , & - qbuoy , qdiss , sh , & - sm , qc_bl , qi_bl , & - cldfra_bl , icloud_bl , bl_mynn_tkeadvect , & - bl_mynn_tkebudget , bl_mynn_cloudpdf , bl_mynn_mixlength , & - bl_mynn_closure , bl_mynn_stfunc , bl_mynn_topdown , & - bl_mynn_edmf , bl_mynn_edmf_dd , bl_mynn_edmf_mom , & - bl_mynn_edmf_tke , bl_mynn_mixscalars , bl_mynn_output , & - bl_mynn_cloudmix , bl_mynn_mixqt , bl_mynn_scaleaware , & - bl_mynn_dheatopt , edmf_a , edmf_w , & - edmf_qt , edmf_thl , edmf_ent , & - edmf_qc , sub_thl , sub_sqv , & - det_thl , det_sqv , edmf_a_dd , & - edmf_w_dd , edmf_qt_dd , edmf_thl_dd , & - edmf_ent_dd , edmf_qc_dd , maxwidth , & - maxmf , ztop_plume , ktop_plume , & - spp_pbl , pattern_spp_pbl , rthraten , & - flag_qc , flag_qi , flag_qs , & - flag_qnc , flag_qni , flag_qnwfa , & - flag_qnifa , flag_qnbca , flag_qoz , & -#if(WRF_CHEM == 1) - mix_chem , nchem , kdvel , & - ndvel , chem , emis_ant_no , & - frp , vdep , & -#endif - its, ite , kts , kte , kme , errmsg , errflg & - ) - -!================================================================================================================= - -!input arguments: - logical,intent(in):: & - flag_qc,flag_qi,flag_qs,flag_qoz,flag_qnc,flag_qni,flag_qnifa,flag_qnwfa,flag_qnbca - - logical,intent(in):: bl_mynn_edmf,bl_mynn_edmf_dd,bl_mynn_edmf_mom,bl_mynn_edmf_tke - logical,intent(in):: bl_mynn_mixscalars,bl_mynn_cloudmix,bl_mynn_mixqt - logical,intent(in):: bl_mynn_tkeadvect,bl_mynn_tkebudget - logical,intent(in):: bl_mynn_output,bl_mynn_dheatopt,bl_mynn_scaleaware,bl_mynn_topdown - - logical,intent(in):: & - restart,cycling - - integer,intent(in):: its,ite,kts,kte,kme - - integer,intent(in):: & - initflag,icloud_bl,spp_pbl - - integer,intent(in):: & - bl_mynn_cloudpdf,bl_mynn_mixlength,bl_mynn_stfunc - - real(kind=kind_phys),intent(in):: & - bl_mynn_closure - - real(kind=kind_phys),intent(in):: & - delt - - real(kind=kind_phys),intent(in),dimension(its:ite):: & - dx, &! - xland, &! - ps, &! - ts, &! - qsfc, &! - ust, &! - ch, &! - hfx, &! - qfx, &! - rmol, &! - wspd, &! - uoce, &! - voce, &! - znt ! - - real(kind=kind_phys),intent(in),dimension(its:ite,kts:kte):: & - dz, &! - u, &! - v, &! - th, &! - tt, &! - p, &! - exner, &! - rho, &! - rthraten ! - - real(kind=kind_phys),intent(in),dimension(its:ite,kts:kte):: & - sqv, &! - sqc, &! - sqi, &! - sqs, &! - qnc, &! - qni, &! - qnifa, &! - qnwfa, &! - qnbca, &! - qozone ! - - real(kind=kind_phys),intent(in),dimension(its:ite,kts:kte):: & - pattern_spp_pbl - - real(kind=kind_phys),intent(in),dimension(its:ite,kts:kme):: & - w ! - -!inout arguments: - integer,intent(inout),dimension(its:ite):: & - kpbl, &! - ktop_plume ! - - real(kind=kind_phys),intent(inout),dimension(its:ite):: & - pblh - - real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte):: & - cldfra_bl, &! - qc_bl, &! - qi_bl ! - - real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte):: & - el_pbl, &! - qke, &! - qke_adv, &! - cov, &! - qsq, &! - tsq, &! - sh, &! - sm ! - - real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte):: & - rublten, &! - rvblten, &! - rthblten, &! - rqvblten, &! - rqcblten, &! - rqiblten, &! - rqsblten, &! - rqncblten, &! - rqniblten, &! - rqnifablten, &! - rqnwfablten, &! - rqnbcablten, &! - rqozblten ! - - real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte):: & - edmf_a, &! - edmf_w, &! - edmf_qt, &! - edmf_thl, &! - edmf_ent, &! - edmf_qc, &! - sub_thl, &! - sub_sqv, &! - det_thl, &! - det_sqv ! - - real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte),optional:: & - edmf_a_dd, &! - edmf_w_dd, &! - edmf_qt_dd, &! - edmf_thl_dd, &! - edmf_ent_dd, &! - edmf_qc_dd - - -!output arguments: - character(len=*),intent(out):: & - errmsg ! output error message (-). - - integer,intent(out):: & - errflg ! output error flag (-). - - real(kind=kind_phys),intent(out),dimension(its:ite):: & - maxwidth, &! - maxmf, &! - ztop_plume - - real(kind=kind_phys),intent(out),dimension(its:ite,kts:kte):: & - exch_h, &! - exch_m ! - - real(kind=kind_phys),intent(out),dimension(its:ite,kts:kte),optional:: & - dqke, &! - qwt, &! - qshear, &! - qbuoy, &! - qdiss ! - - -!local variable and arrays: - logical:: initialize_qke - - integer:: i,k - - real(kind=kind_phys):: qc_bl2,qi_bl2 - real(kind=kind_phys):: cpm,exnerg,flq,flqc,flqv,flt,fltv,phh,pmz,psig_bl,psig_shcu,sqcg,phi_m, & - th_sfc,zet,ts_decay - - real(kind=kind_phys),dimension(kts:kte):: cldfra_bl1_old,qc_bl1_old,qi_bl1_old - real(kind=kind_phys),dimension(kts:kte):: qv1,qc1,qi1,qs1 - real(kind=kind_phys),dimension(kts:kte):: det_sqc,det_u,det_v,sub_u,sub_v - - real(kind=kind_phys),dimension(kts:kte):: pdc,pdk,pdq,pdt,sgm,sqw,thetav,thl,vq,vt,kzero - - real(kind=kind_phys),dimension(kts:kte):: dfh,dfm,dfq,qcd,tcd,diss_heat - - real(kind=kind_phys),dimension(kts:kte):: rstoch_col - - real(kind=kind_phys),dimension(kts:kte+1):: zw - - real(kind=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=kind_phys),dimension(kts:kte+1):: & - sd_aw1,sd_awthl1,sd_awqt1,sd_awqv1,sd_awqc1,sd_awu1,sd_awv1,sd_awqke1 - -!JOE-top-down diffusion - logical :: cloudflg - integer :: kk,kminrad - - real(kind=kind_phys),parameter:: pfac =2.0, zfmin = 0.01, phifac=8.0 - real(kind=kind_phys):: maxkhtopdown - real(kind=kind_phys):: bfxpbl,dthvx,tmp1,temps,templ,zl1,wstar3_2 - real(kind=kind_phys):: ent_eff,radsum,radflux,we,rcldb,rvls,minrad,zminrad - real(kind=kind_phys),dimension(kts:kte):: khtopdown,zfac,wscalek2,zfacent,tkeprodtd -!JOE-end top down - - -!local 1D input arguments: - real(kind=kind_phys):: dx1,xland1,ps1,ts1,qsfc1,ust1,ch1,hfx1,qfx1,rmol1,wspd1, & - uoce1,voce1,znt1 - real(kind=kind_phys),dimension(kts:kte):: & - dz1,u1,v1,th1,tk1,p1,ex1,rho1,qnc1,qni1,qnifa1,qnwfa1,qnbca1,qozone1,rthraten1,sqv1,sqc1,sqi1,sqs1 - real(kind=kind_phys),dimension(kts:kme):: w1 - -!local 1D inout arguments: - integer:: kpbl1,ktop_plume1 - - real(kind=kind_phys):: pblh1 - real(kind=kind_phys),dimension(kts:kte):: cldfra_bl1,qc_bl1,qi_bl1 - real(kind=kind_phys),dimension(kts:kte):: el_pbl1,qke1,qke_adv1,cov1,qsq1,tsq1,sh1,sm1 - real(kind=kind_phys),dimension(kts:kte):: du1,dv1,dth1,dqv1,dqc1,dqi1,dqs1,dqnc1,dqni1,dqnifa1,dqnwfa1, & - dqnbca1,dqozone1 - real(kind=kind_phys),dimension(kts:kte):: edmf_a1,edmf_w1,edmf_qt1,edmf_thl1,edmf_ent1,edmf_qc1,sub_thl1, & - sub_sqv1,det_thl1,det_sqv1 - real(kind=kind_phys),dimension(kts:kte):: edmf_a_dd1,edmf_w_dd1,edmf_qt_dd1,edmf_thl_dd1,edmf_ent_dd1, & - edmf_qc_dd1 - -!local 1D output arguments: - real(kind=kind_phys):: maxwidth1,maxmf1,ztop_plume1 - real(kind=kind_phys),dimension(kts:kte):: exch_h1,exch_m1 - - real(kind=kind_phys),dimension(kts:kte):: dqke1,qwt1,qshear1,qbuoy1,qdiss1 - -!substepping TKE: - integer:: nsub - real(kind=kind_phys):: delt2 - - - -!VARIABLES NEEDED FOR MIXING OF CHEMICAL SPECIES: -#if(WRF_CHEM == 1) -!--- inputs: - logical,intent(in):: mix_chem - integer,intent(in):: nchem,kdvel,ndvel - real(kind=kind_phys),intent(in),dimension(its:ite),optional:: frp,emis_ant_no - real(kind=kind_phys),intent(in),dimension(its:ite,ndvel):: vdep - -!--- inouts: - real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte,nchem):: chem -#else - logical,parameter:: mix_chem = .false. - integer,parameter:: nchem = 1 - integer,parameter:: kdvel = 1 - integer,parameter:: ndvel = 1 -#endif -!--- local variables and arrays: - logical,parameter:: rrfs_sd = .false. - logical,parameter:: smoke_dbg = .false. - logical,parameter:: enh_mix = .false. - - integer:: ic - real(kind=kind_phys):: emis_ant_no1,frp1 - real(kind=kind_phys),dimension(ndvel):: vd1 - real(kind=kind_phys),dimension(kts:kte,nchem):: chem1 - real(kind=kind_phys),dimension(kts:kte+1,nchem):: s_awchem1 - !END VARIABLES NEEDED FOR MIXING OF CHEMICAL SPECIES. - -!----------------------------------------------------------------------------------------------------------------- - - errmsg = " " - errflg = 0 - - do i = its,ite - - if(present(dqke)) then - do k = kts,kte - dqke(i,k) = qke(i,k) - enddo - endif - -!--- initialization of 2D inout tendencies: - do k = kts,kte - rublten(i,k) = 0._kind_phys - rvblten(i,k) = 0._kind_phys - rthblten(i,k) = 0._kind_phys - rqvblten(i,k) = 0._kind_phys - rqcblten(i,k) = 0._kind_phys - rqiblten(i,k) = 0._kind_phys - rqsblten(i,k) = 0._kind_phys - rqncblten(i,k) = 0._kind_phys - rqniblten(i,k) = 0._kind_phys - rqnifablten(i,k) = 0._kind_phys - rqnwfablten(i,k) = 0._kind_phys - rqnbcablten(i,k) = 0._kind_phys - rqozblten(i,k) = 0._kind_phys - enddo - -!--- initialization of 2D output variables: - ktop_plume(i) = 0 - maxwidth(i) = 0._kind_phys - maxmf(i) = 0._kind_phys - ztop_plume(i) = 0._kind_phys - -!--- initialization of 1D input variables using 2D input variables: - dx1 = dx(i) - xland1 = xland(i) - ps1 = ps(i) - ts1 = ts(i) - qsfc1 = qsfc(i) - ust1 = ust(i) - ch1 = ch(i) - hfx1 = hfx(i) - qfx1 = qfx(i) - rmol1 = rmol(i) - wspd1 = wspd(i) - uoce1 = uoce(i) - voce1 = voce(i) - znt1 = znt(i) - - do k = kts,kte - 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) = tt(i,k) - p1(k) = p(i,k) - ex1(k) = exner(i,k) - rho1(k) = rho(i,k) - sh1(k) = sh(i,k) - sm1(k) = sm(i,k) - rthraten1(k) = rthraten(i,k) - sqv1(k) = sqv(i,k) - sqc1(k) = sqc(i,k) - sqi1(k) = sqi(i,k) - sqs1(k) = sqs(i,k) - qnc1(k) = qnc(i,k) - qni1(k) = qni(i,k) - qnifa1(k) = qnifa(i,k) - qnwfa1(k) = qnwfa(i,k) - qnbca1(k) = qnbca(i,k) - qozone1(k) = qozone(i,k) - kzero(k) = 0._kind_phys - enddo - do k = kte,kte+1 - w1(k) = w(i,k) - enddo - -!--- initialization of the PBL stochastic forcing: - if(spp_pbl .eq. 1) then - do k = kts,kte - rstoch_col(k) = pattern_spp_pbl(i,k) - enddo - else - do k = kts,kte - rstoch_col(k) = 0._kind_phys - enddo - endif - - -!--- initialization of 1D inout variables using 2D inout variables: - kpbl1 = kpbl(i) - pblh1 = pblh(i) - - do k = kts,kte - cldfra_bl1(k) = cldfra_bl(i,k) - qc_bl1(k) = qc_bl(i,k) - qi_bl1(k) = qi_bl(i,k) - enddo - - do k = kts,kte - el_pbl1(k) = el_pbl(i,k) - qke1(k) = qke(i,k) - qke_adv1(k) = qke_adv(i,k) - cov1(k) = cov(i,k) - qsq1(k) = qsq(i,k) - tsq1(k) = tsq(i,k) - sh1(k) = sh(i,k) - sm1(k) = sm(i,k) - enddo - -!--- initialization of 1D local variables: - ktop_plume1 = 0 - maxwidth1 = 0._kind_phys - maxmf1 = 0._kind_phys - ztop_plume1 = 0._kind_phys - maxkhtopdown = 0._kind_phys - - do k = kts,kte - du1(k) = 0._kind_phys - dv1(k) = 0._kind_phys - dth1(k) = 0._kind_phys - dqv1(k) = 0._kind_phys - dqc1(k) = 0._kind_phys - dqi1(k) = 0._kind_phys - dqs1(k) = 0._kind_phys - dqnc1(k) = 0._kind_phys - dqni1(k) = 0._kind_phys - dqnifa1(k) = 0._kind_phys - dqnwfa1(k) = 0._kind_phys - dqnbca1(k) = 0._kind_phys - dqozone1(k) = 0._kind_phys - enddo - do k = kts,kte - edmf_a1(k) = 0._kind_phys - edmf_w1(k) = 0._kind_phys - edmf_qc1(k) = 0._kind_phys - edmf_ent1(k) = 0._kind_phys - edmf_qt1(k) = 0._kind_phys - edmf_thl1(k) = 0._kind_phys - sub_thl1(k) = 0._kind_phys - sub_sqv1(k) = 0._kind_phys - det_thl1(k) = 0._kind_phys - det_sqv1(k) = 0._kind_phys - - edmf_a_dd1(k) = 0._kind_phys - edmf_w_dd1(k) = 0._kind_phys - edmf_qc_dd1(k) = 0._kind_phys - edmf_ent_dd1(k) = 0._kind_phys - edmf_qt_dd1(k) = 0._kind_phys - edmf_thl_dd1(k) = 0._kind_phys - enddo - do k = kts,kte - dqke1(k) = 0._kind_phys - qwt1(k) = 0._kind_phys - qshear1(k) = 0._kind_phys - qbuoy1(k) = 0._kind_phys - qdiss1(k) = 0._kind_phys - exch_h1(k) = 0._kind_phys - exch_m1(k) = 0._kind_phys - enddo - do k = kts,kte - sub_u(k) = 0._kind_phys - sub_v(k) = 0._kind_phys - det_sqc(k) = 0._kind_phys - det_u(k) = 0._kind_phys - det_v(k) = 0._kind_phys - enddo - do k = kts,kte+1 - s_aw1(k) = 0._kind_phys - s_awthl1(k) = 0._kind_phys - s_awqt1(k) = 0._kind_phys - s_awqv1(k) = 0._kind_phys - s_awqc1(k) = 0._kind_phys - s_awu1(k) = 0._kind_phys - s_awv1(k) = 0._kind_phys - s_awqke1(k) = 0._kind_phys - s_awqnc1(k) = 0._kind_phys - s_awqni1(k) = 0._kind_phys - s_awqnwfa1(k) = 0._kind_phys - s_awqnifa1(k) = 0._kind_phys - s_awqnbca1(k) = 0._kind_phys - enddo - do k = kts,kte+1 - sd_aw1(k) = 0._kind_phys - sd_awthl1(k) = 0._kind_phys - sd_awqt1(k) = 0._kind_phys - sd_awqv1(k) = 0._kind_phys - sd_awqc1(k) = 0._kind_phys - sd_awu1(k) = 0._kind_phys - sd_awv1(k) = 0._kind_phys - sd_awqke1(k) = 0._kind_phys - enddo - do k = kts,kte - cldfra_bl1_old(k) = 0._kind_phys - qc_bl1_old(k) = 0._kind_phys - qi_bl1_old(k) = 0._kind_phys - enddo - - do k = kts,kte - qv1(k) = sqv1(k)/(1.-sqv1(k)) - qc1(k) = sqc1(k)/(1.-sqv1(k)) - qi1(k) = sqi1(k)/(1.-sqv1(k)) - qs1(k) = sqs1(k)/(1.-sqv1(k)) - enddo - - k = kts - zw(k) = 0._kind_phys - do k = kts+1,kte+1 - zw(k) = zw(k-1) + dz1(k-1) - enddo - -!INITIALIZATION OF LOCAL CHEMICAL SPECIES: -#if(WRF_CHEM == 1) - do ic = 1,nchem - vd1(ic) = vdep(i,ic) - do k = kts,kte - chem1(k,ic) = chem(i,k,ic) - enddo - enddo - if(present(emis_ant_no) .and. present(frp)) then - emis_ant_no1 = emis_ant_no(i) - frp1 = frp(i) - else - emis_ant_no1 = 0._kind_phys - frp1 = 0._kind_phys - endif - !END INITIALIZATION OF LOCAL CHEMICAL SPECIES. -#else - do ic = 1,nchem - vd1(ic) = 0._kind_phys - do k = kts,kte - chem1(k,ic) = 0._kind_phys - enddo - enddo - emis_ant_no1 = 0._kind_phys - frp1 = 0._kind_phys -#endif - do ic = 1,nchem - do k = kts,kte+1 - s_awchem1(k,ic) = 0._kind_phys - enddo - enddo -!END INITIALIZATION OF LOCAL CHEMICAL SPECIES. - - - do k = kts,kte - !keep snow out for now - increase ceiling bias - sqw(k) = sqv1(k)+sqc1(k)+sqi1(k) !+sqs1(k) - thl(k) = th1(k) - xlvcp/ex1(k)*sqc1(k) - xlscp/ex1(k)*(sqi1(k))!+sqs1(k)) - thetav(k) = th1(k)*(1.+0.608*sqv1(k)) - - !Use form from Tripoli and Cotton (1981) with their - !suggested min temperature to improve accuracy. - !thl(k)=th(k)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc1(k) - xlscp/MAX(tk1(k),TKmin)*sqi1(k)) - !thetav(k) = th1(k)*(1.+p608)*sqv1(k) - enddo - -!----------------------------------------------------------------------------------------------------------------- -!initflag > 0: -!----------------------------------------------------------------------------------------------------------------- - if(initflag > 0 .and. .not.restart) then - - !test to see if we want to initialize qke1: - if((restart .or. cycling)) then - if(qke1(kts) < 0.0002) then - initialize_qke = .true. - else - initialize_qke = .false. - endif - else ! not cycling or restarting: - initialize_qke = .true. - endif - - if(.not.restart .or. .not.cycling) then - do k = kts,kte - sh1(k) = 0._kind_phys - sm1(k) = 0._kind_phys - el_pbl1(k) = 0._kind_phys - tsq1(k) = 0._kind_phys - qsq1(k) = 0._kind_phys - cov1(k) = 0._kind_phys - cldfra_bl1(k) = 0._kind_phys - qc_bl1(k) = 0._kind_phys - qi_bl1(k) = 0._kind_phys - qke1(k) = 0._kind_phys - enddo - endif - do k = kts,kte - cldfra_bl1_old(k) = 0._kind_phys - qc_bl1_old(k) = 0._kind_phys - qi_bl1_old(k) = 0._kind_phys - enddo - - if(initialize_qke) then - do k = kts,kte - qke1(k)=5.*ust1*max((ust1*700.-zw(k))/(max(ust1,0.01)*700.),0.01) - enddo - endif - - !--- computes the PBL height: - call get_pblh(kts,kte,pblh1,thetav,qke1,zw,dz1,xland1,kpbl1) - - !--- computes the similarity functions: - if(bl_mynn_scaleaware) then - call scale_aware(dx1,pblh1,psig_bl,psig_shcu) - else - psig_bl = 1._kind_phys - psig_shcu = 1._kind_phys - endif - - !--- calls mym_initialize: - call mym_initialize( & - kts,kte,xland1, & - dz1,dx1,zw, & - u1,v1,thl,sqv1, & - pblh1,th1,thetav,sh1,sm1, & - ust1, rmol1, & - el_pbl1,qke1,tsq1,qsq1,cov1, & - psig_bl,cldfra_bl1, & - bl_mynn_mixlength, & - edmf_w1,edmf_a1, & - initialize_qke, & - spp_pbl,rstoch_col) - - endif -!----------------------------------------------------------------------------------------------------------------- -!end initflag > 0: -!----------------------------------------------------------------------------------------------------------------- - - - if(bl_mynn_tkeadvect) then - do k = kts,kte - qke1(k) = qke_adv1(k) - enddo - endif - !Joe-TKE budget: - if(bl_mynn_tkebudget) then - do k = kts,kte - dqke1(k) = qke1(k) - enddo - endif - if(icloud_bl > 0) then - do k = kts,kte - cldfra_bl1_old(k) = cldfra_bl1(k) - qc_bl1_old(k) = qc_bl1(k) - qi_bl1_old(k) = qi_bl1(k) - enddo - endif - - !--- computes the PBL height: - call get_pblh(kts,kte,pblh1,thetav,qke1,zw,dz1,xland1,kpbl1) - - !--- computes the similarity functions: - if(bl_mynn_scaleaware) then - call scale_aware(dx1,pblh1,psig_bl,psig_shcu) - else - psig_bl = 1._kind_phys - psig_shcu = 1._kind_phys - endif - - sqcg = 0.0 !ill-defined variable; qcg has been removed - cpm = cp*(1.+0.84*qv1(kts)) - exnerg = (ps1/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 = qfx1/rho1(kts) - flqc = 0.0 !currently no sea-spray fluxes, fog settling hangled elsewhere - th_sfc = ts1/ex1(kts) - - !--- turbulent flux for the TKE voundary conditions: - flq = flqv + flqc ! Latent - flt = hfx1/(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: - rmol1 = -karman*gtr*fltv/max(ust1**3,1.0e-6) - zet = 0.5*dz1(kts)*rmol1 - 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) - endif - phi_m = pmz + zet - else - !updated stability functions (Puhales, 2020): - phi_m = phim(zet) - pmz = phi_m - zet - phh = phih(zet) - endif - - !call mym_condensation() to calculate the nonconvective component of the subgrid-scale 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 bl_mynn_cloudpdf: - do k = kts,kte - vt(k) = 0._kind_phys - vq(k) = 0._kind_phys - sgm(k) = 0._kind_phys - enddo - - call mym_condensation(kts,kte, & - dx1,dz1,zw,xland1, & - thl,sqw,sqv1,sqc1,sqi1,sqs1, & - p1,ex1,tsq1,qsq1,cov1, & - sh1,el_pbl1,bl_mynn_cloudpdf, & - qc_bl1,qi_bl1,cldfra_bl1, & - pblh1,hfx1, & - vt,vq,th1,sgm,rmol1, & - spp_pbl,rstoch_col) - - - !add TKE source driven by cloud top cooling. calculate the buoyancy production of tke from cloud-top - !cooling when bl_mynn_topdown = .true. - if(bl_mynn_topdown)then - call topdown_cloudrad(kts,kte,dz1,zw,fltv, & - xland1,kpbl1,pblh1, & - sqc1,sqi1,sqw,thl,th1,ex1,p1,rho1,thetav, & - cldfra_bl1,rthraten1, & - maxkhtopdown,khtopdown,tkeprodtd) - else - maxkhtopdown = 0._kind_phys - do k = kts,kte - khtopdown(k) = 0._kind_phys - tkeprodtd(k) = 0._kind_phys - enddo - endif - - - !--- calls subroutine dmp_mf(): - if(bl_mynn_edmf) then - call dmp_mf( i, & - 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,sqv1,sqc1,qke1, & - qnc1,qni1,qnwfa1,qnifa1,qnbca1, & - ex1,vt,vq,sgm, & - ust1,flt,fltv,flq,flqv, & - pblh1,kpbl1,dx1, & - xland1,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_thl1,sub_sqv1, & - sub_u,sub_v, & - det_thl1,det_sqv1,det_sqc, & - det_u,det_v, & - !chem/smoke mixing - nchem,chem1,s_awchem1, & - mix_chem, & - qc_bl1,cldfra_bl1, & - qc_bl1_old,cldfra_bl1_old, & - flag_qc,flag_qi, & - flag_qnc,flag_qni, & - flag_qnwfa,flag_qnifa,flag_qnbca, & - psig_shcu, & - maxwidth1,ktop_plume1, & - maxmf1,ztop_plume1, & - spp_pbl,rstoch_col) - - if(bl_mynn_edmf_dd) then - call ddmf_jpl(kts,kte,delt,zw,dz1,p1, & - u1,v1,th1,thl,thetav,tk1, & - sqw,sqv1,sqc1,rho1,ex1, & - ust1,flt,flq, & - pblh1,kpbl1, & - 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_bl1,cldfra_bl1, & - rthraten) - endif - 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,xland1,bl_mynn_closure, & - dz1,dx1,zw, & - u1,v1,thl,thetav,sqc1,sqw, & - qke1,tsq1,qsq1,cov1, & - vt,vq, & - rmol1,flt,fltv,flq, & - pblh1,th1, & - sh1,sm1,el_pbl1, & - dfm,dfh,dfq, & - tcd,qcd,pdk, & - pdt,pdq,pdc, & - qwt1,qshear1,qbuoy1,qdiss1, & - bl_mynn_tkebudget, & - psig_bl,psig_shcu, & - cldfra_bl1,bl_mynn_mixlength, & - edmf_w1,edmf_a1, & - tkeprodtd, & - spp_pbl,rstoch_col) - - - !--- calls subroutine mym_predict() to solve TKE: - call mym_predict & - (kts,kte,bl_mynn_closure, & - delt2,dz1, & - ust1,flt,flq,pmz,phh, & - el_pbl1,dfq,rho1,pdk,pdt,pdq,pdc, & - qke1,tsq1,qsq1,cov1, & - s_aw1,s_awqke1,bl_mynn_edmf_tke, & - qwt1,qdiss1,bl_mynn_tkebudget) ! TKE budget (Puhales 2020) - - if(bl_mynn_dheatopt) 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_pbl1(k)+el_pbl1(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 - do k = kts,kte - diss_heat(k) = 0. - enddo - endif - - - !--- call to subroutine mynn_tendencies: - call mynn_tendencies(kts,kte, & - delt,dz1,rho1, & - u1,v1,th1,tk1,qv1, & - qc1,qi1,kzero,qnc1,qni1, & !kzero replaces qs1 - not mixing snow - ps1,p1,ex1,thl, & - sqv1,sqc1,sqi1,kzero,sqw, & !kzero replaces sqs - not mxing snow - qnwfa1,qnifa1,qnbca1,qozone1, & - ust1,flt,flq,flqv,flqc, & - wspd1,uoce1,voce1, & - tsq1,qsq1,cov1, & - tcd,qcd, & - dfm,dfh,dfq, & - du1,dv1,dth1,dqv1, & - dqc1,dqi1,dqs1,dqnc1,dqni1, & - dqnwfa1,dqnifa1,dqnbca1, & - dqozone1, & - 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_thl1,sub_sqv1, & - sub_u,sub_v, & - det_thl1,det_sqv1,det_sqc, & - det_u,det_v, & - flag_qc,flag_qi,flag_qnc, & - flag_qni,flag_qs, & - flag_qnwfa,flag_qnifa, & - flag_qnbca,flag_qoz, & - cldfra_bl1, & - bl_mynn_cloudmix, & - bl_mynn_mixqt, & - bl_mynn_edmf_mom, & - bl_mynn_mixscalars) - - - !--- call to subroutine mynn_mix_chem for PBL and tropospheric mixing of - ! chemical species: - if(mix_chem) then - if(rrfs_sd) then - call mynn_mix_chem(kts,kte, & - delt,dz1,pblh1, & - nchem,kdvel,ndvel, & - chem1,vd1, & - rho1,flt, & - tcd,qcd, & - dfh, & - s_aw1,s_awchem1, & - emis_ant_no1, & - frp1,rrfs_sd, & - enh_mix,smoke_dbg) - else - call mynn_mix_chem(kts,kte, & - delt,dz1,pblh1, & - nchem,kdvel,ndvel, & - chem1,vd1, & - rho1,flt, & - tcd,qcd, & - dfh, & - s_aw1,s_awchem1, & - zero, & - zero,rrfs_sd, & - enh_mix,smoke_dbg) - endif - endif -#if(WRF == 1) - !directly updates chem3 instead of computing a tendency: - do ic = 1,nchem - do k = kts,kte - chem(i,k,ic) = max(1.e-12,chem1(k,ic)) - enddo - enddo -#endif - - - !--- computes the exchange coefficients: - call retrieve_exchange_coeffs(kts,kte,dfm,dfh,dz1,exch_m1,exch_h1) - - -!----------------------------------------------------------------------------------------------------------------- -!begin output of 2D variables: -!----------------------------------------------------------------------------------------------------------------- - !output tendencies: - do k = kts,kte - rublten(i,k) = du1(k) - rvblten(i,k) = dv1(k) - rthblten(i,k) = dth1(k) - rqvblten(i,k) = dqv1(k) - enddo - if(bl_mynn_cloudmix .and. flag_qc) then - do k = kts,kte - rqcblten(i,k) = dqc1(k) - enddo - endif - if(bl_mynn_cloudmix .and. flag_qi) then - do k = kts,kte - rqiblten(i,k) = dqi1(k) - enddo - endif - if(bl_mynn_cloudmix .and. flag_qs) then - do k = kts,kte - rqsblten(i,k) = dqs1(k) - enddo - endif - if(bl_mynn_cloudmix .and. bl_mynn_mixscalars .and. flag_qnc) then - do k = kts,kte - rqncblten(i,k) = dqnc1(k) - enddo - endif - if(bl_mynn_cloudmix .and. bl_mynn_mixscalars .and. flag_qni) then - do k = kts,kte - rqniblten(i,k) = dqni1(k) - enddo - endif - if(bl_mynn_cloudmix .and. bl_mynn_mixscalars .and. flag_qnifa) then - do k = kts,kte - rqnifablten(i,k) = dqnifa1(k) - enddo - endif - if(bl_mynn_cloudmix .and. bl_mynn_mixscalars .and. flag_qnwfa) then - do k = kts,kte - rqnwfablten(i,k) = dqnwfa1(k) - enddo - endif - if(bl_mynn_cloudmix .and. bl_mynn_mixscalars .and. flag_qnbca) then - do k = kts,kte - rqnbcablten(i,k) = dqnbca1(k) - enddo - endif - do k = kts,kte - rqozblten(i,k) = 0._kind_phys - enddo - - !inout arrays: - kpbl(i) = kpbl1 - ktop_plume(i) = ktop_plume1 - - pblh(i) = pblh1 - - do k = kts,kte - cldfra_bl(i,k) = cldfra_bl1(k) - qc_bl(i,k) = qc_bl1(k) - qi_bl(i,k) = qi_bl1(k) - enddo - - do k = kts,kte - el_pbl(i,k) = el_pbl1(k) - qke(i,k) = qke1(k) - qke_adv(i,k) = qke_adv1(k) - cov(i,k) = cov1(k) - qsq(i,k) = qsq1(k) - tsq(i,k) = tsq1(k) - sh(i,k) = sh1(k) - sm(i,k) = sm1(k) - enddo - - - !the TKE budget is now given in m**2/s**-3 (Puhales, 2020): - if(present(qwt) .and. present(qbuoy) .and. present(qshear) .and. & - present(qdiss) .and. present(dqke)) then - if(bl_mynn_tkebudget) then - !lower boundary condtions (using similarity relationships such as the prognostic equation for Qke) - k = kts - qshear1(k) = 4.*(ust1**3*phi_m/(karman*dz1(k)))-qshear1(k+1) ! staggered - qbuoy1(k) = 4.*(-ust1**3*zet/(karman*dz1(k)))-qbuoy1(k+1) ! staggered - - !unstaggering shear and buoy and trasnfering all TKE budget to 2D arrays: - 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._kind_phys - qbuoy(i,k) = 0._kind_phys - qwt(i,k) = 0._kind_phys - qdiss(i,k) = 0._kind_phys - dqke(i,k) = 0._kind_phys - else - do k = kts,kte - qshear(i,k) = 0._kind_phys - qbuoy(i,k) = 0._kind_phys - qwt(i,k) = 0._kind_phys - qdiss(i,k) = 0._kind_phys - dqke(i,k) = 0._kind_phys - enddo - endif - endif - - - !optional inout arrays for updraft/downdraft properties: - if(bl_mynn_edmf .and. bl_mynn_output) then - do k = kts,kte - edmf_a(i,k) = edmf_a1(k) - edmf_w(i,k) = edmf_w1(k) - edmf_qt(i,k) = edmf_qt1(k) - edmf_thl(i,k) = edmf_thl1(k) - edmf_ent(i,k) = edmf_ent1(k) - edmf_qc(i,k) = edmf_qc1(k) - sub_thl(i,k) = sub_thl1(k) - sub_sqv(i,k) = sub_sqv1(k) - det_thl(i,k) = det_thl1(k) - det_sqv(i,k) = det_sqv1(k) - enddo - else - do k = kts,kte - edmf_a(i,k) = 0._kind_phys - edmf_w(i,k) = 0._kind_phys - edmf_qt(i,k) = 0._kind_phys - edmf_thl(i,k) = 0._kind_phys - edmf_ent(i,k) = 0._kind_phys - edmf_qc(i,k) = 0._kind_phys - sub_thl(i,k) = 0._kind_phys - sub_sqv(i,k) = 0._kind_phys - det_thl(i,k) = 0._kind_phys - det_sqv(i,k) = 0._kind_phys - enddo - endif - if(bl_mynn_edmf_dd .and. bl_mynn_output) then - if(present(edmf_a_dd) .and. present(edmf_w_dd) .and. present(edmf_qt_dd) .and. & - present(edmf_thl_dd) .and. present(edmf_ent_dd) .and. present(edmf_qc_dd)) then - do k = kts,kte - edmf_a_dd(i,k) = edmf_a_dd1(k) - edmf_w_dd(i,k) = edmf_w_dd1(k) - edmf_qt_dd(i,k) = edmf_qt_dd1(k) - edmf_thl_dd(i,k) = edmf_thl_dd1(k) - edmf_ent_dd(i,k) = edmf_ent_dd1(k) - edmf_qc_dd(i,k) = edmf_qc_dd1(k) - enddo - endif - endif - - !output arrays: - maxwidth(i) = maxwidth1 - maxmf(i) = maxmf1 - ztop_plume(i) = ztop_plume1 - - do k = kts,kte - exch_h(i,k) = exch_h1(k) - exch_m(i,k) = exch_m1(k) - enddo - - enddo - - end subroutine bl_mynn_run - -!================================================================================================================= - end module bl_mynn -!================================================================================================================= diff --git a/src/core_atmosphere/physics/physics_mmm/bl_mynn_subroutines.F b/src/core_atmosphere/physics/physics_mmm/bl_mynn_subroutines.F deleted file mode 100644 index 324c368517..0000000000 --- a/src/core_atmosphere/physics/physics_mmm/bl_mynn_subroutines.F +++ /dev/null @@ -1,6565 +0,0 @@ -!================================================================================================================= - module bl_mynn_common - use mpas_kind_types,only: kind_phys => RKIND - - implicit none - save - - -!--- physics constants that need to be initialized with physics constants from the host model: - real(kind=kind_phys):: cp ! defined in bl_mynn_init. - real(kind=kind_phys):: cpv ! defined in bl_mynn_init. - real(kind=kind_phys):: cice ! defined in bl_mynn_init. - real(kind=kind_phys):: cliq ! defined in bl_mynn_init. - - real(kind=kind_phys):: ep_1 ! defined in bl_mynn_init. - real(kind=kind_phys):: ep_2 ! defined in bl_mynn_init. - - real(kind=kind_phys):: grav ! defined in bl_mynn_init. - - real(kind=kind_phys):: karman ! defined in bl_mynn_init. - real(kind=kind_phys):: p1000mb ! defined in bl_mynn_init. - - real(kind=kind_phys):: rcp ! defined in bl_mynn_init. - real(kind=kind_phys):: r_d ! defined in bl_mynn_init. - real(kind=kind_phys):: r_v ! defined in bl_mynn_init. - real(kind=kind_phys):: rvovrd ! defined in bl_mynn_init. - - real(kind=kind_phys):: svp1 ! defined in bl_mynn_init. - real(kind=kind_phys):: svp2 ! defined in bl_mynn_init. - real(kind=kind_phys):: svp3 ! defined in bl_mynn_init. - real(kind=kind_phys):: svpt0 ! defined in bl_mynn_init. - - real(kind=kind_phys):: xlf ! defined in bl_mynn_init. - real(kind=kind_phys):: xlv ! defined in bl_mynn_init. - real(kind=kind_phys):: xls ! defined in bl_mynn_init. - - -!--- derived physics constants: - real(kind=kind_phys):: ep_3 - real(kind=kind_phys):: gtr - real(kind=kind_phys):: p608 - real(kind=kind_phys):: t0c - real(kind=kind_phys):: tv0 - real(kind=kind_phys):: xlscp - real(kind=kind_phys):: xlvcp - -!real(kind=kind_phys):: ev -!real(kind=kind_phys):: rk -!real(kind=kind_phys):: svp11 -!real(kind=kind_phys):: tv1 -!real(kind=kind_phys):: vk - - -!--- parameters: - real(kind=kind_phys),parameter:: tice = 240.0 !-33 (C), temp at saturation w.r.t. ice - real(kind=kind_phys),parameter:: tkmin = 253.0 - real(kind=kind_phys),parameter:: tref = 300.0 - real(kind=kind_phys),parameter:: onethird = 1./3. - real(kind=kind_phys),parameter:: twothirds = 2./3. - real(kind=kind_phys),parameter:: zero = 0._kind_phys - - -!--- physics constants also needed in subroutine bl_mynn_run: - real(kind=kind_phys),parameter:: b1 = 24.0 - real(kind=kind_phys),parameter:: b2 = 15.0 - - real(kind=kind_phys),parameter:: cphh_st = 5.0 - real(kind=kind_phys),parameter:: cphm_st = 5.0 - real(kind=kind_phys),parameter:: cphh_unst = 16.0 - real(kind=kind_phys),parameter:: cphm_unst = 16.0 - - end module bl_mynn_common - -!================================================================================================================= -!>\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, = .true. for DMP mass-flux, .false.: off). -! Related options: -! bl_mynn_edmf_mom = .true. : activate momentum transport in MF scheme -! bl_mynn_edmf_tke = .true. : 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 = .true.; 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 (.false. or .true.) 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 bl_mynn_subroutines - use mpas_kind_types,only: kind_phys => RKIND,kind_phys8 => R8KIND - use bl_mynn_common,only: & - b1 , b2 , cice , cliq , cp , & - cpv , ep_2 , ep_3 , grav , gtr , & - karman , onethird , p1000mb , p608 , r_d , & - r_v , rcp , rvovrd , svp1 , t0c , & - tice , tkmin , tv0 , twothirds , xls , & - xlscp , xlv , xlvcp , cphh_st , cphm_st , & - cphh_unst , cphm_unst - - use mynn_shared,only: esat_blend,qsat_blend,xl_blend - - implicit none - private - public:: dmp_mf, & - ddmf_jpl, & - topdown_cloudrad, & - get_pblh, & - mym_condensation, & - mym_initialize, & - mynn_mix_chem, & - mym_predict, & - mym_turbulence, & - mynn_tendencies, & - phih, & - phim, & - retrieve_exchange_coeffs, & - scale_aware - -!=================================================================== -! From here on, these are MYNN-specific parameters: -! The parameters below depend on stability functions of module_sf_mynn. - -! 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 :: gpw=5./3., qcgmin=1.e-8, qkemin=1.e-12 - 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. - - !Option to activate environmental subsidence in mass-flux scheme - logical, parameter :: env_subs = .false. - - !option to print out more stuff for debugging purposes - logical, parameter :: debug_code = .false. - integer, parameter :: idbg = 23 !specific i-point to write out - -CONTAINS - -!======================================================================= -! 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) - - - 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),1.0e-10)) - 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,1.0e-3)) - 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 ) )**(1.0/3.0) - - ! ** 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 = 2.7 !was 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.01) !tke at full sigma levels - thetaw(kts)=theta(kts) !theta at full-sigma levels - qkw(kts) = SQRT(MAX(qke(kts),1.0e-10)) - - 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,1.0e-3)) - qtke(k) = 0.5*(qkw(k)**2) ! 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.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) !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*qkw(k), & - & alp6*edmf_a1(k-1)*edmf_w1(k-1)) / bv & - & *( 1.0 + alp3*SQRT( vsc/(bv*elt) ) ) - elb = MIN(elb, zwk) - elf = 1.0 * qkw(k)/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.01) !tke at full sigma levels - qkw(kts) = SQRT(MAX(qke(kts),1.0e-4)) - - 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,1.0e-3)) - 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 bl_mynn_tkebudget -!! 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, & - & bl_mynn_tkebudget, & - & 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 - - logical, intent(in) :: bl_mynn_tkebudget - integer, intent(in) :: bl_mynn_mixlength - 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(kind_phys):: auh,aum,adh,adm,aeh,aem,Req,Rsl,Rsl2, & - gmelq,sm20,sh20,sm25max,sh25max,sm25min,sh25min, & - sm_pbl,sh_pbl,zi2,wt,slht,wtpr - - real(kind=kind_phys8):: q2sq, t2sq, r2sq, c2sq, elsq, gmel, ghel - real(kind=kind_phys8):: q3sq, t3sq, r3sq, c3sq, dlsq, qdiv - real(kind=kind_phys8):: 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, 1d-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.002) - 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 (bl_mynn_tkebudget) 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,bl_mynn_tkebudget) !! TKE budget (Puhales, 2020) - -!------------------------------------------------------------------- - integer, intent(in) :: kts,kte - -#ifdef HARDCODE_VERTICAL -# define kts 1 -# define kte HARDCODE_VERTICAL -#endif - - logical, intent(in) :: bl_mynn_edmf_tke,bl_mynn_tkebudget - real(kind_phys), intent(in) :: closure - 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 (.not. bl_mynn_edmf_tke) 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), 1.e-4) - qke(k)=max(x(k), 1.e-4) - qke(k)=min(qke(k), 150.) - ENDDO - - -!! TKE budget (Puhales, 2020, WRF 4.2.1) << EOB - IF (bl_mynn_tkebudget) 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(kind_phys):: 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,t0c,tice) - !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,t0c,tice) - !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,t0c,tice,cice,cliq,cpv,xls,xlv) ! obtain latent heat - qsat_tk= qsat_blend(t,t0c,tice,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, & - &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_mom, & - &bl_mynn_mixscalars ) - -!------------------------------------------------------------------- - integer, intent(in) :: kts,kte - -#ifdef HARDCODE_VERTICAL -# define kts 1 -# define kte HARDCODE_VERTICAL -#endif - - logical, intent(in) :: bl_mynn_edmf_mom - logical, intent(in) :: bl_mynn_mixscalars,bl_mynn_cloudmix,bl_mynn_mixqt - 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 == .false., so - ! we only need to zero-out the MF term - IF (.not. bl_mynn_edmf_mom) 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) 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 (.not. bl_mynn_mixqt) 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 .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 (.not. bl_mynn_mixqt) 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 .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 .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 .AND. FLAG_QNI .AND. & - bl_mynn_mixscalars) 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 .AND. FLAG_QNC .AND. & - bl_mynn_mixscalars) 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 .AND. FLAG_QNWFA .AND. & - bl_mynn_mixscalars) 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 .AND. FLAG_QNIFA .AND. & - bl_mynn_mixscalars) 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 .AND. FLAG_QNBCA .AND. & - bl_mynn_mixscalars) 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) 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,t0c,tice,p(k)) - !SATURATED VAPOR PRESSURE - !esat=esat_blend(t,t0c,tice) - !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) 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) 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) 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 MIXED (when bl_mynn_cloudmix == .false.) - 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) 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) 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: 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, & - 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 - 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 true (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(ii, & - & 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) :: ii - integer, intent(in) :: KTS,KTE,KPBL - logical, intent(in) :: momentum_opt,scalar_opt,tke_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 - 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 - if ((landsea-1.5).LT.0) then !land - acfac = .5*tanh((fltv2 - 0.02)/0.05) + .5 - else !water - acfac = .5*tanh((fltv2 - 0.01)/0.03) + .5 - endif - !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) 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) 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) 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 - !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*flt/dz(kts) .AND. flx1>0.0) THEN - adjustment= fluxportion*flt/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) THEN - s_awu = s_awu*adjustment - s_awv = s_awv*adjustment - ENDIF - IF (tke_opt) 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) +rhoz(k)*UPA(K,i)*UPW(K,i) - edmf_qt(K) =edmf_qt(K) +rhoz(k)*UPA(K,i)*UPQT(K,i) - edmf_thl(K)=edmf_thl(K)+rhoz(k)*UPA(K,i)*UPTHL(K,i) - edmf_ent(K)=edmf_ent(K)+rhoz(k)*UPA(K,i)*ENT(K,i) - edmf_qc(K) =edmf_qc(K) +rhoz(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) 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),t0c,tice) - !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),t0c,tice,cice,cliq,cpv,xls,xlv) ! obtain blended heat capacity - qsat_tk = qsat_blend(tk(k),t0c,tice,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,t0c,tice,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,t0c,tice,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,t0c,tice,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 -! =================================================================== - 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,wm2,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) -! wm2 = wm2 + wm3**twothirds - 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 bl_mynn_subroutines diff --git a/src/core_atmosphere/physics/physics_mmm/bl_ysu.F b/src/core_atmosphere/physics/physics_mmm/bl_ysu.F deleted file mode 100644 index 601c232cb9..0000000000 --- a/src/core_atmosphere/physics/physics_mmm/bl_ysu.F +++ /dev/null @@ -1,1709 +0,0 @@ -#define NEED_B4B_DURING_CCPP_TESTING 1 -!================================================================================================================= - module bl_ysu - use ccpp_kinds,only: kind_phys - - implicit none - private - public:: bl_ysu_run , & - bl_ysu_init , & - bl_ysu_final , & - bl_ysu_timestep_init, & - bl_ysu_timestep_final - - - contains - - -!================================================================================================================= - 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,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 - - integer, 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:ite, kts:kte ) , & - intent(in) :: dz8w2d, & - pi2d -! - real(kind=kind_phys), dimension( its:ite, kts:kte ) , & - intent(in ) :: tx, & - qvx, & - qcx, & - qix -! - real(kind=kind_phys), dimension( its:ite, kts:kte, nmix ) , & - intent(in ) :: qmix -! - real(kind=kind_phys), dimension( its:ite, kts:kte ) , & - intent(out ) :: utnp, & - vtnp, & - ttnp, & - qvtnp, & - qctnp, & - qitnp -! - real(kind=kind_phys), dimension( its:ite, kts:kte, nmix ) , & - intent(out ) :: qmixtnp -! - real(kind=kind_phys), dimension( its:ite, kms:kme ) , & - intent(in ) :: p2di -! - real(kind=kind_phys), dimension( its:ite, kts:kte ) , & - intent(in ) :: p2d -! - real(kind=kind_phys), dimension( its:ite ) , & - intent(out ) :: hpbl -! - real(kind=kind_phys), dimension( its:ite ) , & - intent(in ) :: ust, & - znt - real(kind=kind_phys), dimension( its:ite ) , & - intent(in ) :: xland, & - hfx, & - qfx -! - real(kind=kind_phys), dimension( its:ite ), intent(in ) :: wspd - real(kind=kind_phys), dimension( its:ite ), intent(in ) :: br -! - real(kind=kind_phys), dimension( its:ite ), intent(in ) :: psim, & - psih -! - real(kind=kind_phys), dimension( its:ite ), intent(in ) :: psfcpa - integer, dimension( its:ite ), intent(out ) :: kpbl1d -! - real(kind=kind_phys), dimension( its:ite, kts:kte ) , & - intent(in ) :: ux, & - vx, & - rthraten - real(kind=kind_phys), dimension( its:ite ) , & - optional , & - intent(in ) :: ctopo, & - ctopo2 -! - logical, intent(in ) :: flag_bep - real(kind=kind_phys), dimension( its:ite, kts:kte ) , & - 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:ite ) , & - 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, & - dusfc,dvsfc, & - dtsfc,dqsfc, & - 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 - dusfc(i) = 0. - dvsfc(i) = 0. - dtsfc(i) = 0. - dqsfc(i) = 0. - enddo -! - do i = its,ite - hgamt(i) = 0. - hgamq(i) = 0. - wscale(i) = 0. - we(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.eq.1)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.eq.1)then - if ( kpbl(i) .ge. 2) then - cloudflg(i)=.true. - templ=thlix(i,k)*(p2di(i,k+1)/100000)**rovcp - !rvls is ws at full level - rvls=100.*6.112*EXP(17.67*(templ-273.16)/(templ-29.65))*(ep2/p2di(i,k+1)) - temps=templ + ((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 - 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 - 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 - 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 - dusfc(i) = dusfc(i) + utend*conwrc*del(i,k) - 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 bl_ysu_init (errmsg, errflg) - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! This routine currently does nothing - - errmsg = '' - errflg = 0 - - end subroutine bl_ysu_init - -!================================================================================================================= - subroutine bl_ysu_final (errmsg, errflg) - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! This routine currently does nothing - - errmsg = '' - errflg = 0 - - end subroutine bl_ysu_final - -!================================================================================================================= - subroutine bl_ysu_timestep_init (errmsg, errflg) - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! This routine currently does nothing - - errmsg = '' - errflg = 0 - - end subroutine bl_ysu_timestep_init - -!================================================================================================================= - subroutine bl_ysu_timestep_final (errmsg, errflg) - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! This routine currently does nothing - - errmsg = '' - errflg = 0 - - end subroutine bl_ysu_timestep_final -!------------------------------------------------------------------------------- -! -!------------------------------------------------------------------------------- - 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/src/core_atmosphere/physics/physics_mmm/cu_ntiedtke.F b/src/core_atmosphere/physics/physics_mmm/cu_ntiedtke.F deleted file mode 100644 index 041bb67456..0000000000 --- a/src/core_atmosphere/physics/physics_mmm/cu_ntiedtke.F +++ /dev/null @@ -1,3766 +0,0 @@ -!================================================================================================================= - module cu_ntiedtke_common - use ccpp_kinds,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_kinds,only: kind_phys - use cu_ntiedtke_common - - - implicit none - private - public:: cu_ntiedtke_run, & - cu_ntiedtke_init, & - cu_ntiedtke_final, & - cu_ntiedtke_timestep_init, & - cu_ntiedtke_timestep_final - - - contains - - -!================================================================================================================= - 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 - -!================================================================================================================= - subroutine cu_ntiedtke_final(errmsg,errflg) -!================================================================================================================= - -!--- output arguments: - character(len=*),intent(out):: errmsg - integer,intent(out):: errflg - -!----------------------------------------------------------------------------------------------------------------- - - errmsg = 'cu_ntiedtke_final OK' - errflg = 0 - - end subroutine cu_ntiedtke_final - -!================================================================================================================= - subroutine cu_ntiedtke_timestep_init(its,ite,kts,kte,im,kx,kx1,itimestep,stepcu,dt,grav,xland,dz,pres,presi, & - t,rho,qv,qc,qi,u,v,w,qvften,thften,qvftenz,thftenz,slimsk,delt,prsl,ghtl,tf,qvf,qcf, & - qif,uf,vf,prsi,ghti,omg,errmsg,errflg) -!================================================================================================================= - -!--- input arguments: - integer,intent(in):: its,ite,kts,kte - integer,intent(in):: itimestep - integer,intent(in):: stepcu - - real(kind=kind_phys),intent(in):: dt,grav - real(kind=kind_phys),intent(in),dimension(its:ite):: xland - real(kind=kind_phys),intent(in),dimension(its:ite,kts:kte):: dz,pres,t,rho,qv,qc,qi,u,v - real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte):: qvften,thften - real(kind=kind_phys),intent(in),dimension(its:ite,kts:kte+1):: presi,w - -!--- inout arguments: - integer,intent(inout):: im,kx,kx1 - integer,intent(inout),dimension(its:ite):: slimsk - - real(kind=kind_phys),intent(inout):: delt - real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte):: tf,qvf,qcf,qif,uf,vf - real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte):: ghtl,omg,prsl - real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte):: qvftenz,thftenz - real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte+1):: ghti,prsi - -!--- output arguments: - character(len=*),intent(out):: errmsg - integer,intent(out):: errflg - -!--- local variables and arrays: - integer:: i,k,pp,zz - - real(kind=kind_phys),dimension(its:ite,kts:kte):: zl,dot - real(kind=kind_phys),dimension(its:ite,kts:kte+1):: zi - -!----------------------------------------------------------------------------------------------------------------- - - im = ite-its+1 - kx = kte-kts+1 - kx1 = kx+1 - - delt = dt*stepcu - - do i = its,ite - slimsk(i) = (abs(xland(i)-2.)) - enddo - - k = kts - do i = its,ite - zi(i,k) = 0. - enddo - do k = kts,kte - do i = its,ite - zi(i,k+1) = zi(i,k)+dz(i,k) - enddo - enddo - do k = kts,kte - do i = its,ite - zl(i,k) = 0.5*(zi(i,k)+zi(i,k+1)) - dot(i,k) = -0.5*grav*rho(i,k)*(w(i,k)+w(i,k+1)) - enddo - enddo - - pp = 0 - do k = kts,kte+1 - zz = kte + 1 - pp - do i = its,ite - ghti(i,zz) = zi(i,k) - prsi(i,zz) = presi(i,k) - enddo - pp = pp + 1 - enddo - pp = 0 - do k = kts,kte - zz = kte-pp - do i = its,ite - ghtl(i,zz) = zl(i,k) - omg(i,zz) = dot(i,k) - prsl(i,zz) = pres(i,k) - enddo - pp = pp + 1 - enddo - - pp = 0 - do k = kts,kte - zz = kte-pp - do i = its,ite - tf(i,zz) = t(i,k) - qvf(i,zz) = qv(i,k) - qcf(i,zz) = qc(i,k) - qif(i,zz) = qi(i,k) - uf(i,zz) = u(i,k) - vf(i,zz) = v(i,k) - enddo - pp = pp + 1 - enddo - - if(itimestep == 1) then - do k = kts,kte - do i = its,ite - qvftenz(i,k) = 0. - thftenz(i,k) = 0. - enddo - enddo - else - pp = 0 - do k = kts,kte - zz = kte-pp - do i = its,ite - qvftenz(i,zz) = qvften(i,k) - thftenz(i,zz) = thften(i,k) - enddo - pp = pp + 1 - enddo - endif - - errmsg = 'cu_ntiedtke_timestep_init OK' - errflg = 0 - - end subroutine cu_ntiedtke_timestep_init - -!================================================================================================================= - subroutine cu_ntiedtke_timestep_final(its,ite,kts,kte,stepcu,dt,exner,qv,qc,qi,t,u,v,qvf,qcf,qif,tf,uf,vf,rn, & - raincv,pratec,rthcuten,rqvcuten,rqccuten,rqicuten,rucuten,rvcuten,errmsg,errflg) -!================================================================================================================= - -!--- input arguments: - integer,intent(in):: its,ite,kts,kte - integer,intent(in):: stepcu - - real(kind=kind_phys),intent(in):: dt - real(kind=kind_phys),intent(in),dimension(its:ite):: rn - real(kind=kind_phys),intent(in),dimension(its:ite,kts:kte):: exner,qv,qc,qi,t,u,v,qvf,qcf,qif,tf,uf,vf - -!--- inout arguments: - real(kind=kind_phys),intent(inout),dimension(its:ite):: raincv,pratec - real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte):: rqvcuten,rqccuten,rqicuten - real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte):: rthcuten,rucuten,rvcuten - -!--- output arguments: - character(len=*),intent(out):: errmsg - integer,intent(out):: errflg - -!--- local variables and arrays: - integer:: i,k,pp,zz - - real(kind=kind_phys):: delt,rdelt - -!----------------------------------------------------------------------------------------------------------------- - - delt = dt*stepcu - rdelt = 1./delt - - do i = its,ite - raincv(i) = rn(i)/stepcu - pratec(i) = rn(i)/(stepcu*dt) - enddo - - pp = 0 - do k = kts,kte - zz = kte - pp - do i = its,ite - rthcuten(i,k) = (tf(i,zz)-t(i,k))/exner(i,k)*rdelt - rqvcuten(i,k) = (qvf(i,zz)-qv(i,k))*rdelt - rqccuten(i,k) = (qcf(i,zz)-qc(i,k))*rdelt - rqicuten(i,k) = (qif(i,zz)-qi(i,k))*rdelt - rucuten(i,k) = (uf(i,zz)-u(i,k))*rdelt - rvcuten(i,k) = (vf(i,zz)-v(i,k))*rdelt - enddo - pp = pp + 1 - enddo - - errmsg = 'cu_ntiedtke_timestep_final OK' - errflg = 0 - - end subroutine cu_ntiedtke_timestep_final - -!================================================================================================================= -! 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(lq):: lndj - - real(kind=kind_phys),intent(in):: dt - real(kind=kind_phys),intent(in),dimension(lq):: dx - real(kind=kind_phys),intent(in),dimension(lq):: evap,hfx - real(kind=kind_phys),intent(in),dimension(lq,km):: pqvf,ptf - real(kind=kind_phys),intent(in),dimension(lq,km):: poz,pomg,pap - real(kind=kind_phys),intent(in),dimension(lq,km1):: pzz,paph - -!--- inout arguments: - real(kind=kind_phys),intent(inout),dimension(lq):: zprecc - real(kind=kind_phys),intent(inout),dimension(lq,km):: 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/src/core_atmosphere/physics/physics_mmm/module_libmassv.F b/src/core_atmosphere/physics/physics_mmm/module_libmassv.F deleted file mode 100644 index 60ff9fa022..0000000000 --- a/src/core_atmosphere/physics/physics_mmm/module_libmassv.F +++ /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/src/core_atmosphere/physics/physics_mmm/mp_radar.F b/src/core_atmosphere/physics/physics_mmm/mp_radar.F deleted file mode 100644 index 08199da7df..0000000000 --- a/src/core_atmosphere/physics/physics_mmm/mp_radar.F +++ /dev/null @@ -1,677 +0,0 @@ -!================================================================================================================= - module mp_radar - use ccpp_kinds,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/src/core_atmosphere/physics/physics_mmm/mp_wsm6.F b/src/core_atmosphere/physics/physics_mmm/mp_wsm6.F deleted file mode 100644 index ca345b3ba8..0000000000 --- a/src/core_atmosphere/physics/physics_mmm/mp_wsm6.F +++ /dev/null @@ -1,2441 +0,0 @@ -!================================================================================================================= - module mp_wsm6 - use ccpp_kinds,only: kind_phys - use module_libmassv,only: vrec,vsqrt - - use mp_radar - - implicit none - private - public:: mp_wsm6_run, & - mp_wsm6_init, & - mp_wsm6_final, & - 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 - - -!================================================================================================================= - 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 - -!================================================================================================================= - subroutine mp_wsm6_final(errmsg,errflg) -!================================================================================================================= - -!--- output arguments: - character(len=*),intent(out):: errmsg - integer,intent(out):: errflg - -!----------------------------------------------------------------------------------------------------------------- - - errmsg = 'mp_wsm6_final OK' - errflg = 0 - - end subroutine mp_wsm6_final - -!================================================================================================================= - 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:ite,kts:kte):: & - 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:ite,kts:kte):: & - t -real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte):: & - q, & - qc, & - qi, & - qr, & - qs, & - qg -real(kind=kind_phys),intent(inout),dimension(its:ite):: & - rain, & - rainncv, & - sr - -real(kind=kind_phys),intent(inout),dimension(its:ite),optional:: & - snow, & - snowncv -real(kind=kind_phys),intent(inout),dimension(its:ite),optional:: & - graupel, & - graupelncv - - - real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte), & - 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/src/core_atmosphere/physics/physics_mmm/mp_wsm6_effectRad.F b/src/core_atmosphere/physics/physics_mmm/mp_wsm6_effectRad.F deleted file mode 100644 index d54cf74b66..0000000000 --- a/src/core_atmosphere/physics/physics_mmm/mp_wsm6_effectRad.F +++ /dev/null @@ -1,188 +0,0 @@ -!================================================================================================================= - module mp_wsm6_effectrad - use ccpp_kinds,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_final - - - contains - - -!================================================================================================================= - 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 - -!================================================================================================================= - subroutine mp_wsm6_effectRad_final(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_final - -!================================================================================================================= - 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:ite,kts:kte),intent(in):: t - real(kind=kind_phys),dimension(its:ite,kts:kte),intent(in):: qc - real(kind=kind_phys),dimension(its:ite,kts:kte),intent(in):: qi - real(kind=kind_phys),dimension(its:ite,kts:kte),intent(in):: qs - real(kind=kind_phys),dimension(its:ite,kts:kte),intent(in):: rho - real(kind=kind_phys),dimension(its:ite,kts:kte),intent(inout):: re_qc - real(kind=kind_phys),dimension(its:ite,kts:kte),intent(inout):: re_qi - real(kind=kind_phys),dimension(its:ite,kts:kte),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/src/core_atmosphere/physics/physics_mmm/mynn_shared.F b/src/core_atmosphere/physics/physics_mmm/mynn_shared.F deleted file mode 100644 index ee74077ba3..0000000000 --- a/src/core_atmosphere/physics/physics_mmm/mynn_shared.F +++ /dev/null @@ -1,133 +0,0 @@ -!================================================================================================================= - module mynn_shared - use mpas_kind_types,only: kind_phys => RKIND - - implicit none - private - public:: esat_blend,qsat_blend,xl_blend - - -!> Constants used for empirical calculations of saturation vapor pressures (in function "esat") and -!! saturation mixing ratios (in function "qsat"), reproduced from module_mp_thompson.F. - real(kind=kind_phys),parameter:: j0 = .611583699e03 - real(kind=kind_phys),parameter:: j1 = .444606896e02 - real(kind=kind_phys),parameter:: j2 = .143177157e01 - real(kind=kind_phys),parameter:: j3 = .264224321e-1 - real(kind=kind_phys),parameter:: j4 = .299291081e-3 - real(kind=kind_phys),parameter:: j5 = .203154182e-5 - real(kind=kind_phys),parameter:: j6 = .702620698e-8 - real(kind=kind_phys),parameter:: j7 = .379534310e-11 - real(kind=kind_phys),parameter:: j8 =-.321582393e-13 - - real(kind=kind_phys),parameter:: k0 = .609868993e03 - real(kind=kind_phys),parameter:: k1 = .499320233e02 - real(kind=kind_phys),parameter:: k2 = .184672631e01 - real(kind=kind_phys),parameter:: k3 = .402737184e-1 - real(kind=kind_phys),parameter:: k4 = .565392987e-3 - real(kind=kind_phys),parameter:: k5 = .521693933e-5 - real(kind=kind_phys),parameter:: k6 = .307839583e-7 - real(kind=kind_phys),parameter:: k7 = .105785160e-9 - real(kind=kind_phys),parameter:: k8 = .161444444e-12 - - -contains - - -!================================================================================================================= -!>\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-dependent "blend". -!! Because the final value is "phase-aware", this formulation may be preferred for use throughout bl_mynn.F and -!! sf_mynn.F (replacing "svp"). - - function esat_blend(t,t0c,tice) - implicit none - - real(kind=kind_phys),intent(in):: t,t0c,tice - real(kind=kind_phys):: esat_blend,xc,esl,esi,chi - - xc = max(-80.,t-t0c) - -!For 253 < t < 273.16 K, the vapor pressures are "blended" as a function of temperature, using the approach of -!Chaboureau and Bechtold (2002), JAS, p. 2363. The resulting values are returned from the function. - if(t .ge. t0c) 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 = (273.16-t)/20.16 - esat_blend = (1.-chi)*esl + chi*esi - end if - - end function esat_blend - -!================================================================================================================= -!>\ingroup gsd_mynn_edmf -!! \author JAYMES- added 22 Apr 2015 -!! This function extends function "esat" and returns a "blended" saturation mixing ratio. - - function qsat_blend(t,t0c,tice,p,waterice) - implicit none - - real(kind=kind_phys),intent(in):: t,t0c,tice,p - character(len=1),intent(in),optional:: waterice - character(len=1):: wrt - real(kind=kind_phys):: qsat_blend,xc,esl,esi,rslf,rsif,chi - - if(.not. present(waterice) ) then - wrt = 'b' - else - wrt = waterice - endif - - xc=max(-80.,t-t0c) - - if((t .ge. t0c) .or. (wrt .eq. 'w')) then - esl = j0+xc*(j1+xc*(j2+xc*(j3+xc*(j4+xc*(j5+xc*(j6+xc*(j7+xc*j8))))))) - qsat_blend = 0.622*esl/(p-esl) - else if(t .le. tice) then - esi = k0+xc*(k1+xc*(k2+xc*(k3+xc*(k4+xc*(k5+xc*(k6+xc*(k7+xc*k8))))))) - qsat_blend = 0.622*esi/(p-esi) - 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))))))) - rslf = 0.622*esl/(p-esl) - rsif = 0.622*esi/(p-esi) - chi = (t0c-t)/(t0c-tice) - qsat_blend = (1.-chi)*rslf + chi*rsif - end if - - end function qsat_blend - -!================================================================================================================= -!>\ingroup gsd_mynn_edmf -!! \author jaymes- added 22 apr 2015 -!! 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. - - function xl_blend(t,t0c,tice,cice,cliq,cpv,xls,xlv) - implicit none - - real(kind=kind_phys),intent(in):: t,t0c,tice - real(kind=kind_phys),intent(in):: cice,cliq,cpv,xls,xlv - real(kind=kind_phys):: xl_blend,xlvt,xlst,chi - - 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 = (t0c-t)/(t0c-tice) - xl_blend = (1.-chi)*xlvt + chi*xlst !blended - end if - - end function xl_blend - -!================================================================================================================= - end module mynn_shared -!================================================================================================================= diff --git a/src/core_atmosphere/physics/physics_mmm/sf_mynn.F b/src/core_atmosphere/physics/physics_mmm/sf_mynn.F deleted file mode 100644 index e324ef4aab..0000000000 --- a/src/core_atmosphere/physics/physics_mmm/sf_mynn.F +++ /dev/null @@ -1,2237 +0,0 @@ -!================================================================================================================= - module sf_mynn - -!------------------------------------------------------------------- -!Modifications implemented by Joseph Olson NOAA/GSL -!The following overviews the current state of this scheme:: -! -! BOTH LAND AND WATER: -!1) Calculation of stability parameter (z/L) taken from Li et al. (2010 BLM) -! for first iteration of first time step; afterwards, exact calculation -! using a brute force iterative method described in Olson et al. (2021 NOAA -! Tech memorandum). This method replaces the iterative technique used in -! module_sf_sfclayrev.F (Jimenez et al. 2013) with mods. Either technique -! gives about the same result. The former technique is retained in this -! module (commented out) for potential subsequent benchmarking. -!2) Fixed isflux=0 option to turn off scalar fluxes, but keep momentum -! fluxes for idealized studies (credit: Anna Fitch). -!3) Kinematic viscosity varies with temperature according to Andreas (1989). -!4) Uses the blended Monin-Obukhov flux-profile relationships COARE (Fairall -! et al 2003) for the unstable regime (a blended mix of Dyer-Hicks 1974 and -! Grachev et al (2000). Uses Cheng and Brutsaert (2005) for stable conditions. -!5) The following overviews the namelist variables that control the -! aerodynamic roughness lengths (over water) and the thermal and moisture -! roughness lengths (defaults are recommended): -! -! LAND only: -! "iz0tlnd" namelist option is used to select the following options: -! (default) =0: Zilitinkevich (1995); Czil now set to 0.085 -! =1: Czil_new (modified according to Chen & Zhang 2008) -! =2: Modified Yang et al (2002, 2008) - generalized for all landuse -! =3: constant zt = z0/7.4 (original form; Garratt 1992) -! -! WATER only: -! "isftcflx" namelist option is used to select the following options: -! (default) =0: z0, zt, and zq from the COARE algorithm. Set COARE_OPT (below) to -! 3.0 (Fairall et al. 2003, default) -! 3.5 (Edson et al 2013) - now with bug fix (Edson et al. 2014, JPO) -! =1: z0 from Davis et al (2008), zt & zq from COARE 3.0/3.5 -! =2: z0 from Davis et al (2008), zt & zq from Garratt (1992) -! =3: z0 from Taylor and Yelland (2004), zt and zq from COARE 3.0/3.5 -! -! SNOW/ICE only: -! Andreas (2002) snow/ice parameterization for thermal and -! moisture roughness is used over all gridpoints with snow deeper than -! 0.1 m. This algorithm calculates a z0 for snow (Andreas et al. 2005, BLM), -! which is only used as part of the thermal and moisture roughness -! length calculation, not to directly impact the surface winds. -! -! Misc: -!1) Added a more elaborate diagnostic for u10 & V10 for high vertical resolution -! model configurations but for most model configurations with depth of -! the lowest half-model level near 10 m, a neutral-log diagnostic is used. -! -!2) Option to activate stochastic parameter perturbations (SPP), which -! perturb z0, zt, and zq, along with many other parameters in the MYNN- -! EDMF scheme. -! -!NOTE: This code was primarily tested in combination with the RUC LSM. -! Performance with the Noah (or other) LSM is relatively unknown. -!------------------------------------------------------------------- - use ccpp_kinds,only: kind_phys - use mynn_shared,only: esat_blend,qsat_blend,xl_blend - - implicit none - private - public:: sf_mynn_run, & - sf_mynn_init, & - sf_mynn_finalize - - - logical,parameter:: debug_code = .false. - integer,parameter:: psi_opt = 0 ! 0 = stable: Cheng and Brustaert - ! unstable: blended COARE - ! 1 = GFS - real,parameter:: wmin = 0.1 - real,parameter:: vconvc = 1.25 - real,parameter:: snowz0 = 0.011 - real,parameter:: coare_opt = 3.0 ! 3.0 or 3.5 - !For debugging purposes: - - real,dimension(0:1000),save:: psim_stab,psim_unstab, & - psih_stab,psih_unstab - - - contains - - -!================================================================================================================= -!>\section arg_table_sf_mynn_init -!!\html\include sf_mynn_init.html -!! - subroutine sf_mynn_init(errmsg,errflg) -!================================================================================================================= - -!--- output arguments: - character(len=*),intent(out):: errmsg - integer,intent(out):: errflg - -!----------------------------------------------------------------------------------------------------------------- - - call psi_init(psi_opt) - - errmsg = ' ' - errflg = 0 - - end subroutine sf_mynn_init - -!================================================================================================================= -!>\section arg_table_sf_mynn_finalize -!!\html\include sf_mynn_finalize.html -!! - subroutine sf_mynn_finalize(errmsg,errflg) -!================================================================================================================= - -!--- output arguments: - character(len=*),intent(out):: errmsg - integer,intent(out):: errflg - -!----------------------------------------------------------------------------------------------------------------- - - errmsg = ' ' - errflg = 0 - - end subroutine sf_mynn_finalize - -!================================================================================================================= -!>\section arg_table_sf_mynn_run -!!\html\include sf_mynn_run.html -!! - subroutine sf_mynn_run( & - u1d,v1d,t1d,qv1d,p1d,dz8w1d,rho1d, & - u1d2,v1d2,dz2w1d,cp,g,rovcp,r,xlv, & - psfcpa,chs,chs2,cqs2,cpm,pblh,rmol, & - znt,ust,mavail,zol,mol,regime,psim, & - psih,xland,hfx,qfx,tsk,u10,v10,th2, & - t2,q2,flhc,flqc,snowh,qgh,qsfc,lh, & - gz1oz0,wspd,br,isfflx,dx,svp1,svp2, & - svp3,svpt0,ep1,ep2,karman,ch,qcg, & - itimestep,wstar,qstar,ustm,ck,cka, & - cd,cda,spp_pbl,rstoch1d,isftcflx, & - iz0tlnd,its,ite,errmsg,errflg & - ) - implicit none -!================================================================================================================= - -!----------------------------- -! scalars: -!----------------------------- - integer,intent(in):: its,ite - integer,intent(in):: itimestep - - real(kind=kind_phys),intent(in):: svp1,svp2,svp3,svpt0,ep1,ep2 - real(kind=kind_phys),intent(in):: karman,cp,g,rovcp,r,xlv - - real(kind=kind_phys),parameter:: prt=1. !prandlt number - real(kind=kind_phys),parameter:: xka=2.4e-5 !molecular diffusivity - - character(len=*),intent(out):: errmsg - integer,intent(out):: errflg - -!----------------------------- -! namelist options -!----------------------------- - logical,intent(in):: spp_pbl - - integer,intent(in):: isfflx - integer,intent(in),optional:: isftcflx,iz0tlnd - -!----------------------------- -! 1d arrays -!----------------------------- - real(kind=kind_phys),intent(in),dimension(its:ite):: mavail, & - pblh, & - xland, & - tsk, & - psfcpa, & - qcg, & - snowh, & - dx - - real(kind=kind_phys),intent(in),dimension(its:ite):: u1d, & - v1d, & - u1d2, & - v1d2, & - qv1d, & - p1d, & - t1d, & - dz8w1d, & - dz2w1d, & - rho1d - real(kind=kind_phys),intent(in),dimension(its:ite):: & - rstoch1d - - - real(kind=kind_phys),intent(inout),dimension(its:ite):: & - regime, & - hfx, & - qfx, & - lh, & - mol, & - rmol, & - qgh, & - qsfc, & - znt, & - zol, & - ust, & - cpm, & - chs2, & - cqs2, & - chs, & - ch, & - flhc, & - flqc, & - gz1oz0, & - wspd, & - br, & - psim, & - psih - -!----------------------------- -! diagnostic outputs: -!----------------------------- - real(kind=kind_phys),intent(out),dimension(its:ite):: & - u10, & - v10, & - th2, & - t2, & - q2 - - real(kind=kind_phys),intent(out),dimension(its:ite):: & - wstar, & - qstar - - real(kind=kind_phys),intent(out),dimension(its:ite),optional:: & - ck, & - cka, & - cd, & - cda, & - ustm - -!----------------------------- -! local variables -!----------------------------- - integer:: n,i,k,l,yesno - - real(kind=kind_phys):: ep3 - real(kind=kind_phys):: pl,thcon,tvcon,e1 - real(kind=kind_phys):: dthvdz,dthvm,vconv,zol2,zol10,zolza,zolz0,zolzt - real(kind=kind_phys):: dtg,psix,dtthx,dthdz,psix10,psit,psit2, & - psiq,psiq2,psiq10,dzdt - real(kind=kind_phys):: fluxc,vsgd - real(kind=kind_phys):: restar,visc,dqg,oldust,oldtst - - real(kind=kind_phys),dimension(its:ite) :: & - za, & !height of lowest 1/2 sigma level(m) - za2, & !height of 2nd lowest 1/2 sigma level(m) - thv1d, & !theta-v at lowest 1/2 sigma (K) - th1d, & !theta at lowest 1/2 sigma (K) - tc1d, & !t at lowest 1/2 sigma (Celsius) - tv1d, & !tv at lowest 1/2 sigma (K) - qvsh, & !qv at lowest 1/2 sigma (spec humidity) - psih2, & !m-o stability functions at z=2 m - psim10, & !m-o stability functions at z=10 m - psih10, & !m-o stability functions at z=10 m - wspdi, & - z_q, & !moisture roughness length - z_t, & !thermalroughness length - ZNTstoch, & - govrth, & !g/theta - thgb, & !theta at ground - thvgb, & !theta-v at ground - psfc, & !press at surface (Pa/1000) - qsfcmr, & !qv at surface (mixing ratio, kg/kg) - gz2oz0, & !log((2.0+znt(i))/znt(i)) - gz10oz0, & !log((10.+znt(i))/znt(i)) - gz2ozt, & !log((2.0+z_t(i))/z_t(i)) - gz10ozt, & !log((10.+z_t(i))/z_t(i)) - gz1ozt, & !log((za(i)+z_t(i))/z_t(i)) - zratio !z0/zt - -!----------------------------------------------------------------------------------------------------------------- - - ep3 = 1.-ep2 - - do i=its,ite - !convert ground & lowest layer temperature to potential temperature: - !psfc cmb - psfc(i)=psfcpa(i)/1000. - thgb(i)=tsk(i)*(100./psfc(i))**rovcp !(K) - !PL cmb - pl=p1d(i)/1000. - thcon=(100./pl)**rovcp - th1d(i)=t1d(i)*thcon !(Theta, K) - tc1d(i)=t1d(i)-273.15 !(T, Celsius) - - !convert to virtual temperature - qvsh(i)=qv1d(i)/(1.+qv1d(i)) !convert to spec hum (kg/kg) - tvcon=(1.+ep1*qvsh(i)) - thv1d(i)=th1d(i)*tvcon !(K) - tv1d(i)=t1d(i)*tvcon !(K) - - !rho1d(i)=psfcpa(i)/(r*tv1d(i)) !now using value calculated in sfc driver - za(i)=0.5*dz8w1d(i) !height of first half-sigma level - za2(i)=dz8w1d(i) + 0.5*dz2w1d(i) !height of 2nd half-sigma level - govrth(i)=g/th1d(i) - enddo - - do i=its,ite - if (tsk(i) .lt. 273.15) then - !saturation vapor pressure wrt ice (svp1=.6112; 10*mb) - e1=svp1*exp(4648*(1./273.15 - 1./tsk(i)) - & - & 11.64*log(273.15/tsk(i)) + 0.02265*(273.15 - tsk(i))) - else - !saturation vapor pressure wrt water (Bolton 1980) - e1=svp1*exp(svp2*(tsk(i)-svpt0)/(tsk(i)-svp3)) - endif - !for land points, qsfc can come from lsm, only recompute over water - if (xland(i).gt.1.5 .or. qsfc(i).le.0.0) then !water - qsfc(i)=ep2*e1/(psfc(i)-ep3*e1) !specific humidity - qsfcmr(i)=ep2*e1/(psfc(i)-e1) !mixing ratio - else !land - qsfcmr(i)=qsfc(i)/(1.-qsfc(i)) - endif - - !qgh changed to use lowest-level air temp consistent with myjsfc change - !q2sat = qgh in LSM - if (tsk(i) .lt. 273.15) then - !saturation vapor pressure wrt ice - e1=svp1*exp(4648*(1./273.15 - 1./t1d(i)) - & - & 11.64*log(273.15/t1d(i)) + 0.02265*(273.15 - t1d(i))) - else - !saturation vapor pressure wrt water (Bolton 1980) - e1=svp1*exp(svp2*(t1d(i)-svpt0)/(t1d(i)-svp3)) - endif - pl=p1d(i)/1000. - !qgh(i)=ep2*e1/(pl-ep_3*e1) !specific humidity - qgh(i)=ep2*e1/(pl-e1) !mixing ratio - cpm(i)=cp*(1.+0.84*qv1d(i)) - enddo - - do i=its,ite - wspd(i)=sqrt(u1d(i)*u1d(i)+v1d(i)*v1d(i)) - - !tgs:thvgb(i)=thgb(i)*(1.+ep1*qsfc(i)*mavail(i)) - thvgb(i)=thgb(i)*(1.+ep1*qsfc(i)) - - dthdz=(th1d(i)-thgb(i)) - dthvdz=(thv1d(i)-thvgb(i)) - - !-------------------------------------------------------- - ! Calculate the convective velocity scale (WSTAR) and - ! subgrid-scale velocity (VSGD) following Beljaars (1995, QJRMS) - ! and Mahrt and Sun (1995, MWR), respectively - !------------------------------------------------------- - !Use Beljaars over land and water - fluxc = max(hfx(i)/rho1d(i)/cp & - & + ep1*thvgb(i)*qfx(i)/rho1d(i),0.) - !wstar(i) = vconvc*(g/tsk(i)*pblh(i)*fluxc)**.33 - if (xland(i).gt.1.5 .or. qsfc(i).le.0.0) then !water - wstar(i) = vconvc*(g/tsk(i)*pblh(i)*fluxc)**.33 - else !land - !increase height scale, assuming that the non-local transoport - !from the mass-flux (plume) mixing exceedsd the pblh. - wstar(i) = vconvc*(g/tsk(i)*min(1.5*pblh(i),4000.)*fluxc)**.33 - endif - !-------------------------------------------------------- - ! Mahrt and Sun low-res correction - ! (for 13 km ~ 0.37 m/s; for 3 km == 0 m/s) - !-------------------------------------------------------- - vsgd = 0.32 * (max(dx(i)/5000.-1.,0.))**.33 - wspd(i)=sqrt(wspd(i)*wspd(i)+wstar(i)*wstar(i)+vsgd*vsgd) - wspd(i)=max(wspd(i),wmin) - - !-------------------------------------------------------- - ! calculate the bulk richardson number of surface layer, - ! according to Akb(1976), Eq(12). - !-------------------------------------------------------- - br(i)=govrth(i)*za(i)*dthvdz/(wspd(i)*wspd(i)) - if (itimestep == 1) then - !set limits according to Li et al. (2010) boundary-layer meteorol (p.158) - br(i)=max(br(i),-2.0) - br(i)=min(br(i),2.0) - else - br(i)=max(br(i),-4.0) - br(i)=min(br(i), 4.0) - endif - - ! if previously unstable, do not let into regimes 1 and 2 (stable) - ! if (itimestep .gt. 1) then - ! if(mol(i).lt.0.)br(i)=min(br(i),0.0) - !endif - - enddo - - 1006 format(a,f7.3,a,f9.4,a,f9.5,a,f9.4) - 1007 format(a,f2.0,a,f6.2,a,f7.3,a,f7.2) - -!-------------------------------------------------------------------- -!-------------------------------------------------------------------- -!--- begin i-loop -!-------------------------------------------------------------------- -!-------------------------------------------------------------------- - - do i=its,ite - - !compute kinematic viscosity (m2/s) Andreas (1989) CRREL Rep. 89-11 - !valid between -173 and 277 degrees C. - visc=1.326e-5*(1. + 6.542e-3*tc1d(i) + 8.301e-6*tc1d(i)*tc1d(i) & - - 4.84e-9*tc1d(i)*tc1d(i)*tc1d(i)) - - if ((xland(i)-1.5).ge.0) then - !-------------------------------------- - ! water - !-------------------------------------- - ! calculate z0 (znt) - !-------------------------------------- - if ( present(isftcflx) ) then - if ( isftcflx .eq. 0 ) then - if (coare_opt .eq. 3.0) then - !COARE 3.0 (misleading subroutine name) - call charnock_1955(znt(i),ust(i),wspd(i),visc,za(i)) - else - !COARE 3.5 - call edson_etal_2013(znt(i),ust(i),wspd(i),visc,za(i)) - endif - elseif ( isftcflx .eq. 1 .or. isftcflx .eq. 2 ) then - call davis_etal_2008(znt(i),ust(i)) - elseif ( isftcflx .eq. 3 ) then - call taylor_yelland_2001(znt(i),ust(i),wspd(i)) - elseif ( isftcflx .eq. 4 ) then - if (coare_opt .eq. 3.0) then - !COARE 3.0 (MISLEADING SUBROUTINE NAME) - call charnock_1955(znt(i),ust(i),wspd(i),visc,za(i)) - else - !COARE 3.5 - call edson_etal_2013(znt(i),ust(i),wspd(i),visc,za(i)) - endif - endif - else - !default to COARE 3.0/3.5 - if (coare_opt .eq. 3.0) then - !COARE 3.0 - call charnock_1955(znt(i),ust(i),wspd(i),visc,za(i)) - else - !COARE 3.5 - call edson_etal_2013(znt(i),ust(i),wspd(i),visc,za(i)) - endif - endif - - !add stochastic perturbaction of ZNT - if (spp_pbl) then - zntstoch(i) = max(znt(i) + znt(i)*1.0*rstoch1d(i), 1e-6) - else - zntstoch(i) = znt(i) - endif - - !compute roughness reynolds number (restar) using new znt - ! AHW: Garrattt formula: Calculate roughness Reynolds number - ! Kinematic viscosity of air (linear approx to - ! temp dependence at sea level) - restar=max(ust(i)*zntstoch(i)/visc, 0.1) - - !-------------------------------------- - !calculate z_t and z_q - !-------------------------------------- - if ( present(isftcflx) ) then - if ( isftcflx .eq. 0 ) then - if (coare_opt .eq. 3.0) then - call fairall_etal_2003(z_t(i),z_q(i),restar,ust(i),visc,rstoch1d(i),spp_pbl) - else - !presumably, this will be published soon, but hasn't yet - call fairall_etal_2014(z_t(i),z_q(i),restar,ust(i),visc,rstoch1d(i),spp_pbl) - endif - elseif ( isftcflx .eq. 1 ) then - if (coare_opt .eq. 3.0) then - call fairall_etal_2003(z_t(i),z_q(i),restar,ust(i),visc,rstoch1d(i),spp_pbl) - else - call fairall_etal_2014(z_t(i),z_q(i),restar,ust(i),visc,rstoch1d(i),spp_pbl) - endif - elseif ( isftcflx .eq. 2 ) then - call garratt_1992(z_t(i),z_q(i),zntstoch(i),restar,xland(i)) - elseif ( isftcflx .eq. 3 ) then - if (coare_opt .eq. 3.0) then - call fairall_etal_2003(z_t(i),z_q(i),restar,ust(i),visc,rstoch1d(i),spp_pbl) - else - call fairall_etal_2014(z_t(i),z_q(i),restar,ust(i),visc,rstoch1d(i),spp_pbl) - endif - endif - else - !default to COARE 3.0/3.5 - if (coare_opt .eq. 3.0) then - call fairall_etal_2003(z_t(i),z_q(i),restar,ust(i),visc,rstoch1d(i),spp_pbl) - else - call fairall_etal_2014(z_t(i),z_q(i),restar,ust(i),visc,rstoch1d(i),spp_pbl) - endif - endif - - else - - !add stochastic perturbaction of znt - if (spp_pbl) then - zntstoch(i) = max(znt(i) + znt(i)*1.0*rstoch1d(i), 1e-6) - else - zntstoch(i) = znt(i) - endif - - !-------------------------------------- - ! land - !-------------------------------------- - !compute roughness reynolds number (restar) using default znt - restar=max(ust(i)*zntstoch(i)/visc, 0.1) - - !-------------------------------------- - ! get z_t and z_q - !-------------------------------------- - !check for snow/ice points over land - if ( snowh(i) .ge. 0.1) then - call andreas_2002(zntstoch(i),visc,ust(i),z_t(i),z_q(i)) - else - if ( present(iz0tlnd) ) then - if ( iz0tlnd .le. 1 ) then - call zilitinkevich_1995(zntstoch(i),z_t(i),z_q(i),restar,& - ust(i),karman,xland(i),iz0tlnd,spp_pbl,rstoch1d(i)) - elseif ( iz0tlnd .eq. 2 ) then - call yang_2008(zntstoch(i),z_t(i),z_q(i),ust(i),mol(i),& - qstar(i),restar,visc,xland(i)) - elseif ( iz0tlnd .eq. 3 ) then - !original mynn in wrf-arw used this form: - call garratt_1992(z_t(i),z_q(i),zntstoch(i),restar,xland(i)) - endif - else - !default to zilitinkevich - call zilitinkevich_1995(zntstoch(i),z_t(i),z_q(i),restar,& - ust(i),karman,xland(i),0,spp_pbl,rstoch1d(i)) - endif - endif - - endif - zratio(i)=zntstoch(i)/z_t(i) !needed for Li et al. - - gz1oz0(i)= log((za(i)+zntstoch(i))/zntstoch(i)) - gz1ozt(i)= log((za(i)+zntstoch(i))/z_t(i)) - gz2oz0(i)= log((2.0+zntstoch(i))/zntstoch(i)) - gz2ozt(i)= log((2.0+zntstoch(i))/z_t(i)) - gz10oz0(i)=log((10.+zntstoch(i))/zntstoch(i)) - gz10ozt(i)=log((10.+zntstoch(i))/z_t(i)) - - !-------------------------------------------------------------------- - !--- DIAGNOSE BASIC PARAMETERS FOR THE APPROPRIATE STABILITY CLASS: - ! - ! THE STABILITY CLASSES ARE DETERMINED BY BR (BULK RICHARDSON NO.). - ! - ! CRITERIA FOR THE CLASSES ARE AS FOLLOWS: - ! - ! 1. BR .GE. 0.2; - ! REPRESENTS NIGHTTIME STABLE CONDITIONS (REGIME=1), - ! - ! 2. BR .LT. 0.2 .AND. BR .GT. 0.0; - ! REPRESENTS DAMPED MECHANICAL TURBULENT CONDITIONS - ! (REGIME=2), - ! - ! 3. BR .EQ. 0.0 - ! REPRESENTS FORCED CONVECTION CONDITIONS (REGIME=3), - ! - ! 4. BR .LT. 0.0 - ! REPRESENTS FREE CONVECTION CONDITIONS (REGIME=4). - ! - !-------------------------------------------------------------------- - if (br(i) .gt. 0.0) then - if (br(i) .gt. 0.2) then - !---class 1; stable (nighttime) conditions: - regime(i)=1. - else - !---class 2; damped mechanical turbulence: - regime(i)=2. - endif - - !compute z/l first guess: - if (itimestep .le. 1) then - call li_etal_2010(zol(i),br(i),za(i)/zntstoch(i),zratio(i)) - else - zol(i)=za(i)*karman*g*mol(i)/(th1d(i)*max(ust(i)*ust(i),0.0001)) - zol(i)=max(zol(i),0.0) - zol(i)=min(zol(i),20.) - endif - - !Use Pedros iterative function to find z/L - !zol(i)=zolri(br(i),za(i),zntstoch(i),z_t(i),zol(i),psi_opt) - !Use brute-force method - zol(i)=zolrib(br(i),za(i),zntstoch(i),z_t(i),gz1oz0(i),gz1ozt(i),zol(i),psi_opt) - zol(i)=max(zol(i),0.0) - zol(i)=min(zol(i),20.) - - zolzt = zol(i)*z_t(i)/za(i) ! zt/l - zolz0 = zol(i)*zntstoch(i)/za(i) ! z0/l - zolza = zol(i)*(za(i)+zntstoch(i))/za(i) ! (z+z0/l - zol10 = zol(i)*(10.+zntstoch(i))/za(i) ! (10+z0)/l - zol2 = zol(i)*(2.+zntstoch(i))/za(i) ! (2+z0)/l - - !compute psim and psih - if ((xland(i)-1.5).ge.0) then - ! water - !call psi_suselj_sood_2010(psim(i),psih(i),zol(i)) - !call psi_beljaars_holtslag_1991(psim(i),psih(i),zol(i)) - !call psi_businger_1971(psim(i),psih(i),zol(i)) - !call psi_dyerhicks(psim(i),psih(i),zol(i),z_t(i),zntstoch(i),za(i)) - !call psi_cb2005(psim(i),psih(i),zolza,zolz0) - ! or use tables - psim(i)=psim_stable(zolza,psi_opt)-psim_stable(zolz0,psi_opt) - psih(i)=psih_stable(zolza,psi_opt)-psih_stable(zolzt,psi_opt) - psim10(i)=psim_stable(zol10,psi_opt)-psim_stable(zolz0,psi_opt) - psih10(i)=psih_stable(zol10,psi_opt)-psih_stable(zolz0,psi_opt) - psih2(i)=psih_stable(zol2,psi_opt)-psih_stable(zolz0,psi_opt) - else - ! land - !call psi_beljaars_holtslag_1991(psim(i),psih(i),zol(i)) - !call psi_businger_1971(psim(i),psih(i),zol(i)) - !call psi_zilitinkevich_esau_2007(psim(i),psih(i),zol(i)) - !call psi_dyerhicks(psim(i),psih(i),zol(i),z_t(i),zntstoch(i),za(i)) - !call psi_cb2005(psim(i),psih(i),zolza,zolz0) - ! or use tables - psim(i)=psim_stable(zolza,psi_opt)-psim_stable(zolz0,psi_opt) - psih(i)=psih_stable(zolza,psi_opt)-psih_stable(zolzt,psi_opt) - psim10(i)=psim_stable(zol10,psi_opt)-psim_stable(zolz0,psi_opt) - psih10(i)=psih_stable(zol10,psi_opt)-psih_stable(zolz0,psi_opt) - psih2(i)=psih_stable(zol2,psi_opt)-psih_stable(zolz0,psi_opt) - endif - - !psim10(i)=10./za(i)*psim(i) - !psih10(i)=10./za(i)*psih(i) - !psim2(i)=2./za(i)*psim(i) - !psih2(i)=2./za(i)*psih(i) - - ! 1.0 over monin-obukhov length - rmol(i)= zol(i)/za(i) - - elseif(br(i) .eq. 0.) then - !========================================================= - !-----class 3; forced convection/neutral: - !========================================================= - regime(i)=3. - - psim(i)=0.0 - psih(i)=psim(i) - psim10(i)=0. - psih10(i)=0. - psih2(i)=0. - - zol(i)=0. - !if (ust(i) .lt. 0.01) then - ! zol(i)=br(i)*gz1oz0(i) - !else - ! zol(i)=karman*govrth(i)*za(i)*mol(i)/(max(ust(i)*ust(i),0.001)) - !endif - rmol(i) = zol(i)/za(i) - - elseif(br(i) .lt. 0.)then - !========================================================== - !-----class 4; free convection: - !========================================================== - regime(i)=4. - - !compute z/l first guess: - if (itimestep .le. 1) then - call li_etal_2010(zol(i),br(i),za(i)/zntstoch(i),zratio(i)) - else - zol(i)=za(i)*karman*g*mol(i)/(th1d(i)*max(ust(i)*ust(i),0.001)) - zol(i)=max(zol(i),-20.0) - zol(i)=min(zol(i),0.0) - endif - - !Use Pedros iterative function to find z/L - !zol(I)=zolri(br(I),ZA(I),ZNTstoch(I),z_t(I),ZOL(I),psi_opt) - !Use alternative method - zol(i)=zolrib(br(i),za(i),zntstoch(i),z_t(i),gz1oz0(i),gz1ozt(i),zol(i),psi_opt) - zol(i)=max(zol(i),-20.0) - zol(i)=min(zol(i),0.0) - - zolzt = zol(i)*z_t(i)/za(i) ! zt/l - zolz0 = zol(i)*zntstoch(i)/za(i) ! z0/l - zolza = zol(i)*(za(i)+zntstoch(i))/za(i) ! (z+z0/l - zol10 = zol(i)*(10.+zntstoch(i))/za(i) ! (10+z0)/l - zol2 = zol(i)*(2.+zntstoch(i))/za(i) ! (2+z0)/l - - !compute psim and psih - if ((xland(i)-1.5).ge.0) then - ! water - !call psi_suselj_sood_2010(psim(i),psih(i),zol(i)) - !call psi_hogstrom_1996(psim(i),psih(i),zol(i), z_t(i), zntstoch(i), za(i)) - !call psi_businger_1971(psim(i),psih(i),zol(i)) - !call psi_dyerhicks(psim(i),psih(i),zol(i),z_t(i),zntstoch(i),za(i)) - ! use tables - psim(i)=psim_unstable(zolza,psi_opt)-psim_unstable(zolz0,psi_opt) - psih(i)=psih_unstable(zolza,psi_opt)-psih_unstable(zolzt,psi_opt) - psim10(i)=psim_unstable(zol10,psi_opt)-psim_unstable(zolz0,psi_opt) - psih10(i)=psih_unstable(zol10,psi_opt)-psih_unstable(zolz0,psi_opt) - psih2(i)=psih_unstable(zol2,psi_opt)-psih_unstable(zolz0,psi_opt) - else - ! land - !call psi_hogstrom_1996(psim(i),psih(i),zol(i), z_t(i), zntstoch(i), za(i)) - !call psi_businger_1971(psim(i),psih(i),zol(i)) - !call psi_dyerhicks(psim(i),psih(i),zol(i),z_t(i),zntstoch(i),za(i)) - ! use tables - psim(i)=psim_unstable(zolza,psi_opt)-psim_unstable(zolz0,psi_opt) - psih(i)=psih_unstable(zolza,psi_opt)-psih_unstable(zolzt,psi_opt) - psim10(i)=psim_unstable(zol10,psi_opt)-psim_unstable(zolz0,psi_opt) - psih10(i)=psih_unstable(zol10,psi_opt)-psih_unstable(zolz0,psi_opt) - psih2(i)=psih_unstable(zol2,psi_opt)-psih_unstable(zolz0,psi_opt) - endif - - !psim10(i)=10./za(i)*psim(i) - !psih2(i)=2./za(i)*psih(i) - - !---limit psih and psim in the case of thin layers and - !---high roughness. this prevents denominator in fluxes - !---from getting too small - psih(i)=min(psih(i),0.9*gz1ozt(i)) - psim(i)=min(psim(i),0.9*gz1oz0(i)) - psih2(i)=min(psih2(i),0.9*gz2ozt(i)) - psim10(i)=min(psim10(i),0.9*gz10oz0(i)) - psih10(i)=min(psih10(i),0.9*gz10ozt(i)) - - rmol(i) = zol(i)/za(i) - - endif - - !------------------------------------------------------------ - !-----compute the frictional velocity: - !------------------------------------------------------------ - ! Za(1982) Eqs(2.60),(2.61). - psix=gz1oz0(i)-psim(i) - psix10=gz10oz0(i)-psim10(i) - ! to prevent oscillations average with old value - oldust = ust(i) - ust(i)=0.5*ust(i)+0.5*karman*wspd(i)/psix - !non-averaged: ust(i)=karman*wspd(i)/psix - - ! compute u* without vconv for use in hfx calc when isftcflx > 0 - wspdi(i)=max(sqrt(u1d(i)*u1d(i)+v1d(i)*v1d(i)), wmin) - if ( present(ustm) ) then - ustm(i)=0.5*ustm(i)+0.5*karman*wspdi(i)/psix - endif - - if ((xland(i)-1.5).lt.0.) then !land - ust(i)=max(ust(i),0.005) !further relaxing this limit - no need to go lower - !keep ustm = ust over land. - if ( present(ustm) ) ustm(i)=ust(i) - endif - - !------------------------------------------------------------ - !-----compute the thermal and moisture resistance (psiq and psit): - !------------------------------------------------------------ - ! lower limit added to prevent large flhc in soil model - ! activates in unstable conditions with thin layers or high z0 - gz1ozt(i)= log((za(i)+zntstoch(i))/z_t(i)) - gz2ozt(i)= log((2.0+zntstoch(i))/z_t(i)) - - psit =max(gz1ozt(i)-psih(i) ,1.) - psit2=max(gz2ozt(i)-psih2(i),1.) - - psiq=max(log((za(i)+zntstoch(i))/z_q(i))-psih(i) ,1.0) - psiq2=max(log((2.0+zntstoch(i))/z_q(i))-psih2(i) ,1.0) - psiq10=max(log((10.0+zntstoch(i))/z_q(i))-psih10(i) ,1.0) - !---------------------------------------------------- - !compute the temperature scale (or friction temperature, T*) - !---------------------------------------------------- - dtg=thv1d(i)-thvgb(i) - oldtst=mol(i) - mol(i)=karman*dtg/psit/prt - !t_star(i) = -hfx(i)/(ust(i)*cpm(i)*rho1d(i)) - !t_star(i) = mol(i) - !---------------------------------------------------- - !compute the moisture scale (or q*) - dqg=(qvsh(i)-qsfc(i))*1000. !(kg/kg -> g/kg) - qstar(i)=karman*dqg/psiq/prt - - !if () then - ! write(*,1001)"regime:",regime(i)," z/l:",zol(i)," u*:",ust(i)," tstar:",mol(i) - ! write(*,1002)"psim:",psim(i)," psih:",psih(i)," w*:",wstar(i)," dthv:",thv1d(i)-thvgb(i) - ! write(*,1003)"cpm:",cpm(i)," rho1d:",rho1d(i)," l:",zol(i)/za(i)," dth:",th1d(i)-thgb(i) - ! write(*,1004)"z0/zt:",zratio(i)," z0:",zntstoch(i)," zt:",z_t(i)," za:",za(i) - ! write(*,1005)"re:",restar," mavail:",mavail(i)," qsfc(i):",qsfc(i)," qvsh(i):",qvsh(i) - ! print*,"visc=",visc," z0:",zntstoch(i)," t1d(i):",t1d(i) - ! write(*,*)"=============================================" - !endif - - enddo ! end i-loop - - 1000 format(a,f6.1, a,f6.1, a,f5.1, a,f7.1) - 1001 format(a,f2.0, a,f10.4,a,f5.3, a,f11.5) - 1002 format(a,f7.2, a,f7.2, a,f7.2, a,f10.3) - 1003 format(a,f7.2, a,f7.2, a,f10.3,a,f10.3) - 1004 format(a,f11.3,a,f9.7, a,f9.7, a,f6.2, a,f10.3) - 1005 format(a,f9.2,a,f6.4,a,f7.4,a,f7.4) - - !---------------------------------------------------------- - ! compute surface heat and moisture fluxes - !---------------------------------------------------------- - do i=its,ite - - !For computing the diagnostics and fluxes (below), whether the fluxes - !are turned off or on, we need the following: - psix=gz1oz0(i)-psim(i) - psix10=gz10oz0(i)-psim10(i) - - psit =max(gz1ozt(i)-psih(i), 1.0) - psit2=max(gz2ozt(i)-psih2(i),1.0) - - psiq=max(log((za(i)+z_q(i))/z_q(i))-psih(i) ,1.0) - psiq2=max(log((2.0+z_q(i))/z_q(i))-psih2(i) ,1.0) - psiq10=max(log((10.0+z_q(i))/z_q(i))-psih10(i) ,1.0) - - if (isfflx .lt. 1) then - - qfx(i) = 0. - hfx(i) = 0. - flhc(i) = 0. - flqc(i) = 0. - lh(i) = 0. - chs(i) = 0. - ch(i) = 0. - chs2(i) = 0. - cqs2(i) = 0. - if(present(ck) .and. present(cd) .and. & - &present(cka) .and. present(cda)) then - ck(i) = 0. - cd(i) = 0. - cka(i)= 0. - cda(i)= 0. - endif - else - - !------------------------------------------ - ! calculate the exchange coefficients for heat (flhc) - ! and moisture (flqc) - !------------------------------------------ - flqc(i)=rho1d(i)*mavail(i)*ust(i)*karman/psiq - flhc(i)=rho1d(i)*cpm(i)*ust(i)*karman/psit - - !---------------------------------- - ! compute surface moisture flux: - !---------------------------------- - qfx(i)=flqc(i)*(qsfcmr(i)-qv1d(i)) - !joe: qfx(i)=max(qfx(i),0.) !originally did not allow neg qfx - qfx(i)=max(qfx(i),-0.02) !allows small neg qfx, like myj - lh(i)=xlv*qfx(i) - - !---------------------------------- - ! compute surface heat flux: - !---------------------------------- - if(xland(i)-1.5.gt.0.)then !water - hfx(i)=flhc(i)*(thgb(i)-th1d(i)) - if ( present(isftcflx) ) then - if ( isftcflx.ne.0 ) then - ! ahw: add dissipative heating term - hfx(i)=hfx(i)+rho1d(i)*ustm(i)*ustm(i)*wspdi(i) - endif - endif - elseif(xland(i)-1.5.lt.0.)then !land - hfx(i)=flhc(i)*(thgb(i)-th1d(i)) - hfx(i)=max(hfx(i),-250.) - endif - - !chs(i)=ust(i)*karman/(alog(karman*ust(i)*za(i) & - ! /xka+za(i)/zl)-psih(i)) - - chs(i)=ust(i)*karman/psit - - ! the exchange coefficient for cloud water is assumed to be the - ! same as that for heat. ch is multiplied by wspd. - - !ch(i)=chs(i) - ch(i)=flhc(i)/( cpm(i)*rho1d(i) ) - - !these are used for 2-m diagnostics only - cqs2(i)=ust(i)*karman/psiq2 - chs2(i)=ust(i)*karman/psit2 - - 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 - - endif !end isfflx option - - !----------------------------------------------------- - !compute diagnostics - !----------------------------------------------------- - !compute 10 m wnds - !----------------------------------------------------- - ! If the lowest model level is close to 10-m, use it - ! instead of the flux-based diagnostic formula. - if (za(i) .le. 7.0) then - ! high vertical resolution - if(za2(i) .gt. 7.0 .and. za2(i) .lt. 13.0) then - !use 2nd model level - u10(i)=u1d2(i) - v10(i)=v1d2(i) - else - u10(i)=u1d(i)*log(10./zntstoch(i))/log(za(i)/zntstoch(i)) - v10(i)=v1d(i)*log(10./zntstoch(i))/log(za(i)/zntstoch(i)) - endif - elseif(za(i) .gt. 7.0 .and. za(i) .lt. 13.0) then - !moderate vertical resolution - !u10(i)=u1d(i)*psix10/psix - !v10(i)=v1d(i)*psix10/psix - !use neutral-log: - u10(i)=u1d(i)*log(10./zntstoch(i))/log(za(i)/zntstoch(i)) - v10(i)=v1d(i)*log(10./zntstoch(i))/log(za(i)/zntstoch(i)) - else - ! very coarse vertical resolution - u10(i)=u1d(i)*psix10/psix - v10(i)=v1d(i)*psix10/psix - endif - - !----------------------------------------------------- - !compute 2m t, th, and q - !these will be overwritten for land points in the lsm - !----------------------------------------------------- - dtg=th1d(i)-thgb(i) - th2(i)=thgb(i)+dtg*psit2/psit - !*** be certain that the 2-m theta is bracketed by - !*** the values at the surface and lowest model level. - if ((th1d(i)>thgb(i) .and. (th2(i)th1d(i))) .or. & - (th1d(i)thgb(i) .or. th2(i) 1200. .or. hfx(i) < -700.)then - print*,"suspicious values in mynn sfclayer",& - i, "hfx: ",hfx(i) - yesno = 1 - endif - if (lh(i) > 1200. .or. lh(i) < -700.)then - print*,"suspicious values in mynn sfclayer",& - i, "lh: ",lh(i) - yesno = 1 - endif - if (ust(i) < 0.0 .or. ust(i) > 4.0 )then - print*,"suspicious values in mynn sfclayer",& - i, "ust: ",ust(i) - yesno = 1 - endif - if (wstar(i)<0.0 .or. wstar(i) > 6.0)then - print*,"suspicious values in mynn sfclayer",& - i, "wstar: ",wstar(i) - yesno = 1 - endif - if (rho1d(i)<0.0 .or. rho1d(i) > 1.6 )then - print*,"suspicious values in mynn sfclayer",& - i, "rho: ",rho1d(i) - yesno = 1 - endif - if (qsfc(i)*1000. <0.0 .or. qsfc(i)*1000. >40.)then - print*,"suspicious values in mynn sfclayer",& - i, "qsfc: ",qsfc(i) - yesno = 1 - endif - if (pblh(i)<0. .or. pblh(i)>6000.)then - print*,"suspicious values in mynn sfclayer",& - i, "pblh: ",pblh(i) - yesno = 1 - endif - - if (yesno == 1) then - print*," other info:" - write(*,1001)"regime:",regime(i)," z/l:",zol(i)," u*:",ust(i),& - " tstar:",mol(i) - write(*,1002)"psim:",psim(i)," psih:",psih(i)," w*:",wstar(i),& - " dthv:",thv1d(i)-thvgb(i) - write(*,1003)"cpm:",cpm(i)," rho1d:",rho1d(i)," l:",& - zol(i)/za(i)," dth:",th1d(i)-thgb(i) - write(*,*)" z0:",zntstoch(i)," zt:",z_t(i)," za:",za(i) - write(*,1005)"re:",restar," mavail:",mavail(i)," qsfc(i):",& - qsfc(i)," qvsh(i):",qvsh(i) - print*,"psix=",psix," z0:",zntstoch(i)," t1d(i):",t1d(i) - write(*,*)"=============================================" - endif - endif - - enddo !end i-loop - - errmsg = ' ' - errflg = 0 - - end subroutine sf_mynn_run - -!================================================================================================================= - subroutine zilitinkevich_1995(z_0,zt,zq,restar,ustar,karman,landsea,iz0tlnd2,spp_pbl,rstoch) -!this subroutine returns the thermal and moisture roughness lengths -!from Zilitinkevich (1995) and Zilitinkevich et al. (2001) over -!land and water, respectively. -! -!MODS: -!20120705 : added IZ0TLND option. Note: This option was designed -! to work with the Noah LSM and may be specific for that -! LSM only. Tests with RUC LSM showed no improvements. - implicit none -!================================================================================================================= - -!--- input arguments: - logical,intent(in):: spp_pbl - integer,optional,intent(in):: iz0tlnd2 - - real(kind=kind_phys),intent(in):: rstoch - real(kind=kind_phys),intent(in):: z_0,restar,ustar,karman,landsea - -!--- output arguments: - real(kind=kind_phys),intent(out):: zt,zq - -!--- local variables: - real(kind=kind_phys):: czil !=0.100 in Chen et al. (1997) - !=0.075 in Zilitinkevich (1995) - !=0.500 in Lemone et al. (2008) - -!----------------------------------------------------------------------------------------------------------------- - - if (landsea-1.5 .gt. 0) then !water - -!this is based on Zilitinkevich, Grachev, and Fairall (2001): -!their equations 15 and 16). - if (restar .lt. 0.1) then - zt = z_0*exp(karman*2.0) - zt = min( zt, 6.0e-5) - zt = max( zt, 2.0e-9) - zq = z_0*exp(karman*3.0) - zq = min( zq, 6.0e-5) - zq = max( zq, 2.0e-9) - else - zt = z_0*exp(-karman*(4.0*sqrt(restar)-3.2)) - zt = min( zt, 6.0e-5) - zt = max( zt, 2.0e-9) - zq = z_0*exp(-karman*(4.0*sqrt(restar)-4.2)) - zq = min( zt, 6.0e-5) - zq = max( zt, 2.0e-9) - endif - - else !land - -!option to modify czil according to Chen & Zhang (2009): - if ( iz0tlnd2 .eq. 1 ) then - czil = 10.0 ** ( -0.40 * ( z_0 / 0.07 ) ) - else - czil = 0.085 !0.075 !0.10 - end if - - zt = z_0*exp(-karman*czil*sqrt(restar)) - zt = min( zt, 0.75*z_0) - - zq = z_0*exp(-karman*czil*sqrt(restar)) - zq = min( zq, 0.75*z_0) - -!stochastically perturb thermal and moisture roughness length. -!currently set to half the amplitude: - if (spp_pbl) then - zt = zt + zt * 0.5 * rstoch - zt = max(zt, 0.0001) - zq = zt - endif - - endif - - end subroutine zilitinkevich_1995 - -!================================================================================================================= - subroutine davis_etal_2008(Z_0,ustar) -!a.k.a. : Donelan et al. (2004) -!this formulation for roughness length was designed to match -!the labratory experiments of Donelan et al. (2004). -!this is an update version from Davis et al. 2008, which -!corrects a small-bias in Z_0 (AHW real-time 2012). - implicit none -!================================================================================================================= - -!--- input arguments: - real(kind=kind_phys),intent(in):: ustar - -!--- output arguments: - real(kind=kind_phys),intent(out):: z_0 - -!--- local variables: - real(kind=kind_phys):: zw, zn1, zn2 - real(kind=kind_phys),parameter:: g=9.81,ozo=1.59e-5 - -!----------------------------------------------------------------------------------------------------------------- - -!old form: z_0 = 10.*exp(-10./(ustar**(1./3.))) -!new form: - - zw = min((ustar/1.06)**(0.3),1.0) - zn1 = 0.011*ustar*ustar/g + ozo - zn2 = 10.*exp(-9.5*ustar**(-.3333)) + & - 0.11*1.5e-5/amax1(ustar,0.01) - z_0 = (1.0-zw) * zn1 + zw * zn2 - - z_0 = max( z_0, 1.27e-7) !these max/mins were suggested by - z_0 = min( z_0, 2.85e-3) !Davis et al. (2008) - - end subroutine davis_etal_2008 - -!================================================================================================================= - subroutine taylor_yelland_2001(z_0,ustar,wsp10) -!this formulation for roughness length was designed account for -!wave steepness. - implicit none -!================================================================================================================= - -!--- input arguments: - real(kind=kind_phys),intent(in):: ustar,wsp10 - -!--- output arguments: - real(kind=kind_phys),intent(out):: z_0 - -!--- local variables: - real(kind=kind_phys),parameter:: g=9.81, pi=3.14159265 - real(kind=kind_phys):: hs, tp, lp - -!----------------------------------------------------------------------------------------------------------------- - -!hs is the significant wave height - hs = 0.0248*(wsp10**2.) -!Tp dominant wave period - tp = 0.729*max(wsp10,0.1) -!lp is the wavelength of the dominant wave - lp = g*tp**2/(2*pi) - - z_0 = 1200.*hs*(hs/lp)**4.5 - z_0 = max( z_0, 1.27e-7) !these max/mins were suggested by - z_0 = min( z_0, 2.85e-3) !Davis et al. (2008) - - end subroutine taylor_yelland_2001 - -!================================================================================================================= - subroutine charnock_1955(Z_0,ustar,wsp10,visc,zu) -!This version of Charnock's relation employs a varying -!Charnock parameter, similar to COARE3.0 [Fairall et al. (2003)]. -!The Charnock parameter CZC is varied from .011 to .018 -!between 10-m wsp = 10 and 18. - implicit none -!================================================================================================================= - -!--- input arguments: - real(kind=kind_phys),intent(in):: ustar,visc,wsp10,zu - -!--- output arguments: - real(kind=kind_phys),intent(out):: z_0 - -!--- local variables: - real(kind=kind_phys),parameter:: G=9.81, CZO2=0.011 - real(kind=kind_phys):: czc !variable charnock "constant" - real(kind=kind_phys):: wsp10m ! logarithmically calculated 10 m - -!----------------------------------------------------------------------------------------------------------------- - - wsp10m = wsp10*log(10./1e-4)/log(zu/1e-4) - czc = czo2 + 0.007*min(max((wsp10m-10.)/8., 0.), 1.0) - - z_0 = czc*ustar*ustar/g + (0.11*visc/max(ustar,0.05)) - z_0 = max( z_0, 1.27e-7) !these max/mins were suggested by - z_0 = min( z_0, 2.85e-3) !Davis et al. (2008) - - end subroutine charnock_1955 - -!================================================================================================================= - subroutine edson_etal_2013(z_0,ustar,wsp10,visc,zu) -!This version of Charnock's relation employs a varying -!Charnock parameter, taken from COARE 3.5 [Edson et al. (2001, JPO)]. -!The Charnock parameter CZC is varied from about .005 to .028 -!between 10-m wind speeds of 6 and 19 m/s. -!11 Nov 2021: Note that this was finally fixed according to the -! Edson et al (2014) corrigendum, where "m" was corrected. - implicit none -!================================================================================================================= - -!--- input arguments: - real(kind=kind_phys),intent(in):: ustar,visc,wsp10,zu - -!--- output arguments: - real(kind=kind_phys),intent(out):: z_0 - -!--- local variables: - real(kind=kind_phys),parameter:: g=9.81 - real(kind=kind_phys),parameter:: m=0.0017, b=-0.005 - real(kind=kind_phys):: czc ! variable charnock "constant" - real(kind=kind_phys):: wsp10m ! logarithmically calculated 10 m - -!----------------------------------------------------------------------------------------------------------------- - - wsp10m = wsp10*log(10/1e-4)/log(zu/1e-4) - wsp10m = min(19.,wsp10m) - czc = m*wsp10m + b - czc = max(czc, 0.0) - - z_0 = czc*ustar*ustar/g + (0.11*visc/max(ustar,0.07)) - z_0 = max( z_0, 1.27e-7) !These max/mins were suggested by - z_0 = min( z_0, 2.85e-3) !Davis et al. (2008) - - end subroutine edson_etal_2013 - -!================================================================================================================= - subroutine garratt_1992(zt,zq,z_0,ren,landsea) -!This formulation for the thermal and moisture roughness lengths -!(Zt and Zq) relates them to Z0 via the roughness Reynolds number (Ren). -!This formula comes from Fairall et al. (2003). It is modified from -!the original Garratt-Brutsaert model to better fit the COARE/HEXMAX -!data. The formula for land uses a constant ratio (Z_0/7.4) taken -!from Garratt (1992). - implicit none -!================================================================================================================= - -!--- input arguments: - real(kind=kind_phys),intent(in):: ren, z_0,landsea - -!--- output arguments: - real(kind=kind_phys),intent(out):: zt,zq - -!--- local variables: - real(kind=kind_phys):: rq - real(kind=kind_phys),parameter:: e=2.71828183 - -!----------------------------------------------------------------------------------------------------------------- - - if (landsea-1.5 .gt. 0) then !water - - zt = z_0*exp(2.0 - (2.48*(ren**0.25))) - zq = z_0*exp(2.0 - (2.28*(ren**0.25))) - - zq = min( zq, 5.5e-5) - zq = max( zq, 2.0e-9) - zt = min( zt, 5.5e-5) - zt = max( zt, 2.0e-9) !same lower limit as ecmwf - - else !land - - zq = z_0/(e**2.) !taken from Garratt (1980,1992) - zt = zq - - endif - - end subroutine garratt_1992 - -!================================================================================================================= - subroutine fairall_etal_2003(zt,zq,ren,ustar,visc,rstoch,spp_pbl) -!This formulation for thermal and moisture roughness length (Zt and Zq) -!as a function of the roughness Reynolds number (Ren) comes from the -!COARE3.0 formulation, empirically derived from COARE and HEXMAX data -![Fairall et al. (2003)]. Edson et al. (2004; JGR) suspected that this -!relationship overestimated the scalar roughness lengths for low Reynolds -!number flows, so an optional smooth flow relationship, taken from Garratt -!(1992, p. 102), is available for flows with Ren < 2. -! -!This is for use over water only. - implicit none -!================================================================================================================= - -!--- input arguments: - logical,intent(in):: spp_pbl - real(kind=kind_phys),intent(in):: ren,ustar,visc,rstoch - -!--- output arguments: - real(kind=kind_phys),intent(out):: zt,zq - -!----------------------------------------------------------------------------------------------------------------- - - if (ren .le. 2.) then - - zt = (5.5e-5)*(ren**(-0.60)) - zq = zt - !for smooth seas, can use Garratt - !zq = 0.2*visc/max(ustar,0.1) - !zq = 0.3*visc/max(ustar,0.1) - - else - - !for rough seas, use coare - zt = (5.5e-5)*(ren**(-0.60)) - zq = zt - - endif - - if (spp_pbl) then - zt = zt + zt * 0.5 * rstoch - zq = zt - endif - - zt = min(zt,1.0e-4) - zt = max(zt,2.0e-9) - - zq = min(zt,1.0e-4) - zq = max(zt,2.0e-9) - - end subroutine fairall_etal_2003 - -!================================================================================================================= - subroutine fairall_etal_2014(zt,zq,ren,ustar,visc,rstoch,spp_pbl) -!This formulation for thermal and moisture roughness length (Zt and Zq) -!as a function of the roughness Reynolds number (Ren) comes from the -!COARE 3.5/4.0 formulation, empirically derived from COARE and HEXMAX data -![Fairall et al. (2014? coming soon, not yet published as of July 2014)]. -!This is for use over water only. - implicit none -!================================================================================================================= - -!--- input arguments: - logical,intent(in):: spp_pbl - real(kind=kind_phys),intent(in):: ren,ustar,visc,rstoch - -!--- output arguments: - real(kind=kind_phys),intent(out):: Zt,Zq - -!----------------------------------------------------------------------------------------------------------------- - -!zt = (5.5e-5)*(ren**(-0.60)) - zt = min(1.6e-4, 5.8e-5/(ren**0.72)) - zq = zt - - if (spp_pbl) then - zt = max(zt + zt*0.5*rstoch,2.0e-9) - zq = max(zt + zt*0.5*rstoch,2.0e-9) - else - zt = max(zt,2.0e-9) - zq = max(zt,2.0e-9) - endif - - - end subroutine fairall_etal_2014 - -!================================================================================================================= - subroutine yang_2008(z_0,zt,zq,ustar,tstar,qst,ren,visc,landsea) -!This is a modified version of Yang et al (2002 QJRMS, 2008 JAMC) -!and Chen et al (2010, J of Hydromet). Although it was originally -!designed for arid regions with bare soil, it is modified -!here to perform over a broader spectrum of vegetation. -! -!The original formulation relates the thermal roughness length (Zt) -!to u* and T*: -! -! Zt = ht * EXP(-beta*(ustar**0.5)*(ABS(tstar)**0.25)) -! -!where ht = Renc*visc/ustar and the critical Reynolds number -!(Renc) = 70. Beta was originally = 10 (2002 paper) but was revised -!to 7.2 (in 2008 paper). Their form typically varies the -!ratio Z0/Zt by a few orders of magnitude (1-1E4). -! -!This modified form uses beta = 1.5 and a variable Renc (function of Z_0), -!so zt generally varies similarly to the Zilitinkevich form (with Czil ~ 0.1) -!for very small or negative surface heat fluxes but can become close to the -!Zilitinkevich with Czil = 0.2 for very large HFX (large negative T*). -!Also, the exponent (0.25) on tstar was changed to 1.0, since we found -!Zt was reduced too much for low-moderate positive heat fluxes. -! -!This should only be used over land! - implicit none -!================================================================================================================= - -!--- input arguments: - real(kind=kind_phys),intent(in):: z_0,ren,ustar,tstar,qst,visc,landsea - -!--- output arguments: - real(kind=kind_phys),intent(out):: zt,zq - -!--- local variables: - real(kind=kind_phys):: ht, &! roughness height at critical Reynolds number - tstar2, &! bounded T*, forced to be non-positive - qstar2, &! bounded q*, forced to be non-positive - z_02, &! bounded Z_0 for variable Renc2 calc - renc2 ! variable Renc, function of Z_0 - - real(kind=kind_phys),parameter:: renc=300., & !old constant Renc - beta=1.5, & !important for diurnal variation - m=170., & !slope for Renc2 function - b=691. !y-intercept for Renc2 function - -!----------------------------------------------------------------------------------------------------------------- - - z_02 = min(z_0,0.5) - z_02 = max(z_02,0.04) - renc2= b + m*log(z_02) - ht = renc2*visc/max(ustar,0.01) - tstar2 = min(tstar, 0.0) - qstar2 = min(qst,0.0) - - zt = ht * exp(-beta*(ustar**0.5)*(abs(tstar2)**1.0)) - zq = ht * exp(-beta*(ustar**0.5)*(abs(qstar2)**1.0)) -!zq = zt - - zt = min(zt, z_0/2.0) - zq = min(zq, z_0/2.0) - - end subroutine yang_2008 - -!================================================================================================================= - subroutine andreas_2002(z_0,bvisc,ustar,zt,zq) -! This is taken from Andreas (2002; J. of Hydromet) and -! Andreas et al. (2005; BLM). -! -! This should only be used over snow/ice! - implicit none -!================================================================================================================= - -!--- input arguments: - real(kind=kind_phys),intent(in):: z_0,bvisc,ustar - -!--- output arguments: - real(kind=kind_phys),intent(out):: zt, zq - -!--- local variables: - real(kind=kind_phys):: ren2,zntsno - - real(kind=kind_phys),parameter:: bt0_s=1.25, bt0_t=0.149, bt0_r=0.317, & - bt1_s=0.0, bt1_t=-0.55, bt1_r=-0.565, & - bt2_s=0.0, bt2_t=0.0, bt2_r=-0.183 - - real(kind=kind_phys),parameter:: bq0_s=1.61, bq0_t=0.351, bq0_r=0.396, & - bq1_s=0.0, bq1_t=-0.628, bq1_r=-0.512, & - bq2_s=0.0, bq2_t=0.0, bq2_r=-0.180 - -!----------------------------------------------------------------------------------------------------------------- - -!calculate zo for snow (Andreas et al. 2005, BLM): - zntsno = 0.135*bvisc/ustar + & - (0.035*(ustar*ustar)/9.8) * & - (5.*exp(-1.*(((ustar - 0.18)/0.1)*((ustar - 0.18)/0.1))) + 1.) - ren2 = ustar*zntsno/bvisc - -!Make sure that Re is not outside of the range of validity -!for using their equations - if (ren2 .gt. 1000.) ren2 = 1000. - - if (ren2 .le. 0.135) then - - zt = zntsno*exp(bt0_s + bt1_s*log(ren2) + bt2_s*log(ren2)**2) - zq = zntsno*exp(bq0_s + bq1_s*log(ren2) + bq2_s*log(ren2)**2) - - else if (ren2 .gt. 0.135 .and. ren2 .lt. 2.5) then - - zt = zntsno*exp(bt0_t + bt1_t*log(ren2) + bt2_t*log(ren2)**2) - zq = zntsno*exp(bq0_t + bq1_t*log(ren2) + bq2_t*log(ren2)**2) - - else - - zt = zntsno*exp(bt0_r + bt1_r*log(ren2) + bt2_r*log(ren2)**2) - zq = zntsno*exp(bq0_r + bq1_r*log(ren2) + bq2_r*log(ren2)**2) - - endif - - end subroutine andreas_2002 - -!================================================================================================================= - subroutine psi_hogstrom_1996(psi_m,psi_h,zl,zt,z_0,za) -!this subroutine returns the stability functions based off -!of hogstrom (1996). - implicit none -!================================================================================================================= - -!--- input arguments: - real(kind=kind_phys),intent(in):: zl,zt,z_0,za - -!--- output arguments: - real(kind=kind_phys),intent(out):: psi_m,psi_h - -!--- local variables: - real(kind=kind_phys):: x,x0,y,y0,zml,zhl - -!----------------------------------------------------------------------------------------------------------------- - - zml = z_0*zl/za - zhl = zt*zl/za - - if (zl .gt. 0.) then !stable (not well tested - seem large) - - psi_m = -5.3*(zl - zml) - psi_h = -8.0*(zl - zhl) - - else !unstable - - x = (1.-19.0*zl)**0.25 - x0= (1.-19.0*zml)**0.25 - y = (1.-11.6*zl)**0.5 - y0= (1.-11.6*zhl)**0.5 - - psi_m = 2.*log((1.+x)/(1.+x0)) + & - &log((1.+x**2.)/(1.+x0**2.)) - & - &2.0*atan(x) + 2.0*atan(x0) - psi_h = 2.*log((1.+y)/(1.+y0)) - - endif - - end subroutine psi_hogstrom_1996 - -!================================================================================================================= - subroutine psi_dyerhicks(psi_m,psi_h,zl,zt,z_0,za) -!This subroutine returns the stability functions based off -!of Hogstrom (1996), but with different constants compatible -!with Dyer and Hicks (1970/74?). This formulation is used for -!testing/development by Nakanishi (personal communication). - implicit none -!================================================================================================================= - -!--- input arguments: - real(kind=kind_phys),intent(in):: zl,zt,z_0,za - -!--- output arguments: - real(kind=kind_phys),intent(out):: psi_m,psi_h - -!--- local variables: - real(kind=kind_phys):: x,x0,y,y0,zml,zhl - -!----------------------------------------------------------------------------------------------------------------- - - zml = z_0*zl/za !zo/l - zhl = zt*zl/za !zt/l - - if (zl .gt. 0.) then !stable - - psi_m = -5.0*(zl - zml) - psi_h = -5.0*(zl - zhl) - - else !unstable - - x = (1.-16.*zl)**0.25 - x0= (1.-16.*zml)**0.25 - - y = (1.-16.*zl)**0.5 - y0= (1.-16.*zhl)**0.5 - - psi_m = 2.*log((1.+x)/(1.+x0)) + & - &log((1.+x**2.)/(1.+x0**2.)) - & - &2.0*atan(x) + 2.0*atan(x0) - psi_h = 2.*log((1.+y)/(1.+y0)) - - endif - - end subroutine psi_dyerhicks - -!================================================================================================================= - subroutine psi_beljaars_holtslag_1991(psi_m,psi_h,zl) -!this subroutine returns the stability functions based off -!of Beljaar and Holtslag 1991, which is an extension of Holtslag -!and Debruin 1989. - implicit none -!================================================================================================================= - -!--- input arguments: - real(kind=kind_phys),intent(in):: zl - -!--- output arguments: - real(kind=kind_phys),intent(out):: psi_m, psi_h - -!--- local variables: - real(kind=kind_phys):: a=1.,b=0.666,c=5.,d=0.35 - -!----------------------------------------------------------------------------------------------------------------- - - if (zl .lt. 0.) then !unstable - - write(*,*)"WARNING: Universal stability functions from" - write(*,*)" Beljaars and Holtslag (1991) should only" - write(*,*)" be used in the stable regime!" - psi_m = 0. - psi_h = 0. - - else !stable - - psi_m = -(a*zl + b*(zl -(c/d))*exp(-d*zl) + (b*c/d)) - psi_h = -((1.+.666*a*zl)**1.5 + & - b*(zl - (c/d))*exp(-d*zl) + (b*c/d) -1.) - - endif - - end subroutine psi_beljaars_holtslag_1991 - -!================================================================================================================= - subroutine psi_zilitinkevich_esau_2007(psi_m,psi_h,zl) -!this subroutine returns the stability functions come from -!Zilitinkevich and Esau (2007, BM), which are formulatioed from the -!"generalized similarity theory" and tuned to the LES DATABASE64 -!to determine their dependence on z/L. - IMPLICIT NONE -!================================================================================================================= - -!--- input arguments: - real(kind=kind_phys),intent(in):: zl - -!--- output arguments: - real(kind=kind_phys),intent(out):: psi_m, psi_h - -!--- local variables: - real(kind=kind_phys),parameter:: cm=3.0,ct=2.5 - -!----------------------------------------------------------------------------------------------------------------- - - if (zl .lt. 0.) then !unstable - -! write(*,*)"WARNING: Universal stability function from" -! write(*,*)" Zilitinkevich and Esau (2007) should only" -! write(*,*)" be used in the stable regime!" - psi_m = 0. - psi_h = 0. - - else !stable - - psi_m = -cm*(zl**(5./6.)) - psi_h = -ct*(zl**(4./5.)) - - endif - - end subroutine psi_zilitinkevich_esau_2007 - -!================================================================================================================= - subroutine psi_businger_1971(psi_m,psi_h,zl) -!this subroutine returns the flux-profile relationships -!of Businger el al. 1971. - implicit none -!================================================================================================================= - -!--- input arguments: - real(kind=kind_phys),intent(in):: zl - -!--- output arguments: - real(kind=kind_phys),intent(out):: psi_m, psi_h - -!--- local variables: - real(kind=kind_phys):: x, y - real(kind=kind_phys),parameter:: pi180 = 3.14159265/180. - -!----------------------------------------------------------------------------------------------------------------- - - if (zl .lt. 0.) then !unstable - - x = (1. - 15.0*zl)**0.25 - y = (1. - 9.0*zl)**0.5 - - psi_m = log(((1.+x)/2.)**2.) + & - & log((1.+x**2.)/2.) - & - & 2.0*atan(x) + pi180*90. - psi_h = 2.*log((1.+y)/2.) - - else !stable - - psi_m = -4.7*zl - psi_h = -(4.7/0.74)*zl - - endif - - end subroutine psi_businger_1971 - -!================================================================================================================= - subroutine psi_suselj_sood_2010(psi_m,psi_h,zl) -!this subroutine returns flux-profile relatioships based off -!of Lobocki (1993), which is derived from the MY-level 2 model. -!Suselj and Sood (2010) applied the surface layer length scales -!from Nakanishi (2001) to get this new relationship. These functions -!are more agressive (larger magnitude) than most formulations. They -!showed improvement over water, but untested over land. - implicit none -!================================================================================================================= - -!--- input arguments: - real(kind=kind_phys),intent(in):: zl - -!--- output arguments: - real(kind=kind_phys),intent(out):: psi_m, psi_h - -!--- local variables: - real(kind=kind_phys),parameter:: rfc=0.19, ric=0.183, phit=0.8 - -!----------------------------------------------------------------------------------------------------------------- - - if (zl .gt. 0.) then !stable - - psi_m = -(zl/rfc + 1.1223*exp(1.-1.6666/zl)) - !psi_h = -zl*ric/((rfc**2.)*phit) + 8.209*(zl**1.1091) - !their eq for psi_h crashes the model and does not match - !their fig 1. this eq (below) matches their fig 1 better: - psi_h = -(zl*ric/((rfc**2.)*5.) + 7.09*(zl**1.1091)) - - else !unstable - - psi_m = 0.9904*log(1. - 14.264*zl) - psi_h = 1.0103*log(1. - 16.3066*zl) - - endif - - end subroutine psi_suselj_sood_2010 - -!================================================================================================================= - subroutine psi_cb2005(psim1,psih1,zl,z0l) -!this subroutine returns the stability functions based off -!of Cheng and Brutseart (2005, BLM), for use in stable conditions only. -!the returned values are the combination of psi((za+zo)/L) - psi(z0/L) - implicit none -!================================================================================================================= - -!--- input arguments: - real(kind=kind_phys),intent(in):: zl,z0l - -!--- output arguments: - real(kind=kind_phys),intent(out):: psim1,psih1 - -!----------------------------------------------------------------------------------------------------------------- - - psim1 = -6.1*log(zl + (1.+ zl **2.5)**0.4) & - -6.1*log(z0l + (1.+ z0l**2.5)**0.4) - psih1 = -5.5*log(zl + (1.+ zl **1.1)**0.90909090909) & - -5.5*log(z0l + (1.+ z0l**1.1)**0.90909090909) - - end subroutine psi_cb2005 - -!================================================================================================================= - subroutine li_etal_2010(zl,rib,zaz0,z0zt) -!this subroutine returns a more robust z/l that best matches -!the z/l from hogstrom (1996) for unstable conditions and beljaars -!and holtslag (1991) for stable conditions. - implicit none -!================================================================================================================= - -!--- input arguments: - real(kind=kind_phys),intent(in):: rib,zaz0,z0zt - -!--- output arguments: - real(kind=kind_phys),intent(out):: zl - -!--- local variables: - real(kind=kind_phys):: alfa,beta,zaz02,z0zt2 - - real(kind=kind_phys),parameter:: au11=0.045, bu11=0.003, bu12=0.0059, & - &bu21=-0.0828, bu22=0.8845, bu31=0.1739, & - &bu32=-0.9213, bu33=-0.1057 - real(kind=kind_phys),parameter:: aw11=0.5738, aw12=-0.4399, aw21=-4.901, & - &aw22=52.50, bw11=-0.0539, bw12=1.540, & - &bw21=-0.669, bw22=-3.282 - real(kind=kind_phys),parameter:: as11=0.7529, as21=14.94, bs11=0.1569, & - &bs21=-0.3091, bs22=-1.303 - -!----------------------------------------------------------------------------------------------------------------- - -!set limits according to Li et al (2010), p 157. - zaz02=zaz0 - if (zaz0 .lt. 100.0) zaz02=100. - if (zaz0 .gt. 100000.0) zaz02=100000. - -!set more limits according to Li et al (2010) - z0zt2=z0zt - if (z0zt .lt. 0.5) z0zt2=0.5 - if (z0zt .gt. 100.0) z0zt2=100. - - alfa = log(zaz02) - beta = log(z0zt2) - - if (rib .le. 0.0) then - zl = au11*alfa*rib**2 + ( & - & (bu11*beta + bu12)*alfa**2 + & - & (bu21*beta + bu22)*alfa + & - & (bu31*beta**2 + bu32*beta + bu33))*rib - - !if(zL .LT. -15 .OR. zl .GT. 0.)print*,"VIOLATION Rib<0:",zL - zl = max(zl,-15.) !limits set according to Li et al (2010) - zl = min(zl,0.) !Figure 1. - elseif (rib .gt. 0.0 .and. rib .le. 0.2) then - zl = ((aw11*beta + aw12)*alfa + & - & (aw21*beta + aw22))*rib**2 + & - & ((bw11*beta + bw12)*alfa + & - & (bw21*beta + bw22))*rib - - !if(zl .lt. 0 .or. zl .gt. 4)print*,"violation 00.2:",zl - zl = min(zl,20.) !limits according to Li et al (2010), their Figure 1c. - zl = max(zl,1.) - endif - - end subroutine li_etal_2010 - -!================================================================================================================= - real(kind=kind_phys) function zolri(ri,za,z0,zt,zol1,psi_opt) - implicit none -! This iterative algorithm is a two-point secant method taken from the revised -! surface layer scheme in WRF-ARW, written by Pedro Jimenez and Jimy Dudhia and -! summarized in Jimenez et al. (2012, MWR). This function was adapted -! to input the thermal roughness length, zt, (as well as z0) and use initial -! estimate of z/L. -!================================================================================================================= - -!--- input arguments: - integer, intent(in):: psi_opt - real(kind=kind_phys),intent(in):: ri,za,z0,zt,zol1 - -!--- local variables and arrays: - integer:: n - integer,parameter:: nmax = 20 - real(kind=kind_phys):: x1,x2,fx1,fx2 - -!----------------------------------------------------------------------------------------------------------------- - - if (ri.lt.0.)then - x1=zol1 - 0.02 !-5. - x2=0. - else - x1=0. - x2=zol1 + 0.02 !5. - endif - - n=0 - fx1=zolri2(x1,ri,za,z0,zt,psi_opt) - fx2=zolri2(x2,ri,za,z0,zt,psi_opt) - - do while (abs(x1 - x2) > 0.01 .and. n < nmax) - if(abs(fx2) .lt. abs(fx1))then - x1=x1-fx1/(fx2-fx1)*(x2-x1) - fx1=zolri2(x1,ri,za,z0,zt,psi_opt) - zolri=x1 - else - x2=x2-fx2/(fx2-fx1)*(x2-x1) - fx2=zolri2(x2,ri,za,z0,zt,psi_opt) - zolri=x2 - endif - n=n+1 - enddo - - if (n==nmax .and. abs(x1 - x2) >= 0.01) then - !if convergence fails, use approximate values: - call li_etal_2010(zolri, ri, za/z0, z0/zt) - !print*,"failed, n=",n," ri=",ri," zt=",zt - else - !print*,"success,n=",n," ri=",ri," z/l=",zolri - endif - - end function zolri - -!================================================================================================================= - real(kind=kind_phys) function zolri2(zol2,ri2,za,z0,zt,psi_opt) - implicit none -! input: ================================= -! zol2 - estimated z/l -! ri2 - calculated bulk richardson number -! za - 1/2 depth of first model layer -! z0 - aerodynamic roughness length -! zt - thermal roughness length -! output: ================================ -! zolri2 - delta ri -!================================================================================================================= - -!--- input arguments: - integer,intent(in):: psi_opt - real(kind=kind_phys),intent(in):: ri2,za,z0,zt - -!--- inout arguments: - real(kind=kind_phys),intent(inout):: zol2 - -!--- local variables and arrays: - real(kind=kind_phys):: zol20,zol3,psim1,psih1,psix2,psit2,zolt - -!----------------------------------------------------------------------------------------------------------------- - - if(zol2*ri2 .lt. 0.) then - !print*,"wrong quadrants: z/l=",zol2," ri=",ri2 - zol2=0. - endif - - zol20=zol2*z0/za ! z0/l - zol3=zol2+zol20 ! (z+z0)/l - zolt=zol2*zt/za ! zt/l - - if (ri2.lt.0) then - psit2=max(log((za+z0)/zt)-(psih_unstable(zol3,psi_opt)-psih_unstable(zolt,psi_opt)), 1.0) - psix2=max(log((za+z0)/z0)-(psim_unstable(zol3,psi_opt)-psim_unstable(zol20,psi_opt)),1.0) - else - psit2=max(log((za+z0)/zt)-(psih_stable(zol3,psi_opt)-psih_stable(zolt,psi_opt)), 1.0) - psix2=max(log((za+z0)/z0)-(psim_stable(zol3,psi_opt)-psim_stable(zol20,psi_opt)),1.0) - endif - - zolri2=zol2*psit2/psix2**2 - ri2 -!print*," target ri=",ri2," est ri=",zol2*psit2/psix2**2 - - end function zolri2 - -!================================================================================================================= - real(kind=kind_phys) function zolrib(ri,za,z0,zt,logz0,logzt,zol1,psi_opt) - implicit none -!this iterative algorithm to compute z/L from bulk-Ri -!================================================================================================================= - -!--- input arguments: - integer,intent(in):: psi_opt - real(kind=kind_phys),intent(in):: ri,za,z0,zt,logz0,logzt - -!--- inout arguments: - real(kind=kind_phys),intent(inout):: zol1 - -!--- local variables and arrays: - integer:: n - integer,parameter :: nmax = 20 - real(kind=kind_phys):: zol20,zol3,zolt,zolold - real(kind=kind_phys):: psit2,psix2 -!real(kind=kind_phys),dimension(nmax):: zlhux - -!----------------------------------------------------------------------------------------------------------------- - - if(zol1*ri .lt. 0.) then -! print*,"WRONG QUADRANTS: z/L=",zol1," ri=",ri - zol1=0. - endif - - if (ri .lt. 0.) then - zolold=-99999. - zolrib=-66666. - else - zolold=99999. - zolrib=66666. - endif - - n=1 - do while (abs(zolold - zolrib) > 0.01 .and. n < nmax) - - if(n==1)then - zolold=zol1 - else - zolold=zolrib - endif - zol20=zolold*z0/za ! z0/L - zol3=zolold+zol20 ! (z+z0)/L - zolt=zolold*zt/za ! zt/L - - if (ri.lt.0) then - psit2=MAX(logzt-(psih_unstable(zol3,psi_opt)-psih_unstable(zolt,psi_opt)), 1.0) - psix2=MAX(logz0-(psim_unstable(zol3,psi_opt)-psim_unstable(zol20,psi_opt)), 1.0) - else - psit2=MAX(logzt-(psih_stable(zol3,psi_opt)-psih_stable(zolt,psi_opt)), 1.0) - psix2=MAX(logz0-(psim_stable(zol3,psi_opt)-psim_stable(zol20,psi_opt)), 1.0) - endif - - zolrib=ri*psix2**2/psit2 - !zLhux(n)=zolrib - n=n+1 - enddo - - if (n==nmax .and. abs(zolold - zolrib) > 0.01 ) then - !print*,"iter FAIL, n=",n," Ri=",ri," z/L=",zolri - !if convergence fails, use approximate values: - call li_etal_2010(zolrib,ri,za/z0,z0/zt) - !zLhux(n)=zolri - !print*,"FAILED, n=",n," Ri=",ri," zt=",zt - !print*,"z/L=",zLhux(1:nmax) - else - !print*,"SUCCESS,n=",n," Ri=",ri," z/L=",zolrib - endif - - end function zolrib - -!================================================================================================================= - subroutine psi_init(psi_opt) - implicit none -!define tables from -10 <= z/L <= 10 -!================================================================================================================= - - integer,intent(in):: psi_opt - integer:: n - real(kind=kind_phys):: zolf - -!----------------------------------------------------------------------------------------------------------------- - - if (psi_opt == 0) then - 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 - else - do n = 0,1000 - !stable function tables - zolf = float(n)*0.01 - psim_stab(n)=psim_stable_full_gfs(zolf) - psih_stab(n)=psih_stable_full_gfs(zolf) - - !unstable function tables - zolf = -float(n)*0.01 - psim_unstab(n)=psim_unstable_full_gfs(zolf) - psih_unstab(n)=psih_unstable_full_gfs(zolf) - enddo - endif - - end subroutine psi_init - -!================================================================================================================= -! ... Full equations for the integrated similarity functions ... -!================================================================================================================= - real(kind=kind_phys) function psim_stable_full(zolf) - implicit none - - real(kind=kind_phys),intent(in):: zolf - - psim_stable_full=-6.1*log(zolf+(1+zolf**2.5)**(1./2.5)) - - end function psim_stable_full - -!================================================================================================================= - real(kind=kind_phys) function psih_stable_full(zolf) - implicit none - - real(kind=kind_phys),intent(in):: zolf - - psih_stable_full=-5.3*log(zolf+(1+zolf**1.1)**(1./1.1)) - - end function psih_stable_full - -!================================================================================================================= - real(kind=kind_phys) function psim_unstable_full(zolf) - implicit none - - real(kind=kind_phys),intent(in):: zolf - real(kind=kind_phys):: x,ym,psimc,psimk - - 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.) - - end function psim_unstable_full - -!================================================================================================================= - real(kind=kind_phys) function psih_unstable_full(zolf) - implicit none - - real(kind=kind_phys),intent(in):: zolf - real(kind=kind_phys):: y,yh,psihc,psihk - - 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.) - - end function psih_unstable_full - -!================================================================================================================= -! ... integrated similarity functions from GFS... -! -!================================================================================================================= - real(kind=kind_phys) function psim_stable_full_gfs(zolf) - implicit none - - real(kind=kind_phys),intent(in):: zolf - real(kind=kind_phys):: aa - real(kind=kind_phys),parameter:: alpha4 = 20. - - aa = sqrt(1. + alpha4 * zolf) - psim_stable_full_gfs = -1.*aa + log(aa + 1.) - - end function psim_stable_full_gfs - -!================================================================================================================= - real(kind=kind_phys) function psih_stable_full_gfs(zolf) - implicit none - - real(kind=kind_phys):: zolf - real(kind=kind_phys):: bb - real(kind=kind_phys),parameter:: alpha4 = 20. - - bb = sqrt(1. + alpha4 * zolf) - psih_stable_full_gfs = -1.*bb + log(bb + 1.) - - end function psih_stable_full_gfs - -!================================================================================================================= - real(kind=kind_phys) function psim_unstable_full_gfs(zolf) - implicit none - - real(kind=kind_phys),intent(in):: zolf - real(kind=kind_phys):: hl1,tem1 - real(kind=kind_phys),parameter:: a0=-3.975, a1=12.32, & - b1=-7.755, b2=6.041 - - if (zolf .ge. -0.5) then - hl1 = zolf - psim_unstable_full_gfs = (a0 + a1*hl1) * hl1 / (1.+ (b1+b2*hl1) *hl1) - else - hl1 = -zolf - tem1 = 1.0 / sqrt(hl1) - psim_unstable_full_gfs = log(hl1) + 2. * sqrt(tem1) - .8776 - end if - - end function psim_unstable_full_gfs - -!================================================================================================================= - real(kind=kind_phys) function psih_unstable_full_gfs(zolf) - implicit none - - real(kind=kind_phys),intent(in):: zolf - real(kind=kind_phys):: hl1,tem1 - real(kind=kind_phys),parameter:: a0p=-7.941, a1p=24.75, & - b1p=-8.705, b2p=7.899 - - if (zolf .ge. -0.5) then - hl1 = zolf - psih_unstable_full_gfs = (a0p + a1p*hl1) * hl1 / (1.+ (b1p+b2p*hl1)*hl1) - else - hl1 = -zolf - tem1 = 1.0 / sqrt(hl1) - psih_unstable_full_gfs = log(hl1) + .5 * tem1 + 1.386 - end if - - end function psih_unstable_full_gfs - -!================================================================================================================= -! These functions use the look-up table functions when |z/L| <= 10 -! but default to the full equations when |z/L| > 10. -!================================================================================================================= - real(kind=kind_phys) function psim_stable(zolf,psi_opt) - implicit none - - integer,intent(in):: psi_opt - integer:: nzol - real(kind=kind_phys),intent(in):: zolf - real(kind=kind_phys):: rzol - -!----------------------------------------------------------------------------------------------------------------- - - nzol = int(zolf*100.) - rzol = zolf*100. - nzol - if(nzol+1 .le. 1000)then - psim_stable = psim_stab(nzol) + rzol*(psim_stab(nzol+1)-psim_stab(nzol)) - else - if (psi_opt == 0) then - psim_stable = psim_stable_full(zolf) - else - psim_stable = psim_stable_full_gfs(zolf) - endif - endif - - end function psim_stable - -!================================================================================================================= - real(kind=kind_phys) function psih_stable(zolf,psi_opt) - implicit none - - integer,intent(in):: psi_opt - integer:: nzol - real(kind=kind_phys),intent(in):: zolf - real(kind=kind_phys):: rzol - -!----------------------------------------------------------------------------------------------------------------- - - nzol = int(zolf*100.) - rzol = zolf*100. - nzol - if(nzol+1 .le. 1000)then - psih_stable = psih_stab(nzol) + rzol*(psih_stab(nzol+1)-psih_stab(nzol)) - else - if (psi_opt == 0) then - psih_stable = psih_stable_full(zolf) - else - psih_stable = psih_stable_full_gfs(zolf) - endif - endif - - end function psih_stable - -!================================================================================================================= - real(kind=kind_phys) function psim_unstable(zolf,psi_opt) - implicit none - - integer,intent(in):: psi_opt - integer:: nzol - real(kind=kind_phys),intent(in):: zolf - real(kind=kind_phys):: rzol - -!----------------------------------------------------------------------------------------------------------------- - - nzol = int(-zolf*100.) - rzol = -zolf*100. - nzol - if(nzol+1 .le. 1000)then - psim_unstable = psim_unstab(nzol) + rzol*(psim_unstab(nzol+1)-psim_unstab(nzol)) - else - if (psi_opt == 0) then - psim_unstable = psim_unstable_full(zolf) - else - psim_unstable = psim_unstable_full_gfs(zolf) - endif - endif - - end function psim_unstable - -!================================================================================================================= - real(kind=kind_phys) function psih_unstable(zolf,psi_opt) - implicit none - - integer,intent(in):: psi_opt - integer:: nzol - real(kind=kind_phys),intent(in):: zolf - real(kind=kind_phys):: rzol - -!----------------------------------------------------------------------------------------------------------------- - - nzol = int(-zolf*100.) - rzol = -zolf*100. - nzol - if(nzol+1 .le. 1000)then - psih_unstable = psih_unstab(nzol) + rzol*(psih_unstab(nzol+1)-psih_unstab(nzol)) - else - if (psi_opt == 0) then - psih_unstable = psih_unstable_full(zolf) - else - psih_unstable = psih_unstable_full_gfs(zolf) - endif - endif - - end function psih_unstable - -!================================================================================================================= - end module sf_mynn -!================================================================================================================= - diff --git a/src/core_atmosphere/physics/physics_mmm/sf_sfclayrev.F b/src/core_atmosphere/physics/physics_mmm/sf_sfclayrev.F deleted file mode 100644 index 6ca81441ad..0000000000 --- a/src/core_atmosphere/physics/physics_mmm/sf_sfclayrev.F +++ /dev/null @@ -1,1161 +0,0 @@ -!================================================================================================================= - module sf_sfclayrev - use ccpp_kinds,only: kind_phys - - implicit none - private - public:: sf_sfclayrev_run, & - sf_sfclayrev_init, & - sf_sfclayrev_final, & - sf_sfclayrev_timestep_init, & - sf_sfclayrev_timestep_final - - - 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 - - -!================================================================================================================= - subroutine sf_sfclayrev_timestep_init(dz2d,u2d,v2d,qv2d,p2d,t2d,dz1d,u1d,v1d,qv1d,p1d,t1d, & - its,ite,kts,kte,errmsg,errflg) -!================================================================================================================= - -!--- input arguments: - integer,intent(in):: its,ite,kts,kte - - real(kind=kind_phys),intent(in),dimension(its:ite,kts:kte):: & - dz2d,u2d,v2d,qv2d,p2d,t2d - -!--- output arguments: - character(len=*),intent(out):: errmsg - integer,intent(out):: errflg - - real(kind=kind_phys),intent(out),dimension(its:ite):: & - dz1d,u1d,v1d,qv1d,p1d,t1d - -!--- local variables: - integer:: i - -!----------------------------------------------------------------------------------------------------------------- - - do i = its,ite - dz1d(i) = dz2d(i,kts) - u1d(i) = u2d(i,kts) - v1d(i) = v2d(i,kts) - qv1d(i) = qv2d(i,kts) - p1d(i) = p2d(i,kts) - t1d(i) = t2d(i,kts) - enddo - - errmsg = 'sf_sfclayrev_timestep_init OK' - errflg = 0 - - end subroutine sf_sfclayrev_timestep_init - -!================================================================================================================= - subroutine sf_sfclayrev_timestep_final(errmsg,errflg) -!================================================================================================================= - -!--- output arguments: - character(len=*),intent(out):: errmsg - integer,intent(out):: errflg - -!----------------------------------------------------------------------------------------------------------------- - - errmsg = 'sf_sfclayrev_timestep_final OK' - errflg = 0 - - end subroutine sf_sfclayrev_timestep_final - -!================================================================================================================= - 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 - -!================================================================================================================= - subroutine sf_sfclayrev_final(errmsg,errflg) -!================================================================================================================= - -!--- output arguments: - character(len=*),intent(out):: errmsg - integer,intent(out):: errflg - -!----------------------------------------------------------------------------------------------------------------- - - errmsg = 'sf_sfclayrev_final OK' - errflg = 0 - - end subroutine sf_sfclayrev_final - -!================================================================================================================= - 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,eomeg,stbolt,p1000mb, & - shalwater_z0,water_depth,shalwater_depth, & - isftcflx,iz0tlnd,scm_force_flux, & - ustm,ck,cka,cd,cda, & - its,ite,errmsg,errflg & - ) -!================================================================================================================= - -!--- input arguments: - integer,intent(in):: its,ite - - integer,intent(in):: isfflx - integer,intent(in):: shalwater_z0 - integer,intent(in),optional:: isftcflx, iz0tlnd - integer,intent(in),optional:: scm_force_flux - - real(kind=kind_phys),intent(in):: svp1,svp2,svp3,svpt0 - real(kind=kind_phys),intent(in):: ep1,ep2,karman,eomeg,stbolt - real(kind=kind_phys),intent(in):: P1000mb - real(kind=kind_phys),intent(in):: cp,g,rovcp,r,xlv - real(kind=kind_phys),intent(in):: shalwater_depth - - real(kind=kind_phys),intent(in),dimension(its:ite):: & - mavail, & - pblh, & - psfcpa, & - tsk, & - xland, & - water_depth - - real(kind=kind_phys),intent(in),dimension(its:ite):: & - 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:ite):: & - lh, & - u10, & - v10, & - th2, & - t2, & - q2 - - real(kind=kind_phys),intent(out),dimension(its:ite),optional:: & - ck, & - cka, & - cd, & - cda - -!--- inout arguments: - real(kind=kind_phys),intent(inout),dimension(its:ite):: & - 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:ite),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):: 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)) - !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 -! - 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.eq.1) goto 350 - endif - do i = its,ite - qfx(i)=0. - hfx(i)=0. - enddo - 350 continue - - if(isfflx.eq.0) 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 .eq. 1) 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.eq.1) 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/src/core_atmosphere/physics/physics_noahmp/LICENSE.txt b/src/core_atmosphere/physics/physics_noahmp/LICENSE.txt new file mode 100644 index 0000000000..fad4f42322 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/LICENSE.txt @@ -0,0 +1,66 @@ +USE OF THIS SOFTWARE IS SUBJECT TO THE FOLLOWING TERMS AND CONDITIONS: + +1. License. Subject to these terms and conditions, University Corporation for Atmospheric Research (UCAR) +grants you a non-exclusive, royalty-free license to use, create derivative works, publish, distribute, +disseminate, transfer, modify, revise and copy the Noah-MP software, in both object and source code +(the "Software"). You shall not sell, license or transfer for a fee the Software, or any work that in any +manner contains the Software. + +2. Disclaimer of Warranty on Software. Use of the Software is at your sole risk. The Software is provided +"AS IS" and without warranty of any kind and UCAR EXPRESSLY DISCLAIMS ALL WARRANTIES AND/OR CONDITIONS OF +ANY KIND, EXPRESS OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, ANY WARRANTIES OR CONDITIONS OF TITLE, +NON-INFRINGEMENT OF A THIRD PARTY'S INTELLECTUAL PROPERTY, MERCHANTABILITY OR SATISFACTORY QUALITY AND +FITNESS FOR A PARTICULAR PURPOSE. THE PARTIES EXPRESSLY DISCLAIM THAT THE UNIFORM COMPUTER INFORMATION +TRANSACTIONS ACT (UCITA) APPLIES TO OR GOVERNS THIS AGREEMENT. No oral or written information or advice +given by UCAR or a UCAR authorized representative shall create a warranty or in any way increase the scope +of this warranty. Should the Software prove defective, you (and neither UCAR nor any UCAR representative) +assume the cost of all necessary correction. + +3. Limitation of Liability. UNDER NO CIRCUMSTANCES, INCLUDING NEGLIGENCE, SHALL UCAR BE LIABLE FOR ANY +DIRECT, INCIDENTAL, SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES INCLUDING LOST REVENUE, PROFIT OR DATA, +WHETHER IN AN ACTION IN CONTRACT OR TORT ARISING OUT OF OR RELATING TO THE USE OF OR INABILITY TO USE THE +SOFTWARE, EVEN IF UCAR HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. + +4. Compliance with Law. All Software and any technical data delivered under this Agreement are subject to +U.S. export control laws and may be subject to export or import regulations in other countries. You agree +to comply strictly with all applicable laws and regulations in connection with use and distribution of the +Software, including export control laws, and you acknowledge that you have responsibility to obtain any +required license to export, re-export, or import as may be required. + +5. No Endorsement/No Support. The names UCAR/NCAR, National Center for Atmospheric Research and the +University Corporation for Atmospheric Research may not be used in any advertising or publicity to endorse +or promote any products or commercial entity unless specific written permission is obtained from UCAR. The +Software is provided without any support or maintenance, and without any obligation to provide you with +modifications, improvements, enhancements, or updates of the Software. + +6. Controlling Law and Severability. This Agreement shall be governed by the laws of the United States and the +State of Colorado. If for any reason a court of competent jurisdiction finds any provision, or portion +thereof, to be unenforceable, the remainder of this Agreement shall continue in full force and effect. This +Agreement shall not be governed by the United Nations Convention on Contracts for the International Sale of +Goods, the application of which is hereby expressly excluded. + +7. Termination. Your rights under this Agreement will terminate automatically without notice from UCAR if you +fail to comply with any term(s) of this Agreement. You may terminate this Agreement at any time by destroying +the Software and any related documentation and any complete or partial copies thereof. Upon termination, all +rights granted under this Agreement shall terminate. The following provisions shall survive termination: +Sections 2, 3, 6 and 9. + +8. Complete Agreement. This Agreement constitutes the entire agreement between the parties with respect to the +use of the Software and supersedes all prior or contemporaneous understandings regarding such subject matter. +No amendment to or modification of this Agreement will be binding unless in a writing and signed by UCAR. + +9. Notices and Additional Terms. Copyright in Software is held by UCAR. You must include, with each copy of the +Software and associated documentation, a copy of this Agreement and the following notice: + +"The source of this material is the Research Applications Laboratory at the National Center for Atmospheric +Research, a program of the University Corporation for Atmospheric Research (UCAR) pursuant to a Cooperative +Agreement with the National Science Foundation; ©2007 University Corporation for Atmospheric Research. All +Rights Reserved." + +The following notice shall be displayed on any scholarly works associated with, related to or derived from +the Software: + +"The Noah-MP modeling system was developed at the National Center for Atmospheric Research (NCAR) with collaborations +from university partners. NCAR is sponsored by the United States National Science Foundation." + +BY USING OR DOWNLOADING THIS SOFTWARE, YOU AGREE TO BE BOUND BY THE TERMS AND CONDITIONS OF THIS AGREEMENT. diff --git a/src/core_atmosphere/physics/physics_noahmp/README.md b/src/core_atmosphere/physics/physics_noahmp/README.md new file mode 100644 index 0000000000..de0a3fb93d --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/README.md @@ -0,0 +1,88 @@ +![noahmp_logo_update](https://github.com/NCAR/noahmp/assets/43385564/1fb47fc2-99bd-4360-9ed0-6d5656c29626) + + +[![DOI](https://zenodo.org/badge/236657733.svg)](https://zenodo.org/badge/latestdoi/236657733) + + +# Noah-MP® Community Model Repository + +Noah-MP® is a widely-used state-of-the-art land surface model used in many research and operational weather/climate models (e.g., HRLDAS, WRF, MPAS, WRF-Hydro/NWM, NOAA/UFS, NASA/LIS, etc.). + +This is the official Noah-MP land surface model unified repository for code downloading and contribution. Noah-MP is a community open-source model developed with the contributions from the entire scientific community. For development, maintenance, and release of the community Noah-MP GitHub code, please contact: Cenlin He (cenlinhe@ucar.edu) and Fei Chen (feichen@ucar.edu). + +Noah-MP model website: https://ral.ucar.edu/solutions/products/noah-multiparameterization-land-surface-model-noah-mp-lsm + + +## New: Release of Noah-MP version 5.0 (Refactored/Modernized version) + +The latest Noah-MP model version (version 5.0) has been released in March 9, 2023, which is a modernized/refactored version by re-writing the entire model with modern Fortran code infrastructure and data structures. All future Noah-MP developments and updates will be made only to this modernized/refactored version. The version 5.0 has the same model physics as the version 4.5, but with a different code infrastructure. More details about the Noah-MP version 5.0 can be found in the model description paper (He et al., 2023b, in review) and the technical documentation (He et al. 2023a). Currently, the Noah-MP version 5.0 coupling with HRLDAS has been completed, but its coupling with other host models (e.g., WRF-Hydro, NASA/LIS, WRF, MPAS, UFS, etc.) is still on-going. + + +## Noah-MP technical documentation and model description papers + +Technical documentation freely available at http://dx.doi.org/10.5065/ew8g-yr95 + +**To cite the technical documentation**: He, C., P. Valayamkunnath, M. Barlage, F. Chen, D. Gochis, R. Cabell, T. Schneider, R. Rasmussen, G.-Y. Niu, Z.-L. Yang, D. Niyogi, and M. Ek (2023): The Community Noah-MP Land Surface Modeling System Technical Description Version 5.0, (No. NCAR/TN-575+STR). doi:10.5065/ew8g-yr95 + +**Original Noah-MP model description paper**: Niu, G. Y., Yang, Z. L., Mitchell, K. E., Chen, F., Ek, M. B., Barlage, M., ... & Xia, Y. (2011). The community Noah land surface model with multiparameterization options (Noah‐MP): 1. Model description and evaluation with local‐scale measurements. Journal of Geophysical Research: Atmospheres, 116(D12). + +**Noah-MP version 5.0 model description paper**: He, C., Valayamkunnath, P., Barlage, M., Chen, F., Gochis, D., Cabell, R., Schneider, T., Rasmussen, R., Niu, G.-Y., Yang, Z.-L., Niyogi, D., and Ek, M.: Modernizing the open-source community Noah with multi-parameterization options (Noah-MP) land surface model (version 5.0) with enhanced modularity, interoperability, and applicability, Geosci. Model Dev., 16, 5131–5151, https://doi.org/10.5194/gmd-16-5131-2023, 2023. + + +## Noah-MP GitHub structure + +**The folders**: + +1. docs/: Noah-MP variable glossary and technical documentation; + +2. drivers/: Noah-MP driver and interface code to connect to different host models (each host model will has its own subdirectory under this driver/); + +3. parameters/: Noah-MP parameter table (note that the original 3 parameter tables have been merged into one NoahmpTable.TBL starting from version 5.0); + +4. src/: Noah-MP source code modules; + +5. utility/: Noah-MP utility code. + +**The branches**: + +1. "master" branch: (currently version 5.0), most stable & latest version, updated whenever there are bug fixes or major model update/release (by merging from the "develop" branch); + +2. "develop" branch: (currently version 5.0), used for continuous NoahMP development, keep updated by including bug fixes and code updates (e.g., new physics options, processes, etc.); + +3. other version release branches: store different released code versions. + + +## Important notes + +This GitHub repository only provides the Noah-MP source code and driver/interface code. To run Noah-MP in either offline or online mode, users need to have the host model system/framework coupled with Noah-MP. + +NCAR also maintains and releases the HRLDAS (High Resolution Land Data Assimilation System) coupled with Noah-MP to allow offline Noah-MP simulations. Please see the HRLDAS GitHub repository (https://github.com/NCAR/hrldas) for details. For users who are interested in other host models that couple with Noah-MP, please refer to those host model GitHub repositories. + +For users who are interested in previous Noah-MP code versions (prior to version 5.0), please refer to the different GitHub branches in this repository. Particularly, the "release-v4.5-WRF" branch has the same model physics as the Noah-MP version 5.0, but with an old model code structures, which is consistent with the Noah-MP code released along with WRF version 4.5. + + +## Code contribution via GitHub + +Users are welcome to make code development and contributions through GitHub pull requests. The pull request will be reviewed by the Noah-MP model physics and code release team, and if everything looks good, the pull request of new code development or bug fixes will be merged into the develop branch. During each year's major version release period, the updated develop branch will be further merged into the master branch for official release of a new Noah-MP model version. + +Some suggestions for model developers to contribute to Noah-MP code through the GitHub repository (typical procedures): + +1. Step (1) Create a fork of this official Noah-MP repository to your own GitHub account; + +2. Step (2) Create a new branch based on the latest "develop" branch and make code updates/changes in the forked repository under your own account; + +3. Step (3) Finalize and test the code updates you make; + +4. Step (4) Submit a pull request for your code updates from your own forked Github repository to the "develop" branch of this official Noah-MP repository; + +5. Step (5) The Noah-MP physics and code review committee reviews and tests the model updates in the submitted pull request and discusses with the developer if there is any problem; + +6. Step (6) The Noah-MP physics and code review committee confirms the pull request and merges the updated code to the "develop" branch in this official Noah-MP repository; + +7. Step (7) The Noah-MP physics and code review committee merges the updated "develop" branch to the master branch during the annual release of new model versions. + + +## License + +The license and terms of use for this software can be found [here](https://github.com/NCAR/noahmp/blob/develop/LICENSE.txt) + diff --git a/src/core_atmosphere/physics/physics_noahmp/RELEASE_NOTES.md b/src/core_atmosphere/physics/physics_noahmp/RELEASE_NOTES.md new file mode 100644 index 0000000000..ae45c39f5a --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/RELEASE_NOTES.md @@ -0,0 +1,426 @@ +# Noah-MP model release notes + +## Noah-MP version 5.0 release + +### LSM capabilities/enhancements + +- Modernization/refactoring: + + - Major re-structure/refactoring of the entire Noah-MP code with modern Fortran standards without physics changes. + +### LSM bug fixes + +- None + +### External modules capabilities/enhancements + +- None + +### Driver capabilities/enhancements + +- Refactored driver to work with the modernized Noah-MP version 5.0 + +### Driver bug fixes + +- None + + +## Noah-MP version 4.5 release + +### LSM capabilities/enhancements + +- Urban modeling: + + - Update the local climate zone numbers + +- Canopy heat storage: + + - bring hard-coded tunable canopy heat capacity parameter to MPTABLE + +### LSM bug fixes + +- Several bug fixes in urban, runoff, canopy, crop processes + +### External modules capabilities/enhancements + +- None + +### Driver capabilities/enhancements + +- None + +### Driver bug fixes + +- None + + +## Noah-MP version 4.4 release + +### LSM capabilities/enhancements + +- Tile drainage: + + - Add new tile drainage physics and options + +- Snowpack process enhancement: + + - Improved snow viscosity to enhance snowpack compaction + +- Canopy heat storage: + + - add canopy heat storage in vegetation temperature calculation + +- Runoff scheme: + + - Updated formulation in runoff option =1 (TOPMODEL with groundwater) + +- Soil processes: + + - Add new capabilities to allow using a different soil timestep with main Noah-MP timestep using namelist control + +- Input/output: + + - Add new capabilities to output additional detailed Noah-MP water budget terms using namelist control + +### LSM bug fixes + +- Several bug fixes in inout variables, energy, water, and canopy processes + +### External modules capabilities/enhancements + +- None + +### Driver capabilities/enhancements + +- None + +### Driver bug fixes + +- None + + +## Noah-MP version 4.3 release + +### LSM capabilities/enhancements + +- Snow-related updates: + + - Add wet-bulb temperature snow-rain partitioning scheme (OPT_SNF=5) based on Wang et al. 2019 (NWM) + - Add snow retention process at the snowpack bottom to improve streamflow modeling (NWM) + - Modify wind-canopy absorption coefficient (CWPVT) parameter values in MPTABLE to be vegetation dependent based on Goudriaan1977 + - Bring hard-coded snow emissivity and parameter (2.5*z0) in snow cover formulation to tunable MPTABLE parameters + - Update MFSNO in snow cover formulation with optimized vegetation-dependent values + - Limit the bulk leaf boundary layer resistance (RB) to a more realistic range (5~50) + +- New irrigation scheme: + + - multiple irrigation methods: sprinkler, micro, and surface flooding + +- Crop scheme update: + + - separate the original generic crop physiology parameters in the modis vegetation section into C3/C4 specific parameters in the crop section + +- New urban physics working with Noah-MP: + + - Local climate zone (LCZ), solar panel, green roof, new building drag parameterization + +### LSM bug fixes + +- None + +### External modules capabilities/enhancements + +- None + +### Driver capabilities/enhancements + +- None + +### Driver bug fixes + +- None + + +## Noah-MP version 4.1 release + +### LSM capabilities/enhancements + +- Consolidate NWM changes into WRF version (#18) + - add unpopulated header required by NOAA + - add BATS parameters to data structure and output band snow albedo + - update MPTABLE for BATS albedo parameters + - add BATS albedo local variables to noahmpdrv + - transfer new BATS table values to parameters data structure in noahmpdrv + - add RSURF_EXP parameter to data structure and update MPTABLE + - change snow water equivalent limit to 5000mm + - assume LAI is stand LAI and doesn't need to be rescaled by FVEG + - conserve snow pack heat when layer melts completely + - change output messages and Fortran open/read unit numbers to WCOSS standard + - include a few missed changes from WRF + +### LSM bug fixes + +- Define and declare a few variables in physics routines + +- Noah-MP bulk urban roughness length set to table values + +### External modules capabilities/enhancements + +- Air conditioning fraction for BEM model + +- Improve urban memory by allowing different dimensions for urban variables + +### Driver capabilities/enhancements + +- None + +### Driver bug fixes + +- None + + +## Noah-MP version 4.0.1 release + +### LSM capabilities/enhancements + +- None + +### LSM bug fixes + +- Noah-MP frozen soil initialization- An incorrect sign change was introduced in v4.0, impacting soil moisture and soil temperature initialization. + +- Array out of bounds Noah-MP - Fix possible/likely array out of bounds by assuming homogeneous soil with depth.Only applies to opt_run=2. + +- Noah-MP snow liquid water movement - prevent excessive gravitational water movement. Fixes unrealistic snow density values during melt season. + +- Noah-MP divide by zero - Bug fix in v4.0 introduced a possible divide by zero when LAI is zero. + +- Noah-MP leaf aerodynamic resistance - limit leaf aerodynamic resistance to prevent very large canopy exchange coefficients with high wind speed. + +### Driver capabilities/enhancements + +- Add new single point driver based on Bondville data + +### Driver bug fixes + +- Missing quotation mark in spatial_filename check print statement + + +## Noah-MP version 4.0 release + +### LSM capabilities/enhancements + +- Add pedotransfer function option for soil propertis + - add optional read for soil composition and multi-layer soil texture from setup/input file + - activated with opt_soil and opt_pedo + - update MPTABLE.TBL with pedotransfer function coefficients + +- Add Gecros crop model + - activated with opt_crop=2 (Liu et al. crop now opt_crop=1) + - some modifications for crop initialization + +- Groundwater module (opt_run=5) updates + - move init to driver for parallel capability + - remove rivermask/nonriver from input + +- EPA modifications to output total stomatal resistance + +### LSM bug fixes + +- None + +### Driver capabilities/enhancements + +- Change some predefined defaults in user_build_options.compiler files based on some Cheyenne tests + +- Add ISLAKE to the preprocessing and driver to accommodate WRF files that define a distinct lake category + +### Driver bug fixes + +- Change PGSXY and CROPCAT to be initialized undefined_int + + +## Noah-MP version 3.9 release + +### LSM capabilities/enhancements + +- Crop modifications in v3.9 to read in crop datasets and initialize properly + +- Modifications in v3.9 to read in groundwater datasets + +- Noah-MP can now run with single-layer and multi-layer urban models + +### LSM bug fixes + +- Several fixes in Section 1 of SOILPARM.TBL + +- Fix strange Noah-MP behavior in soil water in certain conditions + +- Fix uninitialized variable in Noah-MP surface exchange option + +### Driver capabilities/enhancements + +- Add capability to include snow in forcing files + - Need to set FORCING_NAME_SN and PCP_PARTITION_OPTION = 4 + - Snow is assumed to be <= incoming precipitation + +- Add capability to define name of forcing variables in namelist.hrldas + +- Add spinup option to namelist + - controlled by spinup_loops in namelist.hrldas + - will run kday/khour spinup_loops times before starting the simulation + +- Add capability to exclude the first output file since this file contains only initial states + - and no computed fluxes + - activated by namelist.hrldas option: SKIP_FIRST_OUTPUT = .true. + +- Added README.namelist to describe all the namelist.hrldas options + +### Driver bug fixes + +- None + + +## Noah-MP version 3.8.1 release + +### LSM capabilities/enhancements + +- None + +### LSM bug fixes + +- Change C3C4 in MPTABLE to integer + +- Set some limits on stability function for OPT_SFC = 2 + +- Change limit for minimum wood pool in dynamic vegetation + +- Fix bug in QSFC calculation + +- Prevent divide by zero when soil moisture is zero + +- Fix a few bugs in the crop code; make DVEG = 10 activate crop model + +### Driver capabilities/enhancements + +- Added configure script for generating user_build_options file + +### Driver bug fixes + +- None + + +## Noah-MP version 3.8 release + +### LSM capabilities/enhancements + +- Added 3 new dveg option for reading LAI from forcing and 1 new dveg option for reading FVEG; + + - Also added initial commit of crop model; currently runs crop everywhere + - dveg = 6 -> dynamic vegetation on (use FVEG = SHDFAC from input) + - dveg = 7 -> dynamic vegetation off (use input LAI; use FVEG = SHDFAC from input) + - dveg = 8 -> dynamic vegetation off (use input LAI; calculate FVEG) + - dveg = 9 -> dynamic vegetation off (use input LAI; use maximum vegetation fraction) + - dveg = 10 -> crop model on (use maximum vegetation fraction) + +- Added glacier options: + + - opt_gla = 1 -> original Noah-MP version + - opt_gla = 2 -> no ice phase change or sublimation (like Noah glacier) + +- Added surface resistance as an option (now four options) + + - opt_sfc = 1 -> Sakaguchi and Zeng, 2009 (has been Noah-MP default) + - opt_sfc = 2 -> Sellers (1992) + - opt_sfc = 3 -> adjusted Sellers to decrease RSURF for wet soil + - opt_sfc = 4 -> option 1 for non-snow; rsurf = rsurf_snow for snow (set as RSURF_SNOW in MPTABLE) + +- Made the specification of urban types more general + + - (LOW_DENSITY_RESIDENTIAL, HIGH_DENSITY_RESIDENTIAL, HIGH_INTENSITY_INDUSTRIAL), + - now set in the MPTABLE dependent on classification scheme (i.e., not limited to 31,32,33); + - this is for future coupling with urban models. + +### LSM bug fixes + +- Fixed two bugs with OPT_STC=3 + +- Fixed bug in new surface resistance option causing divide by 0 + +- Write a message if incoming snow water and snow depth are inconsistent; + Reduce SWE to 2000mm if input is >2000mm, Noah-MP limits SWE internally to 2000mm + +- Recalculate ESTG in glacier code when snow is melting, will decrease sublimation, but likely increase melting + +### Driver capabilities/enhancements + +- Added instructions and scripts for extraction of single point forcing and setup files from + 2D datasets (e.g., NLDAS) + +- Structure for spatially-varying soil properties added to DRV and LSM; + Use of the 2D/3D fields in the driver and DRV commented to be consistent with WRF + +### Driver bug fixes + +- Zero forcing where not land to prevent overflow with ifort + + +## Noah-MP version 3.7.1 release + +### LSM capabilities/enhancements + +- Added depth dimension to soil parameters. + +### LSM bug fixes + +- Reorganized parameters to fix problems with OpenMP in WRF simulations. + +### Driver capabilities/enhancements + +- none + +### Driver bug fixes + +- Initialized some accumulated fields at 0 (instead of undefined). + + +## Noah-MP version 3.7 release + +### New capabilities: + +- A parallel capability has been added by Wei Yu (weiyu@ncar.edu) to support mpi only. + + - To compile with parallel version, edit the file 'user_build_options', + uncommment the compiler section with MPI (available for pgf90 and ifort compilers) + - To compile with sequential version, edit the file 'user_build_options', uncommment the compiler section without MPI + +- System setup and execution now requires only a WRF/WPS geo_em file, Dependence on the wrfinput file has been removed. + +- As part of #2, initialization no longer occurs in the first forcing file, + + - but in the file listed in the namelist as: HRLDAS_SETUP_FILE = " + - The initialization fields are: SNOW,CANWAT,TSK,TSLB,SMOIS + - This file also contains the static grid/domain information: XLAT,XLONG,TMN,HGT,SEAICE,MAPFAC_MX,MAPFAC_MY,SHDMAX,SHDMIN,XLAND,IVGTYP,ISLTYP,DZS,ZS + - This file can also contains some optional fields: LAI + - NOTE: a WRF input file can be used as a HRLDAS_SETUP_FILE + +- The timing structure has changed: + + - The initial conditions are the states at START time. + - First forcing file used is START time + FORCING_TIMESTEP + - First integration is START time + NOAH_TIMESTEP + +- First output file is now START time + OUTPUT_TIMESTEP + +- RESTART file states are consistent with OUTPUT file states with the same time stamp + +- Instructions for using GLDAS and NLDAS as forcing has been provided in addition to the NARR instructions (see /docs) + - Also, a NCL script has been included for preparing single- or multi-point forcing + +- Initial LAI (if present in the HRLDAS_SETUP_FILE) will be used to initialize the leaf and stem carbon pools + +- Removed dependence on external GRIB tables for forcing creation; now in namelist only + + + +Updated: March 10, 2023 diff --git a/src/core_atmosphere/physics/physics_noahmp/docs/NoahMP_refactored_variable_name_glossary_Feb2023.xlsx b/src/core_atmosphere/physics/physics_noahmp/docs/NoahMP_refactored_variable_name_glossary_Feb2023.xlsx new file mode 100644 index 0000000000..8008b630b6 Binary files /dev/null and b/src/core_atmosphere/physics/physics_noahmp/docs/NoahMP_refactored_variable_name_glossary_Feb2023.xlsx differ diff --git a/src/core_atmosphere/physics/physics_noahmp/docs/NoahMP_v5_technote.pdf b/src/core_atmosphere/physics/physics_noahmp/docs/NoahMP_v5_technote.pdf new file mode 100644 index 0000000000..cc0e9eaf43 Binary files /dev/null and b/src/core_atmosphere/physics/physics_noahmp/docs/NoahMP_v5_technote.pdf differ diff --git a/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/BiochemVarInTransferMod.F90 b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/BiochemVarInTransferMod.F90 new file mode 100644 index 0000000000..82d041957e --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/BiochemVarInTransferMod.F90 @@ -0,0 +1,148 @@ +module BiochemVarInTransferMod + +!!! Transfer input 2-D NoahmpIO Biochemistry variables to 1-D column variable +!!! 1-D variables should be first defined in /src/BiochemVarType.F90 +!!! 2-D variables should be first defined in NoahmpIOVarType.F90 + +! ------------------------ Code history ----------------------------------- +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + use Machine + use NoahmpIOVarType + use NoahmpVarType + + implicit none + +contains + +!=== initialize with input data or table values + + subroutine BiochemVarInTransfer(noahmp, NoahmpIO) + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + type(NoahmpIO_type), intent(inout) :: NoahmpIO + +! ------------------------------------------------------------------------- + associate( & + I => noahmp%config%domain%GridIndexI ,& + VegType => noahmp%config%domain%VegType ,& + CropType => noahmp%config%domain%CropType ,& + OptCropModel => noahmp%config%nmlist%OptCropModel & + ) +! ------------------------------------------------------------------------- + + ! biochem state variables + noahmp%biochem%state%PlantGrowStage = NoahmpIO%PGSXY (I) + noahmp%biochem%state%LeafMass = NoahmpIO%LFMASSXY(I) + noahmp%biochem%state%RootMass = NoahmpIO%RTMASSXY(I) + noahmp%biochem%state%StemMass = NoahmpIO%STMASSXY(I) + noahmp%biochem%state%WoodMass = NoahmpIO%WOODXY (I) + noahmp%biochem%state%CarbonMassDeepSoil = NoahmpIO%STBLCPXY(I) + noahmp%biochem%state%CarbonMassShallowSoil = NoahmpIO%FASTCPXY(I) + noahmp%biochem%state%GrainMass = NoahmpIO%GRAINXY (I) + noahmp%biochem%state%GrowDegreeDay = NoahmpIO%GDDXY (I) + noahmp%biochem%state%NitrogenConcFoliage = 1.0 ! for now, set to nitrogen saturation + + ! biochem parameter variables + noahmp%biochem%param%NitrogenConcFoliageMax = NoahmpIO%FOLNMX_TABLE (VegType) + noahmp%biochem%param%QuantumEfficiency25C = NoahmpIO%QE25_TABLE (VegType) + noahmp%biochem%param%CarboxylRateMax25C = NoahmpIO%VCMX25_TABLE (VegType) + noahmp%biochem%param%CarboxylRateMaxQ10 = NoahmpIO%AVCMX_TABLE (VegType) + noahmp%biochem%param%PhotosynPathC3 = NoahmpIO%C3PSN_TABLE (VegType) + noahmp%biochem%param%SlopeConductToPhotosyn = NoahmpIO%MP_TABLE (VegType) + noahmp%biochem%param%RespMaintQ10 = NoahmpIO%ARM_TABLE (VegType) + noahmp%biochem%param%RespMaintLeaf25C = NoahmpIO%RMF25_TABLE (VegType) + noahmp%biochem%param%RespMaintStem25C = NoahmpIO%RMS25_TABLE (VegType) + noahmp%biochem%param%RespMaintRoot25C = NoahmpIO%RMR25_TABLE (VegType) + noahmp%biochem%param%WoodToRootRatio = NoahmpIO%WRRAT_TABLE (VegType) + noahmp%biochem%param%WoodPoolIndex = NoahmpIO%WDPOOL_TABLE (VegType) + noahmp%biochem%param%TurnoverCoeffLeafVeg = NoahmpIO%LTOVRC_TABLE (VegType) + noahmp%biochem%param%TemperaureLeafFreeze = NoahmpIO%TDLEF_TABLE (VegType) + noahmp%biochem%param%LeafDeathWaterCoeffVeg = NoahmpIO%DILEFW_TABLE (VegType) + noahmp%biochem%param%LeafDeathTempCoeffVeg = NoahmpIO%DILEFC_TABLE (VegType) + noahmp%biochem%param%GrowthRespFrac = NoahmpIO%FRAGR_TABLE (VegType) + noahmp%biochem%param%MicroRespCoeff = NoahmpIO%MRP_TABLE (VegType) + noahmp%biochem%param%TemperatureMinPhotosyn = NoahmpIO%TMIN_TABLE (VegType) + noahmp%biochem%param%LeafAreaPerMass1side = NoahmpIO%SLA_TABLE (VegType) + noahmp%biochem%param%StemAreaIndexMin = NoahmpIO%XSAMIN_TABLE (VegType) + noahmp%biochem%param%WoodAllocFac = NoahmpIO%BF_TABLE (VegType) + noahmp%biochem%param%WaterStressCoeff = NoahmpIO%WSTRC_TABLE (VegType) + noahmp%biochem%param%LeafAreaIndexMin = NoahmpIO%LAIMIN_TABLE (VegType) + noahmp%biochem%param%TurnoverCoeffRootVeg = NoahmpIO%RTOVRC_TABLE (VegType) + noahmp%biochem%param%WoodRespCoeff = NoahmpIO%RSWOODC_TABLE(VegType) + ! crop model specific parameters + if ( (OptCropModel > 0) .and. (CropType > 0) ) then + noahmp%biochem%param%DatePlanting = NoahmpIO%PLTDAY_TABLE (CropType) + noahmp%biochem%param%DateHarvest = NoahmpIO%HSDAY_TABLE (CropType) + noahmp%biochem%param%NitrogenConcFoliageMax = NoahmpIO%FOLNMXI_TABLE (CropType) + noahmp%biochem%param%QuantumEfficiency25C = NoahmpIO%QE25I_TABLE (CropType) + noahmp%biochem%param%CarboxylRateMax25C = NoahmpIO%VCMX25I_TABLE (CropType) + noahmp%biochem%param%CarboxylRateMaxQ10 = NoahmpIO%AVCMXI_TABLE (CropType) + noahmp%biochem%param%PhotosynPathC3 = NoahmpIO%C3PSNI_TABLE (CropType) + noahmp%biochem%param%SlopeConductToPhotosyn = NoahmpIO%MPI_TABLE (CropType) + noahmp%biochem%param%RespMaintQ10 = NoahmpIO%Q10MR_TABLE (CropType) + noahmp%biochem%param%RespMaintLeaf25C = NoahmpIO%LFMR25_TABLE (CropType) + noahmp%biochem%param%RespMaintStem25C = NoahmpIO%STMR25_TABLE (CropType) + noahmp%biochem%param%RespMaintRoot25C = NoahmpIO%RTMR25_TABLE (CropType) + noahmp%biochem%param%GrowthRespFrac = NoahmpIO%FRA_GR_TABLE (CropType) + noahmp%biochem%param%TemperaureLeafFreeze = NoahmpIO%LEFREEZ_TABLE (CropType) + noahmp%biochem%param%LeafAreaPerBiomass = NoahmpIO%BIO2LAI_TABLE (CropType) + noahmp%biochem%param%TempBaseGrowDegDay = NoahmpIO%GDDTBASE_TABLE (CropType) + noahmp%biochem%param%TempMaxGrowDegDay = NoahmpIO%GDDTCUT_TABLE (CropType) + noahmp%biochem%param%GrowDegDayEmerg = NoahmpIO%GDDS1_TABLE (CropType) + noahmp%biochem%param%GrowDegDayInitVeg = NoahmpIO%GDDS2_TABLE (CropType) + noahmp%biochem%param%GrowDegDayPostVeg = NoahmpIO%GDDS3_TABLE (CropType) + noahmp%biochem%param%GrowDegDayInitReprod = NoahmpIO%GDDS4_TABLE (CropType) + noahmp%biochem%param%GrowDegDayMature = NoahmpIO%GDDS5_TABLE (CropType) + noahmp%biochem%param%PhotosynRadFrac = NoahmpIO%I2PAR_TABLE (CropType) + noahmp%biochem%param%TempMinCarbonAssim = NoahmpIO%TASSIM0_TABLE (CropType) + noahmp%biochem%param%TempMaxCarbonAssim = NoahmpIO%TASSIM1_TABLE (CropType) + noahmp%biochem%param%TempMaxCarbonAssimMax = NoahmpIO%TASSIM2_TABLE (CropType) + noahmp%biochem%param%CarbonAssimRefMax = NoahmpIO%AREF_TABLE (CropType) + noahmp%biochem%param%LightExtCoeff = NoahmpIO%K_TABLE (CropType) + noahmp%biochem%param%LightUseEfficiency = NoahmpIO%EPSI_TABLE (CropType) + noahmp%biochem%param%CarbonAssimReducFac = NoahmpIO%PSNRF_TABLE (CropType) + noahmp%biochem%param%RespMaintGrain25C = NoahmpIO%GRAINMR25_TABLE(CropType) + noahmp%biochem%param%LeafDeathTempCoeffCrop = NoahmpIO%DILE_FC_TABLE (CropType,:) + noahmp%biochem%param%LeafDeathWaterCoeffCrop = NoahmpIO%DILE_FW_TABLE (CropType,:) + noahmp%biochem%param%CarbohydrLeafToGrain = NoahmpIO%LFCT_TABLE (CropType,:) + noahmp%biochem%param%CarbohydrStemToGrain = NoahmpIO%STCT_TABLE (CropType,:) + noahmp%biochem%param%CarbohydrRootToGrain = NoahmpIO%RTCT_TABLE (CropType,:) + noahmp%biochem%param%CarbohydrFracToLeaf = NoahmpIO%LFPT_TABLE (CropType,:) + noahmp%biochem%param%CarbohydrFracToStem = NoahmpIO%STPT_TABLE (CropType,:) + noahmp%biochem%param%CarbohydrFracToRoot = NoahmpIO%RTPT_TABLE (CropType,:) + noahmp%biochem%param%CarbohydrFracToGrain = NoahmpIO%GRAINPT_TABLE (CropType,:) + noahmp%biochem%param%TurnoverCoeffLeafCrop = NoahmpIO%LF_OVRC_TABLE (CropType,:) + noahmp%biochem%param%TurnoverCoeffStemCrop = NoahmpIO%ST_OVRC_TABLE (CropType,:) + noahmp%biochem%param%TurnoverCoeffRootCrop = NoahmpIO%RT_OVRC_TABLE (CropType,:) + + if ( OptCropModel == 1 ) then + noahmp%biochem%param%DatePlanting = NoahmpIO%PLANTING(I) + noahmp%biochem%param%DateHarvest = NoahmpIO%HARVEST(I) + noahmp%biochem%param%GrowDegDayEmerg = NoahmpIO%SEASON_GDD(I) / 1770.0 * & + noahmp%biochem%param%GrowDegDayEmerg + noahmp%biochem%param%GrowDegDayInitVeg = NoahmpIO%SEASON_GDD(I) / 1770.0 * & + noahmp%biochem%param%GrowDegDayInitVeg + noahmp%biochem%param%GrowDegDayPostVeg = NoahmpIO%SEASON_GDD(I) / 1770.0 * & + noahmp%biochem%param%GrowDegDayPostVeg + noahmp%biochem%param%GrowDegDayInitReprod = NoahmpIO%SEASON_GDD(I) / 1770.0 * & + noahmp%biochem%param%GrowDegDayInitReprod + noahmp%biochem%param%GrowDegDayMature = NoahmpIO%SEASON_GDD(I) / 1770.0 * & + noahmp%biochem%param%GrowDegDayMature + endif + endif ! activate crop parameters + + if ( noahmp%config%nmlist%OptIrrigation == 2 ) then + noahmp%biochem%param%DatePlanting = NoahmpIO%PLANTING(I) + noahmp%biochem%param%DateHarvest = NoahmpIO%HARVEST (I) + endif + + end associate + + end subroutine BiochemVarInTransfer + +end module BiochemVarInTransferMod diff --git a/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/BiochemVarOutTransferMod.F90 b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/BiochemVarOutTransferMod.F90 new file mode 100644 index 0000000000..b8e81b65f6 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/BiochemVarOutTransferMod.F90 @@ -0,0 +1,54 @@ +module BiochemVarOutTransferMod + +!!! Transfer column (1-D) biochemistry variables to 2D NoahmpIO for output + +! ------------------------ Code history ----------------------------------- +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + use Machine + use NoahmpIOVarType + use NoahmpVarType + + implicit none + +contains + +!=== Transfer model states to output ===== + + subroutine BiochemVarOutTransfer(noahmp, NoahmpIO) + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + type(NoahmpIO_type), intent(inout) :: NoahmpIO + +! --------------------------------------------------------------------- + associate( & + I => noahmp%config%domain%GridIndexI & + ) +! --------------------------------------------------------------------- + + ! biochem state variables + NoahmpIO%LFMASSXY(I) = noahmp%biochem%state%LeafMass + NoahmpIO%RTMASSXY(I) = noahmp%biochem%state%RootMass + NoahmpIO%STMASSXY(I) = noahmp%biochem%state%StemMass + NoahmpIO%WOODXY (I) = noahmp%biochem%state%WoodMass + NoahmpIO%STBLCPXY(I) = noahmp%biochem%state%CarbonMassDeepSoil + NoahmpIO%FASTCPXY(I) = noahmp%biochem%state%CarbonMassShallowSoil + NoahmpIO%GDDXY (I) = noahmp%biochem%state%GrowDegreeDay + NoahmpIO%PGSXY (I) = noahmp%biochem%state%PlantGrowStage + NoahmpIO%GRAINXY (I) = noahmp%biochem%state%GrainMass + + ! biochem flux variables + NoahmpIO%NEEXY (I) = noahmp%biochem%flux%NetEcoExchange + NoahmpIO%GPPXY (I) = noahmp%biochem%flux%GrossPriProduction + NoahmpIO%NPPXY (I) = noahmp%biochem%flux%NetPriProductionTot + NoahmpIO%PSNXY (I) = noahmp%biochem%flux%PhotosynTotal + + end associate + + end subroutine BiochemVarOutTransfer + +end module BiochemVarOutTransferMod diff --git a/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/ConfigVarInTransferMod.F90 b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/ConfigVarInTransferMod.F90 new file mode 100644 index 0000000000..2de35ed9c2 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/ConfigVarInTransferMod.F90 @@ -0,0 +1,170 @@ +module ConfigVarInTransferMod + +!!! Transfer input 2-D NoahmpIO Configuration variables to 1-D column variable +!!! 1-D variables should be first defined in /src/ConfigVarType.F90 +!!! 2-D variables should be first defined in NoahmpIOVarType.F90 + +! ------------------------ Code history ----------------------------------- +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + use Machine + use NoahmpIOVarType + use NoahmpVarType + + implicit none + +contains + +!=== initialize with input/restart data or table values + + subroutine ConfigVarInTransfer(noahmp, NoahmpIO) + + implicit none + + type(NoahmpIO_type) , intent(inout) :: NoahmpIO + type(noahmp_type), intent(inout) :: noahmp + +! --------------------------------------------------------------------- + associate( & + I => NoahmpIO%I ,& + NumSnowLayerMax => NoahmpIO%NSNOW ,& + NumSoilLayer => NoahmpIO%NSOIL & + ) +! --------------------------------------------------------------------- + + ! config namelist variable + noahmp%config%nmlist%OptDynamicVeg = NoahmpIO%IOPT_DVEG + noahmp%config%nmlist%OptRainSnowPartition = NoahmpIO%IOPT_SNF + noahmp%config%nmlist%OptSoilWaterTranspiration = NoahmpIO%IOPT_BTR + noahmp%config%nmlist%OptGroundResistanceEvap = NoahmpIO%IOPT_RSF + noahmp%config%nmlist%OptSurfaceDrag = NoahmpIO%IOPT_SFC + noahmp%config%nmlist%OptStomataResistance = NoahmpIO%IOPT_CRS + noahmp%config%nmlist%OptSnowAlbedo = NoahmpIO%IOPT_ALB + noahmp%config%nmlist%OptCanopyRadiationTransfer = NoahmpIO%IOPT_RAD + noahmp%config%nmlist%OptSnowSoilTempTime = NoahmpIO%IOPT_STC + noahmp%config%nmlist%OptSnowThermConduct = NoahmpIO%IOPT_TKSNO + noahmp%config%nmlist%OptSoilTemperatureBottom = NoahmpIO%IOPT_TBOT + noahmp%config%nmlist%OptSoilSupercoolWater = NoahmpIO%IOPT_FRZ + noahmp%config%nmlist%OptSoilPermeabilityFrozen = NoahmpIO%IOPT_INF + noahmp%config%nmlist%OptDynVicInfiltration = NoahmpIO%IOPT_INFDV + noahmp%config%nmlist%OptTileDrainage = NoahmpIO%IOPT_TDRN + noahmp%config%nmlist%OptIrrigation = NoahmpIO%IOPT_IRR + noahmp%config%nmlist%OptIrrigationMethod = NoahmpIO%IOPT_IRRM + noahmp%config%nmlist%OptCropModel = NoahmpIO%IOPT_CROP + noahmp%config%nmlist%OptSoilProperty = NoahmpIO%IOPT_SOIL + noahmp%config%nmlist%OptPedotransfer = NoahmpIO%IOPT_PEDO + noahmp%config%nmlist%OptRunoffSurface = NoahmpIO%IOPT_RUNSRF + noahmp%config%nmlist%OptRunoffSubsurface = NoahmpIO%IOPT_RUNSUB + noahmp%config%nmlist%OptGlacierTreatment = NoahmpIO%IOPT_GLA + + ! config domain variable + noahmp%config%domain%SurfaceType = 1 + noahmp%config%domain%NumSwRadBand = 2 + noahmp%config%domain%SoilColor = 4 + noahmp%config%domain%NumCropGrowStage = 8 + noahmp%config%domain%FlagSoilProcess = NoahmpIO%calculate_soil + noahmp%config%domain%NumSoilTimeStep = NoahmpIO%soil_update_steps + noahmp%config%domain%NumSnowLayerMax = NoahmpIO%NSNOW + noahmp%config%domain%NumSnowLayerNeg = NoahmpIO%ISNOWXY(I) + noahmp%config%domain%NumSoilLayer = NoahmpIO%NSOIL + noahmp%config%domain%GridIndexI = NoahmpIO%I + noahmp%config%domain%GridIndexJ = NoahmpIO%J + noahmp%config%domain%MainTimeStep = NoahmpIO%DTBL + noahmp%config%domain%SoilTimeStep = NoahmpIO%DTBL * NoahmpIO%soil_update_steps + noahmp%config%domain%GridSize = NoahmpIO%DX + noahmp%config%domain%LandUseDataName = NoahmpIO%LLANDUSE + noahmp%config%domain%VegType = NoahmpIO%IVGTYP(I) + noahmp%config%domain%CropType = NoahmpIO%CROPCAT(I) + noahmp%config%domain%IndicatorIceSfc = NoahmpIO%ICE + noahmp%config%domain%DayJulianInYear = NoahmpIO%JULIAN + noahmp%config%domain%NumDayInYear = NoahmpIO%YEARLEN + noahmp%config%domain%Latitude = NoahmpIO%XLAT(I) + noahmp%config%domain%RefHeightAboveSfc = NoahmpIO%DZ8W(I,1)*0.5 + noahmp%config%domain%ThicknessAtmosBotLayer = NoahmpIO%DZ8W(I,1) + noahmp%config%domain%CosSolarZenithAngle = NoahmpIO%COSZEN(I) + noahmp%config%domain%IndexWaterPoint = NoahmpIO%ISWATER_TABLE + noahmp%config%domain%IndexBarrenPoint = NoahmpIO%ISBARREN_TABLE + noahmp%config%domain%IndexIcePoint = NoahmpIO%ISICE_TABLE + noahmp%config%domain%IndexCropPoint = NoahmpIO%ISCROP_TABLE + noahmp%config%domain%IndexEBLForest = NoahmpIO%EBLFOREST_TABLE + noahmp%config%domain%RunoffSlopeType = NoahmpIO%SLOPETYP + noahmp%config%domain%DepthSoilTempBottom = NoahmpIO%ZBOT_TABLE + + ! the following initialization cannot be done in ConfigVarInitMod + ! because the NumSoilLayer and NumSnowLayerMax are initialized with input values in this module + if ( .not. allocated(noahmp%config%domain%DepthSoilLayer) ) & + allocate( noahmp%config%domain%DepthSoilLayer(1:NumSoilLayer) ) + if ( .not. allocated(noahmp%config%domain%ThicknessSoilLayer) ) & + allocate( noahmp%config%domain%ThicknessSoilLayer(1:NumSoilLayer) ) + if ( .not. allocated(noahmp%config%domain%SoilType) ) & + allocate( noahmp%config%domain%SoilType(1:NumSoilLayer) ) + if ( .not. allocated(noahmp%config%domain%ThicknessSnowSoilLayer) ) & + allocate( noahmp%config%domain%ThicknessSnowSoilLayer(-NumSnowLayerMax+1:NumSoilLayer) ) + if ( .not. allocated(noahmp%config%domain%DepthSnowSoilLayer) ) & + allocate( noahmp%config%domain%DepthSnowSoilLayer(-NumSnowLayerMax+1:NumSoilLayer) ) + + noahmp%config%domain%SoilType (:) = undefined_int + noahmp%config%domain%DepthSoilLayer (:) = undefined_real + noahmp%config%domain%ThicknessSoilLayer (:) = undefined_real + noahmp%config%domain%ThicknessSnowSoilLayer(:) = undefined_real + noahmp%config%domain%DepthSnowSoilLayer (:) = undefined_real + + if ( noahmp%config%nmlist%OptSoilProperty == 1 ) then + noahmp%config%domain%SoilType(1:NumSoilLayer) = NoahmpIO%ISLTYP(I) ! soil type same in all layers + elseif ( noahmp%config%nmlist%OptSoilProperty == 2 ) then + noahmp%config%domain%SoilType(1) = nint(NoahmpIO%SOILCL1(I)) ! soil type in layer1 + noahmp%config%domain%SoilType(2) = nint(NoahmpIO%SOILCL2(I)) ! soil type in layer2 + noahmp%config%domain%SoilType(3) = nint(NoahmpIO%SOILCL3(I)) ! soil type in layer3 + noahmp%config%domain%SoilType(4) = nint(NoahmpIO%SOILCL4(I)) ! soil type in layer4 + elseif ( noahmp%config%nmlist%OptSoilProperty == 3 ) then + noahmp%config%domain%SoilType(1:NumSoilLayer) = NoahmpIO%ISLTYP(I) ! to initialize with default + endif + + noahmp%config%domain%DepthSoilLayer(1:NumSoilLayer) = NoahmpIO%ZSOIL(1:NumSoilLayer) + noahmp%config%domain%DepthSnowSoilLayer(-NumSnowLayerMax+1:NumSoilLayer) = & + NoahmpIO%ZSNSOXY(I,-NumSnowLayerMax+1:NumSoilLayer) + + ! treatment for urban point + if ( (NoahmpIO%IVGTYP(I) == NoahmpIO%ISURBAN_TABLE) .or. (NoahmpIO%IVGTYP(I) > NoahmpIO%URBTYPE_beg) ) then + noahmp%config%domain%FlagUrban = .true. + if(NoahmpIO%SF_URBAN_PHYSICS == 0 ) then + noahmp%config%domain%VegType = NoahmpIO%ISURBAN_TABLE + else + noahmp%config%domain%VegType = NoahmpIO%NATURAL_TABLE ! set urban vegetation type based on table natural + NoahmpIO%GVFMAX(I) = 0.96 * 100.0 ! unit: % + endif + endif + + ! treatment for crop point + noahmp%config%domain%CropType = 0 + if ( (NoahmpIO%IOPT_CROP > 0) .and. (NoahmpIO%IVGTYP(I) == NoahmpIO%ISCROP_TABLE) ) & + noahmp%config%domain%CropType = NoahmpIO%DEFAULT_CROP_TABLE + + if ( (NoahmpIO%IOPT_CROP > 0) .and. (NoahmpIO%CROPCAT(I) > 0) ) then + noahmp%config%domain%CropType = NoahmpIO%CROPCAT(I) + noahmp%config%domain%VegType = NoahmpIO%ISCROP_TABLE + NoahmpIO%VEGFRA(I) = 0.95 * 100.0 ! unit: % + NoahmpIO%GVFMAX(I) = 0.95 * 100.0 ! unit: % + endif + + ! correct inconsistent soil type + if ( any(noahmp%config%domain%SoilType == 14) .and. (NoahmpIO%XICE(I) == 0.0) ) then + write(*,*) "SOIL TYPE FOUND TO BE WATER AT A LAND-POINT" + write(*,*) "RESET SOIL type to SANDY CLAY LOAM at grid = ", I + noahmp%config%domain%SoilType = 7 + endif + + ! set warning message for inconsistent surface and subsurface runoff option + ! for now, only the same options for surface and subsurface runoff have been tested + if ( noahmp%config%nmlist%OptRunoffSurface /= noahmp%config%nmlist%OptRunoffSubsurface ) then + write(*,*) "Warning: Surface and subsurface runoff options are inconsistent! They may be incompatible!" + write(*,*) "Warning: Currently only the same options for surface and subsurface runoff are tested." + endif + + end associate + + end subroutine ConfigVarInTransfer + +end module ConfigVarInTransferMod diff --git a/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/ConfigVarOutTransferMod.F90 b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/ConfigVarOutTransferMod.F90 new file mode 100644 index 0000000000..d261f45b90 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/ConfigVarOutTransferMod.F90 @@ -0,0 +1,45 @@ +module ConfigVarOutTransferMod + +!!! To transfer 1D Noah-MP column Config variables to 2D NoahmpIO for output + +! ------------------------ Code history ----------------------------------- +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + use Machine + use NoahmpIOVarType + use NoahmpVarType + + implicit none + +contains + +!=== Transfer model states to output===== + + subroutine ConfigVarOutTransfer(noahmp, NoahmpIO) + + implicit none + + type(NoahmpIO_type) , intent(inout) :: NoahmpIO + type(noahmp_type), intent(inout) :: noahmp + +! ---------------------------------------------------------------------- + associate( & + I => noahmp%config%domain%GridIndexI ,& + NumSnowLayerMax => noahmp%config%domain%NumSnowLayerMax ,& + NumSoilLayer => noahmp%config%domain%NumSoilLayer & + ) +! ---------------------------------------------------------------------- + + ! config domain variables + NoahmpIO%ISNOWXY(I) = noahmp%config%domain%NumSnowLayerNeg + NoahmpIO%ZSNSOXY(I,-NumSnowLayerMax+1:NumSoilLayer) = & + noahmp%config%domain%DepthSnowSoilLayer(-NumSnowLayerMax+1:NumSoilLayer) + NoahmpIO%FORCZLSM(I) = noahmp%config%domain%RefHeightAboveSfc + + end associate + + end subroutine ConfigVarOutTransfer + +end module ConfigVarOutTransferMod diff --git a/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/EnergyVarInTransferMod.F90 b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/EnergyVarInTransferMod.F90 new file mode 100644 index 0000000000..f0a96a5795 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/EnergyVarInTransferMod.F90 @@ -0,0 +1,154 @@ +module EnergyVarInTransferMod + +!!! Transfer input 2-D NoahmpIO Energy variables to 1-D column variable +!!! 1-D variables should be first defined in /src/EnergyVarType.F90 +!!! 2-D variables should be first defined in NoahmpIOVarType.F90 + +! ------------------------ Code history ----------------------------------- +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + use Machine + use NoahmpIOVarType + use NoahmpVarType + + implicit none + +contains + +!=== initialize with input data or table values + + subroutine EnergyVarInTransfer(noahmp, NoahmpIO) + + implicit none + + type(NoahmpIO_type), intent(inout) :: NoahmpIO + type(noahmp_type), intent(inout) :: noahmp + + ! local loop index + integer :: SoilLayerIndex + +! ------------------------------------------------------------------------- + associate( & + I => noahmp%config%domain%GridIndexI ,& + VegType => noahmp%config%domain%VegType ,& + SoilType => noahmp%config%domain%SoilType ,& + CropType => noahmp%config%domain%CropType ,& + SoilColor => noahmp%config%domain%SoilColor ,& + FlagUrban => noahmp%config%domain%FlagUrban ,& + NumSnowLayerMax => noahmp%config%domain%NumSnowLayerMax ,& + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& + NumSwRadBand => noahmp%config%domain%NumSwRadBand & + ) +! ------------------------------------------------------------------------- + + ! energy state variables + noahmp%energy%state%LeafAreaIndex = NoahmpIO%LAI (I) + noahmp%energy%state%StemAreaIndex = NoahmpIO%XSAIXY (I) + noahmp%energy%state%SpecHumiditySfcMean = NoahmpIO%QSFC (I) + noahmp%energy%state%TemperatureGrd = NoahmpIO%TGXY (I) + noahmp%energy%state%TemperatureCanopy = NoahmpIO%TVXY (I) + noahmp%energy%state%SnowAgeNondim = NoahmpIO%TAUSSXY (I) + noahmp%energy%state%AlbedoSnowPrev = NoahmpIO%ALBOLDXY(I) + noahmp%energy%state%PressureVaporCanAir = NoahmpIO%EAHXY (I) + noahmp%energy%state%TemperatureCanopyAir = NoahmpIO%TAHXY (I) + noahmp%energy%state%ExchCoeffShSfc = NoahmpIO%CHXY (I) + noahmp%energy%state%ExchCoeffMomSfc = NoahmpIO%CMXY (I) + noahmp%energy%state%TemperatureSoilSnow(-NumSnowLayerMax+1:0) = NoahmpIO%TSNOXY (I,-NumSnowLayerMax+1:0) + noahmp%energy%state%TemperatureSoilSnow(1:NumSoilLayer) = NoahmpIO%TSLB (I,1:NumSoilLayer) + noahmp%energy%state%PressureAtmosCO2 = NoahmpIO%CO2_TABLE * noahmp%forcing%PressureAirRefHeight + noahmp%energy%state%PressureAtmosO2 = NoahmpIO%O2_TABLE * noahmp%forcing%PressureAirRefHeight + ! vegetation treatment for USGS land types (playa, lava, sand to bare) + if ( (VegType == 25) .or. (VegType == 26) .or. (VegType == 27) ) then + noahmp%energy%state%VegFrac = 0.0 + noahmp%energy%state%LeafAreaIndex = 0.0 + endif + + ! energy flux variables + noahmp%energy%flux%HeatGroundTotAcc = NoahmpIO%ACC_SSOILXY(I) + + ! energy parameter variables + noahmp%energy%param%SoilHeatCapacity = NoahmpIO%CSOIL_TABLE + noahmp%energy%param%SnowAgeFacBats = NoahmpIO%TAU0_TABLE + noahmp%energy%param%SnowGrowVapFacBats = NoahmpIO%GRAIN_GROWTH_TABLE + noahmp%energy%param%SnowSootFacBats = NoahmpIO%DIRT_SOOT_TABLE + noahmp%energy%param%SnowGrowFrzFacBats = NoahmpIO%EXTRA_GROWTH_TABLE + noahmp%energy%param%SolarZenithAdjBats = NoahmpIO%BATS_COSZ_TABLE + noahmp%energy%param%FreshSnoAlbVisBats = NoahmpIO%BATS_VIS_NEW_TABLE + noahmp%energy%param%FreshSnoAlbNirBats = NoahmpIO%BATS_NIR_NEW_TABLE + noahmp%energy%param%SnoAgeFacDifVisBats = NoahmpIO%BATS_VIS_AGE_TABLE + noahmp%energy%param%SnoAgeFacDifNirBats = NoahmpIO%BATS_NIR_AGE_TABLE + noahmp%energy%param%SzaFacDirVisBats = NoahmpIO%BATS_VIS_DIR_TABLE + noahmp%energy%param%SzaFacDirNirBats = NoahmpIO%BATS_NIR_DIR_TABLE + noahmp%energy%param%SnowAlbRefClass = NoahmpIO%CLASS_ALB_REF_TABLE + noahmp%energy%param%SnowAgeFacClass = NoahmpIO%CLASS_SNO_AGE_TABLE + noahmp%energy%param%SnowAlbFreshClass = NoahmpIO%CLASS_ALB_NEW_TABLE + noahmp%energy%param%UpscatterCoeffSnowDir = NoahmpIO%BETADS_TABLE + noahmp%energy%param%UpscatterCoeffSnowDif = NoahmpIO%BETAIS_TABLE + noahmp%energy%param%ZilitinkevichCoeff = NoahmpIO%CZIL_TABLE + noahmp%energy%param%EmissivitySnow = NoahmpIO%SNOW_EMIS_TABLE + noahmp%energy%param%EmissivitySoilLake = NoahmpIO%EG_TABLE + noahmp%energy%param%AlbedoLandIce = NoahmpIO%ALBICE_TABLE + noahmp%energy%param%RoughLenMomSnow = NoahmpIO%Z0SNO_TABLE + noahmp%energy%param%RoughLenMomSoil = NoahmpIO%Z0SOIL_TABLE + noahmp%energy%param%RoughLenMomLake = NoahmpIO%Z0LAKE_TABLE + noahmp%energy%param%EmissivityIceSfc = NoahmpIO%EICE_TABLE + noahmp%energy%param%ResistanceSoilExp = NoahmpIO%RSURF_EXP_TABLE + noahmp%energy%param%ResistanceSnowSfc = NoahmpIO%RSURF_SNOW_TABLE + noahmp%energy%param%VegFracAnnMax = NoahmpIO%GVFMAX(I) / 100.0 + noahmp%energy%param%VegFracGreen = NoahmpIO%VEGFRA(I) / 100.0 + noahmp%energy%param%TreeCrownRadius = NoahmpIO%RC_TABLE (VegType) + noahmp%energy%param%HeightCanopyTop = NoahmpIO%HVT_TABLE (VegType) + noahmp%energy%param%HeightCanopyBot = NoahmpIO%HVB_TABLE (VegType) + noahmp%energy%param%RoughLenMomVeg = NoahmpIO%Z0MVT_TABLE (VegType) + noahmp%energy%param%CanopyWindExtFac = NoahmpIO%CWPVT_TABLE (VegType) + noahmp%energy%param%TreeDensity = NoahmpIO%DEN_TABLE (VegType) + noahmp%energy%param%CanopyOrientIndex = NoahmpIO%XL_TABLE (VegType) + noahmp%energy%param%ConductanceLeafMin = NoahmpIO%BP_TABLE (VegType) + noahmp%energy%param%Co2MmConst25C = NoahmpIO%KC25_TABLE (VegType) + noahmp%energy%param%O2MmConst25C = NoahmpIO%KO25_TABLE (VegType) + noahmp%energy%param%Co2MmConstQ10 = NoahmpIO%AKC_TABLE (VegType) + noahmp%energy%param%O2MmConstQ10 = NoahmpIO%AKO_TABLE (VegType) + noahmp%energy%param%RadiationStressFac = NoahmpIO%RGL_TABLE (VegType) + noahmp%energy%param%ResistanceStomataMin = NoahmpIO%RS_TABLE (VegType) + noahmp%energy%param%ResistanceStomataMax = NoahmpIO%RSMAX_TABLE (VegType) + noahmp%energy%param%AirTempOptimTransp = NoahmpIO%TOPT_TABLE (VegType) + noahmp%energy%param%VaporPresDeficitFac = NoahmpIO%HS_TABLE (VegType) + noahmp%energy%param%LeafDimLength = NoahmpIO%DLEAF_TABLE (VegType) + noahmp%energy%param%HeatCapacCanFac = NoahmpIO%CBIOM_TABLE (VegType) + noahmp%energy%param%LeafAreaIndexMon (1:12) = NoahmpIO%LAIM_TABLE (VegType,1:12) + noahmp%energy%param%StemAreaIndexMon (1:12) = NoahmpIO%SAIM_TABLE (VegType,1:12) + noahmp%energy%param%ReflectanceLeaf (1:NumSwRadBand) = NoahmpIO%RHOL_TABLE (VegType,1:NumSwRadBand) + noahmp%energy%param%ReflectanceStem (1:NumSwRadBand) = NoahmpIO%RHOS_TABLE (VegType,1:NumSwRadBand) + noahmp%energy%param%TransmittanceLeaf(1:NumSwRadBand) = NoahmpIO%TAUL_TABLE (VegType,1:NumSwRadBand) + noahmp%energy%param%TransmittanceStem(1:NumSwRadBand) = NoahmpIO%TAUS_TABLE (VegType,1:NumSwRadBand) + noahmp%energy%param%AlbedoSoilSat (1:NumSwRadBand) = NoahmpIO%ALBSAT_TABLE(SoilColor,1:NumSwRadBand) + noahmp%energy%param%AlbedoSoilDry (1:NumSwRadBand) = NoahmpIO%ALBDRY_TABLE(SoilColor,1:NumSwRadBand) + noahmp%energy%param%AlbedoLakeFrz (1:NumSwRadBand) = NoahmpIO%ALBLAK_TABLE(1:NumSwRadBand) + noahmp%energy%param%ScatterCoeffSnow (1:NumSwRadBand) = NoahmpIO%OMEGAS_TABLE(1:NumSwRadBand) + + do SoilLayerIndex = 1, size(SoilType) + noahmp%energy%param%SoilQuartzFrac(SoilLayerIndex) = NoahmpIO%QUARTZ_TABLE(SoilType(SoilLayerIndex)) + enddo + + ! spatial varying soil input + if ( noahmp%config%nmlist%OptSoilProperty == 4 ) then + noahmp%energy%param%SoilQuartzFrac(1:NumSoilLayer) = NoahmpIO%QUARTZ_3D(I,1:NumSoilLayer) + endif + + if ( FlagUrban .eqv. .true. ) noahmp%energy%param%SoilHeatCapacity = 3.0e6 + + if ( CropType > 0 ) then + noahmp%energy%param%ConductanceLeafMin = NoahmpIO%BPI_TABLE (CropType) + noahmp%energy%param%Co2MmConst25C = NoahmpIO%KC25I_TABLE(CropType) + noahmp%energy%param%O2MmConst25C = NoahmpIO%KO25I_TABLE(CropType) + noahmp%energy%param%Co2MmConstQ10 = NoahmpIO%AKCI_TABLE (CropType) + noahmp%energy%param%O2MmConstQ10 = NoahmpIO%AKOI_TABLE (CropType) + endif + + end associate + + end subroutine EnergyVarInTransfer + +end module EnergyVarInTransferMod diff --git a/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/EnergyVarOutTransferMod.F90 b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/EnergyVarOutTransferMod.F90 new file mode 100644 index 0000000000..377a7a8bb7 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/EnergyVarOutTransferMod.F90 @@ -0,0 +1,188 @@ +module EnergyVarOutTransferMod + +!!! Transfer column (1-D) Noah-MP Energy variables to 2D NoahmpIO for output + +! ------------------------ Code history ----------------------------------- +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + use Machine + use NoahmpIOVarType + use NoahmpVarType + + implicit none + +contains + +!=== Transfer model states to output ===== + + subroutine EnergyVarOutTransfer(noahmp, NoahmpIO) + + implicit none + + type(NoahmpIO_type), intent(inout) :: NoahmpIO + type(noahmp_type), intent(inout) :: noahmp + + ! local variables + integer :: LoopInd ! snow/soil layer loop index + real(kind=kind_noahmp) :: LeafAreaIndSunlit ! sunlit leaf area index [m2/m2] + real(kind=kind_noahmp) :: LeafAreaIndShade ! shaded leaf area index [m2/m2] + real(kind=kind_noahmp) :: ResistanceLeafBoundary ! leaf boundary layer resistance [s/m] + real(kind=kind_noahmp) :: ThicknessSnowSoilLayer ! temporary snow/soil layer thickness [m] + +!----------------------------------------------------------------------- + associate( & + I => noahmp%config%domain%GridIndexI ,& + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& + NumSnowLayerMax => noahmp%config%domain%NumSnowLayerMax ,& + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg ,& + IndicatorIceSfc => noahmp%config%domain%IndicatorIceSfc & + ) +!----------------------------------------------------------------------- + + ! special treatment for glacier point output + if ( IndicatorIceSfc == -1 ) then ! land ice point + noahmp%energy%state%VegFrac = 0.0 + noahmp%energy%state%RoughLenMomSfcToAtm = 0.002 + noahmp%energy%flux%RadSwAbsVeg = 0.0 + noahmp%energy%flux%RadLwNetCanopy = 0.0 + noahmp%energy%flux%RadLwNetVegGrd = 0.0 + noahmp%energy%flux%HeatSensibleCanopy = 0.0 + noahmp%energy%flux%HeatSensibleVegGrd = 0.0 + noahmp%energy%flux%HeatLatentVegGrd = 0.0 + noahmp%energy%flux%HeatGroundVegGrd = 0.0 + noahmp%energy%flux%HeatCanStorageChg = 0.0 + noahmp%energy%flux%HeatLatentCanTransp = 0.0 + noahmp%energy%flux%HeatLatentCanEvap = 0.0 + noahmp%energy%flux%HeatPrecipAdvCanopy = 0.0 + noahmp%energy%flux%HeatPrecipAdvVegGrd = 0.0 + noahmp%energy%flux%HeatLatentCanopy = 0.0 + noahmp%energy%flux%HeatLatentTransp = 0.0 + noahmp%energy%flux%RadLwNetBareGrd = noahmp%energy%flux%RadLwNetSfc + noahmp%energy%flux%HeatSensibleBareGrd = noahmp%energy%flux%HeatSensibleSfc + noahmp%energy%flux%HeatLatentBareGrd = noahmp%energy%flux%HeatLatentGrd + noahmp%energy%flux%HeatGroundBareGrd = noahmp%energy%flux%HeatGroundTot + noahmp%energy%state%TemperatureGrdBare = noahmp%energy%state%TemperatureGrd + noahmp%energy%state%ExchCoeffShBare = noahmp%energy%state%ExchCoeffShSfc + NoahmpIO%LH(I) = noahmp%energy%flux%HeatLatentGrd + endif + + if ( IndicatorIceSfc == 0 ) then ! land soil point + NoahmpIO%LH(I) = noahmp%energy%flux%HeatLatentGrd + noahmp%energy%flux%HeatLatentCanopy + & + noahmp%energy%flux%HeatLatentTransp + noahmp%energy%flux%HeatLatentIrriEvap + endif + + ! energy flux variables + NoahmpIO%HFX (I) = noahmp%energy%flux%HeatSensibleSfc + NoahmpIO%GRDFLX (I) = noahmp%energy%flux%HeatGroundTot + NoahmpIO%FSAXY (I) = noahmp%energy%flux%RadSwAbsSfc + NoahmpIO%FIRAXY (I) = noahmp%energy%flux%RadLwNetSfc + NoahmpIO%APARXY (I) = noahmp%energy%flux%RadPhotoActAbsCan + NoahmpIO%SAVXY (I) = noahmp%energy%flux%RadSwAbsVeg + NoahmpIO%SAGXY (I) = noahmp%energy%flux%RadSwAbsGrd + NoahmpIO%IRCXY (I) = noahmp%energy%flux%RadLwNetCanopy + NoahmpIO%IRGXY (I) = noahmp%energy%flux%RadLwNetVegGrd + NoahmpIO%SHCXY (I) = noahmp%energy%flux%HeatSensibleCanopy + NoahmpIO%SHGXY (I) = noahmp%energy%flux%HeatSensibleVegGrd + NoahmpIO%EVGXY (I) = noahmp%energy%flux%HeatLatentVegGrd + NoahmpIO%GHVXY (I) = noahmp%energy%flux%HeatGroundVegGrd + NoahmpIO%IRBXY (I) = noahmp%energy%flux%RadLwNetBareGrd + NoahmpIO%SHBXY (I) = noahmp%energy%flux%HeatSensibleBareGrd + NoahmpIO%EVBXY (I) = noahmp%energy%flux%HeatLatentBareGrd + NoahmpIO%GHBXY (I) = noahmp%energy%flux%HeatGroundBareGrd + NoahmpIO%TRXY (I) = noahmp%energy%flux%HeatLatentCanTransp + NoahmpIO%EVCXY (I) = noahmp%energy%flux%HeatLatentCanEvap + NoahmpIO%CANHSXY (I) = noahmp%energy%flux%HeatCanStorageChg + NoahmpIO%PAHXY (I) = noahmp%energy%flux%HeatPrecipAdvSfc + NoahmpIO%PAHGXY (I) = noahmp%energy%flux%HeatPrecipAdvVegGrd + NoahmpIO%PAHVXY (I) = noahmp%energy%flux%HeatPrecipAdvCanopy + NoahmpIO%PAHBXY (I) = noahmp%energy%flux%HeatPrecipAdvBareGrd + NoahmpIO%ACC_SSOILXY(I) = noahmp%energy%flux%HeatGroundTotAcc + NoahmpIO%EFLXBXY (I) = noahmp%energy%flux%HeatFromSoilBot + + ! energy state variables + NoahmpIO%TSK (I) = noahmp%energy%state%TemperatureRadSfc + NoahmpIO%EMISS (I) = noahmp%energy%state%EmissivitySfc + NoahmpIO%QSFC (I) = noahmp%energy%state%SpecHumiditySfcMean + NoahmpIO%TVXY (I) = noahmp%energy%state%TemperatureCanopy + NoahmpIO%TGXY (I) = noahmp%energy%state%TemperatureGrd + NoahmpIO%EAHXY (I) = noahmp%energy%state%PressureVaporCanAir + NoahmpIO%TAHXY (I) = noahmp%energy%state%TemperatureCanopyAir + NoahmpIO%CMXY (I) = noahmp%energy%state%ExchCoeffMomSfc + NoahmpIO%CHXY (I) = noahmp%energy%state%ExchCoeffShSfc + NoahmpIO%ALBOLDXY(I) = noahmp%energy%state%AlbedoSnowPrev + NoahmpIO%LAI (I) = noahmp%energy%state%LeafAreaIndex + NoahmpIO%XSAIXY (I) = noahmp%energy%state%StemAreaIndex + NoahmpIO%TAUSSXY (I) = noahmp%energy%state%SnowAgeNondim + NoahmpIO%Z0 (I) = noahmp%energy%state%RoughLenMomSfcToAtm + NoahmpIO%ZNT (I) = noahmp%energy%state%RoughLenMomSfcToAtm + NoahmpIO%T2MVXY (I) = noahmp%energy%state%TemperatureAir2mVeg + NoahmpIO%T2MBXY (I) = noahmp%energy%state%TemperatureAir2mBare + NoahmpIO%TRADXY (I) = noahmp%energy%state%TemperatureRadSfc + NoahmpIO%FVEGXY (I) = noahmp%energy%state%VegFrac + NoahmpIO%RSSUNXY (I) = noahmp%energy%state%ResistanceStomataSunlit + NoahmpIO%RSSHAXY (I) = noahmp%energy%state%ResistanceStomataShade + NoahmpIO%BGAPXY (I) = noahmp%energy%state%GapBtwCanopy + NoahmpIO%WGAPXY (I) = noahmp%energy%state%GapInCanopy + NoahmpIO%TGVXY (I) = noahmp%energy%state%TemperatureGrdVeg + NoahmpIO%TGBXY (I) = noahmp%energy%state%TemperatureGrdBare + NoahmpIO%CHVXY (I) = noahmp%energy%state%ExchCoeffShAbvCan + NoahmpIO%CHBXY (I) = noahmp%energy%state%ExchCoeffShBare + NoahmpIO%CHLEAFXY(I) = noahmp%energy%state%ExchCoeffShLeaf + NoahmpIO%CHUCXY (I) = noahmp%energy%state%ExchCoeffShUndCan + NoahmpIO%CHV2XY (I) = noahmp%energy%state%ExchCoeffSh2mVeg + NoahmpIO%CHB2XY (I) = noahmp%energy%state%ExchCoeffSh2mBare + NoahmpIO%Q2MVXY (I) = noahmp%energy%state%SpecHumidity2mVeg /(1.0-noahmp%energy%state%SpecHumidity2mVeg) ! spec humidity to mixing ratio + NoahmpIO%Q2MBXY (I) = noahmp%energy%state%SpecHumidity2mBare/(1.0-noahmp%energy%state%SpecHumidity2mBare) + NoahmpIO%IRRSPLH (I) = NoahmpIO%IRRSPLH(I) + & + (noahmp%energy%flux%HeatLatentIrriEvap * noahmp%config%domain%MainTimeStep) + NoahmpIO%TSLB (I,1:NumSoilLayer) = noahmp%energy%state%TemperatureSoilSnow(1:NumSoilLayer) + NoahmpIO%TSNOXY (I,-NumSnowLayerMax+1:0) = noahmp%energy%state%TemperatureSoilSnow(-NumSnowLayerMax+1:0) + if ( noahmp%energy%state%AlbedoSfc > -999 ) then + NoahmpIO%ALBEDO(I) = noahmp%energy%state%AlbedoSfc + endif + + ! New Calculation of total Canopy/Stomatal Conductance Based on Bonan et al. (2011), Inverse of Canopy Resistance (below) + LeafAreaIndSunlit = max(noahmp%energy%state%LeafAreaIndSunlit, 0.0) + LeafAreaIndShade = max(noahmp%energy%state%LeafAreaIndShade, 0.0) + ResistanceLeafBoundary = max(noahmp%energy%state%ResistanceLeafBoundary, 0.0) + if ( (noahmp%energy%state%ResistanceStomataSunlit <= 0.0) .or. (noahmp%energy%state%ResistanceStomataShade <= 0.0) .or. & + (LeafAreaIndSunlit == 0.0) .or. (LeafAreaIndShade == 0.0) .or. & + (noahmp%energy%state%ResistanceStomataSunlit == undefined_real) .or. & + (noahmp%energy%state%ResistanceStomataShade == undefined_real) ) then + NoahmpIO%RS (I) = 0.0 + else + NoahmpIO%RS (I) = ((1.0 / (noahmp%energy%state%ResistanceStomataSunlit + ResistanceLeafBoundary) * & + noahmp%energy%state%LeafAreaIndSunlit) + & + ((1.0 / (noahmp%energy%state%ResistanceStomataShade + ResistanceLeafBoundary)) * & + noahmp%energy%state%LeafAreaIndShade)) + NoahmpIO%RS (I) = 1.0 / NoahmpIO%RS (I) ! Resistance + endif + + ! calculation of snow and soil energy storage + NoahmpIO%SNOWENERGY(I) = 0.0 + NoahmpIO%SOILENERGY(I) = 0.0 + do LoopInd = NumSnowLayerNeg+1, NumSoilLayer + if ( LoopInd == NumSnowLayerNeg+1 ) then + ThicknessSnowSoilLayer = -noahmp%config%domain%DepthSnowSoilLayer(LoopInd) + else + ThicknessSnowSoilLayer = noahmp%config%domain%DepthSnowSoilLayer(LoopInd-1) - & + noahmp%config%domain%DepthSnowSoilLayer(LoopInd) + endif + if ( LoopInd >= 1 ) then + NoahmpIO%SOILENERGY(I) = NoahmpIO%SOILENERGY(I) + ThicknessSnowSoilLayer * & + noahmp%energy%state%HeatCapacSoilSnow(LoopInd) * & + (noahmp%energy%state%TemperatureSoilSnow(LoopInd) - 273.16) * 0.001 + else + NoahmpIO%SNOWENERGY(I) = NoahmpIO%SNOWENERGY(I) + ThicknessSnowSoilLayer * & + noahmp%energy%state%HeatCapacSoilSnow(LoopInd) * & + (noahmp%energy%state%TemperatureSoilSnow(LoopInd) - 273.16) * 0.001 + endif + enddo + + end associate + + end subroutine EnergyVarOutTransfer + +end module EnergyVarOutTransferMod diff --git a/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/ForcingVarInTransferMod.F90 b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/ForcingVarInTransferMod.F90 new file mode 100644 index 0000000000..6ebf049f44 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/ForcingVarInTransferMod.F90 @@ -0,0 +1,68 @@ +module ForcingVarInTransferMod + +!!! Transfer input 2-D NoahmpIO Forcing variables to 1-D column variable +!!! 1-D variables should be first defined in /src/ForcingVarType.F90 +!!! 2-D variables should be first defined in NoahmpIOVarType.F90 + +! ------------------------ Code history ----------------------------------- +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + use Machine + use NoahmpIOVarType + use NoahmpVarType + + implicit none + +contains + +!=== initialize with input data or table values + + subroutine ForcingVarInTransfer(noahmp, NoahmpIO) + + implicit none + + type(NoahmpIO_type), intent(inout) :: NoahmpIO + type(noahmp_type), intent(inout) :: noahmp + + ! local variables + real(kind=kind_noahmp) :: PrecipOtherRefHeight ! other precipitation, e.g. fog [mm/s] at reference height + real(kind=kind_noahmp) :: PrecipTotalRefHeight ! total precipitation [mm/s] at reference height + +! --------------------------------------------------------------- + associate( & + I => noahmp%config%domain%GridIndexI & + ) +! --------------------------------------------------------------- + + noahmp%forcing%TemperatureAirRefHeight = NoahmpIO%T_PHY(I,1) + noahmp%forcing%WindEastwardRefHeight = NoahmpIO%U_PHY(I,1) + noahmp%forcing%WindNorthwardRefHeight = NoahmpIO%V_PHY(I,1) + noahmp%forcing%SpecHumidityRefHeight = NoahmpIO%QV_CURR(I,1)/(1.0+NoahmpIO%QV_CURR(I,1)) ! convert from mixing ratio to specific humidity + noahmp%forcing%PressureAirRefHeight = (NoahmpIO%P8W(I,1) + NoahmpIO%P8W(I,2)) * 0.5 ! air pressure at middle point of lowest atmos model layer + noahmp%forcing%PressureAirSurface = NoahmpIO%P8W (I,1) + noahmp%forcing%RadLwDownRefHeight = NoahmpIO%GLW (I) + noahmp%forcing%RadSwDownRefHeight = NoahmpIO%SWDOWN (I) + noahmp%forcing%TemperatureSoilBottom = NoahmpIO%TMN (I) + + ! treat different precipitation types + PrecipTotalRefHeight = NoahmpIO%RAINBL (I) / NoahmpIO%DTBL ! convert precip unit from mm/timestep to mm/s + noahmp%forcing%PrecipConvRefHeight = NoahmpIO%MP_RAINC (I) / NoahmpIO%DTBL + noahmp%forcing%PrecipNonConvRefHeight = NoahmpIO%MP_RAINNC(I) / NoahmpIO%DTBL + noahmp%forcing%PrecipShConvRefHeight = NoahmpIO%MP_SHCV (I) / NoahmpIO%DTBL + noahmp%forcing%PrecipSnowRefHeight = NoahmpIO%MP_SNOW (I) / NoahmpIO%DTBL + noahmp%forcing%PrecipGraupelRefHeight = NoahmpIO%MP_GRAUP (I) / NoahmpIO%DTBL + noahmp%forcing%PrecipHailRefHeight = NoahmpIO%MP_HAIL (I) / NoahmpIO%DTBL + ! treat other precipitation (e.g. fog) contained in total precipitation + PrecipOtherRefHeight = PrecipTotalRefHeight - noahmp%forcing%PrecipConvRefHeight - & + noahmp%forcing%PrecipNonConvRefHeight - noahmp%forcing%PrecipShConvRefHeight + PrecipOtherRefHeight = max(0.0, PrecipOtherRefHeight) + noahmp%forcing%PrecipNonConvRefHeight = noahmp%forcing%PrecipNonConvRefHeight + PrecipOtherRefHeight + noahmp%forcing%PrecipSnowRefHeight = noahmp%forcing%PrecipSnowRefHeight + PrecipOtherRefHeight * NoahmpIO%SR(I) + + end associate + + end subroutine ForcingVarInTransfer + +end module ForcingVarInTransferMod diff --git a/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/ForcingVarOutTransferMod.F90 b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/ForcingVarOutTransferMod.F90 new file mode 100644 index 0000000000..2b5bd23fae --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/ForcingVarOutTransferMod.F90 @@ -0,0 +1,43 @@ +module ForcingVarOutTransferMod + +!!! Transfer column (1-D) Noah-MP forcing variables to 2D NoahmpIO for output + +! ------------------------ Code history ----------------------------------- +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + use Machine + use NoahmpIOVarType + use NoahmpVarType + + implicit none + +contains + +!=== Transfer model states to output ===== + + subroutine ForcingVarOutTransfer(noahmp, NoahmpIO) + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + type(NoahmpIO_type), intent(inout) :: NoahmpIO + +! ------------------------------------------------------------------------- + associate( & + I => noahmp%config%domain%GridIndexI & + ) +! ------------------------------------------------------------------------- + + NoahmpIO%FORCTLSM (I) = noahmp%forcing%TemperatureAirRefHeight + NoahmpIO%FORCQLSM (I) = noahmp%forcing%SpecHumidityRefHeight + NoahmpIO%FORCPLSM (I) = noahmp%forcing%PressureAirRefHeight + NoahmpIO%FORCWLSM (I) = sqrt(noahmp%forcing%WindEastwardRefHeight**2 + & + noahmp%forcing%WindNorthwardRefHeight**2) + + end associate + + end subroutine ForcingVarOutTransfer + +end module ForcingVarOutTransferMod diff --git a/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/Makefile b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/Makefile new file mode 100644 index 0000000000..5f816fff44 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/Makefile @@ -0,0 +1,74 @@ +.SUFFIXES: .o .F90 + +.PHONY: driver driver_lib + +all: dummy driver + +dummy: + echo "****** compiling physics_noahmp/drivers ******" + +OBJS = NoahmpSnowInitMod.o \ + NoahmpInitMainMod.o \ + NoahmpDriverMainMod.o \ + NoahmpIOVarType.o \ + NoahmpIOVarInitMod.o \ + NoahmpIOVarFinalizeMod.o \ + NoahmpReadTableMod.o \ + NoahmpReadNamelistMod.o \ + ConfigVarOutTransferMod.o \ + ForcingVarOutTransferMod.o \ + EnergyVarOutTransferMod.o \ + WaterVarOutTransferMod.o \ + BiochemVarOutTransferMod.o \ + ConfigVarInTransferMod.o \ + ForcingVarInTransferMod.o \ + EnergyVarInTransferMod.o \ + WaterVarInTransferMod.o \ + BiochemVarInTransferMod.o \ + PedoTransferSR2006Mod.o + +driver: $(OBJS) + +driver_lib: + ar -ru ./../../../libphys.a $(OBJS) + +# DEPENDENCIES: + +NoahmpIOVarType.o: ../../utility/Machine.o +NoahmpIOVarInitMod.o: ../../utility/Machine.o NoahmpIOVarType.o +NoahmpIOVarFinalizeMod.o: ../../utility/Machine.o NoahmpIOVarType.o +NoahmpReadTableMod.o: ../../utility/Machine.o NoahmpIOVarType.o +NoahmpReadNamelistMod.o: ../../utility/Machine.o NoahmpIOVarType.o +PedoTransferSR2006Mod.o: ../../utility/Machine.o NoahmpIOVarType.o +ConfigVarOutTransferMod.o: ../../utility/Machine.o NoahmpIOVarType.o ../../src/NoahmpVarType.o +ForcingVarOutTransferMod.o: ../../utility/Machine.o NoahmpIOVarType.o ../../src/NoahmpVarType.o +EnergyVarOutTransferMod.o: ../../utility/Machine.o NoahmpIOVarType.o ../../src/NoahmpVarType.o +WaterVarOutTransferMod.o: ../../utility/Machine.o NoahmpIOVarType.o ../../src/NoahmpVarType.o +BiochemVarOutTransferMod.o: ../../utility/Machine.o NoahmpIOVarType.o ../../src/NoahmpVarType.o +ConfigVarInTransferMod.o: ../../utility/Machine.o NoahmpIOVarType.o ../../src/NoahmpVarType.o +ForcingVarInTransferMod.o: ../../utility/Machine.o NoahmpIOVarType.o ../../src/NoahmpVarType.o +EnergyVarInTransferMod.o: ../../utility/Machine.o NoahmpIOVarType.o ../../src/NoahmpVarType.o +BiochemVarInTransferMod.o: ../../utility/Machine.o NoahmpIOVarType.o ../../src/NoahmpVarType.o +WaterVarInTransferMod.o: ../../utility/Machine.o NoahmpIOVarType.o ../../src/NoahmpVarType.o PedoTransferSR2006Mod.o +NoahmpSnowInitMod.o: ../../utility/Machine.o NoahmpIOVarType.o +NoahmpInitMainMod.o: ../../utility/Machine.o NoahmpIOVarType.o NoahmpSnowInitMod.o +NoahmpDriverMainMod.o: ../../utility/Machine.o ../../src/NoahmpVarType.o NoahmpIOVarType.o \ + ../../src/ConfigVarInitMod.o \ + ../../src/EnergyVarInitMod.o ../../src/ForcingVarInitMod.o \ + ../../src/WaterVarInitMod.o ../../src/BiochemVarInitMod.o \ + ../../src/NoahmpMainMod.o ../../src/NoahmpMainGlacierMod.o \ + ConfigVarOutTransferMod.o EnergyVarOutTransferMod.o \ + WaterVarOutTransferMod.o BiochemVarOutTransferMod.o \ + ForcingVarOutTransferMod.o ConfigVarInTransferMod.o \ + ForcingVarInTransferMod.o EnergyVarInTransferMod.o \ + WaterVarInTransferMod.o BiochemVarInTransferMod.o + +clean: + $(RM) *.f90 *.o *.mod + @# Certain systems with intel compilers generate *.i files + @# This removes them during the clean process + $(RM) *.i + +.F90.o: + $(FC) $(CPPFLAGS) $(COREDEF) $(FFLAGS) -c $*.F90 $(CPPINCLUDES) $(FCINCLUDES) -I. -I../../utility -I../../src -I../../../../../framework -I../../../../../external/esmf_time_f90 + diff --git a/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/NoahmpDriverMainMod.F90 b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/NoahmpDriverMainMod.F90 new file mode 100644 index 0000000000..2cbeb3bd26 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/NoahmpDriverMainMod.F90 @@ -0,0 +1,231 @@ + module NoahmpDriverMainMod + + use Machine + use NoahmpVarType + use NoahmpIOVarType + use ConfigVarInitMod + use EnergyVarInitMod + use ForcingVarInitMod + use WaterVarInitMod + use BiochemVarInitMod + use ConfigVarInTransferMod + use EnergyVarInTransferMod + use ForcingVarInTransferMod + use WaterVarInTransferMod + use BiochemVarInTransferMod + use ConfigVarOutTransferMod + use ForcingVarOutTransferMod + use EnergyVarOutTransferMod + use WaterVarOutTransferMod + use BiochemVarOutTransferMod + use NoahmpMainMod + use NoahmpMainGlacierMod + + use mpas_log + + implicit none + + contains + + subroutine NoahmpDriverMain(NoahmpIO) + +! ------------------------ Code history ------------------------------------- +! Original Noah-MP subroutine: noahmplsm +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! --------------------------------------------------------------------------- + + implicit none + + type(NoahmpIO_type), intent(inout) :: NoahmpIO + +! local variables + type(noahmp_type) :: noahmp + integer :: i,k + integer :: jmonth,jday + real(kind=kind_noahmp) :: solar_time + real(kind=kind_noahmp), dimension( 1:NoahmpIO%nsoil ) :: sand + real(kind=kind_noahmp), dimension( 1:NoahmpIO%nsoil ) :: clay + real(kind=kind_noahmp), dimension( 1:NoahmpIO%nsoil ) :: orgm +! --------------------------------------------------------------------------- +!call mpas_log_write(' ') +!call mpas_log_write('--- enter subroutine NoahmpDriverMain:') + +!--------------------------------------------------------------------- +! Treatment of Noah-MP soil timestep +!--------------------------------------------------------------------- + NoahmpIO%calculate_soil = .false. + NoahmpIO%soil_update_steps = nint(NoahmpIO%soiltstep / NoahmpIO%dtbl) + NoahmpIO%soil_update_steps = max(NoahmpIO%soil_update_steps,1) + + if ( NoahmpIO%soil_update_steps == 1 ) then + NoahmpIO%acc_ssoilxy = 0.0 + NoahmpIO%acc_qinsurxy = 0.0 + NoahmpIO%acc_qsevaxy = 0.0 + NoahmpIO%acc_etranixy = 0.0 + NoahmpIO%acc_dwaterxy = 0.0 + NoahmpIO%acc_prcpxy = 0.0 + NoahmpIO%acc_ecanxy = 0.0 + NoahmpIO%acc_etranxy = 0.0 + NoahmpIO%acc_edirxy = 0.0 + endif + + if ( NoahmpIO%soil_update_steps > 1 ) then + if ( mod(NoahmpIO%itimestep, NoahmpIO%soil_update_steps) == 1 ) then + NoahmpIO%acc_ssoilxy = 0.0 + NoahmpIO%acc_qinsurxy = 0.0 + NoahmpIO%acc_qsevaxy = 0.0 + NoahmpIO%acc_etranixy = 0.0 + NoahmpIO%acc_dwaterxy = 0.0 + NoahmpIO%acc_prcpxy = 0.0 + NoahmpIO%acc_ecanxy = 0.0 + NoahmpIO%acc_etranxy = 0.0 + NoahmpIO%acc_edirxy = 0.0 + end if + endif + + if ( mod(NoahmpIO%itimestep, NoahmpIO%soil_update_steps) == 0 ) NoahmpIO%calculate_soil = .true. +!call mpas_log_write(' ') +!call mpas_log_write('--- enter subroutine noahmpdrivermain:') +!call mpas_log_write('--- NoahmpIO%itimestep = $i',intArgs=(/NoahmpIO%itimestep/)) +!call mpas_log_write('--- NoahmpIO%soiltstep = $r',realArgs=(/NoahmpIO%soiltstep/)) +!call mpas_log_write('--- NoahmpIO%dtbl = $r',realArgs=(/NoahmpIO%dtbl/)) +!call mpas_log_write('--- NoahmpIO%soil_update_steps = $i',intArgs=(/NoahmpIO%soil_update_steps/)) +!call mpas_log_write('--- NoahmpIO%calculate_soil = $l',logicArgs=(/NoahmpIO%calculate_soil/)) +!call mpas_log_write(' ') +!call mpas_log_write('--- NoahmpIO%isurban_table = $i',intArgs=(/NoahmpIO%isurban_table/)) +!call mpas_log_write('--- NoahmpIO%urbtype_beg = $i',intArgs=(/NoahmpIO%urbtype_beg/)) +!call mpas_log_write('--- NoahmpIO%sf_urban_physics = $i',intArgs=(/NoahmpIO%sf_urban_physics/)) +!call mpas_log_write('--- NoahmpIO%iri_urban = $i',intArgs=(/NoahmpIO%iri_urban/)) +!call mpas_log_write(' ') + +!--------------------------------------------------------------------- +! Prepare Noah-MP driver +!--------------------------------------------------------------------- + +! find length of year for phenology (also S Hemisphere): + NoahmpIO%yearlen = 365 + if (mod(NoahmpIO%yr,4) == 0)then + NoahmpIO%yearlen = 366 + if (mod(NoahmpIO%yr,100) == 0)then + NoahmpIO%yearlen = 365 + if (mod(NoahmpIO%yr,400) == 0)then + NoahmpIO%yearlen = 366 + endif + endif + endif + +! initialize jmonth and jday: + jmonth = NoahmpIO%month + jday = NoahmpIO%day +!call mpas_log_write('--- NoahmpIO%yearlen = $i',intargs=(/NoahmpIO%yearlen/)) +!call mpas_log_write('--- NoahmpIO%yr = $i',intargs=(/NoahmpIO%yr/)) +!call mpas_log_write('--- NoahmpIO%month = $i',intargs=(/jmonth/)) +!call mpas_log_write('--- NoahmpIO%day = $i',intargs=(/jday/)) +!call mpas_log_write('--- NoahmpIO%julian = $r',realargs=(/NoahmpIO%julian/)) +!call mpas_log_write('--- NoahmpIO%xice_threshold = $r',realargs=(/NoahmpIO%xice_threshold/)) +!call mpas_log_write(' ') + +! depth to soil interfaces (<0) [m] + NoahmpIO%zsoil(1) = -NoahmpIO%dzs(1) + do k = 2, NoahmpIO%nsoil + NoahmpIO%zsoil(k) = -NoahmpIO%dzs(k) + NoahmpIO%zsoil(k-1) + enddo + + if ( NoahmpIO%itimestep == 1 ) then + do i = NoahmpIO%its, NoahmpIO%ite + if ( (NoahmpIO%xland(i)-1.5) >= 0.0 ) then ! open water point + if ( NoahmpIO%xice(i) == 1.0 ) print*,' sea-ice at water point, i=',i + NoahmpIO%smstav(i) = 1.0 + NoahmpIO%smstot(i) = 1.0 + do k = 1, NoahmpIO%nsoil + NoahmpIO%smois(i,k) = 1.0 + NoahmpIO%tslb(i,k) = 273.16 + enddo + else + if ( NoahmpIO%xice(i) == 1.0 ) then ! sea-ice case + NoahmpIO%smstav(i) = 1.0 + NoahmpIO%smstot(i) = 1.0 + do k = 1, NoahmpIO%nsoil + NoahmpIO%smois(i,k) = 1.0 + enddo + endif + endif + enddo + endif ! end of initialization over ocean + + iloop : do i = NoahmpIO%its, NoahmpIO%ite + + NoahmpIO%j = 1 + NoahmpIO%i = i + if ( NoahmpIO%xice(i) >= NoahmpIO%xice_threshold ) then ! sea-ice point + NoahmpIO%ice = 1 + NoahmpIO%sh2o(i,1:NoahmpIO%nsoil) = 1.0 + NoahmpIO%lai (i) = 0.01 + cycle iloop ! skip any sea-ice points + else + if ( (NoahmpIO%xland(i)-1.5) >= 0.0 ) cycle ILOOP ! skip any open water points + !------------------------------------------------------------------------------------ + ! initialize Data Types and transfer all the inputs from 2-D to 1-D column variables + !------------------------------------------------------------------------------------ + call ConfigVarInitDefault (noahmp) + call ConfigVarInTransfer (noahmp, NoahmpIO) + call ForcingVarInitDefault (noahmp) + call ForcingVarInTransfer (noahmp, NoahmpIO) + call EnergyVarInitDefault (noahmp) + call EnergyVarInTransfer (noahmp, NoahmpIO) + call WaterVarInitDefault (noahmp) + call WaterVarInTransfer (noahmp, NoahmpIO) + call BiochemVarInitDefault (noahmp) + call BiochemVarInTransfer (noahmp, NoahmpIO) + + !---------------------------------------------------------------------- + ! hydrological processes for vegetation in urban model + ! irrigate vegetation only in urban area, MAY-SEP, 9-11pm + ! need to be separated from Noah-MP into outside urban specific module + !---------------------------------------------------------------------- + if ( (NoahmpIO%ivgtyp(i) == NoahmpIO%isurban_table) .or. & + (NoahmpIO%ivgtyp(i) > NoahmpIO%urbtype_beg) ) then + if ( (NoahmpIO%sf_urban_physics > 0) .and. (NoahmpIO%iri_urban == 1) ) then + solar_time = (NoahmpIO%julian - int(NoahmpIO%julian))*24 + NoahmpIO%xlong(i)/15.0 + if ( solar_time < 0.0 ) solar_time = solar_time + 24.0 + if ( (solar_time >= 21.0) .and. (solar_time <= 23.0) .and. & + (jmonth >= 5) .and. (jmonth <= 9) ) then + noahmp%water%state%SoilMoisture(1) = & + max(noahmp%water%state%SoilMoisture(1),noahmp%water%param%SoilMoistureFieldCap(1)) + noahmp%water%state%SoilMoisture(2) = & + max(noahmp%water%state%SoilMoisture(2),noahmp%water%param%SoilMoistureFieldCap(2)) + endif + endif + endif + + !------------------------------------------------------------------------ + ! Call 1D Noah-MP LSM + !------------------------------------------------------------------------ + + if (noahmp%config%domain%VegType == noahmp%config%domain%IndexIcePoint ) then + noahmp%config%domain%IndicatorIceSfc = -1 ! Land-ice point + noahmp%forcing%TemperatureSoilBottom = min(noahmp%forcing%TemperatureSoilBottom,263.15) ! set deep glacier temp to >= -10C + call NoahmpMainGlacier(noahmp) + ! non-glacier land + else + noahmp%config%domain%IndicatorIceSfc = 0 ! land soil point. + call NoahmpMain(noahmp) + endif ! glacial split ends + + !--------------------------------------------------------------------- + ! Transfer 1-D Noah-MP column variables to 2-D output variables + !--------------------------------------------------------------------- + call ConfigVarOutTransfer (noahmp, NoahmpIO) + call ForcingVarOutTransfer(noahmp, NoahmpIO) + call EnergyVarOutTransfer (noahmp, NoahmpIO) + call WaterVarOutTransfer (noahmp, NoahmpIO) + call BiochemVarOutTransfer(noahmp, NoahmpIO) + + endif ! land-sea split ends + + enddo iloop ! i loop + + end subroutine NoahmpDriverMain + + end module NoahmpDriverMainMod diff --git a/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/NoahmpGroundwaterInitMod.F90 b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/NoahmpGroundwaterInitMod.F90 new file mode 100644 index 0000000000..7bbf8c3fd3 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/NoahmpGroundwaterInitMod.F90 @@ -0,0 +1,326 @@ +module NoahmpGroundwaterInitMod + +!!! Module to initialize Noah-MP Groundwater (GW) variables for MMF GW scheme + + use Machine + use NoahmpIOVarType + + implicit none + +contains + + subroutine NoahmpGroundwaterInitMain(grid, NoahmpIO) + +! ------------------------ Code history ------------------------------------- +! Original Noah-MP subroutine: GROUNDWATER_INIT +! Original code: Miguez-Macho, Fan et al. (2007) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! --------------------------------------------------------------------------- + + use GroundWaterMmfMod, only : LATERALFLOW + use module_domain, only : domain + +#if (EM_CORE == 1) +#ifdef DM_PARALLEL + use module_dm , only : ntasks_x,ntasks_y,local_communicator,mytask,ntasks + use module_comm_dm, only : halo_em_hydro_noahmp_sub +#endif +#endif + + implicit none + + type(NoahmpIO_type), intent(inout) :: NoahmpIO + type(domain), target :: grid + + ! local variables + logical :: urbanpt_flag ! added to identify urban pixels + integer :: I,J,K,ITER,itf,jtf,NITER,NCOUNT,NS + real(kind=kind_noahmp) :: BEXP,SMCMAX,PSISAT,SMCWLT,DWSAT,DKSAT + real(kind=kind_noahmp) :: FRLIQ,SMCEQDEEP + real(kind=kind_noahmp) :: DELTAT,RCOND,TOTWATER + real(kind=kind_noahmp) :: AA,BBB,CC,DD,DX,FUNC,DFUNC,DDZ,EXPON,SMC,FLUX + real(kind=kind_noahmp), dimension(1:NoahmpIO%NSOIL) :: SMCEQ,ZSOIL + real(kind=kind_noahmp), dimension(NoahmpIO%ims:NoahmpIO%ime, NoahmpIO%jms:NoahmpIO%jme) :: QLAT, QRF + ! landmask: -1 for water (ice or no ice) and glacial areas, 1 for land where the LSM does its soil moisture calculations + integer, dimension(NoahmpIO%ims:NoahmpIO%ime, NoahmpIO%jms:NoahmpIO%jme) :: LANDMASK + +! -------------------------------------------------------------------------------- + associate( & + ids => NoahmpIO%ids ,& + ide => NoahmpIO%ide ,& + jds => NoahmpIO%jds ,& + jde => NoahmpIO%jde ,& + kds => NoahmpIO%kds ,& + kde => NoahmpIO%kde ,& + ims => NoahmpIO%ims ,& + ime => NoahmpIO%ime ,& + jms => NoahmpIO%jms ,& + jme => NoahmpIO%jme ,& + kms => NoahmpIO%kms ,& + kme => NoahmpIO%kme ,& + ips => NoahmpIO%ims ,& + ipe => NoahmpIO%ime ,& + jps => NoahmpIO%jms ,& + jpe => NoahmpIO%jme ,& + kps => NoahmpIO%kms ,& + kpe => NoahmpIO%kme ,& + its => NoahmpIO%its ,& + ite => NoahmpIO%ite ,& + jts => NoahmpIO%jts ,& + jte => NoahmpIO%jte ,& + kts => NoahmpIO%kts ,& + kte => NoahmpIO%kte & + ) +! -------------------------------------------------------------------------------- + + ! Given the soil layer thicknesses (in DZS), calculate the soil layer depths from the surface. + ZSOIL(1) = -NoahmpIO%DZS(1) ! negative + do NS = 2, NoahmpIO%NSOIL + ZSOIL(NS) = ZSOIL(NS-1) - NoahmpIO%DZS(NS) + enddo + + ! initialize grid index + itf = min0(ite,(ide+1)-1) + jtf = min0(jte,(jde+1)-1) + + ! initialize land mask + where ( (NoahmpIO%IVGTYP /= NoahmpIO%ISWATER_TABLE) .and. (NoahmpIO%IVGTYP /= NoahmpIO%ISICE_TABLE) ) + LANDMASK = 1 + elsewhere + LANDMASK = -1 + endwhere + + NoahmpIO%PEXPXY = 1.0 + DELTAT = 365.0*24*3600.0 ! 1 year + + ! read just the raw aggregated water table from hi-res map, so that it is better compatible with topography + ! use WTD here, to use the lateral communication routine + NoahmpIO%ZWTXY = NoahmpIO%EQZWT + NCOUNT = 0 + + do NITER = 1, 500 +#if (EM_CORE == 1) +#ifdef DM_PARALLEL +# include "HALO_EM_HYDRO_NOAHMP.inc" +#endif +#endif + ! Calculate lateral flow + if ( (NCOUNT > 0) .or. (NITER == 1) ) then + QLAT = 0.0 + call LATERALFLOW(NoahmpIO,NoahmpIO%ISLTYP,NoahmpIO%ZWTXY,QLAT,NoahmpIO%FDEPTHXY,& + NoahmpIO%TERRAIN,LANDMASK,DELTAT,NoahmpIO%AREAXY, & + ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte ) + NCOUNT = 0 + do J = jts, jtf + do I = its, itf + if ( LANDMASK(I,J) > 0 ) then + if ( QLAT(i,j) > 1.0e-2 ) then + NCOUNT = NCOUNT + 1 + NoahmpIO%ZWTXY(I,J) = min(NoahmpIO%ZWTXY(I,J)+0.25, 0.0) + endif + endif + enddo + enddo + + endif + enddo !NITER + +#if (EM_CORE == 1) +#ifdef DM_PARALLEL +# include "HALO_EM_HYDRO_NOAHMP.inc" +#endif +#endif + + NoahmpIO%EQZWT=NoahmpIO%ZWTXY + + ! after adjusting, where qlat > 1cm/year now wtd is at the surface. + ! it may still happen that qlat + rech > 0 and eqwtd-rbed <0. There the wtd can + ! rise to the surface (poor drainage) but the et will then increase. + + ! now, calculate river conductivity + do J = jts, jtf + do I = its, itf + DDZ = NoahmpIO%EQZWT(I,J) - (NoahmpIO%RIVERBEDXY(I,J) - NoahmpIO%TERRAIN(I,J)) + ! dont allow riverbed above water table + if ( DDZ < 0.0 ) then + NoahmpIO%RIVERBEDXY(I,J) = NoahmpIO%TERRAIN(I,J) + NoahmpIO%EQZWT(I,J) + DDZ = 0.0 + endif + TOTWATER = NoahmpIO%AREAXY(I,J) * (QLAT(I,J) + NoahmpIO%RECHCLIM(I,J)*0.001) / DELTAT + if ( TOTWATER > 0 ) then + NoahmpIO%RIVERCONDXY(I,J) = TOTWATER / max(DDZ,0.05) + else + NoahmpIO%RIVERCONDXY(I,J) = 0.01 + ! make riverbed equal to eqwtd, otherwise qrf might be too big... + NoahmpIO%RIVERBEDXY(I,J) = NoahmpIO%TERRAIN(I,J) + NoahmpIO%EQZWT(I,J) + endif + enddo + enddo + + ! make riverbed to be height down from the surface instead of above sea level + NoahmpIO%RIVERBEDXY = min(NoahmpIO%RIVERBEDXY-NoahmpIO%TERRAIN, 0.0) + + ! now recompute lateral flow and flow to rivers to initialize deep soil moisture + DELTAT = NoahmpIO%WTDDT * 60.0 !timestep in seconds for this calculation + QLAT = 0.0 + call LATERALFLOW(NoahmpIO,NoahmpIO%ISLTYP,NoahmpIO%ZWTXY,QLAT,NoahmpIO%FDEPTHXY,& + NoahmpIO%TERRAIN,LANDMASK,DELTAT,NoahmpIO%AREAXY, & + ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte ) + + ! compute flux from grounwater to rivers in the cell + do J = jts, jtf + do I = its, itf + if ( LANDMASK(I,J) > 0 ) then + if ( (NoahmpIO%ZWTXY(I,J) > NoahmpIO%RIVERBEDXY(I,J)) .and. & + (NoahmpIO%EQZWT(I,J) > NoahmpIO%RIVERBEDXY(I,J)) ) then + RCOND = NoahmpIO%RIVERCONDXY(I,J) * exp(NoahmpIO%PEXPXY(I,J)*(NoahmpIO%ZWTXY(I,J)-NoahmpIO%EQZWT(I,J))) + else + RCOND = NoahmpIO%RIVERCONDXY(I,J) + endif + QRF(I,J) = RCOND * (NoahmpIO%ZWTXY(I,J)-NoahmpIO%RIVERBEDXY(I,J)) * DELTAT / NoahmpIO%AREAXY(I,J) + ! for now, dont allow it to go from river to groundwater + QRF(I,J) = max(QRF(I,J), 0.0) + else + QRF(I,J) = 0.0 + endif + enddo + enddo + + ! now compute eq. soil moisture, change soil moisture to be compatible with the water table and compute deep soil moisture + do J = jts, jtf + do I = its, itf + + BEXP = NoahmpIO%BEXP_TABLE(NoahmpIO%ISLTYP(I,J)) + SMCMAX = NoahmpIO%SMCMAX_TABLE(NoahmpIO%ISLTYP(I,J)) + SMCWLT = NoahmpIO%SMCWLT_TABLE(NoahmpIO%ISLTYP(I,J)) + ! add urban flag + urbanpt_flag = .false. + if ( (NoahmpIO%IVGTYP(I,J) == NoahmpIO%ISURBAN_TABLE) .or. & + (NoahmpIO%IVGTYP(I,J) > NoahmpIO%URBTYPE_beg) ) urbanpt_flag = .true. + if ( urbanpt_flag .eqv. .true. ) then + SMCMAX = 0.45 + SMCWLT = 0.40 + endif + DWSAT = NoahmpIO%DWSAT_TABLE(NoahmpIO%ISLTYP(I,J)) + DKSAT = NoahmpIO%DKSAT_TABLE(NoahmpIO%ISLTYP(I,J)) + PSISAT = -NoahmpIO%PSISAT_TABLE(NoahmpIO%ISLTYP(I,J)) + if ( (BEXP > 0.0) .and. (SMCMAX > 0.0) .and. (-PSISAT > 0.0) ) then + ! initialize equilibrium soil moisture for water table diagnostic + call EquilibriumSoilMoisture(NoahmpIO%NSOIL, ZSOIL, SMCMAX, SMCWLT, DWSAT, DKSAT, BEXP, SMCEQ) + NoahmpIO%SMOISEQ(I,1:NoahmpIO%NSOIL,J) = SMCEQ(1:NoahmpIO%NSOIL) + + ! make sure that below the water table the layers are saturated and + ! initialize the deep soil moisture + if ( NoahmpIO%ZWTXY(I,J) < (ZSOIL(NoahmpIO%NSOIL)-NoahmpIO%DZS(NoahmpIO%NSOIL)) ) then + ! initialize deep soil moisture so that the flux compensates qlat+qrf + ! use Newton-Raphson method to find soil moisture + EXPON = 2.0 * BEXP + 3.0 + DDZ = ZSOIL(NoahmpIO%NSOIL) - NoahmpIO%ZWTXY(I,J) + CC = PSISAT / DDZ + FLUX = (QLAT(I,J) - QRF(I,J)) / DELTAT + SMC = 0.5 * SMCMAX + do ITER = 1, 100 + DD = (SMC + SMCMAX) / (2.0*SMCMAX) + AA = -DKSAT * DD ** EXPON + BBB = CC * ((SMCMAX / SMC)**BEXP - 1.0) + 1.0 + FUNC = AA * BBB - FLUX + DFUNC = -DKSAT * (EXPON / (2.0*SMCMAX)) * DD ** (EXPON - 1.0) * BBB & + + AA * CC * (-BEXP) * SMCMAX ** BEXP * SMC ** (-BEXP-1.0) + DX = FUNC / DFUNC + SMC = SMC - DX + if ( abs(DX) < 1.0e-6 ) exit + enddo + NoahmpIO%SMCWTDXY(I,J) = max(SMC, 1.0e-4) + elseif ( NoahmpIO%ZWTXY(I,J) < ZSOIL(NoahmpIO%NSOIL) ) then + SMCEQDEEP = SMCMAX * (PSISAT / (PSISAT - NoahmpIO%DZS(NoahmpIO%NSOIL))) ** (1.0/BEXP) + !SMCEQDEEP = MAX(SMCEQDEEP,SMCWLT) + SMCEQDEEP = max(SMCEQDEEP, 1.0e-4) + NoahmpIO%SMCWTDXY(I,J) = SMCMAX * (NoahmpIO%ZWTXY(I,J)-(ZSOIL(NoahmpIO%NSOIL)-NoahmpIO%DZS(NoahmpIO%NSOIL))) + & + SMCEQDEEP * (ZSOIL(NoahmpIO%NSOIL) - NoahmpIO%ZWTXY(I,J)) + else !water table within the resolved layers + NoahmpIO%SMCWTDXY(I,J) = SMCMAX + do K = NoahmpIO%NSOIL, 2, -1 + if ( NoahmpIO%ZWTXY(I,J) >= ZSOIL(K-1) ) then + FRLIQ = NoahmpIO%SH2O(I,K,J) / NoahmpIO%SMOIS(I,K,J) + NoahmpIO%SMOIS(I,K,J) = SMCMAX + NoahmpIO%SH2O(I,K,J) = SMCMAX * FRLIQ + else + if ( NoahmpIO%SMOIS(I,K,J) < SMCEQ(K) ) then + NoahmpIO%ZWTXY(I,J) = ZSOIL(K) + else + NoahmpIO%ZWTXY(I,J) = (NoahmpIO%SMOIS(I,K,J)*NoahmpIO%DZS(K) - SMCEQ(K)*ZSOIL(K-1) + & + SMCMAX*ZSOIL(K)) / (SMCMAX - SMCEQ(K)) + endif + exit + endif + enddo + endif + else + NoahmpIO%SMOISEQ (I,1:NoahmpIO%NSOIL,J) = SMCMAX + NoahmpIO%SMCWTDXY(I,J) = SMCMAX + NoahmpIO%ZWTXY(I,J) = 0.0 + endif + + ! zero out some arrays + NoahmpIO%QLATXY(I,J) = 0.0 + NoahmpIO%QSLATXY(I,J) = 0.0 + NoahmpIO%QRFXY(I,J) = 0.0 + NoahmpIO%QRFSXY(I,J) = 0.0 + NoahmpIO%DEEPRECHXY(I,J) = 0.0 + NoahmpIO%RECHXY(I,J) = 0.0 + NoahmpIO%QSPRINGXY(I,J) = 0.0 + NoahmpIO%QSPRINGSXY(I,J) = 0.0 + + enddo + enddo + + end associate + + end subroutine NoahmpGroundwaterInitMain + + subroutine EquilibriumSoilMoisture(NSOIL, ZSOIL, SMCMAX, SMCWLT, DWSAT, DKSAT, BEXP, SMCEQ) + + implicit none + + integer, intent(in) :: NSOIL !no. of soil layers + real(kind=kind_noahmp), intent(in) :: SMCMAX , SMCWLT, BEXP , DWSAT, DKSAT + real(kind=kind_noahmp), dimension(1:NSOIL), intent(in) :: ZSOIL !depth of soil layer-bottom [m] + real(kind=kind_noahmp), dimension(1:NSOIL), intent(out) :: SMCEQ !equilibrium soil water content [m3/m3] + + ! local variables + integer :: K, ITER + real(kind=kind_noahmp) :: DDZ, SMC, FUNC, DFUNC, AA, BB, EXPON, DX + ! -------------------------------------------------------------------------------- + + ! gmm compute equilibrium soil moisture content for the layer when wtd=zsoil(k) + do K = 1, NSOIL + if ( K == 1 ) then + DDZ = -ZSOIL(K+1) * 0.5 + elseif ( K < NSOIL ) then + DDZ = ( ZSOIL(K-1) - ZSOIL(K+1) ) * 0.5 + else + DDZ = ZSOIL(K-1) - ZSOIL(K) + endif + + ! use Newton-Raphson method to find eq soil moisture + EXPON = BEXP + 1.0 + AA = DWSAT / DDZ + BB = DKSAT / SMCMAX ** EXPON + SMC = 0.5 * SMCMAX + do ITER = 1, 100 + FUNC = (SMC - SMCMAX) * AA + BB * SMC ** EXPON + DFUNC = AA + BB * EXPON * SMC ** BEXP + DX = FUNC / DFUNC + SMC = SMC - DX + if ( abs(DX) < 1.0e-6 ) exit + enddo + +! SMCEQ(K) = min(max(SMC,SMCWLT),SMCMAX*0.99) + SMCEQ(K) = min(max(SMC,1.0e-4), SMCMAX*0.99) + enddo + + end subroutine EquilibriumSoilMoisture + +end module NoahmpGroundwaterInitMod diff --git a/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/NoahmpIOVarFinalizeMod.F90 b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/NoahmpIOVarFinalizeMod.F90 new file mode 100644 index 0000000000..12df9b1909 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/NoahmpIOVarFinalizeMod.F90 @@ -0,0 +1,463 @@ +module NoahmpIOVarFinalizeMod + +!!! Initialize Noah-MP input/output variables +!!! Input/Output variables should be first defined in NoahmpIOVarType.F90 + +! ------------------------ Code history ----------------------------------- +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + use Machine + use NoahmpIOVarType + + implicit none + +contains + +!=== initialize with default values + + subroutine NoahmpIOVarFinalizeDefault(NoahmpIO) + + implicit none + + type(NoahmpIO_type), intent(inout) :: NoahmpIO + +! ------------------------------------------------- + associate( & + nsoil => NoahmpIO%nsoil ,& + nsnow => NoahmpIO%nsnow & + ) +! ------------------------------------------------- + + ! Input variables + if ( allocated (NoahmpIO%coszen) ) deallocate ( NoahmpIO%coszen ) ! cosine zenith angle + if ( allocated (NoahmpIO%xlat) ) deallocate ( NoahmpIO%xlat ) ! latitude [radians] + if ( allocated (NoahmpIO%dzs) ) deallocate ( NoahmpIO%dzs ) ! thickness of soil layers [m] + if ( allocated (NoahmpIO%zsoil) ) deallocate ( NoahmpIO%zsoil ) ! depth to soil interfaces [m] + if ( allocated (NoahmpIO%ivgtyp) ) deallocate ( NoahmpIO%ivgtyp ) ! vegetation type + if ( allocated (NoahmpIO%isltyp) ) deallocate ( NoahmpIO%isltyp ) ! soil type + if ( allocated (NoahmpIO%vegfra) ) deallocate ( NoahmpIO%vegfra ) ! vegetation fraction [] + if ( allocated (NoahmpIO%tmn) ) deallocate ( NoahmpIO%tmn ) ! deep soil temperature [K] + if ( allocated (NoahmpIO%xland) ) deallocate ( NoahmpIO%xland ) ! =2 ocean; =1 land/seaice + if ( allocated (NoahmpIO%xice) ) deallocate ( NoahmpIO%xice ) ! fraction of grid that is seaice + if ( allocated (NoahmpIO%swdown) ) deallocate ( NoahmpIO%swdown ) ! solar down at surface [W m-2] + if ( allocated (NoahmpIO%swddir) ) deallocate ( NoahmpIO%swddir ) ! solar down at surface [W m-2] for new urban solar panel + if ( allocated (NoahmpIO%swddif) ) deallocate ( NoahmpIO%swddif ) ! solar down at surface [W m-2] for new urban solar panel + if ( allocated (NoahmpIO%glw) ) deallocate ( NoahmpIO%glw ) ! longwave down at surface [W m-2] + if ( allocated (NoahmpIO%rainbl) ) deallocate ( NoahmpIO%rainbl ) ! total precipitation entering land model [mm] per time step + if ( allocated (NoahmpIO%snowbl) ) deallocate ( NoahmpIO%snowbl ) ! snow entering land model [mm] per time step + if ( allocated (NoahmpIO%sr) ) deallocate ( NoahmpIO%sr ) ! frozen precip ratio entering land model [-] + if ( allocated (NoahmpIO%raincv) ) deallocate ( NoahmpIO%raincv ) ! convective precip forcing [mm] + if ( allocated (NoahmpIO%rainncv) ) deallocate ( NoahmpIO%rainncv ) ! non-convective precip forcing [mm] + if ( allocated (NoahmpIO%rainshv) ) deallocate ( NoahmpIO%rainshv ) ! shallow conv. precip forcing [mm] + if ( allocated (NoahmpIO%snowncv) ) deallocate ( NoahmpIO%snowncv ) ! non-covective snow forcing (subset of rainncv) [mm] + if ( allocated (NoahmpIO%graupelncv)) deallocate ( NoahmpIO%graupelncv ) ! non-convective graupel forcing (subset of rainncv) [mm] + if ( allocated (NoahmpIO%hailncv) ) deallocate ( NoahmpIO%hailncv ) ! non-convective hail forcing (subset of rainncv) [mm] + if ( allocated (NoahmpIO%mp_rainc) ) deallocate ( NoahmpIO%mp_rainc ) ! convective precip forcing [mm] + if ( allocated (NoahmpIO%mp_rainnc) ) deallocate ( NoahmpIO%mp_rainnc ) ! non-convective precip forcing [mm] + if ( allocated (NoahmpIO%mp_shcv) ) deallocate ( NoahmpIO%mp_shcv ) ! shallow conv. precip forcing [mm] + if ( allocated (NoahmpIO%mp_snow) ) deallocate ( NoahmpIO%mp_snow ) ! non-covective snow (subset of rainnc) [mm] + if ( allocated (NoahmpIO%mp_graup) ) deallocate ( NoahmpIO%mp_graup ) ! non-convective graupel (subset of rainnc) [mm] + if ( allocated (NoahmpIO%mp_hail) ) deallocate ( NoahmpIO%mp_hail ) ! non-convective hail (subset of rainnc) [mm] + if ( allocated (NoahmpIO%seaice) ) deallocate ( NoahmpIO%seaice ) ! seaice fraction + if ( allocated (NoahmpIO%dz8w) ) deallocate ( NoahmpIO%dz8w ) ! thickness of atmo layers [m] + if ( allocated (NoahmpIO%t_phy) ) deallocate ( NoahmpIO%t_phy ) ! 3d atmospheric temperature valid at mid-levels [K] + if ( allocated (NoahmpIO%qv_curr) ) deallocate ( NoahmpIO%qv_curr ) ! 3d water vapor mixing ratio [kg/kg_dry] + if ( allocated (NoahmpIO%u_phy) ) deallocate ( NoahmpIO%u_phy ) ! 3d u wind component [m/s] + if ( allocated (NoahmpIO%v_phy) ) deallocate ( NoahmpIO%v_phy ) ! 3d v wind component [m/s] + if ( allocated (NoahmpIO%p8w) ) deallocate ( NoahmpIO%p8w ) ! 3d pressure, valid at interface [Pa] + + ! spatial varying parameter map + if ( NoahmpIO%iopt_soil > 1 ) then + if ( allocated (NoahmpIO%soilcomp)) deallocate ( NoahmpIO%soilcomp ) ! soil sand and clay content [fraction] + if ( allocated (NoahmpIO%soilcl1) ) deallocate ( NoahmpIO%soilcl1 ) ! soil texture class with depth + if ( allocated (NoahmpIO%soilcl2) ) deallocate ( NoahmpIO%soilcl2 ) ! soil texture class with depth + if ( allocated (NoahmpIO%soilcl3) ) deallocate ( NoahmpIO%soilcl3 ) ! soil texture class with depth + if ( allocated (NoahmpIO%soilcl4) ) deallocate ( NoahmpIO%soilcl4 ) ! soil texture class with depth + endif + if ( NoahmpIO%iopt_soil == 4 ) then + if ( allocated (NoahmpIO%bexp_3d) ) deallocate ( NoahmpIO%bexp_3d ) ! c-h b exponent + if ( allocated (NoahmpIO%smcdry_3d) ) deallocate ( NoahmpIO%smcdry_3d ) ! soil moisture limit: dry + if ( allocated (NoahmpIO%smcwlt_3d) ) deallocate ( NoahmpIO%smcwlt_3d ) ! soil moisture limit: wilt + if ( allocated (NoahmpIO%smcref_3d) ) deallocate ( NoahmpIO%smcref_3d ) ! soil moisture limit: reference + if ( allocated (NoahmpIO%smcmax_3d) ) deallocate ( NoahmpIO%smcmax_3d ) ! soil moisture limit: max + if ( allocated (NoahmpIO%dksat_3d) ) deallocate ( NoahmpIO%dksat_3d ) ! saturated soil conductivity + if ( allocated (NoahmpIO%dwsat_3d) ) deallocate ( NoahmpIO%dwsat_3d ) ! saturated soil diffusivity + if ( allocated (NoahmpIO%psisat_3d) ) deallocate ( NoahmpIO%psisat_3d ) ! saturated matric potential + if ( allocated (NoahmpIO%quartz_3d) ) deallocate ( NoahmpIO%quartz_3d ) ! soil quartz content + if ( allocated (NoahmpIO%refdk_2d) ) deallocate ( NoahmpIO%refdk_2d ) ! reference soil conductivity + if ( allocated (NoahmpIO%refkdt_2d) ) deallocate ( NoahmpIO%refkdt_2d ) ! soil infiltration parameter + if ( allocated (NoahmpIO%irr_frac_2d) ) deallocate ( NoahmpIO%irr_frac_2d ) ! irrigation fraction + if ( allocated (NoahmpIO%irr_har_2d) ) deallocate ( NoahmpIO%irr_har_2d ) ! number of days before harvest date to stop irrigation + if ( allocated (NoahmpIO%irr_lai_2d) ) deallocate ( NoahmpIO%irr_lai_2d ) ! minimum lai to trigger irrigation + if ( allocated (NoahmpIO%irr_mad_2d) ) deallocate ( NoahmpIO%irr_mad_2d ) ! management allowable deficit (0-1) + if ( allocated (NoahmpIO%filoss_2d) ) deallocate ( NoahmpIO%filoss_2d ) ! fraction of flood irrigation loss (0-1) + if ( allocated (NoahmpIO%sprir_rate_2d)) deallocate ( NoahmpIO%sprir_rate_2d ) ! mm/h, sprinkler irrigation rate + if ( allocated (NoahmpIO%micir_rate_2d)) deallocate ( NoahmpIO%micir_rate_2d ) ! mm/h, micro irrigation rate + if ( allocated (NoahmpIO%firtfac_2d) ) deallocate ( NoahmpIO%firtfac_2d ) ! flood application rate factor + if ( allocated (NoahmpIO%ir_rain_2d) ) deallocate ( NoahmpIO%ir_rain_2d ) ! maximum precipitation to stop irrigation trigger + if ( allocated (NoahmpIO%bvic_2d) ) deallocate ( NoahmpIO%bvic_2d ) ! VIC model infiltration parameter [-] + if ( allocated (NoahmpIO%axaj_2d) ) deallocate ( NoahmpIO%axaj_2d ) ! tension water distribution inflection parameter [-] + if ( allocated (NoahmpIO%bxaj_2d) ) deallocate ( NoahmpIO%bxaj_2d ) ! tension water distribution shape parameter [-] + if ( allocated (NoahmpIO%xxaj_2d) ) deallocate ( NoahmpIO%xxaj_2d ) ! free water distribution shape parameter [-] + if ( allocated (NoahmpIO%bdvic_2d) ) deallocate ( NoahmpIO%bdvic_2d ) ! DVIC model infiltration parameter [-] + if ( allocated (NoahmpIO%gdvic_2d) ) deallocate ( NoahmpIO%gdvic_2d ) ! mean capillary drive (m) for infiltration models + if ( allocated (NoahmpIO%bbvic_2d) ) deallocate ( NoahmpIO%bbvic_2d ) ! dvic heterogeniety parameter for infiltration [-] + if ( allocated (NoahmpIO%klat_fac) ) deallocate ( NoahmpIO%klat_fac ) ! factor multiplier to hydraulic conductivity + if ( allocated (NoahmpIO%tdsmc_fac) ) deallocate ( NoahmpIO%tdsmc_fac ) ! factor multiplier to field capacity + if ( allocated (NoahmpIO%td_dc) ) deallocate ( NoahmpIO%td_dc ) ! drainage coefficient for simple + if ( allocated (NoahmpIO%td_dcoef) ) deallocate ( NoahmpIO%td_dcoef ) ! drainage coefficient for Hooghoudt + if ( allocated (NoahmpIO%td_ddrain) ) deallocate ( NoahmpIO%td_ddrain ) ! depth of drain + if ( allocated (NoahmpIO%td_radi) ) deallocate ( NoahmpIO%td_radi ) ! tile radius + if ( allocated (NoahmpIO%td_spac) ) deallocate ( NoahmpIO%td_spac ) ! tile spacing + endif + + ! INOUT (with generic LSM equivalent) (as defined in WRF) + if ( allocated (NoahmpIO%tsk) ) deallocate ( NoahmpIO%tsk ) ! surface radiative temperature [K] + if ( allocated (NoahmpIO%hfx) ) deallocate ( NoahmpIO%hfx ) ! sensible heat flux [W m-2] + if ( allocated (NoahmpIO%qfx) ) deallocate ( NoahmpIO%qfx ) ! latent heat flux [kg s-1 m-2] + if ( allocated (NoahmpIO%lh) ) deallocate ( NoahmpIO%lh ) ! latent heat flux [W m-2] + if ( allocated (NoahmpIO%grdflx) ) deallocate ( NoahmpIO%grdflx ) ! ground/snow heat flux [W m-2] + if ( allocated (NoahmpIO%smstav) ) deallocate ( NoahmpIO%smstav ) ! soil moisture avail. [not used] + if ( allocated (NoahmpIO%smstot) ) deallocate ( NoahmpIO%smstot ) ! total soil water [mm][not used] + if ( allocated (NoahmpIO%sfcrunoff)) deallocate ( NoahmpIO%sfcrunoff ) ! accumulated surface runoff [m] + if ( allocated (NoahmpIO%udrunoff) ) deallocate ( NoahmpIO%udrunoff ) ! accumulated sub-surface runoff [m] + if ( allocated (NoahmpIO%albedo) ) deallocate ( NoahmpIO%albedo ) ! total grid albedo [] + if ( allocated (NoahmpIO%snowc) ) deallocate ( NoahmpIO%snowc ) ! snow cover fraction [] + if ( allocated (NoahmpIO%snow) ) deallocate ( NoahmpIO%snow ) ! snow water equivalent [mm] + if ( allocated (NoahmpIO%snowh) ) deallocate ( NoahmpIO%snowh ) ! physical snow depth [m] + if ( allocated (NoahmpIO%canwat) ) deallocate ( NoahmpIO%canwat ) ! total canopy water + ice [mm] + if ( allocated (NoahmpIO%acsnom) ) deallocate ( NoahmpIO%acsnom ) ! accumulated snow melt leaving pack + if ( allocated (NoahmpIO%acsnow) ) deallocate ( NoahmpIO%acsnow ) ! accumulated snow on grid + if ( allocated (NoahmpIO%emiss) ) deallocate ( NoahmpIO%emiss ) ! surface bulk emissivity + if ( allocated (NoahmpIO%qsfc) ) deallocate ( NoahmpIO%qsfc ) ! bulk surface specific humidity + if ( allocated (NoahmpIO%smoiseq) ) deallocate ( NoahmpIO%smoiseq ) ! equilibrium volumetric soil moisture [m3/m3] + if ( allocated (NoahmpIO%smois) ) deallocate ( NoahmpIO%smois ) ! volumetric soil moisture [m3/m3] + if ( allocated (NoahmpIO%sh2o) ) deallocate ( NoahmpIO%sh2o ) ! volumetric liquid soil moisture [m3/m3] + if ( allocated (NoahmpIO%tslb) ) deallocate ( NoahmpIO%tslb ) ! soil temperature [K] + + ! INOUT (with no Noah LSM equivalent) (as defined in WRF) + if ( allocated (NoahmpIO%isnowxy) ) deallocate ( NoahmpIO%isnowxy ) ! actual no. of snow layers + if ( allocated (NoahmpIO%tvxy) ) deallocate ( NoahmpIO%tvxy ) ! vegetation leaf temperature + if ( allocated (NoahmpIO%tgxy) ) deallocate ( NoahmpIO%tgxy ) ! bulk ground surface temperature + if ( allocated (NoahmpIO%canicexy) ) deallocate ( NoahmpIO%canicexy ) ! canopy-intercepted ice (mm) + if ( allocated (NoahmpIO%canliqxy) ) deallocate ( NoahmpIO%canliqxy ) ! canopy-intercepted liquid water (mm) + if ( allocated (NoahmpIO%eahxy) ) deallocate ( NoahmpIO%eahxy ) ! canopy air vapor pressure (Pa) + if ( allocated (NoahmpIO%tahxy) ) deallocate ( NoahmpIO%tahxy ) ! canopy air temperature (K) + if ( allocated (NoahmpIO%cmxy) ) deallocate ( NoahmpIO%cmxy ) ! bulk momentum drag coefficient + if ( allocated (NoahmpIO%chxy) ) deallocate ( NoahmpIO%chxy ) ! bulk sensible heat exchange coefficient + if ( allocated (NoahmpIO%fwetxy) ) deallocate ( NoahmpIO%fwetxy ) ! wetted or snowed fraction of the canopy (-) + if ( allocated (NoahmpIO%sneqvoxy) ) deallocate ( NoahmpIO%sneqvoxy ) ! snow mass at last time step(mm H2O) + if ( allocated (NoahmpIO%alboldxy) ) deallocate ( NoahmpIO%alboldxy ) ! snow albedo at last time step (-) + if ( allocated (NoahmpIO%qsnowxy) ) deallocate ( NoahmpIO%qsnowxy ) ! snowfall on the ground [mm/s] + if ( allocated (NoahmpIO%qrainxy) ) deallocate ( NoahmpIO%qrainxy ) ! rainfall on the ground [mm/s] + if ( allocated (NoahmpIO%wslakexy) ) deallocate ( NoahmpIO%wslakexy ) ! lake water storage [mm] + if ( allocated (NoahmpIO%zwtxy) ) deallocate ( NoahmpIO%zwtxy ) ! water table depth [m] + if ( allocated (NoahmpIO%waxy) ) deallocate ( NoahmpIO%waxy ) ! water in the "aquifer" [mm] + if ( allocated (NoahmpIO%wtxy) ) deallocate ( NoahmpIO%wtxy ) ! groundwater storage [mm] + if ( allocated (NoahmpIO%smcwtdxy) ) deallocate ( NoahmpIO%smcwtdxy ) ! soil moisture below the bottom of the column (m3 m-3) + if ( allocated (NoahmpIO%deeprechxy)) deallocate ( NoahmpIO%deeprechxy ) ! recharge to the water table when deep (m) + if ( allocated (NoahmpIO%rechxy) ) deallocate ( NoahmpIO%rechxy ) ! recharge to the water table (diagnostic) (m) + if ( allocated (NoahmpIO%lfmassxy) ) deallocate ( NoahmpIO%lfmassxy ) ! leaf mass [g/m2] + if ( allocated (NoahmpIO%rtmassxy) ) deallocate ( NoahmpIO%rtmassxy ) ! mass of fine roots [g/m2] + if ( allocated (NoahmpIO%stmassxy) ) deallocate ( NoahmpIO%stmassxy ) ! stem mass [g/m2] + if ( allocated (NoahmpIO%woodxy) ) deallocate ( NoahmpIO%woodxy ) ! mass of wood (incl. woody roots) [g/m2] + if ( allocated (NoahmpIO%grainxy) ) deallocate ( NoahmpIO%grainxy ) ! mass of grain xing [g/m2] + if ( allocated (NoahmpIO%gddxy) ) deallocate ( NoahmpIO%gddxy ) ! growing degree days xing four + if ( allocated (NoahmpIO%stblcpxy) ) deallocate ( NoahmpIO%stblcpxy ) ! stable carbon in deep soil [g/m2] + if ( allocated (NoahmpIO%fastcpxy) ) deallocate ( NoahmpIO%fastcpxy ) ! short-lived carbon, shallow soil [g/m2] + if ( allocated (NoahmpIO%lai) ) deallocate ( NoahmpIO%lai ) ! leaf area index + if ( allocated (NoahmpIO%xsaixy) ) deallocate ( NoahmpIO%xsaixy ) ! stem area index + if ( allocated (NoahmpIO%taussxy) ) deallocate ( NoahmpIO%taussxy ) ! snow age factor + if ( allocated (NoahmpIO%tsnoxy) ) deallocate ( NoahmpIO%tsnoxy ) ! snow temperature [K] + if ( allocated (NoahmpIO%zsnsoxy) ) deallocate ( NoahmpIO%zsnsoxy ) ! snow layer depth [m] + if ( allocated (NoahmpIO%snicexy) ) deallocate ( NoahmpIO%snicexy ) ! snow layer ice [mm] + if ( allocated (NoahmpIO%snliqxy) ) deallocate ( NoahmpIO%snliqxy ) ! snow layer liquid water [mm] + + ! irrigation + if ( allocated (NoahmpIO%irfract) ) deallocate ( NoahmpIO%irfract ) ! irrigation fraction + if ( allocated (NoahmpIO%sifract) ) deallocate ( NoahmpIO%sifract ) ! sprinkler irrigation fraction + if ( allocated (NoahmpIO%mifract) ) deallocate ( NoahmpIO%mifract ) ! micro irrigation fraction + if ( allocated (NoahmpIO%fifract) ) deallocate ( NoahmpIO%fifract ) ! flood irrigation fraction + if ( allocated (NoahmpIO%irnumsi) ) deallocate ( NoahmpIO%irnumsi ) ! irrigation event number, sprinkler + if ( allocated (NoahmpIO%irnummi) ) deallocate ( NoahmpIO%irnummi ) ! irrigation event number, micro + if ( allocated (NoahmpIO%irnumfi) ) deallocate ( NoahmpIO%irnumfi ) ! irrigation event number, flood + if ( allocated (NoahmpIO%irwatsi) ) deallocate ( NoahmpIO%irwatsi ) ! irrigation water amount [m] to be applied, sprinkler + if ( allocated (NoahmpIO%irwatmi) ) deallocate ( NoahmpIO%irwatmi ) ! irrigation water amount [m] to be applied, micro + if ( allocated (NoahmpIO%irwatfi) ) deallocate ( NoahmpIO%irwatfi ) ! irrigation water amount [m] to be applied, flood + if ( allocated (NoahmpIO%ireloss) ) deallocate ( NoahmpIO%ireloss ) ! loss of irrigation water to evaporation,sprinkler [mm] + if ( allocated (NoahmpIO%irsivol) ) deallocate ( NoahmpIO%irsivol ) ! amount of irrigation by sprinkler (mm) + if ( allocated (NoahmpIO%irmivol) ) deallocate ( NoahmpIO%irmivol ) ! amount of irrigation by micro (mm) + if ( allocated (NoahmpIO%irfivol) ) deallocate ( NoahmpIO%irfivol ) ! amount of irrigation by micro (mm) + if ( allocated (NoahmpIO%irrsplh) ) deallocate ( NoahmpIO%irrsplh ) ! latent heating from sprinkler evaporation (W/m2) + if ( allocated (NoahmpIO%loctim) ) deallocate ( NoahmpIO%loctim ) ! local time + + ! OUT (with no Noah LSM equivalent) (as defined in WRF) + if ( allocated (NoahmpIO%t2mvxy) ) deallocate ( NoahmpIO%t2mvxy ) ! 2m temperature of vegetation part + if ( allocated (NoahmpIO%t2mbxy) ) deallocate ( NoahmpIO%t2mbxy ) ! 2m temperature of bare ground part + if ( allocated (NoahmpIO%q2mvxy) ) deallocate ( NoahmpIO%q2mvxy ) ! 2m mixing ratio of vegetation part + if ( allocated (NoahmpIO%q2mbxy) ) deallocate ( NoahmpIO%q2mbxy ) ! 2m mixing ratio of bare ground part + if ( allocated (NoahmpIO%tradxy) ) deallocate ( NoahmpIO%tradxy ) ! surface radiative temperature (K) + if ( allocated (NoahmpIO%neexy) ) deallocate ( NoahmpIO%neexy ) ! net ecosys exchange (g/m2/s CO2) + if ( allocated (NoahmpIO%gppxy) ) deallocate ( NoahmpIO%gppxy ) ! gross primary assimilation [g/m2/s C] + if ( allocated (NoahmpIO%nppxy) ) deallocate ( NoahmpIO%nppxy ) ! net primary productivity [g/m2/s C] + if ( allocated (NoahmpIO%fvegxy) ) deallocate ( NoahmpIO%fvegxy ) ! noah-mp vegetation fraction [-] + if ( allocated (NoahmpIO%runsfxy) ) deallocate ( NoahmpIO%runsfxy ) ! surface runoff [mm per soil timestep] + if ( allocated (NoahmpIO%runsbxy) ) deallocate ( NoahmpIO%runsbxy ) ! subsurface runoff [mm per soil timestep] + if ( allocated (NoahmpIO%ecanxy) ) deallocate ( NoahmpIO%ecanxy ) ! evaporation of intercepted water (mm/s) + if ( allocated (NoahmpIO%edirxy) ) deallocate ( NoahmpIO%edirxy ) ! soil surface evaporation rate (mm/s] + if ( allocated (NoahmpIO%etranxy) ) deallocate ( NoahmpIO%etranxy ) ! transpiration rate (mm/s) + if ( allocated (NoahmpIO%fsaxy) ) deallocate ( NoahmpIO%fsaxy ) ! total absorbed solar radiation (W/m2) + if ( allocated (NoahmpIO%firaxy) ) deallocate ( NoahmpIO%firaxy ) ! total net longwave rad (W/m2) [+ to atm] + if ( allocated (NoahmpIO%aparxy) ) deallocate ( NoahmpIO%aparxy ) ! photosyn active energy by canopy (W/m2) + if ( allocated (NoahmpIO%psnxy) ) deallocate ( NoahmpIO%psnxy ) ! total photosynthesis (umol CO2/m2/s) [+] + if ( allocated (NoahmpIO%savxy) ) deallocate ( NoahmpIO%savxy ) ! solar rad absorbed by veg. (W/m2) + if ( allocated (NoahmpIO%sagxy) ) deallocate ( NoahmpIO%sagxy ) ! solar rad absorbed by ground (W/m2) + if ( allocated (NoahmpIO%rssunxy) ) deallocate ( NoahmpIO%rssunxy ) ! sunlit leaf stomatal resistance (s/m) + if ( allocated (NoahmpIO%rsshaxy) ) deallocate ( NoahmpIO%rsshaxy ) ! shaded leaf stomatal resistance (s/m) + if ( allocated (NoahmpIO%bgapxy) ) deallocate ( NoahmpIO%bgapxy ) ! between gap fraction + if ( allocated (NoahmpIO%wgapxy) ) deallocate ( NoahmpIO%wgapxy ) ! within gap fraction + if ( allocated (NoahmpIO%tgvxy) ) deallocate ( NoahmpIO%tgvxy ) ! under canopy ground temperature[K] + if ( allocated (NoahmpIO%tgbxy) ) deallocate ( NoahmpIO%tgbxy ) ! bare ground temperature [K] + if ( allocated (NoahmpIO%chvxy) ) deallocate ( NoahmpIO%chvxy ) ! sensible heat exchange coefficient vegetated + if ( allocated (NoahmpIO%chbxy) ) deallocate ( NoahmpIO%chbxy ) ! sensible heat exchange coefficient bare-ground + if ( allocated (NoahmpIO%shgxy) ) deallocate ( NoahmpIO%shgxy ) ! veg ground sen. heat [W/m2] [+ to atm] + if ( allocated (NoahmpIO%shcxy) ) deallocate ( NoahmpIO%shcxy ) ! canopy sen. heat [W/m2] [+ to atm] + if ( allocated (NoahmpIO%shbxy) ) deallocate ( NoahmpIO%shbxy ) ! bare sensible heat [W/m2] [+ to atm] + if ( allocated (NoahmpIO%evgxy) ) deallocate ( NoahmpIO%evgxy ) ! veg ground evap. heat [W/m2] [+ to atm] + if ( allocated (NoahmpIO%evbxy) ) deallocate ( NoahmpIO%evbxy ) ! bare soil evaporation [W/m2] [+ to atm] + if ( allocated (NoahmpIO%ghvxy) ) deallocate ( NoahmpIO%ghvxy ) ! veg ground heat flux [W/m2] [+ to soil] + if ( allocated (NoahmpIO%ghbxy) ) deallocate ( NoahmpIO%ghbxy ) ! bare ground heat flux [W/m2] [+ to soil] + if ( allocated (NoahmpIO%irgxy) ) deallocate ( NoahmpIO%irgxy ) ! veg ground net lw rad. [W/m2] [+ to atm] + if ( allocated (NoahmpIO%ircxy) ) deallocate ( NoahmpIO%ircxy ) ! canopy net lw rad. [W/m2] [+ to atm] + if ( allocated (NoahmpIO%irbxy) ) deallocate ( NoahmpIO%irbxy ) ! bare net longwave rad. [W/m2] [+ to atm] + if ( allocated (NoahmpIO%trxy) ) deallocate ( NoahmpIO%trxy ) ! transpiration [w/m2] [+ to atm] + if ( allocated (NoahmpIO%evcxy) ) deallocate ( NoahmpIO%evcxy ) ! canopy evaporation heat [W/m2] [+ to atm] + if ( allocated (NoahmpIO%chleafxy) ) deallocate ( NoahmpIO%chleafxy ) ! leaf exchange coefficient + if ( allocated (NoahmpIO%chucxy) ) deallocate ( NoahmpIO%chucxy ) ! under canopy exchange coefficient + if ( allocated (NoahmpIO%chv2xy) ) deallocate ( NoahmpIO%chv2xy ) ! veg 2m exchange coefficient + if ( allocated (NoahmpIO%chb2xy) ) deallocate ( NoahmpIO%chb2xy ) ! bare 2m exchange coefficient + if ( allocated (NoahmpIO%rs) ) deallocate ( NoahmpIO%rs ) ! total stomatal resistance (s/m) + if ( allocated (NoahmpIO%z0) ) deallocate ( NoahmpIO%z0 ) ! roughness length output to WRF + if ( allocated (NoahmpIO%znt) ) deallocate ( NoahmpIO%znt ) ! roughness length output to WRF + if ( allocated (NoahmpIO%qtdrain) ) deallocate ( NoahmpIO%qtdrain ) ! tile drainage (mm) + if ( allocated (NoahmpIO%td_fraction)) deallocate ( NoahmpIO%td_fraction ) ! tile drainage fraction + if ( allocated (NoahmpIO%xlong) ) deallocate ( NoahmpIO%xlong ) ! longitude + if ( allocated (NoahmpIO%terrain) ) deallocate ( NoahmpIO%terrain ) ! terrain height + if ( allocated (NoahmpIO%gvfmin) ) deallocate ( NoahmpIO%gvfmin ) ! annual minimum in vegetation fraction + if ( allocated (NoahmpIO%gvfmax) ) deallocate ( NoahmpIO%gvfmax ) ! annual maximum in vegetation fraction + + ! additional output variables + if ( allocated (NoahmpIO%pahxy) ) deallocate ( NoahmpIO%pahxy ) + if ( allocated (NoahmpIO%pahgxy) ) deallocate ( NoahmpIO%pahgxy ) + if ( allocated (NoahmpIO%pahbxy) ) deallocate ( NoahmpIO%pahbxy ) + if ( allocated (NoahmpIO%pahvxy) ) deallocate ( NoahmpIO%pahvxy ) + if ( allocated (NoahmpIO%qintsxy) ) deallocate ( NoahmpIO%qintsxy ) + if ( allocated (NoahmpIO%qintrxy) ) deallocate ( NoahmpIO%qintrxy ) + if ( allocated (NoahmpIO%qdripsxy) ) deallocate ( NoahmpIO%qdripsxy ) + if ( allocated (NoahmpIO%qdriprxy) ) deallocate ( NoahmpIO%qdriprxy ) + if ( allocated (NoahmpIO%qthrosxy) ) deallocate ( NoahmpIO%qthrosxy ) + if ( allocated (NoahmpIO%qthrorxy) ) deallocate ( NoahmpIO%qthrorxy ) + if ( allocated (NoahmpIO%qsnsubxy) ) deallocate ( NoahmpIO%qsnsubxy ) + if ( allocated (NoahmpIO%qsnfroxy) ) deallocate ( NoahmpIO%qsnfroxy ) + if ( allocated (NoahmpIO%qsubcxy) ) deallocate ( NoahmpIO%qsubcxy ) + if ( allocated (NoahmpIO%qfrocxy) ) deallocate ( NoahmpIO%qfrocxy ) + if ( allocated (NoahmpIO%qevacxy) ) deallocate ( NoahmpIO%qevacxy ) + if ( allocated (NoahmpIO%qdewcxy) ) deallocate ( NoahmpIO%qdewcxy ) + if ( allocated (NoahmpIO%qfrzcxy) ) deallocate ( NoahmpIO%qfrzcxy ) + if ( allocated (NoahmpIO%qmeltcxy) ) deallocate ( NoahmpIO%qmeltcxy ) + if ( allocated (NoahmpIO%qsnbotxy) ) deallocate ( NoahmpIO%qsnbotxy ) + if ( allocated (NoahmpIO%qmeltxy) ) deallocate ( NoahmpIO%qmeltxy ) + if ( allocated (NoahmpIO%pondingxy) ) deallocate ( NoahmpIO%pondingxy ) + if ( allocated (NoahmpIO%fpicexy) ) deallocate ( NoahmpIO%fpicexy ) + if ( allocated (NoahmpIO%rainlsm) ) deallocate ( NoahmpIO%rainlsm ) + if ( allocated (NoahmpIO%snowlsm) ) deallocate ( NoahmpIO%snowlsm ) + if ( allocated (NoahmpIO%forctlsm) ) deallocate ( NoahmpIO%forctlsm ) + if ( allocated (NoahmpIO%forcqlsm) ) deallocate ( NoahmpIO%forcqlsm ) + if ( allocated (NoahmpIO%forcplsm) ) deallocate ( NoahmpIO%forcplsm ) + if ( allocated (NoahmpIO%forczlsm) ) deallocate ( NoahmpIO%forczlsm ) + if ( allocated (NoahmpIO%forcwlsm) ) deallocate ( NoahmpIO%forcwlsm ) + if ( allocated (NoahmpIO%eflxbxy) ) deallocate ( NoahmpIO%eflxbxy ) + if ( allocated (NoahmpIO%soilenergy) ) deallocate ( NoahmpIO%soilenergy ) + if ( allocated (NoahmpIO%snowenergy) ) deallocate ( NoahmpIO%snowenergy ) + if ( allocated (NoahmpIO%canhsxy) ) deallocate ( NoahmpIO%canhsxy ) + if ( allocated (NoahmpIO%acc_dwaterxy)) deallocate ( NoahmpIO%acc_dwaterxy ) + if ( allocated (NoahmpIO%acc_prcpxy) ) deallocate ( NoahmpIO%acc_prcpxy ) + if ( allocated (NoahmpIO%acc_ecanxy) ) deallocate ( NoahmpIO%acc_ecanxy ) + if ( allocated (NoahmpIO%acc_etranxy) ) deallocate ( NoahmpIO%acc_etranxy ) + if ( allocated (NoahmpIO%acc_edirxy) ) deallocate ( NoahmpIO%acc_edirxy ) + if ( allocated (NoahmpIO%acc_ssoilxy) ) deallocate ( NoahmpIO%acc_ssoilxy ) + if ( allocated (NoahmpIO%acc_qinsurxy)) deallocate ( NoahmpIO%acc_qinsurxy ) + if ( allocated (NoahmpIO%acc_qsevaxy) ) deallocate ( NoahmpIO%acc_qsevaxy ) + if ( allocated (NoahmpIO%acc_etranixy)) deallocate ( NoahmpIO%acc_etranixy ) + + ! needed for mmf_runoff (iopt_run = 5); not part of mp driver in WRF + if ( allocated (NoahmpIO%msftx) ) deallocate ( NoahmpIO%msftx ) + if ( allocated (NoahmpIO%msfty) ) deallocate ( NoahmpIO%msfty ) + if ( allocated (NoahmpIO%eqzwt) ) deallocate ( NoahmpIO%eqzwt ) + if ( allocated (NoahmpIO%riverbedxy) ) deallocate ( NoahmpIO%riverbedxy ) + if ( allocated (NoahmpIO%rivercondxy)) deallocate ( NoahmpIO%rivercondxy ) + if ( allocated (NoahmpIO%pexpxy) ) deallocate ( NoahmpIO%pexpxy ) + if ( allocated (NoahmpIO%fdepthxy) ) deallocate ( NoahmpIO%fdepthxy ) + if ( allocated (NoahmpIO%areaxy) ) deallocate ( NoahmpIO%areaxy ) + if ( allocated (NoahmpIO%qrfsxy) ) deallocate ( NoahmpIO%qrfsxy ) + if ( allocated (NoahmpIO%qspringsxy) ) deallocate ( NoahmpIO%qspringsxy ) + if ( allocated (NoahmpIO%qrfxy) ) deallocate ( NoahmpIO%qrfxy ) + if ( allocated (NoahmpIO%qspringxy) ) deallocate ( NoahmpIO%qspringxy ) + if ( allocated (NoahmpIO%qslatxy) ) deallocate ( NoahmpIO%qslatxy ) + if ( allocated (NoahmpIO%qlatxy) ) deallocate ( NoahmpIO%qlatxy ) + if ( allocated (NoahmpIO%rechclim) ) deallocate ( NoahmpIO%rechclim ) + if ( allocated (NoahmpIO%rivermask) ) deallocate ( NoahmpIO%rivermask ) + if ( allocated (NoahmpIO%nonriverxy) ) deallocate ( NoahmpIO%nonriverxy ) + + ! needed for crop model (opt_crop=1) + if ( allocated (NoahmpIO%pgsxy) ) deallocate ( NoahmpIO%pgsxy ) + if ( allocated (NoahmpIO%cropcat) ) deallocate ( NoahmpIO%cropcat ) + if ( allocated (NoahmpIO%planting) ) deallocate ( NoahmpIO%planting ) + if ( allocated (NoahmpIO%harvest) ) deallocate ( NoahmpIO%harvest ) + if ( allocated (NoahmpIO%season_gdd)) deallocate ( NoahmpIO%season_gdd ) + if ( allocated (NoahmpIO%croptype) ) deallocate ( NoahmpIO%croptype ) + + ! Single- and Multi-layer Urban Models + if ( NoahmpIO%sf_urban_physics > 0 ) then + if ( allocated (NoahmpIO%sh_urb2d) ) deallocate ( NoahmpIO%sh_urb2d ) + if ( allocated (NoahmpIO%lh_urb2d) ) deallocate ( NoahmpIO%lh_urb2d ) + if ( allocated (NoahmpIO%g_urb2d) ) deallocate ( NoahmpIO%g_urb2d ) + if ( allocated (NoahmpIO%rn_urb2d) ) deallocate ( NoahmpIO%rn_urb2d ) + if ( allocated (NoahmpIO%ts_urb2d) ) deallocate ( NoahmpIO%ts_urb2d ) + if ( allocated (NoahmpIO%hrang) ) deallocate ( NoahmpIO%hrang ) + if ( allocated (NoahmpIO%frc_urb2d) ) deallocate ( NoahmpIO%frc_urb2d ) + if ( allocated (NoahmpIO%utype_urb2d)) deallocate ( NoahmpIO%utype_urb2d ) + if ( allocated (NoahmpIO%lp_urb2d) ) deallocate ( NoahmpIO%lp_urb2d ) + if ( allocated (NoahmpIO%lb_urb2d) ) deallocate ( NoahmpIO%lb_urb2d ) + if ( allocated (NoahmpIO%hgt_urb2d) ) deallocate ( NoahmpIO%hgt_urb2d ) + if ( allocated (NoahmpIO%ust) ) deallocate ( NoahmpIO%ust ) + endif + + if(NoahmpIO%sf_urban_physics == 1 ) then ! single layer urban model + if ( allocated (NoahmpIO%cmr_sfcdif) ) deallocate ( NoahmpIO%cmr_sfcdif ) + if ( allocated (NoahmpIO%chr_sfcdif) ) deallocate ( NoahmpIO%chr_sfcdif ) + if ( allocated (NoahmpIO%cmc_sfcdif) ) deallocate ( NoahmpIO%cmc_sfcdif ) + if ( allocated (NoahmpIO%chc_sfcdif) ) deallocate ( NoahmpIO%chc_sfcdif ) + if ( allocated (NoahmpIO%cmgr_sfcdif) ) deallocate ( NoahmpIO%cmgr_sfcdif ) + if ( allocated (NoahmpIO%chgr_sfcdif) ) deallocate ( NoahmpIO%chgr_sfcdif ) + if ( allocated (NoahmpIO%tr_urb2d) ) deallocate ( NoahmpIO%tr_urb2d ) + if ( allocated (NoahmpIO%tb_urb2d) ) deallocate ( NoahmpIO%tb_urb2d ) + if ( allocated (NoahmpIO%tg_urb2d) ) deallocate ( NoahmpIO%tg_urb2d ) + if ( allocated (NoahmpIO%tc_urb2d) ) deallocate ( NoahmpIO%tc_urb2d ) + if ( allocated (NoahmpIO%qc_urb2d) ) deallocate ( NoahmpIO%qc_urb2d ) + if ( allocated (NoahmpIO%uc_urb2d) ) deallocate ( NoahmpIO%uc_urb2d ) + if ( allocated (NoahmpIO%xxxr_urb2d) ) deallocate ( NoahmpIO%xxxr_urb2d ) + if ( allocated (NoahmpIO%xxxb_urb2d) ) deallocate ( NoahmpIO%xxxb_urb2d ) + if ( allocated (NoahmpIO%xxxg_urb2d) ) deallocate ( NoahmpIO%xxxg_urb2d ) + if ( allocated (NoahmpIO%xxxc_urb2d) ) deallocate ( NoahmpIO%xxxc_urb2d ) + if ( allocated (NoahmpIO%psim_urb2d) ) deallocate ( NoahmpIO%psim_urb2d ) + if ( allocated (NoahmpIO%psih_urb2d) ) deallocate ( NoahmpIO%psih_urb2d ) + if ( allocated (NoahmpIO%u10_urb2d) ) deallocate ( NoahmpIO%u10_urb2d ) + if ( allocated (NoahmpIO%v10_urb2d) ) deallocate ( NoahmpIO%v10_urb2d ) + if ( allocated (NoahmpIO%gz1oz0_urb2d) ) deallocate ( NoahmpIO%gz1oz0_urb2d ) + if ( allocated (NoahmpIO%akms_urb2d) ) deallocate ( NoahmpIO%akms_urb2d ) + if ( allocated (NoahmpIO%th2_urb2d) ) deallocate ( NoahmpIO%th2_urb2d ) + if ( allocated (NoahmpIO%q2_urb2d) ) deallocate ( NoahmpIO%q2_urb2d ) + if ( allocated (NoahmpIO%ust_urb2d) ) deallocate ( NoahmpIO%ust_urb2d ) + if ( allocated (NoahmpIO%cmcr_urb2d) ) deallocate ( NoahmpIO%cmcr_urb2d ) + if ( allocated (NoahmpIO%tgr_urb2d) ) deallocate ( NoahmpIO%tgr_urb2d ) + if ( allocated (NoahmpIO%drelr_urb2d) ) deallocate ( NoahmpIO%drelr_urb2d ) + if ( allocated (NoahmpIO%drelb_urb2d) ) deallocate ( NoahmpIO%drelb_urb2d ) + if ( allocated (NoahmpIO%drelg_urb2d) ) deallocate ( NoahmpIO%drelg_urb2d ) + if ( allocated (NoahmpIO%flxhumr_urb2d)) deallocate ( NoahmpIO%flxhumr_urb2d ) + if ( allocated (NoahmpIO%flxhumb_urb2d)) deallocate ( NoahmpIO%flxhumb_urb2d ) + if ( allocated (NoahmpIO%flxhumg_urb2d)) deallocate ( NoahmpIO%flxhumg_urb2d ) + if ( allocated (NoahmpIO%chs) ) deallocate ( NoahmpIO%chs ) + if ( allocated (NoahmpIO%chs2) ) deallocate ( NoahmpIO%chs2 ) + if ( allocated (NoahmpIO%cqs2) ) deallocate ( NoahmpIO%cqs2 ) + if ( allocated (NoahmpIO%mh_urb2d) ) deallocate ( NoahmpIO%mh_urb2d ) + if ( allocated (NoahmpIO%stdh_urb2d) ) deallocate ( NoahmpIO%stdh_urb2d ) + if ( allocated (NoahmpIO%lf_urb2d) ) deallocate ( NoahmpIO%lf_urb2d ) + if ( allocated (NoahmpIO%trl_urb3d) ) deallocate ( NoahmpIO%trl_urb3d ) + if ( allocated (NoahmpIO%tbl_urb3d) ) deallocate ( NoahmpIO%tbl_urb3d ) + if ( allocated (NoahmpIO%tgl_urb3d) ) deallocate ( NoahmpIO%tgl_urb3d ) + if ( allocated (NoahmpIO%tgrl_urb3d) ) deallocate ( NoahmpIO%tgrl_urb3d ) + if ( allocated (NoahmpIO%smr_urb3d) ) deallocate ( NoahmpIO%smr_urb3d ) + if ( allocated (NoahmpIO%dzr) ) deallocate ( NoahmpIO%dzr ) + if ( allocated (NoahmpIO%dzb) ) deallocate ( NoahmpIO%dzb ) + if ( allocated (NoahmpIO%dzg) ) deallocate ( NoahmpIO%dzg ) + endif + + if(NoahmpIO%sf_urban_physics == 2 .or. NoahmpIO%sf_urban_physics == 3) then ! bep or bem urban models + if ( allocated (NoahmpIO%trb_urb4d) ) deallocate ( NoahmpIO%trb_urb4d ) + if ( allocated (NoahmpIO%tw1_urb4d) ) deallocate ( NoahmpIO%tw1_urb4d ) + if ( allocated (NoahmpIO%tw2_urb4d) ) deallocate ( NoahmpIO%tw2_urb4d ) + if ( allocated (NoahmpIO%tgb_urb4d) ) deallocate ( NoahmpIO%tgb_urb4d ) + if ( allocated (NoahmpIO%sfw1_urb3d) ) deallocate ( NoahmpIO%sfw1_urb3d ) + if ( allocated (NoahmpIO%sfw2_urb3d) ) deallocate ( NoahmpIO%sfw2_urb3d ) + if ( allocated (NoahmpIO%sfr_urb3d) ) deallocate ( NoahmpIO%sfr_urb3d ) + if ( allocated (NoahmpIO%sfg_urb3d) ) deallocate ( NoahmpIO%sfg_urb3d ) + if ( allocated (NoahmpIO%hi_urb2d) ) deallocate ( NoahmpIO%hi_urb2d ) + if ( allocated (NoahmpIO%theta_urban)) deallocate ( NoahmpIO%theta_urban ) + if ( allocated (NoahmpIO%u_urban) ) deallocate ( NoahmpIO%u_urban ) + if ( allocated (NoahmpIO%v_urban) ) deallocate ( NoahmpIO%v_urban ) + if ( allocated (NoahmpIO%dz_urban) ) deallocate ( NoahmpIO%dz_urban ) + if ( allocated (NoahmpIO%rho_urban) ) deallocate ( NoahmpIO%rho_urban ) + if ( allocated (NoahmpIO%p_urban) ) deallocate ( NoahmpIO%p_urban ) + if ( allocated (NoahmpIO%a_u_bep) ) deallocate ( NoahmpIO%a_u_bep ) + if ( allocated (NoahmpIO%a_v_bep) ) deallocate ( NoahmpIO%a_v_bep ) + if ( allocated (NoahmpIO%a_t_bep) ) deallocate ( NoahmpIO%a_t_bep ) + if ( allocated (NoahmpIO%a_q_bep) ) deallocate ( NoahmpIO%a_q_bep ) + if ( allocated (NoahmpIO%a_e_bep) ) deallocate ( NoahmpIO%a_e_bep ) + if ( allocated (NoahmpIO%b_u_bep) ) deallocate ( NoahmpIO%b_u_bep ) + if ( allocated (NoahmpIO%b_v_bep) ) deallocate ( NoahmpIO%b_v_bep ) + if ( allocated (NoahmpIO%b_t_bep) ) deallocate ( NoahmpIO%b_t_bep ) + if ( allocated (NoahmpIO%b_q_bep) ) deallocate ( NoahmpIO%b_q_bep ) + if ( allocated (NoahmpIO%b_e_bep) ) deallocate ( NoahmpIO%b_e_bep ) + if ( allocated (NoahmpIO%dlg_bep) ) deallocate ( NoahmpIO%dlg_bep ) + if ( allocated (NoahmpIO%dl_u_bep) ) deallocate ( NoahmpIO%dl_u_bep ) + if ( allocated (NoahmpIO%sf_bep) ) deallocate ( NoahmpIO%sf_bep ) + if ( allocated (NoahmpIO%vl_bep) ) deallocate ( NoahmpIO%vl_bep ) + endif + + if(NoahmpIO%sf_urban_physics == 3) then ! bem urban model + if ( allocated (NoahmpIO%tlev_urb3d) ) deallocate ( NoahmpIO%tlev_urb3d ) + if ( allocated (NoahmpIO%qlev_urb3d) ) deallocate ( NoahmpIO%qlev_urb3d ) + if ( allocated (NoahmpIO%tw1lev_urb3d) ) deallocate ( NoahmpIO%tw1lev_urb3d ) + if ( allocated (NoahmpIO%tw2lev_urb3d) ) deallocate ( NoahmpIO%tw2lev_urb3d ) + if ( allocated (NoahmpIO%tglev_urb3d) ) deallocate ( NoahmpIO%tglev_urb3d ) + if ( allocated (NoahmpIO%tflev_urb3d) ) deallocate ( NoahmpIO%tflev_urb3d ) + if ( allocated (NoahmpIO%sf_ac_urb3d) ) deallocate ( NoahmpIO%sf_ac_urb3d ) + if ( allocated (NoahmpIO%lf_ac_urb3d) ) deallocate ( NoahmpIO%lf_ac_urb3d ) + if ( allocated (NoahmpIO%cm_ac_urb3d) ) deallocate ( NoahmpIO%cm_ac_urb3d ) + if ( allocated (NoahmpIO%sfvent_urb3d) ) deallocate ( NoahmpIO%sfvent_urb3d ) + if ( allocated (NoahmpIO%lfvent_urb3d) ) deallocate ( NoahmpIO%lfvent_urb3d ) + if ( allocated (NoahmpIO%sfwin1_urb3d) ) deallocate ( NoahmpIO%sfwin1_urb3d ) + if ( allocated (NoahmpIO%sfwin2_urb3d) ) deallocate ( NoahmpIO%sfwin2_urb3d ) + if ( allocated (NoahmpIO%ep_pv_urb3d) ) deallocate ( NoahmpIO%ep_pv_urb3d ) + if ( allocated (NoahmpIO%t_pv_urb3d) ) deallocate ( NoahmpIO%t_pv_urb3d ) + if ( allocated (NoahmpIO%trv_urb4d) ) deallocate ( NoahmpIO%trv_urb4d ) + if ( allocated (NoahmpIO%qr_urb4d) ) deallocate ( NoahmpIO%qr_urb4d ) + if ( allocated (NoahmpIO%qgr_urb3d) ) deallocate ( NoahmpIO%qgr_urb3d ) + if ( allocated (NoahmpIO%tgr_urb3d) ) deallocate ( NoahmpIO%tgr_urb3d ) + if ( allocated (NoahmpIO%drain_urb4d) ) deallocate ( NoahmpIO%drain_urb4d ) + if ( allocated (NoahmpIO%draingr_urb3d)) deallocate ( NoahmpIO%draingr_urb3d ) + if ( allocated (NoahmpIO%sfrv_urb3d) ) deallocate ( NoahmpIO%sfrv_urb3d ) + if ( allocated (NoahmpIO%lfrv_urb3d) ) deallocate ( NoahmpIO%lfrv_urb3d ) + if ( allocated (NoahmpIO%dgr_urb3d) ) deallocate ( NoahmpIO%dgr_urb3d ) + if ( allocated (NoahmpIO%dg_urb3d) ) deallocate ( NoahmpIO%dg_urb3d ) + if ( allocated (NoahmpIO%lfr_urb3d) ) deallocate ( NoahmpIO%lfr_urb3d ) + if ( allocated (NoahmpIO%lfg_urb3d) ) deallocate ( NoahmpIO%lfg_urb3d ) + + endif + +#ifdef WRF_HYDRO + if ( allocated (NoahmpIO%infxsrt) ) deallocate ( NoahmpIO%infxsrt ) + if ( allocated (NoahmpIO%sfcheadrt) ) deallocate ( NoahmpIO%sfcheadrt ) + if ( allocated (NoahmpIO%soldrain) ) deallocate ( NoahmpIO%soldrain ) + if ( allocated (NoahmpIO%qtiledrain)) deallocate ( NoahmpIO%qtiledrain ) + if ( allocated (NoahmpIO%zwatble2d) ) deallocate ( NoahmpIO%zwatble2d ) +#endif + + end associate + + end subroutine NoahmpIOVarFinalizeDefault + +end module NoahmpIOVarFinalizeMod diff --git a/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/NoahmpIOVarInitMod.F90 b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/NoahmpIOVarInitMod.F90 new file mode 100644 index 0000000000..ada853d2f1 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/NoahmpIOVarInitMod.F90 @@ -0,0 +1,850 @@ +module NoahmpIOVarInitMod + +!!! Initialize Noah-MP input/output variables +!!! Input/Output variables should be first defined in NoahmpIOVarType.F90 + +! ------------------------ Code history ----------------------------------- +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + use Machine + use NoahmpIOVarType + + implicit none + +contains + +!=== initialize with default values + + subroutine NoahmpIOVarInitDefault(NoahmpIO) + + implicit none + + type(NoahmpIO_type), intent(inout) :: NoahmpIO + +! ------------------------------------------------- + associate( & + its => NoahmpIO%its ,& + ite => NoahmpIO%ite ,& + kts => NoahmpIO%kts ,& + kte => NoahmpIO%kte ,& + nsoil => NoahmpIO%nsoil ,& + nsnow => NoahmpIO%nsnow & + ) +! ------------------------------------------------- + + ! Input variables + if ( .not. allocated (NoahmpIO%coszen) ) allocate ( NoahmpIO%coszen (its:ite ) ) ! cosine zenith angle + if ( .not. allocated (NoahmpIO%xlat) ) allocate ( NoahmpIO%xlat (its:ite ) ) ! latitude [radians] + if ( .not. allocated (NoahmpIO%dzs) ) allocate ( NoahmpIO%dzs (1:nsoil ) ) ! thickness of soil layers [m] + if ( .not. allocated (NoahmpIO%zsoil) ) allocate ( NoahmpIO%zsoil (1:nsoil ) ) ! depth to soil interfaces [m] + if ( .not. allocated (NoahmpIO%ivgtyp) ) allocate ( NoahmpIO%ivgtyp (its:ite ) ) ! vegetation type + if ( .not. allocated (NoahmpIO%isltyp) ) allocate ( NoahmpIO%isltyp (its:ite ) ) ! soil type + if ( .not. allocated (NoahmpIO%vegfra) ) allocate ( NoahmpIO%vegfra (its:ite ) ) ! vegetation fraction [] + if ( .not. allocated (NoahmpIO%tmn) ) allocate ( NoahmpIO%tmn (its:ite ) ) ! deep soil temperature [K] + if ( .not. allocated (NoahmpIO%xland) ) allocate ( NoahmpIO%xland (its:ite ) ) ! =2 ocean; =1 land/seaice + if ( .not. allocated (NoahmpIO%xice) ) allocate ( NoahmpIO%xice (its:ite ) ) ! fraction of grid that is seaice + if ( .not. allocated (NoahmpIO%swdown) ) allocate ( NoahmpIO%swdown (its:ite ) ) ! solar down at surface [W m-2] + if ( .not. allocated (NoahmpIO%swddir) ) allocate ( NoahmpIO%swddir (its:ite ) ) ! solar down at surface [W m-2] for new urban solar panel + if ( .not. allocated (NoahmpIO%swddif) ) allocate ( NoahmpIO%swddif (its:ite ) ) ! solar down at surface [W m-2] for new urban solar panel + if ( .not. allocated (NoahmpIO%glw) ) allocate ( NoahmpIO%glw (its:ite ) ) ! longwave down at surface [W m-2] + if ( .not. allocated (NoahmpIO%rainbl) ) allocate ( NoahmpIO%rainbl (its:ite ) ) ! total precipitation entering land model [mm] per time step + if ( .not. allocated (NoahmpIO%snowbl) ) allocate ( NoahmpIO%snowbl (its:ite ) ) ! snow entering land model [mm] per time step + if ( .not. allocated (NoahmpIO%sr) ) allocate ( NoahmpIO%sr (its:ite ) ) ! frozen precip ratio entering land model [-] + if ( .not. allocated (NoahmpIO%raincv) ) allocate ( NoahmpIO%raincv (its:ite ) ) ! convective precip forcing [mm] + if ( .not. allocated (NoahmpIO%rainncv) ) allocate ( NoahmpIO%rainncv (its:ite ) ) ! non-convective precip forcing [mm] + if ( .not. allocated (NoahmpIO%rainshv) ) allocate ( NoahmpIO%rainshv (its:ite ) ) ! shallow conv. precip forcing [mm] + if ( .not. allocated (NoahmpIO%snowncv) ) allocate ( NoahmpIO%snowncv (its:ite ) ) ! non-covective snow forcing (subset of rainncv) [mm] + if ( .not. allocated (NoahmpIO%graupelncv)) allocate ( NoahmpIO%graupelncv (its:ite ) ) ! non-convective graupel forcing (subset of rainncv) [mm] + if ( .not. allocated (NoahmpIO%hailncv) ) allocate ( NoahmpIO%hailncv (its:ite ) ) ! non-convective hail forcing (subset of rainncv) [mm] + if ( .not. allocated (NoahmpIO%mp_rainc) ) allocate ( NoahmpIO%mp_rainc (its:ite ) ) ! convective precip forcing [mm] + if ( .not. allocated (NoahmpIO%mp_rainnc) ) allocate ( NoahmpIO%mp_rainnc (its:ite ) ) ! non-convective precip forcing [mm] + if ( .not. allocated (NoahmpIO%mp_shcv) ) allocate ( NoahmpIO%mp_shcv (its:ite ) ) ! shallow conv. precip forcing [mm] + if ( .not. allocated (NoahmpIO%mp_snow) ) allocate ( NoahmpIO%mp_snow (its:ite ) ) ! non-covective snow (subset of rainnc) [mm] + if ( .not. allocated (NoahmpIO%mp_graup) ) allocate ( NoahmpIO%mp_graup (its:ite ) ) ! non-convective graupel (subset of rainnc) [mm] + if ( .not. allocated (NoahmpIO%mp_hail) ) allocate ( NoahmpIO%mp_hail (its:ite ) ) ! non-convective hail (subset of rainnc) [mm] + if ( .not. allocated (NoahmpIO%seaice) ) allocate ( NoahmpIO%seaice (its:ite ) ) ! seaice fraction + if ( .not. allocated (NoahmpIO%dz8w) ) allocate ( NoahmpIO%dz8w (its:ite,kts:kte ) ) ! thickness of atmo layers [m] + if ( .not. allocated (NoahmpIO%t_phy) ) allocate ( NoahmpIO%t_phy (its:ite,kts:kte ) ) ! 3d atmospheric temperature valid at mid-levels [K] + if ( .not. allocated (NoahmpIO%qv_curr) ) allocate ( NoahmpIO%qv_curr (its:ite,kts:kte ) ) ! 3d water vapor mixing ratio [kg/kg_dry] + if ( .not. allocated (NoahmpIO%u_phy) ) allocate ( NoahmpIO%u_phy (its:ite,kts:kte ) ) ! 3d u wind component [m/s] + if ( .not. allocated (NoahmpIO%v_phy) ) allocate ( NoahmpIO%v_phy (its:ite,kts:kte ) ) ! 3d v wind component [m/s] + if ( .not. allocated (NoahmpIO%p8w) ) allocate ( NoahmpIO%p8w (its:ite,kts:kte ) ) ! 3d pressure, valid at interface [Pa] + + ! spatial varying parameter map + if ( NoahmpIO%iopt_soil > 1 ) then + if ( .not. allocated (NoahmpIO%soilcomp)) allocate ( NoahmpIO%soilcomp (its:ite,1:2*nsoil) ) ! soil sand and clay content [fraction] + if ( .not. allocated (NoahmpIO%soilcl1) ) allocate ( NoahmpIO%soilcl1 (its:ite ) ) ! soil texture class with depth + if ( .not. allocated (NoahmpIO%soilcl2) ) allocate ( NoahmpIO%soilcl2 (its:ite ) ) ! soil texture class with depth + if ( .not. allocated (NoahmpIO%soilcl3) ) allocate ( NoahmpIO%soilcl3 (its:ite ) ) ! soil texture class with depth + if ( .not. allocated (NoahmpIO%soilcl4) ) allocate ( NoahmpIO%soilcl4 (its:ite ) ) ! soil texture class with depth + endif + if ( NoahmpIO%iopt_soil == 4 ) then + if ( .not. allocated (NoahmpIO%bexp_3d) ) allocate ( NoahmpIO%bexp_3d (its:ite,1:nsoil) ) ! c-h b exponent + if ( .not. allocated (NoahmpIO%smcdry_3d) ) allocate ( NoahmpIO%smcdry_3d (its:ite,1:nsoil) ) ! soil moisture limit: dry + if ( .not. allocated (NoahmpIO%smcwlt_3d) ) allocate ( NoahmpIO%smcwlt_3d (its:ite,1:nsoil) ) ! soil moisture limit: wilt + if ( .not. allocated (NoahmpIO%smcref_3d) ) allocate ( NoahmpIO%smcref_3d (its:ite,1:nsoil) ) ! soil moisture limit: reference + if ( .not. allocated (NoahmpIO%smcmax_3d) ) allocate ( NoahmpIO%smcmax_3d (its:ite,1:nsoil) ) ! soil moisture limit: max + if ( .not. allocated (NoahmpIO%dksat_3d) ) allocate ( NoahmpIO%dksat_3d (its:ite,1:nsoil) ) ! saturated soil conductivity + if ( .not. allocated (NoahmpIO%dwsat_3d) ) allocate ( NoahmpIO%dwsat_3d (its:ite,1:nsoil) ) ! saturated soil diffusivity + if ( .not. allocated (NoahmpIO%psisat_3d) ) allocate ( NoahmpIO%psisat_3d (its:ite,1:nsoil) ) ! saturated matric potential + if ( .not. allocated (NoahmpIO%quartz_3d) ) allocate ( NoahmpIO%quartz_3d (its:ite,1:nsoil) ) ! soil quartz content + if ( .not. allocated (NoahmpIO%refdk_2d) ) allocate ( NoahmpIO%refdk_2d (its:ite ) ) ! reference soil conductivity + if ( .not. allocated (NoahmpIO%refkdt_2d) ) allocate ( NoahmpIO%refkdt_2d (its:ite ) ) ! soil infiltration parameter + if ( .not. allocated (NoahmpIO%irr_frac_2d) ) allocate ( NoahmpIO%irr_frac_2d (its:ite ) ) ! irrigation fraction + if ( .not. allocated (NoahmpIO%irr_har_2d) ) allocate ( NoahmpIO%irr_har_2d (its:ite ) ) ! number of days before harvest date to stop irrigation + if ( .not. allocated (NoahmpIO%irr_lai_2d) ) allocate ( NoahmpIO%irr_lai_2d (its:ite ) ) ! minimum lai to trigger irrigation + if ( .not. allocated (NoahmpIO%irr_mad_2d) ) allocate ( NoahmpIO%irr_mad_2d (its:ite ) ) ! management allowable deficit (0-1) + if ( .not. allocated (NoahmpIO%filoss_2d) ) allocate ( NoahmpIO%filoss_2d (its:ite ) ) ! fraction of flood irrigation loss (0-1) + if ( .not. allocated (NoahmpIO%sprir_rate_2d)) allocate ( NoahmpIO%sprir_rate_2d (its:ite ) ) ! mm/h, sprinkler irrigation rate + if ( .not. allocated (NoahmpIO%micir_rate_2d)) allocate ( NoahmpIO%micir_rate_2d (its:ite ) ) ! mm/h, micro irrigation rate + if ( .not. allocated (NoahmpIO%firtfac_2d) ) allocate ( NoahmpIO%firtfac_2d (its:ite ) ) ! flood application rate factor + if ( .not. allocated (NoahmpIO%ir_rain_2d) ) allocate ( NoahmpIO%ir_rain_2d (its:ite ) ) ! maximum precipitation to stop irrigation trigger + if ( .not. allocated (NoahmpIO%bvic_2d) ) allocate ( NoahmpIO%bvic_2d (its:ite ) ) ! VIC model infiltration parameter [-] + if ( .not. allocated (NoahmpIO%axaj_2d) ) allocate ( NoahmpIO%axaj_2d (its:ite ) ) ! tension water distribution inflection parameter [-] + if ( .not. allocated (NoahmpIO%bxaj_2d) ) allocate ( NoahmpIO%bxaj_2d (its:ite ) ) ! tension water distribution shape parameter [-] + if ( .not. allocated (NoahmpIO%xxaj_2d) ) allocate ( NoahmpIO%xxaj_2d (its:ite ) ) ! free water distribution shape parameter [-] + if ( .not. allocated (NoahmpIO%bdvic_2d) ) allocate ( NoahmpIO%bdvic_2d (its:ite ) ) ! DVIC model infiltration parameter [-] + if ( .not. allocated (NoahmpIO%gdvic_2d) ) allocate ( NoahmpIO%gdvic_2d (its:ite ) ) ! mean capillary drive (m) for infiltration models + if ( .not. allocated (NoahmpIO%bbvic_2d) ) allocate ( NoahmpIO%bbvic_2d (its:ite ) ) ! dvic heterogeniety parameter for infiltration [-] + if ( .not. allocated (NoahmpIO%klat_fac) ) allocate ( NoahmpIO%klat_fac (its:ite ) ) ! factor multiplier to hydraulic conductivity + if ( .not. allocated (NoahmpIO%tdsmc_fac) ) allocate ( NoahmpIO%tdsmc_fac (its:ite ) ) ! factor multiplier to field capacity + if ( .not. allocated (NoahmpIO%td_dc) ) allocate ( NoahmpIO%td_dc (its:ite ) ) ! drainage coefficient for simple + if ( .not. allocated (NoahmpIO%td_dcoef) ) allocate ( NoahmpIO%td_dcoef (its:ite ) ) ! drainage coefficient for Hooghoudt + if ( .not. allocated (NoahmpIO%td_ddrain) ) allocate ( NoahmpIO%td_ddrain (its:ite ) ) ! depth of drain + if ( .not. allocated (NoahmpIO%td_radi) ) allocate ( NoahmpIO%td_radi (its:ite ) ) ! tile radius + if ( .not. allocated (NoahmpIO%td_spac) ) allocate ( NoahmpIO%td_spac (its:ite ) ) ! tile spacing + endif + + ! INOUT (with generic LSM equivalent) (as defined in WRF) + if ( .not. allocated (NoahmpIO%tsk) ) allocate ( NoahmpIO%tsk (its:ite ) ) ! surface radiative temperature [K] + if ( .not. allocated (NoahmpIO%hfx) ) allocate ( NoahmpIO%hfx (its:ite ) ) ! sensible heat flux [W m-2] + if ( .not. allocated (NoahmpIO%qfx) ) allocate ( NoahmpIO%qfx (its:ite ) ) ! latent heat flux [kg s-1 m-2] + if ( .not. allocated (NoahmpIO%lh) ) allocate ( NoahmpIO%lh (its:ite ) ) ! latent heat flux [W m-2] + if ( .not. allocated (NoahmpIO%grdflx) ) allocate ( NoahmpIO%grdflx (its:ite ) ) ! ground/snow heat flux [W m-2] + if ( .not. allocated (NoahmpIO%smstav) ) allocate ( NoahmpIO%smstav (its:ite ) ) ! soil moisture avail. [not used] + if ( .not. allocated (NoahmpIO%smstot) ) allocate ( NoahmpIO%smstot (its:ite ) ) ! total soil water [mm][not used] + if ( .not. allocated (NoahmpIO%sfcrunoff)) allocate ( NoahmpIO%sfcrunoff (its:ite ) ) ! accumulated surface runoff [m] + if ( .not. allocated (NoahmpIO%udrunoff) ) allocate ( NoahmpIO%udrunoff (its:ite ) ) ! accumulated sub-surface runoff [m] + if ( .not. allocated (NoahmpIO%albedo) ) allocate ( NoahmpIO%albedo (its:ite ) ) ! total grid albedo [] + if ( .not. allocated (NoahmpIO%snowc) ) allocate ( NoahmpIO%snowc (its:ite ) ) ! snow cover fraction [] + if ( .not. allocated (NoahmpIO%snow) ) allocate ( NoahmpIO%snow (its:ite ) ) ! snow water equivalent [mm] + if ( .not. allocated (NoahmpIO%snowh) ) allocate ( NoahmpIO%snowh (its:ite ) ) ! physical snow depth [m] + if ( .not. allocated (NoahmpIO%canwat) ) allocate ( NoahmpIO%canwat (its:ite ) ) ! total canopy water + ice [mm] + if ( .not. allocated (NoahmpIO%acsnom) ) allocate ( NoahmpIO%acsnom (its:ite ) ) ! accumulated snow melt leaving pack + if ( .not. allocated (NoahmpIO%acsnow) ) allocate ( NoahmpIO%acsnow (its:ite ) ) ! accumulated snow on grid + if ( .not. allocated (NoahmpIO%emiss) ) allocate ( NoahmpIO%emiss (its:ite ) ) ! surface bulk emissivity + if ( .not. allocated (NoahmpIO%qsfc) ) allocate ( NoahmpIO%qsfc (its:ite ) ) ! bulk surface specific humidity + if ( .not. allocated (NoahmpIO%smoiseq) ) allocate ( NoahmpIO%smoiseq (its:ite,1:nsoil) ) ! equilibrium volumetric soil moisture [m3/m3] + if ( .not. allocated (NoahmpIO%smois) ) allocate ( NoahmpIO%smois (its:ite,1:nsoil) ) ! volumetric soil moisture [m3/m3] + if ( .not. allocated (NoahmpIO%sh2o) ) allocate ( NoahmpIO%sh2o (its:ite,1:nsoil) ) ! volumetric liquid soil moisture [m3/m3] + if ( .not. allocated (NoahmpIO%tslb) ) allocate ( NoahmpIO%tslb (its:ite,1:nsoil) ) ! soil temperature [K] + + ! INOUT (with no Noah LSM equivalent) (as defined in WRF) + if ( .not. allocated (NoahmpIO%isnowxy) ) allocate ( NoahmpIO%isnowxy (its:ite ) ) ! actual no. of snow layers + if ( .not. allocated (NoahmpIO%tvxy) ) allocate ( NoahmpIO%tvxy (its:ite ) ) ! vegetation leaf temperature + if ( .not. allocated (NoahmpIO%tgxy) ) allocate ( NoahmpIO%tgxy (its:ite ) ) ! bulk ground surface temperature + if ( .not. allocated (NoahmpIO%canicexy) ) allocate ( NoahmpIO%canicexy (its:ite ) ) ! canopy-intercepted ice (mm) + if ( .not. allocated (NoahmpIO%canliqxy) ) allocate ( NoahmpIO%canliqxy (its:ite ) ) ! canopy-intercepted liquid water (mm) + if ( .not. allocated (NoahmpIO%eahxy) ) allocate ( NoahmpIO%eahxy (its:ite ) ) ! canopy air vapor pressure (Pa) + if ( .not. allocated (NoahmpIO%tahxy) ) allocate ( NoahmpIO%tahxy (its:ite ) ) ! canopy air temperature (K) + if ( .not. allocated (NoahmpIO%cmxy) ) allocate ( NoahmpIO%cmxy (its:ite ) ) ! bulk momentum drag coefficient + if ( .not. allocated (NoahmpIO%chxy) ) allocate ( NoahmpIO%chxy (its:ite ) ) ! bulk sensible heat exchange coefficient + if ( .not. allocated (NoahmpIO%fwetxy) ) allocate ( NoahmpIO%fwetxy (its:ite ) ) ! wetted or snowed fraction of the canopy (-) + if ( .not. allocated (NoahmpIO%sneqvoxy) ) allocate ( NoahmpIO%sneqvoxy (its:ite ) ) ! snow mass at last time step(mm H2O) + if ( .not. allocated (NoahmpIO%alboldxy) ) allocate ( NoahmpIO%alboldxy (its:ite ) ) ! snow albedo at last time step (-) + if ( .not. allocated (NoahmpIO%qsnowxy) ) allocate ( NoahmpIO%qsnowxy (its:ite ) ) ! snowfall on the ground [mm/s] + if ( .not. allocated (NoahmpIO%qrainxy) ) allocate ( NoahmpIO%qrainxy (its:ite ) ) ! rainfall on the ground [mm/s] + if ( .not. allocated (NoahmpIO%wslakexy) ) allocate ( NoahmpIO%wslakexy (its:ite ) ) ! lake water storage [mm] + if ( .not. allocated (NoahmpIO%zwtxy) ) allocate ( NoahmpIO%zwtxy (its:ite ) ) ! water table depth [m] + if ( .not. allocated (NoahmpIO%waxy) ) allocate ( NoahmpIO%waxy (its:ite ) ) ! water in the "aquifer" [mm] + if ( .not. allocated (NoahmpIO%wtxy) ) allocate ( NoahmpIO%wtxy (its:ite ) ) ! groundwater storage [mm] + if ( .not. allocated (NoahmpIO%smcwtdxy) ) allocate ( NoahmpIO%smcwtdxy (its:ite ) ) ! soil moisture below the bottom of the column (m3 m-3) + if ( .not. allocated (NoahmpIO%deeprechxy)) allocate ( NoahmpIO%deeprechxy (its:ite ) ) ! recharge to the water table when deep (m) + if ( .not. allocated (NoahmpIO%rechxy) ) allocate ( NoahmpIO%rechxy (its:ite ) ) ! recharge to the water table (diagnostic) (m) + if ( .not. allocated (NoahmpIO%lfmassxy) ) allocate ( NoahmpIO%lfmassxy (its:ite ) ) ! leaf mass [g/m2] + if ( .not. allocated (NoahmpIO%rtmassxy) ) allocate ( NoahmpIO%rtmassxy (its:ite ) ) ! mass of fine roots [g/m2] + if ( .not. allocated (NoahmpIO%stmassxy) ) allocate ( NoahmpIO%stmassxy (its:ite ) ) ! stem mass [g/m2] + if ( .not. allocated (NoahmpIO%woodxy) ) allocate ( NoahmpIO%woodxy (its:ite ) ) ! mass of wood (incl. woody roots) [g/m2] + if ( .not. allocated (NoahmpIO%grainxy) ) allocate ( NoahmpIO%grainxy (its:ite ) ) ! mass of grain xing [g/m2] + if ( .not. allocated (NoahmpIO%gddxy) ) allocate ( NoahmpIO%gddxy (its:ite ) ) ! growing degree days xing four + if ( .not. allocated (NoahmpIO%stblcpxy) ) allocate ( NoahmpIO%stblcpxy (its:ite ) ) ! stable carbon in deep soil [g/m2] + if ( .not. allocated (NoahmpIO%fastcpxy) ) allocate ( NoahmpIO%fastcpxy (its:ite ) ) ! short-lived carbon, shallow soil [g/m2] + if ( .not. allocated (NoahmpIO%lai) ) allocate ( NoahmpIO%lai (its:ite ) ) ! leaf area index + if ( .not. allocated (NoahmpIO%xsaixy) ) allocate ( NoahmpIO%xsaixy (its:ite ) ) ! stem area index + if ( .not. allocated (NoahmpIO%taussxy) ) allocate ( NoahmpIO%taussxy (its:ite ) ) ! snow age factor + if ( .not. allocated (NoahmpIO%tsnoxy) ) allocate ( NoahmpIO%tsnoxy (its:ite,-nsnow+1:0 ) ) ! snow temperature [K] + if ( .not. allocated (NoahmpIO%zsnsoxy) ) allocate ( NoahmpIO%zsnsoxy (its:ite,-nsnow+1:nsoil) ) ! snow layer depth [m] + if ( .not. allocated (NoahmpIO%snicexy) ) allocate ( NoahmpIO%snicexy (its:ite,-nsnow+1:0 ) ) ! snow layer ice [mm] + if ( .not. allocated (NoahmpIO%snliqxy) ) allocate ( NoahmpIO%snliqxy (its:ite,-nsnow+1:0 ) ) ! snow layer liquid water [mm] + + ! irrigation + if ( .not. allocated (NoahmpIO%irfract) ) allocate ( NoahmpIO%irfract (its:ite) ) ! irrigation fraction + if ( .not. allocated (NoahmpIO%sifract) ) allocate ( NoahmpIO%sifract (its:ite) ) ! sprinkler irrigation fraction + if ( .not. allocated (NoahmpIO%mifract) ) allocate ( NoahmpIO%mifract (its:ite) ) ! micro irrigation fraction + if ( .not. allocated (NoahmpIO%fifract) ) allocate ( NoahmpIO%fifract (its:ite) ) ! flood irrigation fraction + if ( .not. allocated (NoahmpIO%irnumsi) ) allocate ( NoahmpIO%irnumsi (its:ite) ) ! irrigation event number, sprinkler + if ( .not. allocated (NoahmpIO%irnummi) ) allocate ( NoahmpIO%irnummi (its:ite) ) ! irrigation event number, micro + if ( .not. allocated (NoahmpIO%irnumfi) ) allocate ( NoahmpIO%irnumfi (its:ite) ) ! irrigation event number, flood + if ( .not. allocated (NoahmpIO%irwatsi) ) allocate ( NoahmpIO%irwatsi (its:ite) ) ! irrigation water amount [m] to be applied, sprinkler + if ( .not. allocated (NoahmpIO%irwatmi) ) allocate ( NoahmpIO%irwatmi (its:ite) ) ! irrigation water amount [m] to be applied, micro + if ( .not. allocated (NoahmpIO%irwatfi) ) allocate ( NoahmpIO%irwatfi (its:ite) ) ! irrigation water amount [m] to be applied, flood + if ( .not. allocated (NoahmpIO%ireloss) ) allocate ( NoahmpIO%ireloss (its:ite) ) ! loss of irrigation water to evaporation,sprinkler [mm] + if ( .not. allocated (NoahmpIO%irsivol) ) allocate ( NoahmpIO%irsivol (its:ite) ) ! amount of irrigation by sprinkler (mm) + if ( .not. allocated (NoahmpIO%irmivol) ) allocate ( NoahmpIO%irmivol (its:ite) ) ! amount of irrigation by micro (mm) + if ( .not. allocated (NoahmpIO%irfivol) ) allocate ( NoahmpIO%irfivol (its:ite) ) ! amount of irrigation by micro (mm) + if ( .not. allocated (NoahmpIO%irrsplh) ) allocate ( NoahmpIO%irrsplh (its:ite) ) ! latent heating from sprinkler evaporation (W/m2) + if ( .not. allocated (NoahmpIO%loctim) ) allocate ( NoahmpIO%loctim (its:ite) ) ! local time + + ! OUT (with no Noah LSM equivalent) (as defined in WRF) + if ( .not. allocated (NoahmpIO%t2mvxy) ) allocate ( NoahmpIO%t2mvxy (its:ite) ) ! 2m temperature of vegetation part + if ( .not. allocated (NoahmpIO%t2mbxy) ) allocate ( NoahmpIO%t2mbxy (its:ite) ) ! 2m temperature of bare ground part + if ( .not. allocated (NoahmpIO%q2mvxy) ) allocate ( NoahmpIO%q2mvxy (its:ite) ) ! 2m mixing ratio of vegetation part + if ( .not. allocated (NoahmpIO%q2mbxy) ) allocate ( NoahmpIO%q2mbxy (its:ite) ) ! 2m mixing ratio of bare ground part + if ( .not. allocated (NoahmpIO%tradxy) ) allocate ( NoahmpIO%tradxy (its:ite) ) ! surface radiative temperature (K) + if ( .not. allocated (NoahmpIO%neexy) ) allocate ( NoahmpIO%neexy (its:ite) ) ! net ecosys exchange (g/m2/s CO2) + if ( .not. allocated (NoahmpIO%gppxy) ) allocate ( NoahmpIO%gppxy (its:ite) ) ! gross primary assimilation [g/m2/s C] + if ( .not. allocated (NoahmpIO%nppxy) ) allocate ( NoahmpIO%nppxy (its:ite) ) ! net primary productivity [g/m2/s C] + if ( .not. allocated (NoahmpIO%fvegxy) ) allocate ( NoahmpIO%fvegxy (its:ite) ) ! noah-mp vegetation fraction [-] + if ( .not. allocated (NoahmpIO%runsfxy) ) allocate ( NoahmpIO%runsfxy (its:ite) ) ! surface runoff [mm per soil timestep] + if ( .not. allocated (NoahmpIO%runsbxy) ) allocate ( NoahmpIO%runsbxy (its:ite) ) ! subsurface runoff [mm per soil timestep] + if ( .not. allocated (NoahmpIO%ecanxy) ) allocate ( NoahmpIO%ecanxy (its:ite) ) ! evaporation of intercepted water (mm/s) + if ( .not. allocated (NoahmpIO%edirxy) ) allocate ( NoahmpIO%edirxy (its:ite) ) ! soil surface evaporation rate (mm/s] + if ( .not. allocated (NoahmpIO%etranxy) ) allocate ( NoahmpIO%etranxy (its:ite) ) ! transpiration rate (mm/s) + if ( .not. allocated (NoahmpIO%fsaxy) ) allocate ( NoahmpIO%fsaxy (its:ite) ) ! total absorbed solar radiation (W/m2) + if ( .not. allocated (NoahmpIO%firaxy) ) allocate ( NoahmpIO%firaxy (its:ite) ) ! total net longwave rad (W/m2) [+ to atm] + if ( .not. allocated (NoahmpIO%aparxy) ) allocate ( NoahmpIO%aparxy (its:ite) ) ! photosyn active energy by canopy (W/m2) + if ( .not. allocated (NoahmpIO%psnxy) ) allocate ( NoahmpIO%psnxy (its:ite) ) ! total photosynthesis (umol CO2/m2/s) [+] + if ( .not. allocated (NoahmpIO%savxy) ) allocate ( NoahmpIO%savxy (its:ite) ) ! solar rad absorbed by veg. (W/m2) + if ( .not. allocated (NoahmpIO%sagxy) ) allocate ( NoahmpIO%sagxy (its:ite) ) ! solar rad absorbed by ground (W/m2) + if ( .not. allocated (NoahmpIO%rssunxy) ) allocate ( NoahmpIO%rssunxy (its:ite) ) ! sunlit leaf stomatal resistance (s/m) + if ( .not. allocated (NoahmpIO%rsshaxy) ) allocate ( NoahmpIO%rsshaxy (its:ite) ) ! shaded leaf stomatal resistance (s/m) + if ( .not. allocated (NoahmpIO%bgapxy) ) allocate ( NoahmpIO%bgapxy (its:ite) ) ! between gap fraction + if ( .not. allocated (NoahmpIO%wgapxy) ) allocate ( NoahmpIO%wgapxy (its:ite) ) ! within gap fraction + if ( .not. allocated (NoahmpIO%tgvxy) ) allocate ( NoahmpIO%tgvxy (its:ite) ) ! under canopy ground temperature[K] + if ( .not. allocated (NoahmpIO%tgbxy) ) allocate ( NoahmpIO%tgbxy (its:ite) ) ! bare ground temperature [K] + if ( .not. allocated (NoahmpIO%chvxy) ) allocate ( NoahmpIO%chvxy (its:ite) ) ! sensible heat exchange coefficient vegetated + if ( .not. allocated (NoahmpIO%chbxy) ) allocate ( NoahmpIO%chbxy (its:ite) ) ! sensible heat exchange coefficient bare-ground + if ( .not. allocated (NoahmpIO%shgxy) ) allocate ( NoahmpIO%shgxy (its:ite) ) ! veg ground sen. heat [W/m2] [+ to atm] + if ( .not. allocated (NoahmpIO%shcxy) ) allocate ( NoahmpIO%shcxy (its:ite) ) ! canopy sen. heat [W/m2] [+ to atm] + if ( .not. allocated (NoahmpIO%shbxy) ) allocate ( NoahmpIO%shbxy (its:ite) ) ! bare sensible heat [W/m2] [+ to atm] + if ( .not. allocated (NoahmpIO%evgxy) ) allocate ( NoahmpIO%evgxy (its:ite) ) ! veg ground evap. heat [W/m2] [+ to atm] + if ( .not. allocated (NoahmpIO%evbxy) ) allocate ( NoahmpIO%evbxy (its:ite) ) ! bare soil evaporation [W/m2] [+ to atm] + if ( .not. allocated (NoahmpIO%ghvxy) ) allocate ( NoahmpIO%ghvxy (its:ite) ) ! veg ground heat flux [W/m2] [+ to soil] + if ( .not. allocated (NoahmpIO%ghbxy) ) allocate ( NoahmpIO%ghbxy (its:ite) ) ! bare ground heat flux [W/m2] [+ to soil] + if ( .not. allocated (NoahmpIO%irgxy) ) allocate ( NoahmpIO%irgxy (its:ite) ) ! veg ground net lw rad. [W/m2] [+ to atm] + if ( .not. allocated (NoahmpIO%ircxy) ) allocate ( NoahmpIO%ircxy (its:ite) ) ! canopy net lw rad. [W/m2] [+ to atm] + if ( .not. allocated (NoahmpIO%irbxy) ) allocate ( NoahmpIO%irbxy (its:ite) ) ! bare net longwave rad. [W/m2] [+ to atm] + if ( .not. allocated (NoahmpIO%trxy) ) allocate ( NoahmpIO%trxy (its:ite) ) ! transpiration [w/m2] [+ to atm] + if ( .not. allocated (NoahmpIO%evcxy) ) allocate ( NoahmpIO%evcxy (its:ite) ) ! canopy evaporation heat [W/m2] [+ to atm] + if ( .not. allocated (NoahmpIO%chleafxy) ) allocate ( NoahmpIO%chleafxy (its:ite) ) ! leaf exchange coefficient + if ( .not. allocated (NoahmpIO%chucxy) ) allocate ( NoahmpIO%chucxy (its:ite) ) ! under canopy exchange coefficient + if ( .not. allocated (NoahmpIO%chv2xy) ) allocate ( NoahmpIO%chv2xy (its:ite) ) ! veg 2m exchange coefficient + if ( .not. allocated (NoahmpIO%chb2xy) ) allocate ( NoahmpIO%chb2xy (its:ite) ) ! bare 2m exchange coefficient + if ( .not. allocated (NoahmpIO%rs) ) allocate ( NoahmpIO%rs (its:ite) ) ! total stomatal resistance (s/m) + if ( .not. allocated (NoahmpIO%z0) ) allocate ( NoahmpIO%z0 (its:ite) ) ! roughness length output to WRF + if ( .not. allocated (NoahmpIO%znt) ) allocate ( NoahmpIO%znt (its:ite) ) ! roughness length output to WRF + if ( .not. allocated (NoahmpIO%qtdrain) ) allocate ( NoahmpIO%qtdrain (its:ite) ) ! tile drainage (mm) + if ( .not. allocated (NoahmpIO%td_fraction)) allocate ( NoahmpIO%td_fraction (its:ite) ) ! tile drainage fraction + if ( .not. allocated (NoahmpIO%xlong) ) allocate ( NoahmpIO%xlong (its:ite) ) ! longitude + if ( .not. allocated (NoahmpIO%terrain) ) allocate ( NoahmpIO%terrain (its:ite) ) ! terrain height + if ( .not. allocated (NoahmpIO%gvfmin) ) allocate ( NoahmpIO%gvfmin (its:ite) ) ! annual minimum in vegetation fraction + if ( .not. allocated (NoahmpIO%gvfmax) ) allocate ( NoahmpIO%gvfmax (its:ite) ) ! annual maximum in vegetation fraction + + ! additional output variables + if ( .not. allocated (NoahmpIO%pahxy) ) allocate ( NoahmpIO%pahxy (its:ite) ) + if ( .not. allocated (NoahmpIO%pahgxy) ) allocate ( NoahmpIO%pahgxy (its:ite) ) + if ( .not. allocated (NoahmpIO%pahbxy) ) allocate ( NoahmpIO%pahbxy (its:ite) ) + if ( .not. allocated (NoahmpIO%pahvxy) ) allocate ( NoahmpIO%pahvxy (its:ite) ) + if ( .not. allocated (NoahmpIO%qintsxy) ) allocate ( NoahmpIO%qintsxy (its:ite) ) + if ( .not. allocated (NoahmpIO%qintrxy) ) allocate ( NoahmpIO%qintrxy (its:ite) ) + if ( .not. allocated (NoahmpIO%qdripsxy) ) allocate ( NoahmpIO%qdripsxy (its:ite) ) + if ( .not. allocated (NoahmpIO%qdriprxy) ) allocate ( NoahmpIO%qdriprxy (its:ite) ) + if ( .not. allocated (NoahmpIO%qthrosxy) ) allocate ( NoahmpIO%qthrosxy (its:ite) ) + if ( .not. allocated (NoahmpIO%qthrorxy) ) allocate ( NoahmpIO%qthrorxy (its:ite) ) + if ( .not. allocated (NoahmpIO%qsnsubxy) ) allocate ( NoahmpIO%qsnsubxy (its:ite) ) + if ( .not. allocated (NoahmpIO%qsnfroxy) ) allocate ( NoahmpIO%qsnfroxy (its:ite) ) + if ( .not. allocated (NoahmpIO%qsubcxy) ) allocate ( NoahmpIO%qsubcxy (its:ite) ) + if ( .not. allocated (NoahmpIO%qfrocxy) ) allocate ( NoahmpIO%qfrocxy (its:ite) ) + if ( .not. allocated (NoahmpIO%qevacxy) ) allocate ( NoahmpIO%qevacxy (its:ite) ) + if ( .not. allocated (NoahmpIO%qdewcxy) ) allocate ( NoahmpIO%qdewcxy (its:ite) ) + if ( .not. allocated (NoahmpIO%qfrzcxy) ) allocate ( NoahmpIO%qfrzcxy (its:ite) ) + if ( .not. allocated (NoahmpIO%qmeltcxy) ) allocate ( NoahmpIO%qmeltcxy (its:ite) ) + if ( .not. allocated (NoahmpIO%qsnbotxy) ) allocate ( NoahmpIO%qsnbotxy (its:ite) ) + if ( .not. allocated (NoahmpIO%qmeltxy) ) allocate ( NoahmpIO%qmeltxy (its:ite) ) + if ( .not. allocated (NoahmpIO%pondingxy) ) allocate ( NoahmpIO%pondingxy (its:ite) ) + if ( .not. allocated (NoahmpIO%fpicexy) ) allocate ( NoahmpIO%fpicexy (its:ite) ) + if ( .not. allocated (NoahmpIO%rainlsm) ) allocate ( NoahmpIO%rainlsm (its:ite) ) + if ( .not. allocated (NoahmpIO%snowlsm) ) allocate ( NoahmpIO%snowlsm (its:ite) ) + if ( .not. allocated (NoahmpIO%forctlsm) ) allocate ( NoahmpIO%forctlsm (its:ite) ) + if ( .not. allocated (NoahmpIO%forcqlsm) ) allocate ( NoahmpIO%forcqlsm (its:ite) ) + if ( .not. allocated (NoahmpIO%forcplsm) ) allocate ( NoahmpIO%forcplsm (its:ite) ) + if ( .not. allocated (NoahmpIO%forczlsm) ) allocate ( NoahmpIO%forczlsm (its:ite) ) + if ( .not. allocated (NoahmpIO%forcwlsm) ) allocate ( NoahmpIO%forcwlsm (its:ite) ) + if ( .not. allocated (NoahmpIO%eflxbxy) ) allocate ( NoahmpIO%eflxbxy (its:ite) ) + if ( .not. allocated (NoahmpIO%soilenergy) ) allocate ( NoahmpIO%soilenergy (its:ite) ) + if ( .not. allocated (NoahmpIO%snowenergy) ) allocate ( NoahmpIO%snowenergy (its:ite) ) + if ( .not. allocated (NoahmpIO%canhsxy) ) allocate ( NoahmpIO%canhsxy (its:ite) ) + if ( .not. allocated (NoahmpIO%acc_dwaterxy)) allocate ( NoahmpIO%acc_dwaterxy (its:ite) ) + if ( .not. allocated (NoahmpIO%acc_prcpxy) ) allocate ( NoahmpIO%acc_prcpxy (its:ite) ) + if ( .not. allocated (NoahmpIO%acc_ecanxy) ) allocate ( NoahmpIO%acc_ecanxy (its:ite) ) + if ( .not. allocated (NoahmpIO%acc_etranxy) ) allocate ( NoahmpIO%acc_etranxy (its:ite) ) + if ( .not. allocated (NoahmpIO%acc_edirxy) ) allocate ( NoahmpIO%acc_edirxy (its:ite) ) + if ( .not. allocated (NoahmpIO%acc_ssoilxy) ) allocate ( NoahmpIO%acc_ssoilxy (its:ite) ) + if ( .not. allocated (NoahmpIO%acc_qinsurxy)) allocate ( NoahmpIO%acc_qinsurxy (its:ite) ) + if ( .not. allocated (NoahmpIO%acc_qsevaxy) ) allocate ( NoahmpIO%acc_qsevaxy (its:ite) ) + if ( .not. allocated (NoahmpIO%acc_etranixy)) allocate ( NoahmpIO%acc_etranixy (its:ite,1:nsoil) ) + + ! needed for mmf_runoff (iopt_run = 5); not part of mp driver in WRF + if ( .not. allocated (NoahmpIO%msftx) ) allocate ( NoahmpIO%msftx (its:ite) ) + if ( .not. allocated (NoahmpIO%msfty) ) allocate ( NoahmpIO%msfty (its:ite) ) + if ( .not. allocated (NoahmpIO%eqzwt) ) allocate ( NoahmpIO%eqzwt (its:ite) ) + if ( .not. allocated (NoahmpIO%riverbedxy) ) allocate ( NoahmpIO%riverbedxy (its:ite) ) + if ( .not. allocated (NoahmpIO%rivercondxy)) allocate ( NoahmpIO%rivercondxy (its:ite) ) + if ( .not. allocated (NoahmpIO%pexpxy) ) allocate ( NoahmpIO%pexpxy (its:ite) ) + if ( .not. allocated (NoahmpIO%fdepthxy) ) allocate ( NoahmpIO%fdepthxy (its:ite) ) + if ( .not. allocated (NoahmpIO%areaxy) ) allocate ( NoahmpIO%areaxy (its:ite) ) + if ( .not. allocated (NoahmpIO%qrfsxy) ) allocate ( NoahmpIO%qrfsxy (its:ite) ) + if ( .not. allocated (NoahmpIO%qspringsxy) ) allocate ( NoahmpIO%qspringsxy (its:ite) ) + if ( .not. allocated (NoahmpIO%qrfxy) ) allocate ( NoahmpIO%qrfxy (its:ite) ) + if ( .not. allocated (NoahmpIO%qspringxy) ) allocate ( NoahmpIO%qspringxy (its:ite) ) + if ( .not. allocated (NoahmpIO%qslatxy) ) allocate ( NoahmpIO%qslatxy (its:ite) ) + if ( .not. allocated (NoahmpIO%qlatxy) ) allocate ( NoahmpIO%qlatxy (its:ite) ) + if ( .not. allocated (NoahmpIO%rechclim) ) allocate ( NoahmpIO%rechclim (its:ite) ) + if ( .not. allocated (NoahmpIO%rivermask) ) allocate ( NoahmpIO%rivermask (its:ite) ) + if ( .not. allocated (NoahmpIO%nonriverxy) ) allocate ( NoahmpIO%nonriverxy (its:ite) ) + + ! needed for crop model (opt_crop=1) + if ( .not. allocated (NoahmpIO%pgsxy) ) allocate ( NoahmpIO%pgsxy (its:ite) ) + if ( .not. allocated (NoahmpIO%cropcat) ) allocate ( NoahmpIO%cropcat (its:ite) ) + if ( .not. allocated (NoahmpIO%planting) ) allocate ( NoahmpIO%planting (its:ite) ) + if ( .not. allocated (NoahmpIO%harvest) ) allocate ( NoahmpIO%harvest (its:ite) ) + if ( .not. allocated (NoahmpIO%season_gdd)) allocate ( NoahmpIO%season_gdd (its:ite) ) + if ( .not. allocated (NoahmpIO%croptype) ) allocate ( NoahmpIO%croptype (its:ite,5) ) + + ! Single- and Multi-layer Urban Models + if ( NoahmpIO%sf_urban_physics > 0 ) then + if ( .not. allocated (NoahmpIO%sh_urb2d) ) allocate ( NoahmpIO%sh_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%lh_urb2d) ) allocate ( NoahmpIO%lh_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%g_urb2d) ) allocate ( NoahmpIO%g_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%rn_urb2d) ) allocate ( NoahmpIO%rn_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%ts_urb2d) ) allocate ( NoahmpIO%ts_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%hrang) ) allocate ( NoahmpIO%hrang (its:ite) ) + if ( .not. allocated (NoahmpIO%frc_urb2d) ) allocate ( NoahmpIO%frc_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%utype_urb2d)) allocate ( NoahmpIO%utype_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%lp_urb2d) ) allocate ( NoahmpIO%lp_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%lb_urb2d) ) allocate ( NoahmpIO%lb_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%hgt_urb2d) ) allocate ( NoahmpIO%hgt_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%ust) ) allocate ( NoahmpIO%ust (its:ite) ) + !endif + + !if(NoahmpIO%sf_urban_physics == 1 ) then ! single layer urban model + if ( .not. allocated (NoahmpIO%cmr_sfcdif) ) allocate ( NoahmpIO%cmr_sfcdif (its:ite) ) + if ( .not. allocated (NoahmpIO%chr_sfcdif) ) allocate ( NoahmpIO%chr_sfcdif (its:ite) ) + if ( .not. allocated (NoahmpIO%cmc_sfcdif) ) allocate ( NoahmpIO%cmc_sfcdif (its:ite) ) + if ( .not. allocated (NoahmpIO%chc_sfcdif) ) allocate ( NoahmpIO%chc_sfcdif (its:ite) ) + if ( .not. allocated (NoahmpIO%cmgr_sfcdif) ) allocate ( NoahmpIO%cmgr_sfcdif (its:ite) ) + if ( .not. allocated (NoahmpIO%chgr_sfcdif) ) allocate ( NoahmpIO%chgr_sfcdif (its:ite) ) + if ( .not. allocated (NoahmpIO%tr_urb2d) ) allocate ( NoahmpIO%tr_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%tb_urb2d) ) allocate ( NoahmpIO%tb_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%tg_urb2d) ) allocate ( NoahmpIO%tg_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%tc_urb2d) ) allocate ( NoahmpIO%tc_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%qc_urb2d) ) allocate ( NoahmpIO%qc_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%uc_urb2d) ) allocate ( NoahmpIO%uc_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%xxxr_urb2d) ) allocate ( NoahmpIO%xxxr_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%xxxb_urb2d) ) allocate ( NoahmpIO%xxxb_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%xxxg_urb2d) ) allocate ( NoahmpIO%xxxg_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%xxxc_urb2d) ) allocate ( NoahmpIO%xxxc_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%psim_urb2d) ) allocate ( NoahmpIO%psim_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%psih_urb2d) ) allocate ( NoahmpIO%psih_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%u10_urb2d) ) allocate ( NoahmpIO%u10_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%v10_urb2d) ) allocate ( NoahmpIO%v10_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%gz1oz0_urb2d) ) allocate ( NoahmpIO%gz1oz0_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%akms_urb2d) ) allocate ( NoahmpIO%akms_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%th2_urb2d) ) allocate ( NoahmpIO%th2_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%q2_urb2d) ) allocate ( NoahmpIO%q2_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%ust_urb2d) ) allocate ( NoahmpIO%ust_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%cmcr_urb2d) ) allocate ( NoahmpIO%cmcr_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%tgr_urb2d) ) allocate ( NoahmpIO%tgr_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%drelr_urb2d) ) allocate ( NoahmpIO%drelr_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%drelb_urb2d) ) allocate ( NoahmpIO%drelb_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%drelg_urb2d) ) allocate ( NoahmpIO%drelg_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%flxhumr_urb2d)) allocate ( NoahmpIO%flxhumr_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%flxhumb_urb2d)) allocate ( NoahmpIO%flxhumb_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%flxhumg_urb2d)) allocate ( NoahmpIO%flxhumg_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%chs) ) allocate ( NoahmpIO%chs (its:ite) ) + if ( .not. allocated (NoahmpIO%chs2) ) allocate ( NoahmpIO%chs2 (its:ite) ) + if ( .not. allocated (NoahmpIO%cqs2) ) allocate ( NoahmpIO%cqs2 (its:ite) ) + if ( .not. allocated (NoahmpIO%mh_urb2d) ) allocate ( NoahmpIO%mh_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%stdh_urb2d) ) allocate ( NoahmpIO%stdh_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%lf_urb2d) ) allocate ( NoahmpIO%lf_urb2d (its:ite,4) ) + if ( .not. allocated (NoahmpIO%trl_urb3d) ) allocate ( NoahmpIO%trl_urb3d (its:ite,1:nsoil) ) + if ( .not. allocated (NoahmpIO%tbl_urb3d) ) allocate ( NoahmpIO%tbl_urb3d (its:ite,1:nsoil) ) + if ( .not. allocated (NoahmpIO%tgl_urb3d) ) allocate ( NoahmpIO%tgl_urb3d (its:ite,1:nsoil) ) + if ( .not. allocated (NoahmpIO%tgrl_urb3d) ) allocate ( NoahmpIO%tgrl_urb3d (its:ite,1:nsoil) ) + if ( .not. allocated (NoahmpIO%smr_urb3d) ) allocate ( NoahmpIO%smr_urb3d (its:ite,1:nsoil) ) + if ( .not. allocated (NoahmpIO%dzr) ) allocate ( NoahmpIO%dzr ( 1:nsoil) ) + if ( .not. allocated (NoahmpIO%dzb) ) allocate ( NoahmpIO%dzb ( 1:nsoil) ) + if ( .not. allocated (NoahmpIO%dzg) ) allocate ( NoahmpIO%dzg ( 1:nsoil) ) + !endif + + !if(sf_urban_physics == 2 .or. sf_urban_physics == 3) then ! bep or bem urban models + if ( .not. allocated (NoahmpIO%trb_urb4d) ) allocate ( NoahmpIO%trb_urb4d (its:ite,NoahmpIO%urban_map_zrd) ) + if ( .not. allocated (NoahmpIO%tw1_urb4d) ) allocate ( NoahmpIO%tw1_urb4d (its:ite,NoahmpIO%urban_map_zwd) ) + if ( .not. allocated (NoahmpIO%tw2_urb4d) ) allocate ( NoahmpIO%tw2_urb4d (its:ite,NoahmpIO%urban_map_zwd) ) + if ( .not. allocated (NoahmpIO%tgb_urb4d) ) allocate ( NoahmpIO%tgb_urb4d (its:ite,NoahmpIO%urban_map_gd ) ) + if ( .not. allocated (NoahmpIO%sfw1_urb3d) ) allocate ( NoahmpIO%sfw1_urb3d (its:ite,NoahmpIO%urban_map_zd ) ) + if ( .not. allocated (NoahmpIO%sfw2_urb3d) ) allocate ( NoahmpIO%sfw2_urb3d (its:ite,NoahmpIO%urban_map_zd ) ) + if ( .not. allocated (NoahmpIO%sfr_urb3d) ) allocate ( NoahmpIO%sfr_urb3d (its:ite,NoahmpIO%urban_map_zdf) ) + if ( .not. allocated (NoahmpIO%sfg_urb3d) ) allocate ( NoahmpIO%sfg_urb3d (its:ite,NoahmpIO%num_urban_ndm) ) + if ( .not. allocated (NoahmpIO%hi_urb2d) ) allocate ( NoahmpIO%hi_urb2d (its:ite,NoahmpIO%num_urban_hi ) ) + if ( .not. allocated (NoahmpIO%theta_urban)) allocate ( NoahmpIO%theta_urban (its:ite,kts:kte ) ) + if ( .not. allocated (NoahmpIO%u_urban) ) allocate ( NoahmpIO%u_urban (its:ite,kts:kte ) ) + if ( .not. allocated (NoahmpIO%v_urban) ) allocate ( NoahmpIO%v_urban (its:ite,kts:kte ) ) + if ( .not. allocated (NoahmpIO%dz_urban) ) allocate ( NoahmpIO%dz_urban (its:ite,kts:kte ) ) + if ( .not. allocated (NoahmpIO%rho_urban) ) allocate ( NoahmpIO%rho_urban (its:ite,kts:kte ) ) + if ( .not. allocated (NoahmpIO%p_urban) ) allocate ( NoahmpIO%p_urban (its:ite,kts:kte ) ) + if ( .not. allocated (NoahmpIO%a_u_bep) ) allocate ( NoahmpIO%a_u_bep (its:ite,kts:kte ) ) + if ( .not. allocated (NoahmpIO%a_v_bep) ) allocate ( NoahmpIO%a_v_bep (its:ite,kts:kte ) ) + if ( .not. allocated (NoahmpIO%a_t_bep) ) allocate ( NoahmpIO%a_t_bep (its:ite,kts:kte ) ) + if ( .not. allocated (NoahmpIO%a_q_bep) ) allocate ( NoahmpIO%a_q_bep (its:ite,kts:kte ) ) + if ( .not. allocated (NoahmpIO%a_e_bep) ) allocate ( NoahmpIO%a_e_bep (its:ite,kts:kte ) ) + if ( .not. allocated (NoahmpIO%b_u_bep) ) allocate ( NoahmpIO%b_u_bep (its:ite,kts:kte ) ) + if ( .not. allocated (NoahmpIO%b_v_bep) ) allocate ( NoahmpIO%b_v_bep (its:ite,kts:kte ) ) + if ( .not. allocated (NoahmpIO%b_t_bep) ) allocate ( NoahmpIO%b_t_bep (its:ite,kts:kte ) ) + if ( .not. allocated (NoahmpIO%b_q_bep) ) allocate ( NoahmpIO%b_q_bep (its:ite,kts:kte ) ) + if ( .not. allocated (NoahmpIO%b_e_bep) ) allocate ( NoahmpIO%b_e_bep (its:ite,kts:kte ) ) + if ( .not. allocated (NoahmpIO%dlg_bep) ) allocate ( NoahmpIO%dlg_bep (its:ite,kts:kte ) ) + if ( .not. allocated (NoahmpIO%dl_u_bep) ) allocate ( NoahmpIO%dl_u_bep (its:ite,kts:kte ) ) + if ( .not. allocated (NoahmpIO%sf_bep) ) allocate ( NoahmpIO%sf_bep (its:ite,kts:kte ) ) + if ( .not. allocated (NoahmpIO%vl_bep) ) allocate ( NoahmpIO%vl_bep (its:ite,kts:kte ) ) + !endif + + !if(sf_urban_physics == 3) then ! bem urban model + if ( .not. allocated (NoahmpIO%tlev_urb3d) ) allocate ( NoahmpIO%tlev_urb3d (its:ite,NoahmpIO%urban_map_bd ) ) + if ( .not. allocated (NoahmpIO%qlev_urb3d) ) allocate ( NoahmpIO%qlev_urb3d (its:ite,NoahmpIO%urban_map_bd ) ) + if ( .not. allocated (NoahmpIO%tw1lev_urb3d) ) allocate ( NoahmpIO%tw1lev_urb3d (its:ite,NoahmpIO%urban_map_wd ) ) + if ( .not. allocated (NoahmpIO%tw2lev_urb3d) ) allocate ( NoahmpIO%tw2lev_urb3d (its:ite,NoahmpIO%urban_map_wd ) ) + if ( .not. allocated (NoahmpIO%tglev_urb3d) ) allocate ( NoahmpIO%tglev_urb3d (its:ite,NoahmpIO%urban_map_gbd ) ) + if ( .not. allocated (NoahmpIO%tflev_urb3d) ) allocate ( NoahmpIO%tflev_urb3d (its:ite,NoahmpIO%urban_map_fbd ) ) + if ( .not. allocated (NoahmpIO%sf_ac_urb3d) ) allocate ( NoahmpIO%sf_ac_urb3d (its:ite ) ) + if ( .not. allocated (NoahmpIO%lf_ac_urb3d) ) allocate ( NoahmpIO%lf_ac_urb3d (its:ite ) ) + if ( .not. allocated (NoahmpIO%cm_ac_urb3d) ) allocate ( NoahmpIO%cm_ac_urb3d (its:ite ) ) + if ( .not. allocated (NoahmpIO%sfvent_urb3d) ) allocate ( NoahmpIO%sfvent_urb3d (its:ite ) ) + if ( .not. allocated (NoahmpIO%lfvent_urb3d) ) allocate ( NoahmpIO%lfvent_urb3d (its:ite ) ) + if ( .not. allocated (NoahmpIO%sfwin1_urb3d) ) allocate ( NoahmpIO%sfwin1_urb3d (its:ite,NoahmpIO%urban_map_wd ) ) + if ( .not. allocated (NoahmpIO%sfwin2_urb3d) ) allocate ( NoahmpIO%sfwin2_urb3d (its:ite,NoahmpIO%urban_map_wd ) ) + if ( .not. allocated (NoahmpIO%ep_pv_urb3d) ) allocate ( NoahmpIO%ep_pv_urb3d (its:ite ) ) + if ( .not. allocated (NoahmpIO%t_pv_urb3d) ) allocate ( NoahmpIO%t_pv_urb3d (its:ite,NoahmpIO%urban_map_zdf ) ) + if ( .not. allocated (NoahmpIO%trv_urb4d) ) allocate ( NoahmpIO%trv_urb4d (its:ite,NoahmpIO%urban_map_zgrd) ) + if ( .not. allocated (NoahmpIO%qr_urb4d) ) allocate ( NoahmpIO%qr_urb4d (its:ite,NoahmpIO%urban_map_zgrd) ) + if ( .not. allocated (NoahmpIO%qgr_urb3d) ) allocate ( NoahmpIO%qgr_urb3d (its:ite ) ) + if ( .not. allocated (NoahmpIO%tgr_urb3d) ) allocate ( NoahmpIO%tgr_urb3d (its:ite ) ) + if ( .not. allocated (NoahmpIO%drain_urb4d) ) allocate ( NoahmpIO%drain_urb4d (its:ite,NoahmpIO%urban_map_zdf ) ) + if ( .not. allocated (NoahmpIO%draingr_urb3d)) allocate ( NoahmpIO%draingr_urb3d (its:ite ) ) + if ( .not. allocated (NoahmpIO%sfrv_urb3d) ) allocate ( NoahmpIO%sfrv_urb3d (its:ite,NoahmpIO%urban_map_zdf ) ) + if ( .not. allocated (NoahmpIO%lfrv_urb3d) ) allocate ( NoahmpIO%lfrv_urb3d (its:ite,NoahmpIO%urban_map_zdf ) ) + if ( .not. allocated (NoahmpIO%dgr_urb3d) ) allocate ( NoahmpIO%dgr_urb3d (its:ite,NoahmpIO%urban_map_zdf ) ) + if ( .not. allocated (NoahmpIO%dg_urb3d) ) allocate ( NoahmpIO%dg_urb3d (its:ite,NoahmpIO%num_urban_ndm ) ) + if ( .not. allocated (NoahmpIO%lfr_urb3d) ) allocate ( NoahmpIO%lfr_urb3d (its:ite,NoahmpIO%urban_map_zdf ) ) + if ( .not. allocated (NoahmpIO%lfg_urb3d) ) allocate ( NoahmpIO%lfg_urb3d (its:ite,NoahmpIO%num_urban_ndm ) ) + + endif + +#ifdef WRF_HYDRO + if ( .not. allocated (NoahmpIO%infxsrt) ) allocate ( NoahmpIO%infxsrt (its:ite) ) + if ( .not. allocated (NoahmpIO%sfcheadrt) ) allocate ( NoahmpIO%sfcheadrt (its:ite) ) + if ( .not. allocated (NoahmpIO%soldrain) ) allocate ( NoahmpIO%soldrain (its:ite) ) + if ( .not. allocated (NoahmpIO%qtiledrain)) allocate ( NoahmpIO%qtiledrain (its:ite) ) + if ( .not. allocated (NoahmpIO%zwatble2d) ) allocate ( NoahmpIO%zwatble2d (its:ite) ) +#endif + + !------------------------------------------------------------------- + ! Initialize variables with default values + !------------------------------------------------------------------- + + NoahmpIO%ice = undefined_int + NoahmpIO%ivgtyp = undefined_int + NoahmpIO%isltyp = undefined_int + NoahmpIO%isnowxy = undefined_int + NoahmpIO%coszen = undefined_real + NoahmpIO%xlat = undefined_real + NoahmpIO%dz8w = undefined_real + NoahmpIO%dzs = undefined_real + NoahmpIO%zsoil = undefined_real + NoahmpIO%vegfra = undefined_real + NoahmpIO%tmn = undefined_real + NoahmpIO%xland = undefined_real + NoahmpIO%xice = undefined_real + NoahmpIO%t_phy = undefined_real + NoahmpIO%qv_curr = undefined_real + NoahmpIO%u_phy = undefined_real + NoahmpIO%v_phy = undefined_real + NoahmpIO%swdown = undefined_real + NoahmpIO%swddir = undefined_real + NoahmpIO%swddif = undefined_real + NoahmpIO%glw = undefined_real + NoahmpIO%p8w = undefined_real + NoahmpIO%rainbl = undefined_real + NoahmpIO%snowbl = undefined_real + NoahmpIO%sr = undefined_real + NoahmpIO%raincv = undefined_real + NoahmpIO%rainncv = undefined_real + NoahmpIO%rainshv = undefined_real + NoahmpIO%snowncv = undefined_real + NoahmpIO%graupelncv = undefined_real + NoahmpIO%hailncv = undefined_real + NoahmpIO%qsfc = undefined_real + NoahmpIO%tsk = undefined_real + NoahmpIO%qfx = undefined_real + NoahmpIO%smstav = undefined_real + NoahmpIO%smstot = undefined_real + NoahmpIO%smois = undefined_real + NoahmpIO%sh2o = undefined_real + NoahmpIO%tslb = undefined_real + NoahmpIO%snow = undefined_real + NoahmpIO%snowh = undefined_real + NoahmpIO%canwat = undefined_real + NoahmpIO%smoiseq = undefined_real + NoahmpIO%albedo = undefined_real + NoahmpIO%tvxy = undefined_real + NoahmpIO%tgxy = undefined_real + NoahmpIO%canicexy = undefined_real + NoahmpIO%canliqxy = undefined_real + NoahmpIO%eahxy = undefined_real + NoahmpIO%tahxy = undefined_real + NoahmpIO%cmxy = undefined_real + NoahmpIO%chxy = undefined_real + NoahmpIO%fwetxy = undefined_real + NoahmpIO%sneqvoxy = undefined_real + NoahmpIO%alboldxy = undefined_real + NoahmpIO%qsnowxy = undefined_real + NoahmpIO%qrainxy = undefined_real + NoahmpIO%wslakexy = undefined_real + NoahmpIO%zwtxy = undefined_real + NoahmpIO%waxy = undefined_real + NoahmpIO%wtxy = undefined_real + NoahmpIO%tsnoxy = undefined_real + NoahmpIO%snicexy = undefined_real + NoahmpIO%snliqxy = undefined_real + NoahmpIO%lfmassxy = undefined_real + NoahmpIO%rtmassxy = undefined_real + NoahmpIO%stmassxy = undefined_real + NoahmpIO%woodxy = undefined_real + NoahmpIO%stblcpxy = undefined_real + NoahmpIO%fastcpxy = undefined_real + NoahmpIO%lai = undefined_real + NoahmpIO%xsaixy = undefined_real + NoahmpIO%xlong = undefined_real + NoahmpIO%seaice = undefined_real + NoahmpIO%smcwtdxy = undefined_real + NoahmpIO%zsnsoxy = undefined_real + NoahmpIO%grdflx = undefined_real + NoahmpIO%hfx = undefined_real + NoahmpIO%lh = undefined_real + NoahmpIO%emiss = undefined_real + NoahmpIO%snowc = undefined_real + NoahmpIO%t2mvxy = undefined_real + NoahmpIO%t2mbxy = undefined_real + NoahmpIO%q2mvxy = undefined_real + NoahmpIO%q2mbxy = undefined_real + NoahmpIO%tradxy = undefined_real + NoahmpIO%neexy = undefined_real + NoahmpIO%gppxy = undefined_real + NoahmpIO%nppxy = undefined_real + NoahmpIO%fvegxy = undefined_real + NoahmpIO%runsfxy = undefined_real + NoahmpIO%runsbxy = undefined_real + NoahmpIO%ecanxy = undefined_real + NoahmpIO%edirxy = undefined_real + NoahmpIO%etranxy = undefined_real + NoahmpIO%fsaxy = undefined_real + NoahmpIO%firaxy = undefined_real + NoahmpIO%aparxy = undefined_real + NoahmpIO%psnxy = undefined_real + NoahmpIO%savxy = undefined_real + NoahmpIO%sagxy = undefined_real + NoahmpIO%rssunxy = undefined_real + NoahmpIO%rsshaxy = undefined_real + NoahmpIO%bgapxy = undefined_real + NoahmpIO%wgapxy = undefined_real + NoahmpIO%tgvxy = undefined_real + NoahmpIO%tgbxy = undefined_real + NoahmpIO%chvxy = undefined_real + NoahmpIO%chbxy = undefined_real + NoahmpIO%shgxy = undefined_real + NoahmpIO%shcxy = undefined_real + NoahmpIO%shbxy = undefined_real + NoahmpIO%evgxy = undefined_real + NoahmpIO%evbxy = undefined_real + NoahmpIO%ghvxy = undefined_real + NoahmpIO%ghbxy = undefined_real + NoahmpIO%irgxy = undefined_real + NoahmpIO%ircxy = undefined_real + NoahmpIO%irbxy = undefined_real + NoahmpIO%trxy = undefined_real + NoahmpIO%evcxy = undefined_real + NoahmpIO%chleafxy = undefined_real + NoahmpIO%chucxy = undefined_real + NoahmpIO%chv2xy = undefined_real + NoahmpIO%chb2xy = undefined_real + NoahmpIO%rs = undefined_real + NoahmpIO%canhsxy = undefined_real + NoahmpIO%z0 = undefined_real + NoahmpIO%znt = undefined_real + NoahmpIO%taussxy = 0.0 + NoahmpIO%deeprechxy = 0.0 + NoahmpIO%rechxy = 0.0 + NoahmpIO%acsnom = 0.0 + NoahmpIO%acsnow = 0.0 + NoahmpIO%mp_rainc = 0.0 + NoahmpIO%mp_rainnc = 0.0 + NoahmpIO%mp_shcv = 0.0 + NoahmpIO%mp_snow = 0.0 + NoahmpIO%mp_graup = 0.0 + NoahmpIO%mp_hail = 0.0 + NoahmpIO%sfcrunoff = 0.0 + NoahmpIO%udrunoff = 0.0 + + ! additional output + NoahmpIO%pahxy = undefined_real + NoahmpIO%pahgxy = undefined_real + NoahmpIO%pahbxy = undefined_real + NoahmpIO%pahvxy = undefined_real + NoahmpIO%qintsxy = undefined_real + NoahmpIO%qintrxy = undefined_real + NoahmpIO%qdripsxy = undefined_real + NoahmpIO%qdriprxy = undefined_real + NoahmpIO%qthrosxy = undefined_real + NoahmpIO%qthrorxy = undefined_real + NoahmpIO%qsnsubxy = undefined_real + NoahmpIO%qsnfroxy = undefined_real + NoahmpIO%qsubcxy = undefined_real + NoahmpIO%qfrocxy = undefined_real + NoahmpIO%qevacxy = undefined_real + NoahmpIO%qdewcxy = undefined_real + NoahmpIO%qfrzcxy = undefined_real + NoahmpIO%qmeltcxy = undefined_real + NoahmpIO%qsnbotxy = undefined_real + NoahmpIO%qmeltxy = undefined_real + NoahmpIO%fpicexy = undefined_real + NoahmpIO%rainlsm = undefined_real + NoahmpIO%snowlsm = undefined_real + NoahmpIO%forctlsm = undefined_real + NoahmpIO%forcqlsm = undefined_real + NoahmpIO%forcplsm = undefined_real + NoahmpIO%forczlsm = undefined_real + NoahmpIO%forcwlsm = undefined_real + NoahmpIO%eflxbxy = undefined_real + NoahmpIO%soilenergy = undefined_real + NoahmpIO%snowenergy = undefined_real + NoahmpIO%pondingxy = 0.0 + NoahmpIO%acc_ssoilxy = 0.0 + NoahmpIO%acc_qinsurxy = 0.0 + NoahmpIO%acc_qsevaxy = 0.0 + NoahmpIO%acc_etranixy = 0.0 + NoahmpIO%acc_dwaterxy = 0.0 + NoahmpIO%acc_prcpxy = 0.0 + NoahmpIO%acc_ecanxy = 0.0 + NoahmpIO%acc_etranxy = 0.0 + NoahmpIO%acc_edirxy = 0.0 + + ! MMF Groundwater + NoahmpIO%terrain = undefined_real + NoahmpIO%gvfmin = undefined_real + NoahmpIO%gvfmax = undefined_real + NoahmpIO%msftx = undefined_real + NoahmpIO%msfty = undefined_real + NoahmpIO%eqzwt = undefined_real + NoahmpIO%riverbedxy = undefined_real + NoahmpIO%rivercondxy = undefined_real + NoahmpIO%pexpxy = undefined_real + NoahmpIO%fdepthxy = undefined_real + NoahmpIO%areaxy = undefined_real + NoahmpIO%qrfsxy = undefined_real + NoahmpIO%qspringsxy = undefined_real + NoahmpIO%qrfxy = undefined_real + NoahmpIO%qspringxy = undefined_real + NoahmpIO%qslatxy = undefined_real + NoahmpIO%qlatxy = undefined_real + + ! crop model + NoahmpIO%pgsxy = undefined_int + NoahmpIO%cropcat = undefined_int + NoahmpIO%planting = undefined_real + NoahmpIO%harvest = undefined_real + NoahmpIO%season_gdd = undefined_real + NoahmpIO%croptype = undefined_real + + ! tile drainage + NoahmpIO%qtdrain = 0.0 + NoahmpIO%td_fraction = undefined_real + + ! irrigation + NoahmpIO%irfract = 0.0 + NoahmpIO%sifract = 0.0 + NoahmpIO%mifract = 0.0 + NoahmpIO%fifract = 0.0 + NoahmpIO%irnumsi = 0 + NoahmpIO%irnummi = 0 + NoahmpIO%irnumfi = 0 + NoahmpIO%irwatsi = 0.0 + NoahmpIO%irwatmi = 0.0 + NoahmpIO%irwatfi = 0.0 + NoahmpIO%ireloss = 0.0 + NoahmpIO%irsivol = 0.0 + NoahmpIO%irmivol = 0.0 + NoahmpIO%irfivol = 0.0 + NoahmpIO%irrsplh = 0.0 + NoahmpIO%loctim = undefined_real + + ! spatial varying soil texture + if ( NoahmpIO%iopt_soil > 1 ) then + NoahmpIO%soilcl1 = undefined_real + NoahmpIO%soilcl2 = undefined_real + NoahmpIO%soilcl3 = undefined_real + NoahmpIO%soilcl4 = undefined_real + NoahmpIO%soilcomp = undefined_real + endif + + ! urban model + if ( NoahmpIO%sf_urban_physics > 0 ) then + NoahmpIO%julday = undefined_int_neg + NoahmpIO%iri_urban = undefined_int_neg + NoahmpIO%utype_urb2d = undefined_int_neg + NoahmpIO%hrang = undefined_real_neg + NoahmpIO%declin = undefined_real_neg + NoahmpIO%sh_urb2d = undefined_real_neg + NoahmpIO%lh_urb2d = undefined_real_neg + NoahmpIO%g_urb2d = undefined_real_neg + NoahmpIO%rn_urb2d = undefined_real_neg + NoahmpIO%ts_urb2d = undefined_real_neg + NoahmpIO%gmt = undefined_real_neg + NoahmpIO%frc_urb2d = undefined_real_neg + NoahmpIO%lp_urb2d = undefined_real_neg + NoahmpIO%lb_urb2d = undefined_real_neg + NoahmpIO%hgt_urb2d = undefined_real_neg + NoahmpIO%ust = undefined_real_neg + NoahmpIO%cmr_sfcdif = 1.0e-4 + NoahmpIO%chr_sfcdif = 1.0e-4 + NoahmpIO%cmc_sfcdif = 1.0e-4 + NoahmpIO%chc_sfcdif = 1.0e-4 + NoahmpIO%cmgr_sfcdif = 1.0e-4 + NoahmpIO%chgr_sfcdif = 1.0e-4 + NoahmpIO%tr_urb2d = undefined_real_neg + NoahmpIO%tb_urb2d = undefined_real_neg + NoahmpIO%tg_urb2d = undefined_real_neg + NoahmpIO%tc_urb2d = undefined_real_neg + NoahmpIO%qc_urb2d = undefined_real_neg + NoahmpIO%uc_urb2d = undefined_real_neg + NoahmpIO%xxxr_urb2d = undefined_real_neg + NoahmpIO%xxxb_urb2d = undefined_real_neg + NoahmpIO%xxxg_urb2d = undefined_real_neg + NoahmpIO%xxxc_urb2d = undefined_real_neg + NoahmpIO%trl_urb3d = undefined_real_neg + NoahmpIO%tbl_urb3d = undefined_real_neg + NoahmpIO%tgl_urb3d = undefined_real_neg + NoahmpIO%psim_urb2d = undefined_real_neg + NoahmpIO%psih_urb2d = undefined_real_neg + NoahmpIO%u10_urb2d = undefined_real_neg + NoahmpIO%v10_urb2d = undefined_real_neg + NoahmpIO%gz1oz0_urb2d = undefined_real_neg + NoahmpIO%akms_urb2d = undefined_real_neg + NoahmpIO%th2_urb2d = undefined_real_neg + NoahmpIO%q2_urb2d = undefined_real_neg + NoahmpIO%ust_urb2d = undefined_real_neg + NoahmpIO%dzr = undefined_real_neg + NoahmpIO%dzb = undefined_real_neg + NoahmpIO%dzg = undefined_real_neg + NoahmpIO%cmcr_urb2d = undefined_real_neg + NoahmpIO%tgr_urb2d = undefined_real_neg + NoahmpIO%tgrl_urb3d = undefined_real_neg + NoahmpIO%smr_urb3d = undefined_real_neg + NoahmpIO%drelr_urb2d = undefined_real_neg + NoahmpIO%drelb_urb2d = undefined_real_neg + NoahmpIO%drelg_urb2d = undefined_real_neg + NoahmpIO%flxhumr_urb2d = undefined_real_neg + NoahmpIO%flxhumb_urb2d = undefined_real_neg + NoahmpIO%flxhumg_urb2d = undefined_real_neg + NoahmpIO%chs = 1.0e-4 + NoahmpIO%chs2 = 1.0e-4 + NoahmpIO%cqs2 = 1.0e-4 + NoahmpIO%mh_urb2d = undefined_real_neg + NoahmpIO%stdh_urb2d = undefined_real_neg + NoahmpIO%lf_urb2d = undefined_real_neg + NoahmpIO%trb_urb4d = undefined_real_neg + NoahmpIO%tw1_urb4d = undefined_real_neg + NoahmpIO%tw2_urb4d = undefined_real_neg + NoahmpIO%tgb_urb4d = undefined_real_neg + NoahmpIO%sfw1_urb3d = undefined_real_neg + NoahmpIO%sfw2_urb3d = undefined_real_neg + NoahmpIO%sfr_urb3d = undefined_real_neg + NoahmpIO%sfg_urb3d = undefined_real_neg + NoahmpIO%hi_urb2d = undefined_real_neg + NoahmpIO%theta_urban = undefined_real_neg + NoahmpIO%u_urban = undefined_real_neg + NoahmpIO%v_urban = undefined_real_neg + NoahmpIO%dz_urban = undefined_real_neg + NoahmpIO%rho_urban = undefined_real_neg + NoahmpIO%p_urban = undefined_real_neg + NoahmpIO%a_u_bep = undefined_real_neg + NoahmpIO%a_v_bep = undefined_real_neg + NoahmpIO%a_t_bep = undefined_real_neg + NoahmpIO%a_q_bep = undefined_real_neg + NoahmpIO%a_e_bep = undefined_real_neg + NoahmpIO%b_u_bep = undefined_real_neg + NoahmpIO%b_v_bep = undefined_real_neg + NoahmpIO%b_t_bep = undefined_real_neg + NoahmpIO%b_q_bep = undefined_real_neg + NoahmpIO%b_e_bep = undefined_real_neg + NoahmpIO%dlg_bep = undefined_real_neg + NoahmpIO%dl_u_bep = undefined_real_neg + NoahmpIO%sf_bep = undefined_real_neg + NoahmpIO%vl_bep = undefined_real_neg + NoahmpIO%tlev_urb3d = undefined_real_neg + NoahmpIO%qlev_urb3d = undefined_real_neg + NoahmpIO%tw1lev_urb3d = undefined_real_neg + NoahmpIO%tw2lev_urb3d = undefined_real_neg + NoahmpIO%tglev_urb3d = undefined_real_neg + NoahmpIO%tflev_urb3d = undefined_real_neg + NoahmpIO%sf_ac_urb3d = undefined_real_neg + NoahmpIO%lf_ac_urb3d = undefined_real_neg + NoahmpIO%cm_ac_urb3d = undefined_real_neg + NoahmpIO%sfvent_urb3d = undefined_real_neg + NoahmpIO%lfvent_urb3d = undefined_real_neg + NoahmpIO%sfwin1_urb3d = undefined_real_neg + NoahmpIO%sfwin2_urb3d = undefined_real_neg + NoahmpIO%ep_pv_urb3d = undefined_real_neg + NoahmpIO%t_pv_urb3d = undefined_real_neg + NoahmpIO%trv_urb4d = undefined_real_neg + NoahmpIO%qr_urb4d = undefined_real_neg + NoahmpIO%qgr_urb3d = undefined_real_neg + NoahmpIO%tgr_urb3d = undefined_real_neg + NoahmpIO%drain_urb4d = undefined_real_neg + NoahmpIO%draingr_urb3d = undefined_real_neg + NoahmpIO%sfrv_urb3d = undefined_real_neg + NoahmpIO%lfrv_urb3d = undefined_real_neg + NoahmpIO%dgr_urb3d = undefined_real_neg + NoahmpIO%dg_urb3d = undefined_real_neg + NoahmpIO%lfr_urb3d = undefined_real_neg + NoahmpIO%lfg_urb3d = undefined_real_neg + endif + + NoahmpIO%slopetyp = 1 ! soil parameter slope type + NoahmpIO%soil_update_steps = 1 ! number of model time step to update soil proces + NoahmpIO%calculate_soil = .false. ! index for if do soil process + +#ifdef WRF_HYDRO + NoahmpIO%infxsrt = 0.0 + NoahmpIO%sfcheadrt = 0.0 + NoahmpIO%soldrain = 0.0 + NoahmpIO%qtiledrain = 0.0 + NoahmpIO%zwatble2d = 0.0 +#endif + + end associate + + end subroutine NoahmpIOVarInitDefault + +end module NoahmpIOVarInitMod diff --git a/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/NoahmpIOVarType.F90 b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/NoahmpIOVarType.F90 new file mode 100644 index 0000000000..0a3cd93436 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/NoahmpIOVarType.F90 @@ -0,0 +1,936 @@ +module NoahmpIOVarType + +!!! Define Noah-MP Input variables (2D forcing, namelist, table, static) +!!! Input variable initialization is done in NoahmpIOVarInitMod.F90 + +! ------------------------ Code history ----------------------------------- +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + use Machine + + implicit none + save + private + + type, public :: NoahmpIO_type + +!------------------------------------------------------------------------ +! general 2-D/3-D Noah-MP variables +!------------------------------------------------------------------------ + + ! IN only (as defined in WRF) + integer :: its,ite, & ! t -> tile + kts,kte ! t -> tile + integer :: itimestep ! timestep number + integer :: yr ! 4-digit year + integer :: month ! 2-digit month + integer :: day ! 2-digit day + integer :: nsoil ! number of soil layers + integer :: ice ! sea-ice point + integer :: isice ! land cover category for ice + integer :: isurban ! land cover category for urban + integer :: iswater ! land cover category for water + integer :: islake ! land cover category for lake + integer :: urbtype_beg ! urban type start number - 1 + integer :: iopt_dveg ! dynamic vegetation + integer :: iopt_crs ! canopy stomatal resistance (1-> Ball-Berry; 2->Jarvis) + integer :: iopt_btr ! soil moisture factor for stomatal resistance (1-> Noah; 2-> CLM; 3-> SSiB) + integer :: iopt_runsrf ! surface runoff and groundwater (1->SIMGM; 2->SIMTOP; 3->Schaake96; 4->BATS) + integer :: iopt_runsub ! subsurface runoff option + integer :: iopt_sfc ! surface layer drag coeff (CH & CM) (1->M-O; 2->Chen97) + integer :: iopt_frz ! supercooled liquid water (1-> NY06; 2->Koren99) + integer :: iopt_inf ! frozen soil permeability (1-> NY06; 2->Koren99) + integer :: iopt_rad ! radiation transfer (1->gap=F(3D,cosz); 2->gap=0; 3->gap=1-Fveg) + integer :: iopt_alb ! snow surface albedo (1->BATS; 2->CLASS) + integer :: iopt_snf ! rainfall & snowfall (1-Jordan91; 2->BATS; 3->Noah) + integer :: iopt_tksno ! snow thermal conductivity: 1 -> Stieglitz(yen,1965) scheme (default), 2 -> Anderson, 1976 scheme, 3 -> constant, 4 -> Verseghy (1991) scheme, 5 -> Douvill(Yen, 1981) scheme + integer :: iopt_tbot ! lower boundary of soil temperature (1->zero-flux; 2->Noah) + integer :: iopt_stc ! snow/soil temperature time scheme + integer :: iopt_gla ! glacier option (1->phase change; 2->simple) + integer :: iopt_rsf ! surface resistance option (1->Zeng; 2->simple) + integer :: iz0tlnd ! option of Chen adjustment of Czil (not used) + integer :: iopt_soil ! soil configuration option + integer :: iopt_pedo ! soil pedotransfer function option + integer :: iopt_crop ! crop model option (0->none; 1->Liu et al.) + integer :: iopt_irr ! irrigation scheme (0->none; >1 irrigation scheme ON) + integer :: iopt_irrm ! irrigation method (0->dynamic; 1-> sprinkler; 2-> micro; 3-> flood) + integer :: iopt_infdv ! infiltration options for dynamic VIC (1->Philip; 2-> Green-Ampt;3->Smith-Parlange) + integer :: iopt_tdrn ! drainage option (0->off; 1->simple scheme; 2->Hooghoudt's scheme) + real(kind=kind_noahmp) :: xice_threshold ! fraction of grid determining seaice + real(kind=kind_noahmp) :: julian ! julian day + real(kind=kind_noahmp) :: dtbl ! timestep [s] + real(kind=kind_noahmp) :: dx ! horizontal grid spacing [m] + real(kind=kind_noahmp) :: soiltstep ! soil time step (s) (default=0: same as main NoahMP timstep) + logical :: fndsnowh ! snow depth present in input + logical :: calculate_soil ! logical index for if do soil calculation + integer :: soil_update_steps ! number of model time steps to update soil process + integer, allocatable, dimension(:) :: ivgtyp ! vegetation type + integer, allocatable, dimension(:) :: isltyp ! soil type + real(kind=kind_noahmp), allocatable, dimension(:) :: coszen ! cosine zenith angle + real(kind=kind_noahmp), allocatable, dimension(:) :: xlat ! latitude [rad] + real(kind=kind_noahmp), allocatable, dimension(:,:) :: dz8w ! thickness of atmo layers [m] + real(kind=kind_noahmp), allocatable, dimension(:) :: dzs ! thickness of soil layers [m] + real(kind=kind_noahmp), allocatable, dimension(:) :: zsoil ! depth to soil interfaces [m] + real(kind=kind_noahmp), allocatable, dimension(:) :: vegfra ! vegetation fraction [] + real(kind=kind_noahmp), allocatable, dimension(:) :: tmn ! deep soil temperature [K] + real(kind=kind_noahmp), allocatable, dimension(:) :: xland ! =2 ocean; =1 land/seaice + real(kind=kind_noahmp), allocatable, dimension(:) :: xice ! fraction of grid that is seaice + real(kind=kind_noahmp), allocatable, dimension(:) :: seaice ! seaice fraction + + ! forcings + real(kind=kind_noahmp), allocatable, dimension(:,:) :: t_phy ! 3D atmospheric temperature valid at mid-levels [K] + real(kind=kind_noahmp), allocatable, dimension(:,:) :: qv_curr ! 3D water vapor mixing ratio [kg/kg_dry] + real(kind=kind_noahmp), allocatable, dimension(:,:) :: u_phy ! 3D U wind component [m/s] + real(kind=kind_noahmp), allocatable, dimension(:,:) :: v_phy ! 3D V wind component [m/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: swdown ! solar down at surface [W m-2] + real(kind=kind_noahmp), allocatable, dimension(:) :: glw ! longwave down at surface [W m-2] + real(kind=kind_noahmp), allocatable, dimension(:,:) :: p8w ! 3D pressure, valid at interface [Pa] + real(kind=kind_noahmp), allocatable, dimension(:) :: rainbl ! precipitation entering land model [mm] per time step + real(kind=kind_noahmp), allocatable, dimension(:) :: snowbl ! snow entering land model [mm] per time step + real(kind=kind_noahmp), allocatable, dimension(:) :: sr ! frozen precip ratio entering land model [-] + real(kind=kind_noahmp), allocatable, dimension(:) :: raincv ! convective precip forcing [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: rainncv ! non-convective precip forcing [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: rainshv ! shallow conv. precip forcing [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: snowncv ! non-covective snow forcing (subset of rainncv) [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: graupelncv ! non-convective graupel forcing (subset of rainncv) [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: hailncv ! non-convective hail forcing (subset of rainncv) [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: mp_rainc ! convective precipitation entering land model [mm] ! MB/AN : v3.7 + real(kind=kind_noahmp), allocatable, dimension(:) :: mp_rainnc ! large-scale precipitation entering land model [mm]! MB/AN : v3.7 + real(kind=kind_noahmp), allocatable, dimension(:) :: mp_shcv ! shallow conv precip entering land model [mm] ! MB/AN : v3.7 + real(kind=kind_noahmp), allocatable, dimension(:) :: mp_snow ! snow precipitation entering land model [mm] ! MB/AN : v3.7 + real(kind=kind_noahmp), allocatable, dimension(:) :: mp_graup ! graupel precipitation entering land model [mm] ! MB/AN : v3.7 + real(kind=kind_noahmp), allocatable, dimension(:) :: mp_hail ! hail precipitation entering land model [mm] ! MB/AN : v3.7 + +#ifdef WRF_HYDRO + real(kind=kind_noahmp), allocatable, dimension(:) :: infxsrt ! surface infiltration + real(kind=kind_noahmp), allocatable, dimension(:) :: sfcheadrt ! surface water head + real(kind=kind_noahmp), allocatable, dimension(:) :: soldrain ! soil drainage + real(kind=kind_noahmp), allocatable, dimension(:) :: qtiledrain ! tile drainage + real(kind=kind_noahmp), allocatable, dimension(:) :: zwatble2d ! water table depth +#endif + + ! Spatially varying fields (for now it is de-activated) + real(kind=kind_noahmp), allocatable, dimension(:,:) :: soilcomp ! Soil sand and clay content [fraction] + real(kind=kind_noahmp), allocatable, dimension(:) :: soilcl1 ! Soil texture class with depth + real(kind=kind_noahmp), allocatable, dimension(:) :: soilcl2 ! Soil texture class with depth + real(kind=kind_noahmp), allocatable, dimension(:) :: soilcl3 ! Soil texture class with depth + real(kind=kind_noahmp), allocatable, dimension(:) :: soilcl4 ! Soil texture class with depth + real(kind=kind_noahmp), allocatable, dimension(:,:) :: bexp_3D ! C-H B exponent + real(kind=kind_noahmp), allocatable, dimension(:,:) :: smcdry_3D ! Soil Moisture Limit: Dry + real(kind=kind_noahmp), allocatable, dimension(:,:) :: smcwlt_3D ! Soil Moisture Limit: Wilt + real(kind=kind_noahmp), allocatable, dimension(:,:) :: smcref_3D ! Soil Moisture Limit: Reference + real(kind=kind_noahmp), allocatable, dimension(:,:) :: smcmax_3D ! Soil Moisture Limit: Max + real(kind=kind_noahmp), allocatable, dimension(:,:) :: dksat_3D ! Saturated Soil Conductivity + real(kind=kind_noahmp), allocatable, dimension(:,:) :: dwsat_3D ! Saturated Soil Diffusivity + real(kind=kind_noahmp), allocatable, dimension(:,:) :: psisat_3D ! Saturated Matric Potential + real(kind=kind_noahmp), allocatable, dimension(:,:) :: quartz_3D ! Soil quartz content + real(kind=kind_noahmp), allocatable, dimension(:) :: refdk_2D ! Reference Soil Conductivity + real(kind=kind_noahmp), allocatable, dimension(:) :: refkdt_2D ! Soil Infiltration Parameter + real(kind=kind_noahmp), allocatable, dimension(:) :: irr_frac_2D ! irrigation Fraction + real(kind=kind_noahmp), allocatable, dimension(:) :: irr_har_2D ! number of days before harvest date to stop irrigation + real(kind=kind_noahmp), allocatable, dimension(:) :: irr_lai_2D ! Minimum lai to trigger irrigation + real(kind=kind_noahmp), allocatable, dimension(:) :: irr_mad_2D ! management allowable deficit (0-1) + real(kind=kind_noahmp), allocatable, dimension(:) :: filoss_2D ! fraction of flood irrigation loss (0-1) + real(kind=kind_noahmp), allocatable, dimension(:) :: sprir_rate_2D ! mm/h, sprinkler irrigation rate + real(kind=kind_noahmp), allocatable, dimension(:) :: micir_rate_2D ! mm/h, micro irrigation rate + real(kind=kind_noahmp), allocatable, dimension(:) :: firtfac_2D ! flood application rate factor + real(kind=kind_noahmp), allocatable, dimension(:) :: ir_rain_2D ! maximum precipitation to stop irrigation trigger + real(kind=kind_noahmp), allocatable, dimension(:) :: bvic_2d ! VIC model infiltration parameter [-] opt_run=6 + real(kind=kind_noahmp), allocatable, dimension(:) :: axaj_2D ! Tension water distribution inflection parameter [-] opt_run=7 + real(kind=kind_noahmp), allocatable, dimension(:) :: bxaj_2D ! Tension water distribution shape parameter [-] opt_run=7 + real(kind=kind_noahmp), allocatable, dimension(:) :: xxaj_2D ! Free water distribution shape parameter [-] opt_run=7 + real(kind=kind_noahmp), allocatable, dimension(:) :: bdvic_2d ! VIC model infiltration parameter [-] opt_run=8 + real(kind=kind_noahmp), allocatable, dimension(:) :: gdvic_2d ! Mean Capillary Drive (m) for infiltration models opt_run=8 + real(kind=kind_noahmp), allocatable, dimension(:) :: bbvic_2d ! DVIC heterogeniety parameter for infiltration [-] opt_run=8 + real(kind=kind_noahmp), allocatable, dimension(:) :: KLAT_FAC ! factor multiplier to hydraulic conductivity + real(kind=kind_noahmp), allocatable, dimension(:) :: TDSMC_FAC ! factor multiplier to field capacity + real(kind=kind_noahmp), allocatable, dimension(:) :: TD_DC ! drainage coefficient for simple + real(kind=kind_noahmp), allocatable, dimension(:) :: TD_DCOEF ! drainge coefficient for Hooghoudt + real(kind=kind_noahmp), allocatable, dimension(:) :: TD_DDRAIN ! depth of drain + real(kind=kind_noahmp), allocatable, dimension(:) :: TD_RADI ! tile radius + real(kind=kind_noahmp), allocatable, dimension(:) :: TD_SPAC ! tile spacing + + ! INOUT (with generic LSM equivalent) (as defined in WRF) + real(kind=kind_noahmp), allocatable, dimension(:) :: tsk ! surface radiative temperature [K] + real(kind=kind_noahmp), allocatable, dimension(:) :: hfx ! sensible heat flux [W m-2] + real(kind=kind_noahmp), allocatable, dimension(:) :: qfx ! latent heat flux [kg s-1 m-2] + real(kind=kind_noahmp), allocatable, dimension(:) :: lh ! latent heat flux [W m-2] + real(kind=kind_noahmp), allocatable, dimension(:) :: grdflx ! ground/snow heat flux [W m-2] + real(kind=kind_noahmp), allocatable, dimension(:) :: smstav ! soil moisture avail. [not used] + real(kind=kind_noahmp), allocatable, dimension(:) :: smstot ! total soil water [mm][not used] + real(kind=kind_noahmp), allocatable, dimension(:) :: sfcrunoff ! accumulated surface runoff [m] + real(kind=kind_noahmp), allocatable, dimension(:) :: udrunoff ! accumulated sub-surface runoff [m] + real(kind=kind_noahmp), allocatable, dimension(:) :: albedo ! total grid albedo [] + real(kind=kind_noahmp), allocatable, dimension(:) :: snowc ! snow cover fraction [] + real(kind=kind_noahmp), allocatable, dimension(:,:) :: smoiseq ! volumetric soil moisture [m3/m3] + real(kind=kind_noahmp), allocatable, dimension(:,:) :: smois ! volumetric soil moisture [m3/m3] + real(kind=kind_noahmp), allocatable, dimension(:,:) :: sh2o ! volumetric liquid soil moisture [m3/m3] + real(kind=kind_noahmp), allocatable, dimension(:,:) :: tslb ! soil temperature [K] + real(kind=kind_noahmp), allocatable, dimension(:) :: snow ! snow water equivalent [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: snowh ! physical snow depth [m] + real(kind=kind_noahmp), allocatable, dimension(:) :: canwat ! total canopy water + ice [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: acsnom ! accumulated snow melt leaving pack + real(kind=kind_noahmp), allocatable, dimension(:) :: acsnow ! accumulated snow on grid + real(kind=kind_noahmp), allocatable, dimension(:) :: emiss ! surface bulk emissivity + real(kind=kind_noahmp), allocatable, dimension(:) :: qsfc ! bulk surface specific humidity + + ! INOUT (with no Noah LSM equivalent) (as defined in WRF) + integer, allocatable, dimension(:) :: isnowxy ! actual no. of snow layers + real(kind=kind_noahmp), allocatable, dimension(:) :: tvxy ! vegetation leaf temperature + real(kind=kind_noahmp), allocatable, dimension(:) :: tgxy ! bulk ground surface temperature + real(kind=kind_noahmp), allocatable, dimension(:) :: canicexy ! canopy-intercepted ice (mm) + real(kind=kind_noahmp), allocatable, dimension(:) :: canliqxy ! canopy-intercepted liquid water (mm) + real(kind=kind_noahmp), allocatable, dimension(:) :: eahxy ! canopy air vapor pressure (Pa) + real(kind=kind_noahmp), allocatable, dimension(:) :: tahxy ! canopy air temperature (K) + real(kind=kind_noahmp), allocatable, dimension(:) :: cmxy ! bulk momentum drag coefficient + real(kind=kind_noahmp), allocatable, dimension(:) :: chxy ! bulk sensible heat exchange coefficient + real(kind=kind_noahmp), allocatable, dimension(:) :: fwetxy ! wetted or snowed fraction of the canopy (-) + real(kind=kind_noahmp), allocatable, dimension(:) :: sneqvoxy ! snow mass at last time step(mm h2o) + real(kind=kind_noahmp), allocatable, dimension(:) :: alboldxy ! snow albedo at last time step (-) + real(kind=kind_noahmp), allocatable, dimension(:) :: qsnowxy ! snowfall on the ground [mm/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: qrainxy ! rainfall on the ground [mm/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: wslakexy ! lake water storage [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: zwtxy ! water table depth [m] + real(kind=kind_noahmp), allocatable, dimension(:) :: waxy ! water in the "aquifer" [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: wtxy ! groundwater storage [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: smcwtdxy ! groundwater storage [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: deeprechxy ! groundwater storage [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: rechxy ! groundwater storage [mm] + real(kind=kind_noahmp), allocatable, dimension(:,:) :: tsnoxy ! snow temperature [K] + real(kind=kind_noahmp), allocatable, dimension(:,:) :: zsnsoxy ! snow layer depth [m] + real(kind=kind_noahmp), allocatable, dimension(:,:) :: snicexy ! snow layer ice [mm] + real(kind=kind_noahmp), allocatable, dimension(:,:) :: snliqxy ! snow layer liquid water [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: lfmassxy ! leaf mass [g/m2] + real(kind=kind_noahmp), allocatable, dimension(:) :: rtmassxy ! mass of fine roots [g/m2] + real(kind=kind_noahmp), allocatable, dimension(:) :: stmassxy ! stem mass [g/m2] + real(kind=kind_noahmp), allocatable, dimension(:) :: woodxy ! mass of wood (incl. woody roots) [g/m2] + real(kind=kind_noahmp), allocatable, dimension(:) :: grainxy ! xing mass of grain!three + real(kind=kind_noahmp), allocatable, dimension(:) :: gddxy ! xinggrowingdegressday + real(kind=kind_noahmp), allocatable, dimension(:) :: stblcpxy ! stable carbon in deep soil [g/m2] + real(kind=kind_noahmp), allocatable, dimension(:) :: fastcpxy ! short-lived carbon, shallow soil [g/m2] + real(kind=kind_noahmp), allocatable, dimension(:) :: lai ! leaf area index + real(kind=kind_noahmp), allocatable, dimension(:) :: xsaixy ! stem area index + real(kind=kind_noahmp), allocatable, dimension(:) :: taussxy ! snow age factor + + ! irrigation + real(kind=kind_noahmp), allocatable, dimension(:) :: irfract ! irrigation fraction + real(kind=kind_noahmp), allocatable, dimension(:) :: sifract ! sprinkler irrigation fraction + real(kind=kind_noahmp), allocatable, dimension(:) :: mifract ! micro irrigation fraction + real(kind=kind_noahmp), allocatable, dimension(:) :: fifract ! flood irrigation fraction + integer, allocatable, dimension(:) :: irnumsi ! irrigation event number, sprinkler + integer, allocatable, dimension(:) :: irnummi ! irrigation event number, micro + integer, allocatable, dimension(:) :: irnumfi ! irrigation event number, flood + real(kind=kind_noahmp), allocatable, dimension(:) :: irwatsi ! irrigation water amount [m] to be applied, sprinkler + real(kind=kind_noahmp), allocatable, dimension(:) :: irwatmi ! irrigation water amount [m] to be applied, micro + real(kind=kind_noahmp), allocatable, dimension(:) :: irwatfi ! irrigation water amount [m] to be applied, flood + real(kind=kind_noahmp), allocatable, dimension(:) :: ireloss ! loss of irrigation water to evaporation,sprinkler [m/timestep] + real(kind=kind_noahmp), allocatable, dimension(:) :: irsivol ! amount of irrigation by sprinkler (mm) + real(kind=kind_noahmp), allocatable, dimension(:) :: irmivol ! amount of irrigation by micro (mm) + real(kind=kind_noahmp), allocatable, dimension(:) :: irfivol ! amount of irrigation by micro (mm) + real(kind=kind_noahmp), allocatable, dimension(:) :: irrsplh ! latent heating from sprinkler evaporation (W/m2) + real(kind=kind_noahmp), allocatable, dimension(:) :: loctim ! local time + + ! OUT (with no Noah LSM equivalent) (as defined in WRF) + real(kind=kind_noahmp), allocatable, dimension(:) :: t2mvxy ! 2m temperature of vegetation part + real(kind=kind_noahmp), allocatable, dimension(:) :: t2mbxy ! 2m temperature of bare ground part + real(kind=kind_noahmp), allocatable, dimension(:) :: q2mvxy ! 2m mixing ratio of vegetation part + real(kind=kind_noahmp), allocatable, dimension(:) :: q2mbxy ! 2m mixing ratio of bare ground part + real(kind=kind_noahmp), allocatable, dimension(:) :: tradxy ! surface radiative temperature (K) + real(kind=kind_noahmp), allocatable, dimension(:) :: neexy ! net ecosys exchange (g/m2/s CO2) + real(kind=kind_noahmp), allocatable, dimension(:) :: gppxy ! gross primary assimilation [g/m2/s C] + real(kind=kind_noahmp), allocatable, dimension(:) :: nppxy ! net primary productivity [g/m2/s C] + real(kind=kind_noahmp), allocatable, dimension(:) :: fvegxy ! noah-mp vegetation fraction [-] + real(kind=kind_noahmp), allocatable, dimension(:) :: runsfxy ! surface runoff [mm per soil timestep] + real(kind=kind_noahmp), allocatable, dimension(:) :: runsbxy ! subsurface runoff [mm per soil timestep] + real(kind=kind_noahmp), allocatable, dimension(:) :: ecanxy ! evaporation of intercepted water (mm/s) + real(kind=kind_noahmp), allocatable, dimension(:) :: edirxy ! soil surface evaporation rate (mm/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: etranxy ! transpiration rate (mm/s) + real(kind=kind_noahmp), allocatable, dimension(:) :: fsaxy ! total absorbed solar radiation (W/m2) + real(kind=kind_noahmp), allocatable, dimension(:) :: firaxy ! total net longwave rad (w/m2) [+ to atm] + real(kind=kind_noahmp), allocatable, dimension(:) :: aparxy ! photosyn active energy by canopy (W/m2) + real(kind=kind_noahmp), allocatable, dimension(:) :: psnxy ! total photosynthesis (umol co2/m2/s) [+] + real(kind=kind_noahmp), allocatable, dimension(:) :: savxy ! solar rad absorbed by veg. (W/m2) + real(kind=kind_noahmp), allocatable, dimension(:) :: sagxy ! solar rad absorbed by ground (W/m2) + real(kind=kind_noahmp), allocatable, dimension(:) :: rssunxy ! sunlit leaf stomatal resistance (s/m) + real(kind=kind_noahmp), allocatable, dimension(:) :: rsshaxy ! shaded leaf stomatal resistance (s/m) + real(kind=kind_noahmp), allocatable, dimension(:) :: bgapxy ! between gap fraction + real(kind=kind_noahmp), allocatable, dimension(:) :: wgapxy ! within gap fraction + real(kind=kind_noahmp), allocatable, dimension(:) :: tgvxy ! under canopy ground temperature[K] + real(kind=kind_noahmp), allocatable, dimension(:) :: tgbxy ! bare ground temperature [K] + real(kind=kind_noahmp), allocatable, dimension(:) :: chvxy ! sensible heat exchange coefficient vegetated + real(kind=kind_noahmp), allocatable, dimension(:) :: chbxy ! sensible heat exchange coefficient bare-ground + real(kind=kind_noahmp), allocatable, dimension(:) :: shgxy ! veg ground sen. heat [W/m2] [+ to atm] + real(kind=kind_noahmp), allocatable, dimension(:) :: shcxy ! canopy sen. heat [W/m2] [+ to atm] + real(kind=kind_noahmp), allocatable, dimension(:) :: shbxy ! bare sensible heat [W/m2] [+ to atm] + real(kind=kind_noahmp), allocatable, dimension(:) :: evgxy ! veg ground evap. heat [W/m2] [+ to atm] + real(kind=kind_noahmp), allocatable, dimension(:) :: evbxy ! bare soil evaporation [W/m2] [+ to atm] + real(kind=kind_noahmp), allocatable, dimension(:) :: ghvxy ! veg ground heat flux [W/m2] [+ to soil] + real(kind=kind_noahmp), allocatable, dimension(:) :: ghbxy ! bare ground heat flux [W/m2] [+ to soil] + real(kind=kind_noahmp), allocatable, dimension(:) :: irgxy ! veg ground net lw rad. [W/m2] [+ to atm] + real(kind=kind_noahmp), allocatable, dimension(:) :: ircxy ! canopy net lw rad. [W/m2] [+ to atm] + real(kind=kind_noahmp), allocatable, dimension(:) :: irbxy ! bare net longwave rad. [W/m2] [+ to atm] + real(kind=kind_noahmp), allocatable, dimension(:) :: trxy ! transpiration [W/m2] [+ to atm] + real(kind=kind_noahmp), allocatable, dimension(:) :: evcxy ! canopy evaporation heat [W/m2] [+ to atm] + real(kind=kind_noahmp), allocatable, dimension(:) :: chleafxy ! leaf exchange coefficient + real(kind=kind_noahmp), allocatable, dimension(:) :: chucxy ! under canopy exchange coefficient + real(kind=kind_noahmp), allocatable, dimension(:) :: chv2xy ! veg 2m exchange coefficient + real(kind=kind_noahmp), allocatable, dimension(:) :: chb2xy ! bare 2m exchange coefficient + real(kind=kind_noahmp), allocatable, dimension(:) :: rs ! total stomatal resistance [s/m] + real(kind=kind_noahmp), allocatable, dimension(:) :: z0 ! roughness length output to wrf + real(kind=kind_noahmp), allocatable, dimension(:) :: znt ! roughness length output to wrf + real(kind=kind_noahmp), allocatable, dimension(:) :: qtdrain ! tile drain discharge [mm] + + ! additional output variables + real(kind=kind_noahmp), allocatable, dimension(:) :: pahxy ! precipitation advected heat [W/m2] + real(kind=kind_noahmp), allocatable, dimension(:) :: pahgxy ! precipitation advected heat [W/m2] + real(kind=kind_noahmp), allocatable, dimension(:) :: pahbxy ! precipitation advected heat [W/m2] + real(kind=kind_noahmp), allocatable, dimension(:) :: pahvxy ! precipitation advected heat [W/m2] + real(kind=kind_noahmp), allocatable, dimension(:) :: qintsxy ! canopy intercepted snow [mm/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: qintrxy ! canopy intercepted rain [mm/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: qdripsxy ! canopy dripping snow [mm/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: qdriprxy ! canopy dripping rain [mm/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: qthrosxy ! canopy throughfall snow [mm/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: qthrorxy ! canopy throughfall rain [mm/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: qsnsubxy ! snowpack sublimation rate [mm/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: qmeltxy ! snowpack melting rate due to phase change [mm/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: qsnfroxy ! snowpack frost rate [mm/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: qsubcxy ! canopy snow sublimation rate [mm/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: qfrocxy ! canopy snow frost rate [mm/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: qevacxy ! canopy water evaporation rate [mm/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: qdewcxy ! canopy water dew rate [mm/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: qfrzcxy ! canopy water freezing rate [mm/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: qmeltcxy ! canopy snow melting rate [mm/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: qsnbotxy ! total water (melt+rain through snow) out of snowpack bottom [mm/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: pondingxy ! total surface ponding [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: fpicexy ! fraction of ice in total precipitation + real(kind=kind_noahmp), allocatable, dimension(:) :: rainlsm ! total rain rate at the surface [mm/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: snowlsm ! total snow rate at the surface [mm/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: forctlsm ! surface temperature as lsm forcing [K] + real(kind=kind_noahmp), allocatable, dimension(:) :: forcqlsm ! surface specific humidity as lsm forcing [kg/kg] + real(kind=kind_noahmp), allocatable, dimension(:) :: forcplsm ! surface pressure as lsm forcing [Pa] + real(kind=kind_noahmp), allocatable, dimension(:) :: forczlsm ! reference height as lsm input [m] + real(kind=kind_noahmp), allocatable, dimension(:) :: forcwlsm ! surface wind speed as lsm forcing [m/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: acc_ssoilxy ! accumulated ground heat flux [W/m2 * dt_soil/dt_main] + real(kind=kind_noahmp), allocatable, dimension(:) :: acc_qinsurxy ! accumulated water flux into soil [m/s * dt_soil/dt_main] + real(kind=kind_noahmp), allocatable, dimension(:) :: acc_qsevaxy ! accumulated soil surface evaporation [m/s * dt_soil/dt_main] + real(kind=kind_noahmp), allocatable, dimension(:) :: eflxbxy ! accumulated heat flux through soil bottom per soil timestep [J/m2] + real(kind=kind_noahmp), allocatable, dimension(:) :: soilenergy ! energy content in soil relative to 273.16 [kJ/m2] + real(kind=kind_noahmp), allocatable, dimension(:) :: snowenergy ! energy content in snow relative to 273.16 [kJ/m2] + real(kind=kind_noahmp), allocatable, dimension(:) :: canhsxy ! canopy heat storage change [W/m2] + real(kind=kind_noahmp), allocatable, dimension(:) :: acc_dwaterxy ! accumulated snow,soil,canopy water change per soil timestep [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: acc_prcpxy ! accumulated precipitation per soil timestep [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: acc_ecanxy ! accumulated net canopy evaporation per soil timestep [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: acc_etranxy ! accumulated transpiration per soil timestep [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: acc_edirxy ! accumulated net ground (soil/snow) evaporation per soil timestep [mm] + real(kind=kind_noahmp), allocatable, dimension(:,:) :: acc_etranixy ! accumualted transpiration rate within soil timestep [m/s * dt_soil/dt_main] + +!------------------------------------------------------------------------ +! Needed for MMF_RUNOFF (IOPT_RUN = 5); not part of MP driver in WRF +!------------------------------------------------------------------------ + + real(kind=kind_noahmp), allocatable, dimension(:) :: msftx ! mapping factor x + real(kind=kind_noahmp), allocatable, dimension(:) :: msfty ! mapping factor y + real(kind=kind_noahmp), allocatable, dimension(:) :: eqzwt ! equilibrium water table + real(kind=kind_noahmp), allocatable, dimension(:) :: riverbedxy ! riverbed depth + real(kind=kind_noahmp), allocatable, dimension(:) :: rivercondxy ! river conductivity + real(kind=kind_noahmp), allocatable, dimension(:) :: pexpxy ! exponential factor + real(kind=kind_noahmp), allocatable, dimension(:) :: fdepthxy ! depth + real(kind=kind_noahmp), allocatable, dimension(:) :: areaxy ! river area + real(kind=kind_noahmp), allocatable, dimension(:) :: qrfsxy ! accumulated groundwater baseflow [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: qspringsxy ! accumulated seeping water [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: qrfxy ! groundwater baselow [m] + real(kind=kind_noahmp), allocatable, dimension(:) :: qspringxy ! seeping water [m] + real(kind=kind_noahmp), allocatable, dimension(:) :: qslatxy ! accumulated lateral flow [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: qlatxy ! lateral flow [m] + real(kind=kind_noahmp), allocatable, dimension(:) :: rechclim ! climatology recharge + real(kind=kind_noahmp), allocatable, dimension(:) :: rivermask ! river mask + real(kind=kind_noahmp), allocatable, dimension(:) :: nonriverxy ! non-river portion + real(kind=kind_noahmp) :: wtddt = 30.0 ! frequency of groundwater call [minutes] + integer :: stepwtd ! step of groundwater call + +!------------------------------------------------------------------------ +! Needed for TILE DRAINAGE IF IOPT_TDRN = 1 OR 2 +!------------------------------------------------------------------------ + real(kind=kind_noahmp), allocatable, dimension(:) :: td_fraction ! tile drainage fraction + +!------------------------------------------------------------------------ +! Needed for crop model (OPT_CROP=1) +!------------------------------------------------------------------------ + + integer, allocatable, dimension(:) :: pgsxy ! plant growth stage + integer, allocatable, dimension(:) :: cropcat ! crop category + real(kind=kind_noahmp), allocatable, dimension(:) :: planting ! planting day + real(kind=kind_noahmp), allocatable, dimension(:) :: harvest ! harvest day + real(kind=kind_noahmp), allocatable, dimension(:) :: season_gdd ! seasonal gdd + real(kind=kind_noahmp), allocatable, dimension(:,:) :: croptype ! crop type + +!------------------------------------------------------------------------ +! Single- and Multi-layer Urban Models +!------------------------------------------------------------------------ + + integer :: num_urban_atmosphere ! atmospheric levels including ZLVL for BEP/BEM models + integer :: iri_urban ! urban irrigation flag (move from module_sf_urban to here) + real(kind=kind_noahmp) :: gmt ! hour of day (fractional) (needed for urban) + integer :: julday ! integer day (needed for urban) + real(kind=kind_noahmp), allocatable, dimension(:) :: hrang ! hour angle (needed for urban) + real(kind=kind_noahmp) :: declin ! declination (needed for urban) + integer :: num_roof_layers = 4 ! roof layer number + integer :: num_road_layers = 4 ! road layer number + integer :: num_wall_layers = 4 ! wall layer number + real(kind=kind_noahmp), allocatable, dimension(:) :: cmr_sfcdif + real(kind=kind_noahmp), allocatable, dimension(:) :: chr_sfcdif + real(kind=kind_noahmp), allocatable, dimension(:) :: cmc_sfcdif + real(kind=kind_noahmp), allocatable, dimension(:) :: chc_sfcdif + real(kind=kind_noahmp), allocatable, dimension(:) :: cmgr_sfcdif + real(kind=kind_noahmp), allocatable, dimension(:) :: chgr_sfcdif + real(kind=kind_noahmp), allocatable, dimension(:) :: tr_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: tb_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: tg_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: tc_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: qc_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: uc_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: xxxr_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: xxxb_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: xxxg_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: xxxc_urb2d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: trl_urb3d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: tbl_urb3d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: tgl_urb3d + real(kind=kind_noahmp), allocatable, dimension(:) :: sh_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: lh_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: g_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: rn_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: ts_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: psim_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: psih_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: u10_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: v10_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: gz1oz0_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: akms_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: th2_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: q2_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: ust_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: dzr + real(kind=kind_noahmp), allocatable, dimension(:) :: dzb + real(kind=kind_noahmp), allocatable, dimension(:) :: dzg + real(kind=kind_noahmp), allocatable, dimension(:) :: cmcr_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: tgr_urb2d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: tgrl_urb3d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: smr_urb3d + real(kind=kind_noahmp), allocatable, dimension(:) :: drelr_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: drelb_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: drelg_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: flxhumr_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: flxhumb_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: flxhumg_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: frc_urb2d + integer, allocatable, dimension(:) :: utype_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: chs + real(kind=kind_noahmp), allocatable, dimension(:) :: chs2 + real(kind=kind_noahmp), allocatable, dimension(:) :: cqs2 + real(kind=kind_noahmp), allocatable, dimension(:,:) :: trb_urb4d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: tw1_urb4d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: tw2_urb4d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: tgb_urb4d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: tlev_urb3d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: qlev_urb3d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: tw1lev_urb3d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: tw2lev_urb3d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: tglev_urb3d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: tflev_urb3d + real(kind=kind_noahmp), allocatable, dimension(:) :: sf_ac_urb3d + real(kind=kind_noahmp), allocatable, dimension(:) :: lf_ac_urb3d + real(kind=kind_noahmp), allocatable, dimension(:) :: cm_ac_urb3d + real(kind=kind_noahmp), allocatable, dimension(:) :: sfvent_urb3d + real(kind=kind_noahmp), allocatable, dimension(:) :: lfvent_urb3d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: sfwin1_urb3d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: sfwin2_urb3d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: sfw1_urb3d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: sfw2_urb3d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: sfr_urb3d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: sfg_urb3d + real(kind=kind_noahmp), allocatable, dimension(:) :: lp_urb2d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: hi_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: lb_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: hgt_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: mh_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: stdh_urb2d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: lf_urb2d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: theta_urban + real(kind=kind_noahmp), allocatable, dimension(:,:) :: u_urban + real(kind=kind_noahmp), allocatable, dimension(:,:) :: v_urban + real(kind=kind_noahmp), allocatable, dimension(:,:) :: dz_urban + real(kind=kind_noahmp), allocatable, dimension(:,:) :: rho_urban + real(kind=kind_noahmp), allocatable, dimension(:,:) :: p_urban + real(kind=kind_noahmp), allocatable, dimension(:) :: ust + real(kind=kind_noahmp), allocatable, dimension(:,:) :: a_u_bep + real(kind=kind_noahmp), allocatable, dimension(:,:) :: a_v_bep + real(kind=kind_noahmp), allocatable, dimension(:,:) :: a_t_bep + real(kind=kind_noahmp), allocatable, dimension(:,:) :: a_q_bep + real(kind=kind_noahmp), allocatable, dimension(:,:) :: a_e_bep + real(kind=kind_noahmp), allocatable, dimension(:,:) :: b_u_bep + real(kind=kind_noahmp), allocatable, dimension(:,:) :: b_v_bep + real(kind=kind_noahmp), allocatable, dimension(:,:) :: b_t_bep + real(kind=kind_noahmp), allocatable, dimension(:,:) :: b_q_bep + real(kind=kind_noahmp), allocatable, dimension(:,:) :: b_e_bep + real(kind=kind_noahmp), allocatable, dimension(:,:) :: dlg_bep + real(kind=kind_noahmp), allocatable, dimension(:,:) :: dl_u_bep + real(kind=kind_noahmp), allocatable, dimension(:,:) :: sf_bep + real(kind=kind_noahmp), allocatable, dimension(:,:) :: vl_bep + real(kind=kind_noahmp) :: height_urban + + ! new urban variables for green roof, PVP for BEP_BEM scheme=3, Zonato et al., 2021 + real(kind=kind_noahmp), allocatable, dimension(:) :: ep_pv_urb3d + real(kind=kind_noahmp), allocatable, dimension(:) :: qgr_urb3d + real(kind=kind_noahmp), allocatable, dimension(:) :: tgr_urb3d + real(kind=kind_noahmp), allocatable, dimension(:) :: draingr_urb3d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: t_pv_urb3d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: trv_urb4d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: qr_urb4d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: drain_urb4d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: sfrv_urb3d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: lfrv_urb3d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: dgr_urb3d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: dg_urb3d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: lfr_urb3d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: lfg_urb3d + real(kind=kind_noahmp), allocatable, dimension(:) :: swddir ! solar down at surface [w m-2] + real(kind=kind_noahmp), allocatable, dimension(:) :: swddif + +!------------------------------------------------------------------------ +! 2D variables not used in WRF - should be removed? +!------------------------------------------------------------------------ + + real(kind=kind_noahmp), allocatable, dimension(:) :: xlong ! longitude + real(kind=kind_noahmp), allocatable, dimension(:) :: terrain ! terrain height + real(kind=kind_noahmp), allocatable, dimension(:) :: gvfmin ! annual minimum in vegetation fraction + real(kind=kind_noahmp), allocatable, dimension(:) :: gvfmax ! annual maximum in vegetation fraction + +!------------------------------------------------------------------------ +! End 2D variables not used in WRF +!------------------------------------------------------------------------ + + CHARACTER(LEN=256) :: mminsl = 'STAS' ! soil classification + CHARACTER(LEN=256) :: llanduse ! (=USGS, using USGS landuse classification) + +!------------------------------------------------------------------------ +! Timing: +!------------------------------------------------------------------------ + + integer :: ntime ! timesteps + integer :: clock_count_1 = 0 + integer :: clock_count_2 = 0 + integer :: clock_rate = 0 + real(kind=kind_noahmp) :: timing_sum = 0.0 + integer :: sflx_count_sum + integer :: count_before_sflx + integer :: count_after_sflx + +!--------------------------------------------------------------------- +! DECLARE/Initialize constants +!--------------------------------------------------------------------- + + integer :: i + integer :: j + integer :: slopetyp + integer :: yearlen + integer :: nsnow + logical :: update_lai, update_veg + integer :: spinup_loop + logical :: reset_spinup_date + +!--------------------------------------------------------------------- +! File naming, parallel +!--------------------------------------------------------------------- + + character(len=19) :: olddate, & + newdate, & + startdate + character :: hgrid + integer :: igrid + logical :: lexist + integer :: imode + integer :: ixfull + integer :: jxfull + integer :: ixpar + integer :: jxpar + integer :: ystartpar + integer :: rank = 0 + character(len=256) :: inflnm, & + outflnm, & + inflnm_template + logical :: restart_flag + character(len=256) :: restart_flnm + integer :: ierr + +!--------------------------------------------------------------------- +! Attributes from LDASIN input file (or HRLDAS_SETUP_FILE, as the case may be) +!--------------------------------------------------------------------- + + integer :: ix + integer :: jx + real(kind=kind_noahmp) :: dy + real(kind=kind_noahmp) :: truelat1 + real(kind=kind_noahmp) :: truelat2 + real(kind=kind_noahmp) :: cen_lon + integer :: mapproj + real(kind=kind_noahmp) :: lat1 + real(kind=kind_noahmp) :: lon1 + +!--------------------------------------------------------------------- +! NAMELIST start +!--------------------------------------------------------------------- + + character(len=256) :: indir + ! nsoil defined above + integer :: forcing_timestep + integer :: noah_timestep + integer :: start_year + integer :: start_month + integer :: start_day + integer :: start_hour + integer :: start_min + character(len=256) :: outdir + character(len=256) :: restart_filename_requested + integer :: restart_frequency_hours + integer :: output_timestep + integer :: spinup_loops + + integer :: sf_urban_physics + integer :: use_wudapt_lcz + integer :: num_urban_ndm + integer :: num_urban_ng + integer :: num_urban_nwr + integer :: num_urban_ngb + integer :: num_urban_nf + integer :: num_urban_nz + integer :: num_urban_nbui + integer :: num_urban_hi + integer :: num_urban_ngr + real(kind=kind_noahmp) :: urban_atmosphere_thickness + + ! derived urban dimensions + integer :: urban_map_zrd + integer :: urban_map_zwd + integer :: urban_map_gd + integer :: urban_map_zd + integer :: urban_map_zdf + integer :: urban_map_bd + integer :: urban_map_wd + integer :: urban_map_gbd + integer :: urban_map_fbd + integer :: urban_map_zgrd + integer :: max_urban_dim ! C. He: maximum urban dimension for urban variable + + 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 + + integer :: noahmp_output ! =0: default output; >0 include additional output + integer :: split_output_count + logical :: skip_first_output + integer :: khour + integer :: kday + real(kind=kind_noahmp) :: zlvl + character(len=256) :: hrldas_setup_file + character(len=256) :: spatial_filename + character(len=256) :: external_veg_filename_template + character(len=256) :: external_lai_filename_template + character(len=256) :: agdata_flnm + character(len=256) :: tdinput_flnm + integer :: MAX_SOIL_LEVELS + real(kind=kind_noahmp), allocatable, dimension(:) :: soil_thick_input + +!---------------------------------------------------------------- +! Noahmp Parameters Table +!---------------------------------------------------------------- + + ! vegetation parameters + character(len=256) :: veg_dataset_description_table + integer :: nveg_table ! number of vegetation types + integer :: isurban_table ! urban flag + integer :: iswater_table ! water flag + integer :: isbarren_table ! barren ground flag + integer :: isice_table ! ice flag + integer :: iscrop_table ! cropland flag + integer :: eblforest_table ! evergreen broadleaf forest flag + integer :: natural_table ! natural vegetation type + integer :: lcz_1_table ! urban lcz 1 + integer :: lcz_2_table ! urban lcz 2 + integer :: lcz_3_table ! urban lcz 3 + integer :: lcz_4_table ! urban lcz 4 + integer :: lcz_5_table ! urban lcz 5 + integer :: lcz_6_table ! urban lcz 6 + integer :: lcz_7_table ! urban lcz 7 + integer :: lcz_8_table ! urban lcz 8 + integer :: lcz_9_table ! urban lcz 9 + integer :: lcz_10_table ! urban lcz 10 + integer :: lcz_11_table ! urban lcz 11 + real(kind=kind_noahmp), allocatable, dimension(:) :: ch2op_table ! maximum intercepted h2o per unit lai+sai (mm) + real(kind=kind_noahmp), allocatable, dimension(:) :: dleaf_table ! characteristic leaf dimension (m) + real(kind=kind_noahmp), allocatable, dimension(:) :: z0mvt_table ! momentum roughness length (m) + real(kind=kind_noahmp), allocatable, dimension(:) :: hvt_table ! top of canopy (m) + real(kind=kind_noahmp), allocatable, dimension(:) :: hvb_table ! bottom of canopy (m) + real(kind=kind_noahmp), allocatable, dimension(:) :: den_table ! tree density (no. of trunks per m2) + real(kind=kind_noahmp), allocatable, dimension(:) :: rc_table ! tree crown radius (m) + real(kind=kind_noahmp), allocatable, dimension(:) :: mfsno_table ! snowmelt curve parameter + real(kind=kind_noahmp), allocatable, dimension(:) :: scffac_table ! snow cover factor (m) (replace original hard-coded 2.5*z0 in SCF formulation) + real(kind=kind_noahmp), allocatable, dimension(:) :: cbiom_table ! canopy biomass heat capacity parameter (m) + real(kind=kind_noahmp), allocatable, dimension(:,:) :: saim_table ! monthly stem area index, one-sided + real(kind=kind_noahmp), allocatable, dimension(:,:) :: laim_table ! monthly leaf area index, one-sided + real(kind=kind_noahmp), allocatable, dimension(:) :: sla_table ! single-side leaf area per kg [m2/kg] + real(kind=kind_noahmp), allocatable, dimension(:) :: dilefc_table ! coeficient for leaf stress death [1/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: dilefw_table ! coeficient for leaf stress death [1/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: fragr_table ! fraction of growth respiration !original was 0.3 + real(kind=kind_noahmp), allocatable, dimension(:) :: ltovrc_table ! leaf turnover [1/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: c3psn_table ! photosynthetic pathway: 0. = c4, 1. = c3 + real(kind=kind_noahmp), allocatable, dimension(:) :: kc25_table ! co2 michaelis-menten constant at 25C (Pa) + real(kind=kind_noahmp), allocatable, dimension(:) :: akc_table ! q10 for kc25 + real(kind=kind_noahmp), allocatable, dimension(:) :: ko25_table ! o2 michaelis-menten constant at 25C (Pa) + real(kind=kind_noahmp), allocatable, dimension(:) :: ako_table ! q10 for ko25 + real(kind=kind_noahmp), allocatable, dimension(:) :: vcmx25_table ! maximum rate of carboxylation at 25C (umol CO2/m2/s) + real(kind=kind_noahmp), allocatable, dimension(:) :: avcmx_table ! q10 for vcmx25 + real(kind=kind_noahmp), allocatable, dimension(:) :: bp_table ! minimum leaf conductance (umol/m2/s) + real(kind=kind_noahmp), allocatable, dimension(:) :: mp_table ! slope of conductance-to-photosynthesis relationship + real(kind=kind_noahmp), allocatable, dimension(:) :: qe25_table ! quantum efficiency at 25C (umol CO2 / umol photon) + real(kind=kind_noahmp), allocatable, dimension(:) :: aqe_table ! q10 for qe25 + real(kind=kind_noahmp), allocatable, dimension(:) :: rmf25_table ! leaf maintenance respiration at 25C (umol CO2/m2/s) + real(kind=kind_noahmp), allocatable, dimension(:) :: rms25_table ! stem maintenance respiration at 25C (umol CO2/kg bio/s) + real(kind=kind_noahmp), allocatable, dimension(:) :: rmr25_table ! root maintenance respiration at 25C (umol CO2/kg bio/s) + real(kind=kind_noahmp), allocatable, dimension(:) :: arm_table ! q10 for maintenance respiration + real(kind=kind_noahmp), allocatable, dimension(:) :: folnmx_table ! foliage nitrogen concentration when f(n)=1 (%) + real(kind=kind_noahmp), allocatable, dimension(:) :: tmin_table ! minimum temperature for photosynthesis (K) + real(kind=kind_noahmp), allocatable, dimension(:) :: xl_table ! leaf/stem orientation index + real(kind=kind_noahmp), allocatable, dimension(:,:) :: rhol_table ! leaf reflectance: 1=vis, 2=nir + real(kind=kind_noahmp), allocatable, dimension(:,:) :: rhos_table ! stem reflectance: 1=vis, 2=nir + real(kind=kind_noahmp), allocatable, dimension(:,:) :: taul_table ! leaf transmittance: 1=vis, 2=nir + real(kind=kind_noahmp), allocatable, dimension(:,:) :: taus_table ! stem transmittance: 1=vis, 2=nir + real(kind=kind_noahmp), allocatable, dimension(:) :: mrp_table ! microbial respiration parameter (umol CO2 /kg c/ s) + real(kind=kind_noahmp), allocatable, dimension(:) :: cwpvt_table ! empirical canopy wind parameter + real(kind=kind_noahmp), allocatable, dimension(:) :: wrrat_table ! wood to non-wood ratio + real(kind=kind_noahmp), allocatable, dimension(:) :: wdpool_table ! wood pool (switch 1 or 0) depending on woody or not [-] + real(kind=kind_noahmp), allocatable, dimension(:) :: tdlef_table ! characteristic t for leaf freezing [K] + real(kind=kind_noahmp), allocatable, dimension(:) :: nroot_table ! number of soil layers with root present + real(kind=kind_noahmp), allocatable, dimension(:) :: rgl_table ! parameter used in radiation stress function + real(kind=kind_noahmp), allocatable, dimension(:) :: rs_table ! minimum stomatal resistance [s m-1] + real(kind=kind_noahmp), allocatable, dimension(:) :: hs_table ! parameter used in vapor pressure deficit function + real(kind=kind_noahmp), allocatable, dimension(:) :: topt_table ! optimum transpiration air temperature [K] + real(kind=kind_noahmp), allocatable, dimension(:) :: rsmax_table ! maximal stomatal resistance [s m-1] + real(kind=kind_noahmp), allocatable, dimension(:) :: rtovrc_table ! root turnover coefficient [1/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: rswoodc_table ! wood respiration coeficient [1/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: bf_table ! parameter for present wood allocation [-] + real(kind=kind_noahmp), allocatable, dimension(:) :: wstrc_table ! water stress coeficient [-] + real(kind=kind_noahmp), allocatable, dimension(:) :: laimin_table ! minimum leaf area index [m2/m2] + real(kind=kind_noahmp), allocatable, dimension(:) :: xsamin_table ! minimum stem area index [m2/m2] + + ! radiation parameters + real(kind=kind_noahmp), allocatable, dimension(:,:) :: albsat_table ! saturated soil albedos: 1=vis, 2=nir + real(kind=kind_noahmp), allocatable, dimension(:,:) :: albdry_table ! dry soil albedos: 1=vis, 2=nir + real(kind=kind_noahmp), allocatable, dimension(:) :: albice_table ! albedo land ice: 1=vis, 2=nir + real(kind=kind_noahmp), allocatable, dimension(:) :: alblak_table ! albedo frozen lakes: 1=vis, 2=nir + real(kind=kind_noahmp), allocatable, dimension(:) :: omegas_table ! two-stream parameter omega for snow + real(kind=kind_noahmp) :: betads_table ! two-stream parameter betad for snow + real(kind=kind_noahmp) :: betais_table ! two-stream parameter betad for snow + real(kind=kind_noahmp), allocatable, dimension(:) :: eg_table ! emissivity soil surface + real(kind=kind_noahmp) :: eice_table ! ice surface emissivity + + ! global parameters + real(kind=kind_noahmp) :: co2_table ! co2 partial pressure + real(kind=kind_noahmp) :: o2_table ! o2 partial pressure + real(kind=kind_noahmp) :: timean_table ! gridcell mean topgraphic index (global mean) + real(kind=kind_noahmp) :: fsatmx_table ! maximum surface saturated fraction (global mean) + real(kind=kind_noahmp) :: z0sno_table ! snow surface roughness length (m) (0.002) + real(kind=kind_noahmp) :: ssi_table ! liquid water holding capacity for snowpack (m3/m3) (0.03) + real(kind=kind_noahmp) :: snow_ret_fac_table ! snowpack water release timescale factor (1/s) + real(kind=kind_noahmp) :: snow_emis_table ! snow emissivity + real(kind=kind_noahmp) :: swemx_table ! new snow mass to fully cover old snow (mm) + real(kind=kind_noahmp) :: tau0_table ! tau0 from Yang97 eqn. 10a + real(kind=kind_noahmp) :: grain_growth_table ! growth from vapor diffusion Yang97 eqn. 10b + real(kind=kind_noahmp) :: extra_growth_table ! extra growth near freezing Yang97 eqn. 10c + real(kind=kind_noahmp) :: dirt_soot_table ! dirt and soot term Yang97 eqn. 10d + real(kind=kind_noahmp) :: bats_cosz_table ! zenith angle snow albedo adjustment; b in Yang97 eqn. 15 + real(kind=kind_noahmp) :: bats_vis_new_table ! new snow visible albedo + real(kind=kind_noahmp) :: bats_nir_new_table ! new snow nir albedo + real(kind=kind_noahmp) :: bats_vis_age_table ! age factor for diffuse visible snow albedo Yang97 eqn. 17 + real(kind=kind_noahmp) :: bats_nir_age_table ! age factor for diffuse nir snow albedo Yang97 eqn. 18 + real(kind=kind_noahmp) :: bats_vis_dir_table ! cosz factor for direct visible snow albedo Yang97 eqn. 15 + real(kind=kind_noahmp) :: bats_nir_dir_table ! cosz factor for direct nir snow albedo Yang97 eqn. 16 + real(kind=kind_noahmp) :: rsurf_snow_table ! surface resistance for snow(s/m) + real(kind=kind_noahmp) :: rsurf_exp_table ! exponent in the shape parameter for soil resistance option 1 + real(kind=kind_noahmp) :: c2_snowcompact_table ! overburden snow compaction parameter (m3/kg) + real(kind=kind_noahmp) :: c3_snowcompact_table ! snow desctructive metamorphism compaction parameter1 [1/s] + real(kind=kind_noahmp) :: c4_snowcompact_table ! snow desctructive metamorphism compaction parameter2 [1/k] + real(kind=kind_noahmp) :: c5_snowcompact_table ! snow desctructive metamorphism compaction parameter3 + real(kind=kind_noahmp) :: dm_snowcompact_table ! upper limit on destructive metamorphism compaction [kg/m3] + real(kind=kind_noahmp) :: eta0_snowcompact_table ! snow viscosity coefficient [kg-s/m2] + real(kind=kind_noahmp) :: snliqmaxfrac_table ! maximum liquid water fraction in snow + real(kind=kind_noahmp) :: swemaxgla_table ! maximum swe allowed at glaciers (mm) + real(kind=kind_noahmp) :: wslmax_table ! maximum lake water storage (mm) + real(kind=kind_noahmp) :: rous_table ! specific yield [-] for Niu et al. 2007 groundwater scheme + real(kind=kind_noahmp) :: cmic_table ! microprore content (0.0-1.0), 0.0: close to free drainage + real(kind=kind_noahmp) :: snowden_max_table ! maximum fresh snowfall density (kg/m3) + real(kind=kind_noahmp) :: class_alb_ref_table ! reference snow albedo in class scheme + real(kind=kind_noahmp) :: class_sno_age_table ! snow aging e-folding time (s) in class albedo scheme + real(kind=kind_noahmp) :: class_alb_new_table ! fresh snow albedo in class scheme + real(kind=kind_noahmp) :: psiwlt_table ! soil metric potential for wilting point (m) + real(kind=kind_noahmp) :: z0soil_table ! bare-soil roughness length (m) (i.e., under the canopy) + real(kind=kind_noahmp) :: z0lake_table ! lake surface roughness length (m) + + ! irrigation parameters + integer :: irr_har_table ! number of days before harvest date to stop irrigation + real(kind=kind_noahmp) :: irr_frac_table ! irrigation fraction + real(kind=kind_noahmp) :: irr_lai_table ! minimum lai to trigger irrigation + real(kind=kind_noahmp) :: irr_mad_table ! management allowable deficit (0-1) + real(kind=kind_noahmp) :: filoss_table ! factor of flood irrigation loss + real(kind=kind_noahmp) :: sprir_rate_table ! mm/h, sprinkler irrigation rate + real(kind=kind_noahmp) :: micir_rate_table ! mm/h, micro irrigation rate + real(kind=kind_noahmp) :: firtfac_table ! flood application rate factor + real(kind=kind_noahmp) :: ir_rain_table ! maximum precipitation to stop irrigation trigger + + ! tile drainage parameters + integer :: drain_layer_opt_table ! tile drainage layer + integer , allocatable, dimension(:) :: td_depth_table ! tile drainage depth (layer number) from soil surface + real(kind=kind_noahmp), allocatable, dimension(:) :: tdsmc_fac_table ! tile drainage soil moisture factor + real(kind=kind_noahmp), allocatable, dimension(:) :: td_dc_table ! tile drainage coefficient [mm/d] + real(kind=kind_noahmp), allocatable, dimension(:) :: td_dcoef_table ! tile drainage coefficient [mm/d] + real(kind=kind_noahmp), allocatable, dimension(:) :: td_d_table ! depth to impervious layer from drain water level [m] + real(kind=kind_noahmp), allocatable, dimension(:) :: td_adepth_table ! actual depth of impervious layer from land surface [m] + real(kind=kind_noahmp), allocatable, dimension(:) :: td_radi_table ! effective radius of drain tubes [m] + real(kind=kind_noahmp), allocatable, dimension(:) :: td_spac_table ! distance between two drain tubes or tiles [m] + real(kind=kind_noahmp), allocatable, dimension(:) :: td_ddrain_table ! tile drainage depth [m] + real(kind=kind_noahmp), allocatable, dimension(:) :: klat_fac_table ! hydraulic conductivity mutiplification factor + + ! crop parameters + integer :: default_crop_table ! default crop index + integer , allocatable, dimension(:) :: pltday_table ! planting date + integer , allocatable, dimension(:) :: hsday_table ! harvest date + real(kind=kind_noahmp), allocatable, dimension(:) :: plantpop_table ! plant density [per ha] - used? + real(kind=kind_noahmp), allocatable, dimension(:) :: irri_table ! irrigation strategy 0= non-irrigation 1=irrigation (no water-stress) + real(kind=kind_noahmp), allocatable, dimension(:) :: gddtbase_table ! base temperature for gdd accumulation [C] + real(kind=kind_noahmp), allocatable, dimension(:) :: gddtcut_table ! upper temperature for gdd accumulation [C] + real(kind=kind_noahmp), allocatable, dimension(:) :: gdds1_table ! gdd from seeding to emergence + real(kind=kind_noahmp), allocatable, dimension(:) :: gdds2_table ! gdd from seeding to initial vegetative + real(kind=kind_noahmp), allocatable, dimension(:) :: gdds3_table ! gdd from seeding to post vegetative + real(kind=kind_noahmp), allocatable, dimension(:) :: gdds4_table ! gdd from seeding to intial reproductive + real(kind=kind_noahmp), allocatable, dimension(:) :: gdds5_table ! gdd from seeding to pysical maturity + real(kind=kind_noahmp), allocatable, dimension(:) :: c3psni_table ! photosynthetic pathway: 0. = c4, 1. = c3 ! Zhe Zhang 2020-07-03 + real(kind=kind_noahmp), allocatable, dimension(:) :: kc25i_table ! co2 michaelis-menten constant at 25c (Pa) + real(kind=kind_noahmp), allocatable, dimension(:) :: akci_table ! q10 for kc25 + real(kind=kind_noahmp), allocatable, dimension(:) :: ko25i_table ! o2 michaelis-menten constant at 25c (Pa) + real(kind=kind_noahmp), allocatable, dimension(:) :: akoi_table ! q10 for ko25 + real(kind=kind_noahmp), allocatable, dimension(:) :: vcmx25i_table ! maximum rate of carboxylation at 25c (umol CO2/m2/s) + real(kind=kind_noahmp), allocatable, dimension(:) :: avcmxi_table ! q10 for vcmx25 + real(kind=kind_noahmp), allocatable, dimension(:) :: bpi_table ! minimum leaf conductance (umol/m2/s) + real(kind=kind_noahmp), allocatable, dimension(:) :: mpi_table ! slope of conductance-to-photosynthesis relationship + real(kind=kind_noahmp), allocatable, dimension(:) :: qe25i_table ! quantum efficiency at 25c (umol CO2 / umol photon) + real(kind=kind_noahmp), allocatable, dimension(:) :: folnmxi_table ! foliage nitrogen concentration when f(n)=1 (%) + real(kind=kind_noahmp), allocatable, dimension(:) :: aref_table ! reference maximum CO2 assimulation rate + real(kind=kind_noahmp), allocatable, dimension(:) :: psnrf_table ! co2 assimulation reduction factor(0-1) (caused by non-modeled part, pest,weeds) + real(kind=kind_noahmp), allocatable, dimension(:) :: i2par_table ! fraction of incoming solar radiation to photosynthetically active radiation + real(kind=kind_noahmp), allocatable, dimension(:) :: tassim0_table ! minimum temperature for CO2 assimulation [C] + real(kind=kind_noahmp), allocatable, dimension(:) :: tassim1_table ! co2 assimulation linearly increasing until temperature reaches t1 [C] + real(kind=kind_noahmp), allocatable, dimension(:) :: tassim2_table ! co2 assmilation rate remain at aref until temperature reaches t2 [C] + real(kind=kind_noahmp), allocatable, dimension(:) :: k_table ! light extinction coefficient + real(kind=kind_noahmp), allocatable, dimension(:) :: epsi_table ! initial light use efficiency + real(kind=kind_noahmp), allocatable, dimension(:) :: q10mr_table ! q10 for maintainance respiration + real(kind=kind_noahmp), allocatable, dimension(:) :: lefreez_table ! characteristic t for leaf freezing [K] + real(kind=kind_noahmp), allocatable, dimension(:,:) :: dile_fc_table ! coeficient for temperature leaf stress death [1/s] + real(kind=kind_noahmp), allocatable, dimension(:,:) :: dile_fw_table ! coeficient for water leaf stress death [1/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: fra_gr_table ! fraction of growth respiration + real(kind=kind_noahmp), allocatable, dimension(:,:) :: lf_ovrc_table ! fraction of leaf turnover [1/s] + real(kind=kind_noahmp), allocatable, dimension(:,:) :: st_ovrc_table ! fraction of stem turnover [1/s] + real(kind=kind_noahmp), allocatable, dimension(:,:) :: rt_ovrc_table ! fraction of root tunrover [1/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: lfmr25_table ! leaf maintenance respiration at 25C [umol CO2/m2/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: stmr25_table ! stem maintenance respiration at 25C [umol CO2/kg bio/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: rtmr25_table ! root maintenance respiration at 25C [umol CO2/kg bio/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: grainmr25_table ! grain maintenance respiration at 25C [umol CO2/kg bio/s] + real(kind=kind_noahmp), allocatable, dimension(:,:) :: lfpt_table ! fraction of carbohydrate flux to leaf + real(kind=kind_noahmp), allocatable, dimension(:,:) :: stpt_table ! fraction of carbohydrate flux to stem + real(kind=kind_noahmp), allocatable, dimension(:,:) :: rtpt_table ! fraction of carbohydrate flux to root + real(kind=kind_noahmp), allocatable, dimension(:,:) :: grainpt_table ! fraction of carbohydrate flux to grain + real(kind=kind_noahmp), allocatable, dimension(:,:) :: lfct_table ! fraction of carbohydrate translocation from leaf to grain + real(kind=kind_noahmp), allocatable, dimension(:,:) :: stct_table ! fraction of carbohydrate translocation from stem to grain + real(kind=kind_noahmp), allocatable, dimension(:,:) :: rtct_table ! fraction of carbohydrate translocation from root to grain + real(kind=kind_noahmp), allocatable, dimension(:) :: bio2lai_table ! leaf area per living leaf biomass [m2/kg] + + ! soil parameters + integer :: slcats_table ! number of soil categories + real(kind=kind_noahmp), allocatable, dimension(:) :: bexp_table ! soil b parameter + real(kind=kind_noahmp), allocatable, dimension(:) :: smcdry_table ! dry soil moisture threshold + real(kind=kind_noahmp), allocatable, dimension(:) :: smcmax_table ! porosity, saturated value of soil moisture (volumetric) + real(kind=kind_noahmp), allocatable, dimension(:) :: smcref_table ! reference soil moisture (field capacity) (volumetric) + real(kind=kind_noahmp), allocatable, dimension(:) :: psisat_table ! saturated soil matric potential + real(kind=kind_noahmp), allocatable, dimension(:) :: dksat_table ! saturated soil hydraulic conductivity + real(kind=kind_noahmp), allocatable, dimension(:) :: dwsat_table ! saturated soil hydraulic diffusivity + real(kind=kind_noahmp), allocatable, dimension(:) :: smcwlt_table ! wilting point soil moisture (volumetric) + real(kind=kind_noahmp), allocatable, dimension(:) :: quartz_table ! soil quartz content + real(kind=kind_noahmp), allocatable, dimension(:) :: bvic_table ! vic model infiltration parameter (-) for opt_run=6 + real(kind=kind_noahmp), allocatable, dimension(:) :: axaj_table ! xinanjiang: tension water distribution inflection parameter [-] for opt_run=7 + real(kind=kind_noahmp), allocatable, dimension(:) :: bxaj_table ! xinanjiang: tension water distribution shape parameter [-] for opt_run=7 + real(kind=kind_noahmp), allocatable, dimension(:) :: xxaj_table ! xinanjiang: free water distribution shape parameter [-] for opt_run=7 + real(kind=kind_noahmp), allocatable, dimension(:) :: bdvic_table ! vic model infiltration parameter (-) + real(kind=kind_noahmp), allocatable, dimension(:) :: gdvic_table ! mean capilary drive (m) + real(kind=kind_noahmp), allocatable, dimension(:) :: bbvic_table ! heterogeniety parameter for dvic infiltration [-] + + ! general parameters + real(kind=kind_noahmp), allocatable, dimension(:) :: slope_table ! slope factor for soil drainage + real(kind=kind_noahmp) :: csoil_table ! Soil heat capacity [J m-3 K-1] + real(kind=kind_noahmp) :: refdk_table ! parameter in the surface runoff parameterization + real(kind=kind_noahmp) :: refkdt_table ! parameter in the surface runoff parameterization + real(kind=kind_noahmp) :: frzk_table ! frozen ground parameter + real(kind=kind_noahmp) :: zbot_table ! depth [m] of lower boundary soil temperature + real(kind=kind_noahmp) :: czil_table ! parameter used in the calculation of the roughness length for heat + + ! optional parameters + real(kind=kind_noahmp) :: sr2006_theta_1500t_a_TABLE ! sand coefficient + real(kind=kind_noahmp) :: sr2006_theta_1500t_b_TABLE ! clay coefficient + real(kind=kind_noahmp) :: sr2006_theta_1500t_c_TABLE ! orgm coefficient + real(kind=kind_noahmp) :: sr2006_theta_1500t_d_TABLE ! sand*orgm coefficient + real(kind=kind_noahmp) :: sr2006_theta_1500t_e_TABLE ! clay*orgm coefficient + real(kind=kind_noahmp) :: sr2006_theta_1500t_f_TABLE ! sand*clay coefficient + real(kind=kind_noahmp) :: sr2006_theta_1500t_g_TABLE ! constant adjustment + real(kind=kind_noahmp) :: sr2006_theta_1500_a_TABLE ! theta_1500t coefficient + real(kind=kind_noahmp) :: sr2006_theta_1500_b_TABLE ! constant adjustment + real(kind=kind_noahmp) :: sr2006_theta_33t_a_TABLE ! sand coefficient + real(kind=kind_noahmp) :: sr2006_theta_33t_b_TABLE ! clay coefficient + real(kind=kind_noahmp) :: sr2006_theta_33t_c_TABLE ! orgm coefficient + real(kind=kind_noahmp) :: sr2006_theta_33t_d_TABLE ! sand*orgm coefficient + real(kind=kind_noahmp) :: sr2006_theta_33t_e_TABLE ! clay*orgm coefficient + real(kind=kind_noahmp) :: sr2006_theta_33t_f_TABLE ! sand*clay coefficient + real(kind=kind_noahmp) :: sr2006_theta_33t_g_TABLE ! constant adjustment + real(kind=kind_noahmp) :: sr2006_theta_33_a_TABLE ! theta_33t*theta_33t coefficient + real(kind=kind_noahmp) :: sr2006_theta_33_b_TABLE ! theta_33t coefficient + real(kind=kind_noahmp) :: sr2006_theta_33_c_TABLE ! constant adjustment + real(kind=kind_noahmp) :: sr2006_theta_s33t_a_TABLE ! sand coefficient + real(kind=kind_noahmp) :: sr2006_theta_s33t_b_TABLE ! clay coefficient + real(kind=kind_noahmp) :: sr2006_theta_s33t_c_TABLE ! orgm coefficient + real(kind=kind_noahmp) :: sr2006_theta_s33t_d_TABLE ! sand*orgm coefficient + real(kind=kind_noahmp) :: sr2006_theta_s33t_e_TABLE ! clay*orgm coefficient + real(kind=kind_noahmp) :: sr2006_theta_s33t_f_TABLE ! sand*clay coefficient + real(kind=kind_noahmp) :: sr2006_theta_s33t_g_TABLE ! constant adjustment + real(kind=kind_noahmp) :: sr2006_theta_s33_a_TABLE ! theta_s33t coefficient + real(kind=kind_noahmp) :: sr2006_theta_s33_b_TABLE ! constant adjustment + real(kind=kind_noahmp) :: sr2006_psi_et_a_TABLE ! sand coefficient + real(kind=kind_noahmp) :: sr2006_psi_et_b_TABLE ! clay coefficient + real(kind=kind_noahmp) :: sr2006_psi_et_c_TABLE ! theta_s33 coefficient + real(kind=kind_noahmp) :: sr2006_psi_et_d_TABLE ! sand*theta_s33 coefficient + real(kind=kind_noahmp) :: sr2006_psi_et_e_TABLE ! clay*theta_s33 coefficient + real(kind=kind_noahmp) :: sr2006_psi_et_f_TABLE ! sand*clay coefficient + real(kind=kind_noahmp) :: sr2006_psi_et_g_TABLE ! constant adjustment + real(kind=kind_noahmp) :: sr2006_psi_e_a_TABLE ! psi_et*psi_et coefficient + real(kind=kind_noahmp) :: sr2006_psi_e_b_TABLE ! psi_et coefficient + real(kind=kind_noahmp) :: sr2006_psi_e_c_TABLE ! constant adjustment + real(kind=kind_noahmp) :: sr2006_smcmax_a_TABLE ! sand adjustment + real(kind=kind_noahmp) :: sr2006_smcmax_b_TABLE ! constant adjustment + + end type NoahmpIO_type + +end module NoahmpIOVarType diff --git a/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/NoahmpInitMainMod.F90 b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/NoahmpInitMainMod.F90 new file mode 100644 index 0000000000..2dfce6bf00 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/NoahmpInitMainMod.F90 @@ -0,0 +1,253 @@ + module NoahmpInitMainMod + +!!! Module to initialize Noah-MP 2-D variables + + use Machine + use NoahmpIOVarType + use NoahmpSnowInitMod + + implicit none + + contains + + subroutine NoahmpInitMain(NoahmpIO) + +! ------------------------ Code history ------------------------------------- +! Original Noah-MP subroutine: NOAHMP_INIT +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! --------------------------------------------------------------------------- + + implicit none + + type(NoahmpIO_type), intent(inout) :: NoahmpIO + +! local variables + integer :: its,ite + integer :: i,ns + integer :: errorflag + logical :: urbanpt_flag + real(kind=kind_noahmp) :: bexp, smcmax, psisat, fk + real(kind=kind_noahmp), parameter :: hlice = 3.335e5 + real(kind=kind_noahmp), parameter :: grav0 = 9.81 + real(kind=kind_noahmp), parameter :: t0 = 273.15 +! --------------------------------------------------------------------------- + +! only initialize for non-restart case: + if ( .not. NoahmpIO%restart_flag ) then + + its = NoahmpIO%its + ite = NoahmpIO%ite + + ! initialize physical snow height SNOWH + if ( .not. NoahmpIO%fndsnowh ) then + ! If no SNOWH do the following + print*, 'SNOW HEIGHT NOT FOUND - VALUE DEFINED IN LSMINIT' + do i = its, ite + NoahmpIO%snowh(i) = NoahmpIO%snow(i)*0.005 ! snow in mm and snowh in m. + enddo + endif + + ! Check if snow/snowh are consistent and cap SWE at 2000mm + ! the Noah-MP code does it internally but if we don't do it here, problems ensue + do i = its, its + if ( NoahmpIO%snow(i) < 0.0 ) NoahmpIO%snow(i) = 0.0 + if ( NoahmpIO%snowh(i) < 0.0 ) NoahmpIO%snowh(i) = 0.0 + if ( (NoahmpIO%snow(i) > 0.0) .and. (NoahmpIO%snowh(i) == 0.0) ) & + NoahmpIO%snowh(i) = NoahmpIO%snow(i) * 0.005 + if ( (NoahmpIO%snowh(i) > 0.0) .and. (NoahmpIO%snow(i) == 0.0) ) & + NoahmpIO%snow(i) = NoahmpIO%snowh(i) / 0.005 + if ( NoahmpIO%snow(i) > 2000.0 ) then + NoahmpIO%snowh(i) = NoahmpIO%snowh(i) * 2000.0 / NoahmpIO%snow(i) !snow in mm and snowh in m. + NoahmpIO%snow (i) = 2000.0 !cap snow at 2000 to maintain + !density. + endif + enddo + + ! check soil type: + errorflag = 0 + do i = its, ite + if ( NoahmpIO%isltyp(i) < 1 ) then + errorflag = 1 + write(*,*) "LSMINIT: OUT OF RANGE ISLTYP ",i,NoahmpIO%isltyp(i) + stop + endif + enddo + + ! initialize soil liquid water content SH2O: + do i = its , ite + if ( (NoahmpIO%ivgtyp(i) == NoahmpIO%isice_table) .and. & + (NoahmpIO%xice(i) <= 0.0) ) then + do ns = 1, NoahmpIO%nsoil + NoahmpIO%smois(i,ns) = 1.0 ! glacier starts all frozen + NoahmpIO%sh2o(i,ns) = 0.0 + NoahmpIO%tslb(i,ns) = min(NoahmpIO%tslb(i,ns), 263.15) !set glacier temp to at most -10c + enddo + !NoahmpIO%tmn(i) = min(NoahmpIO%tmn(i), 263.15) !set deep temp to at most -10C + NoahmpIO%snow(i) = max(NoahmpIO%snow(i), 10.0) !set swe to at least 10mm + NoahmpIO%snowh(i) = NoahmpIO%snow(i) * 0.01 !snow in mm and snowh in m + else + bexp = NoahmpIO%bexp_table (NoahmpIO%isltyp(i)) + smcmax = NoahmpIO%smcmax_table(NoahmpIO%isltyp(i)) + psisat = NoahmpIO%psisat_table(NoahmpIO%isltyp(i)) + do ns = 1, NoahmpIO%nsoil + if ( NoahmpIO%smois(i,ns) > smcmax ) NoahmpIO%smois(i,ns) = smcmax + enddo + if ( (bexp > 0.0) .and. (smcmax > 0.0) .and. (psisat > 0.0) ) then + do ns = 1, NoahmpIO%nsoil + if ( NoahmpIO%tslb(i,ns) < 273.149 ) then + fk = (((hlice / (grav0*(-psisat))) * & + ((NoahmpIO%tslb(i,ns)-t0) / NoahmpIO%tslb(i,ns)))**(-1/bexp))*smcmax + fk = max(fk, 0.02) + NoahmpIO%sh2o(i,ns) = min(fk, NoahmpIO%smois(i,ns)) + else + NoahmpIO%sh2o(i,ns) = NoahmpIO%smois(i,ns) + endif + enddo + else + do ns = 1, NoahmpIO%nsoil + NoahmpIO%sh2o(i,ns) = NoahmpIO%smois(i,ns) + enddo + endif + endif + enddo + + ! initialize other quantities: + do i = its, ite + NoahmpIO%qtdrain(i) = 0.0 + NoahmpIO%tvxy(i) = NoahmpIO%tsk(i) + NoahmpIO%tgxy(i) = NoahmpIO%tsk(i) + if ( (NoahmpIO%snow(i) > 0.0) .and. (NoahmpIO%tsk(i) > t0) ) NoahmpIO%tvxy(i) = t0 + if ( (NoahmpIO%snow(i) > 0.0) .and. (NoahmpIO%tsk(i) > t0) ) NoahmpIO%tgxy(i) = t0 + + NoahmpIO%canwat(i) = 0.0 + NoahmpIO%canliqxy(i) = NoahmpIO%canwat(i) + NoahmpIO%canicexy(i) = 0.0 + NoahmpIO%eahxy(i) = 2000.0 + NoahmpIO%tahxy(i) = NoahmpIO%tsk(i) + NoahmpIO%t2mvxy(i) = NoahmpIO%tsk(i) + NoahmpIO%t2mbxy(i) = NoahmpIO%tsk(i) + if ( (NoahmpIO%snow(i) > 0.0) .and. (NoahmpIO%tsk(i) > t0) ) NoahmpIO%tahxy(i) = t0 + if ( (NoahmpIO%snow(i) > 0.0) .and. (NoahmpIO%tsk(i) > t0) ) NoahmpIO%t2mvxy(i) = t0 + if ( (NoahmpIO%snow(i) > 0.0) .and. (NoahmpIO%tsk(i) > t0) ) NoahmpIO%t2mbxy(i) = t0 + + NoahmpIO%cmxy(i) = 0.0 + NoahmpIO%chxy(i) = 0.0 + NoahmpIO%fwetxy(i) = 0.0 + NoahmpIO%sneqvoxy(i) = 0.0 + NoahmpIO%alboldxy(i) = 0.65 + NoahmpIO%qsnowxy(i) = 0.0 + NoahmpIO%qrainxy(i) = 0.0 + NoahmpIO%wslakexy(i) = 0.0 + + if ( NoahmpIO%iopt_runsub /= 5 ) then + NoahmpIO%waxy(i) = 4900.0 + NoahmpIO%wtxy(i) = NoahmpIO%waxy(i) + NoahmpIO%zwtxy(i) = (25.0 + 2.0) - NoahmpIO%waxy(i)/1000/0.2 + else + NoahmpIO%waxy(i) = 0.0 + NoahmpIO%wtxy(i) = 0.0 + endif + + urbanpt_flag = .false. + if ( (NoahmpIO%ivgtyp(i) == NoahmpIO%isurban_table) .or. & + (NoahmpIO%ivgtyp(i) > NoahmpIO%urbtype_beg) ) then + urbanpt_flag = .true. + endif + + if ( (NoahmpIO%ivgtyp(i) == NoahmpIO%isbarren_table) .or. & + (NoahmpIO%ivgtyp(i) == NoahmpIO%isice_table) .or. & + ((NoahmpIO%sf_urban_physics == 0) .and. (urbanpt_flag .eqv. .true.)) .or. & + (NoahmpIO%ivgtyp(i) == NoahmpIO%iswater_table )) then + NoahmpIO%lai(i) = 0.0 + NoahmpIO%xsaixy(i) = 0.0 + NoahmpIO%lfmassxy(i) = 0.0 + NoahmpIO%stmassxy(i) = 0.0 + NoahmpIO%rtmassxy(i) = 0.0 + NoahmpIO%woodxy(i) = 0.0 + NoahmpIO%stblcpxy(i) = 0.0 + NoahmpIO%fastcpxy(i) = 0.0 + NoahmpIO%grainxy(i) = 1.0e-10 + NoahmpIO%gddxy(i) = 0 + NoahmpIO%cropcat(i) = 0 + else + if ( (NoahmpIO%lai(i) > 100) .or. (NoahmpIO%lai(i) < 0) ) NoahmpIO%lai(i) = 0.0 + NoahmpIO%lai(i) = max(NoahmpIO%lai(i), 0.05) !at least start with 0.05 for arbitrary initialization (v3.7) + NoahmpIO%xsaixy(i) = max(0.1*NoahmpIO%lai(i), 0.05) !mb: arbitrarily initialize sai using input lai (v3.7) + NoahmpIO%lfmassxy(i) = NoahmpIO%lai(i) * 1000.0 / & + max(NoahmpIO%sla_table(NoahmpIO%ivgtyp(i)),1.0) !use lai to initialize (v3.7) + NoahmpIO%stmassxy(i) = NoahmpIO%xsaixy(i) * 1000.0 / 3.0 !use sai to initialize (v3.7) + NoahmpIO%rtmassxy(i) = 500.0 !these are all arbitrary and probably should be + NoahmpIO%woodxy(i) = 500.0 !in the table or read from initialization + NoahmpIO%stblcpxy(i) = 1000.0 + NoahmpIO%fastcpxy(i) = 1000.0 + NoahmpIO%grainxy(i) = 1.0e-10 + NoahmpIO%gddxy(i) = 0 + + ! initialize crop for crop model: + if ( NoahmpIO%iopt_crop == 1 ) then + NoahmpIO%cropcat(i) = NoahmpIO%default_crop_table + if ( NoahmpIO%croptype(i,5) >= 0.5 ) then + NoahmpIO%rtmassxy(i) = 0.0 + NoahmpIO%woodxy (i) = 0.0 + if ( (NoahmpIO%croptype(i,1) > NoahmpIO%croptype(i,2)) .and. & + (NoahmpIO%croptype(i,1) > NoahmpIO%croptype(i,3)) .and. & + (NoahmpIO%croptype(i,1) > NoahmpIO%croptype(i,4)) ) then !choose corn + NoahmpIO%cropcat(i) = 1 + NoahmpIO%lfmassxy(i) = NoahmpIO%lai(i) / 0.015 !initialize lfmass zhe zhang 2020-07-13 + NoahmpIO%stmassxy(i) = NoahmpIO%xsaixy(i) / 0.003 + elseif ( (NoahmpIO%croptype(i,2) > NoahmpIO%croptype(i,1)) .and. & + (NoahmpIO%croptype(i,2) > NoahmpIO%croptype(i,3)) .and. & + (NoahmpIO%croptype(i,2) > NoahmpIO%croptype(i,4)) ) then!choose soybean + NoahmpIO%cropcat(i) = 2 + NoahmpIO%lfmassxy(i) = NoahmpIO%lai(i) / 0.030 !initialize lfmass zhe zhang 2020-07-13 + NoahmpIO%stmassxy(i) = NoahmpIO%xsaixy(i) / 0.003 + else + NoahmpIO%cropcat(i) = NoahmpIO%default_crop_table + NoahmpIO%lfmassxy(i) = NoahmpIO%lai(i) / 0.035 + NoahmpIO%stmassxy(i) = NoahmpIO%xsaixy(i) / 0.003 + endif + endif + endif + + ! Noah-MP irrigation scheme: + if ( (NoahmpIO%iopt_irr >= 1) .and. (NoahmpIO%iopt_irr <= 3) ) then + if ( (NoahmpIO%iopt_irrm == 0) .or. (NoahmpIO%iopt_irrm ==1) ) then ! sprinkler + NoahmpIO%irnumsi(i) = 0 + NoahmpIO%irwatsi(i) = 0.0 + NoahmpIO%ireloss(i) = 0.0 + NoahmpIO%irrsplh(i) = 0.0 + elseif ( (NoahmpIO%iopt_irrm == 0) .or. (NoahmpIO%iopt_irrm == 2) ) then ! micro or drip + NoahmpIO%irnummi(i) = 0 + NoahmpIO%irwatmi(i) = 0.0 + NoahmpIO%irmivol(i) = 0.0 + elseif ( (NoahmpIO%iopt_irrm == 0) .or. (NoahmpIO%iopt_irrm == 3) ) then ! flood + NoahmpIO%irnumfi(i) = 0 + NoahmpIO%irwatfi(i) = 0.0 + NoahmpIO%irfivol(i) = 0.0 + endif + endif + endif + enddo + + ! Given the soil layer thicknesses (in DZS), initialize the soil layer + ! depths from the surface: + NoahmpIO%zsoil(1) = -NoahmpIO%dzs(1) ! negative + do ns = 2, NoahmpIO%nsoil + NoahmpIO%zsoil(ns) = NoahmpIO%zsoil(ns-1) - NoahmpIO%dzs(ns) + enddo + + ! initialize noah-mp snow + call NoahmpSnowInitMain(NoahmpIO) + + !initialize arrays for groundwater dynamics iopt_runsub=5 + if ( NoahmpIO%iopt_runsub == 5 ) then + NoahmpIO%stepwtd = nint(NoahmpIO%wtddt * 60.0 / NoahmpIO%dtbl) + NoahmpIO%stepwtd = max(NoahmpIO%stepwtd,1) + endif + + endif ! NoahmpIO%restart_flag + + end subroutine NoahmpInitMain + + end module NoahmpInitMainMod diff --git a/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/NoahmpReadNamelistMod.F90 b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/NoahmpReadNamelistMod.F90 new file mode 100644 index 0000000000..439e9161b5 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/NoahmpReadNamelistMod.F90 @@ -0,0 +1,397 @@ +module NoahmpReadNamelistMod + +!!! Initialize Noah-MP namelist variables +!!! Namelist variables should be first defined in NoahmpIOVarType.F90 + +! ------------------------ Code history ----------------------------------- +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + use Machine + use NoahmpIOVarType + + implicit none + +contains + +!=== read namelist values + + subroutine NoahmpReadNamelist(NoahmpIO) + + implicit none + + type(NoahmpIO_type), intent(inout) :: NoahmpIO + +!--------------------------------------------------------------------- +! NAMELIST start +!--------------------------------------------------------------------- + + ! local namelist variables + + character(len=256) :: indir = '.' + integer :: ierr + integer :: NSOIL ! number of soil layers + integer :: forcing_timestep + integer :: noah_timestep + integer :: start_year + integer :: start_month + integer :: start_day + integer :: start_hour + integer :: start_min + character(len=256) :: outdir = "." + character(len=256) :: restart_filename_requested = " " + integer :: restart_frequency_hours + integer :: output_timestep + integer :: spinup_loops = 0 + integer :: sf_urban_physics = 0 + integer :: use_wudapt_lcz = 0 ! add for LCZ urban + integer :: num_urban_ndm = 2 + integer :: num_urban_ng = 10 + integer :: num_urban_nwr = 10 + integer :: num_urban_ngb = 10 + integer :: num_urban_nf = 10 + integer :: num_urban_nz = 18 + integer :: num_urban_nbui = 15 + integer :: num_urban_hi = 15 + integer :: num_urban_ngr = 10 ! = ngr_u in bep_bem.F + integer :: noahmp_output = 0 + real(kind=kind_noahmp) :: urban_atmosphere_thickness = 2.0 + real(kind=kind_noahmp) :: soil_timestep = 0.0 ! soil timestep (default=0: same as main noahmp timestep) + + ! derived urban dimensions + 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 = "" + integer :: dynamic_veg_option = 4 + integer :: canopy_stomatal_resistance_option = 1 + integer :: btr_option = 1 + integer :: surface_runoff_option = 3 + integer :: subsurface_runoff_option = 3 + integer :: surface_drag_option = 1 + integer :: supercooled_water_option = 1 + integer :: frozen_soil_option = 1 + integer :: radiative_transfer_option = 3 + integer :: snow_albedo_option = 1 + integer :: snow_thermal_conductivity = 1 + integer :: pcp_partition_option = 1 + integer :: tbot_option = 2 + integer :: temp_time_scheme_option = 1 + integer :: glacier_option = 1 + integer :: surface_resistance_option = 1 + integer :: soil_data_option = 1 + integer :: pedotransfer_option = 1 + integer :: crop_option = 0 + integer :: irrigation_option = 0 + integer :: irrigation_method = 0 + integer :: dvic_infiltration_option = 1 + integer :: tile_drainage_option = 0 + integer :: split_output_count = 1 + logical :: skip_first_output = .false. + integer :: khour = -9999 + integer :: kday = -9999 + real(kind=kind_noahmp) :: zlvl = 10. + character(len=256) :: hrldas_setup_file = " " + character(len=256) :: spatial_filename = " " + character(len=256) :: external_veg_filename_template = " " + character(len=256) :: external_lai_filename_template = " " + character(len=256) :: agdata_flnm = " " + character(len=256) :: tdinput_flnm = " " + integer, parameter :: MAX_SOIL_LEVELS = 10 ! maximum soil levels in namelist + real(kind=kind_noahmp), dimension(MAX_SOIL_LEVELS) :: soil_thick_input ! depth to soil interfaces from namelist [m] + + namelist / NOAHLSM_OFFLINE / & +#ifdef WRF_HYDRO + finemesh,finemesh_factor,forc_typ, snow_assim , GEO_STATIC_FLNM, HRLDAS_ini_typ, & +#endif + indir, nsoil, soil_thick_input, forcing_timestep, noah_timestep, soil_timestep, & + start_year, start_month, start_day, start_hour, start_min, & + outdir, skip_first_output, noahmp_output, & + restart_filename_requested, restart_frequency_hours, output_timestep, & + spinup_loops, & + 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, & + dynamic_veg_option, canopy_stomatal_resistance_option, & + btr_option, surface_drag_option, supercooled_water_option, & + frozen_soil_option, radiative_transfer_option, snow_albedo_option, & + snow_thermal_conductivity, surface_runoff_option, subsurface_runoff_option, & + pcp_partition_option, tbot_option, temp_time_scheme_option, & + glacier_option, surface_resistance_option, & + irrigation_option, irrigation_method, dvic_infiltration_option, & + tile_drainage_option,soil_data_option, pedotransfer_option, crop_option, & + sf_urban_physics,use_wudapt_lcz,num_urban_hi,urban_atmosphere_thickness, & + num_urban_ndm,num_urban_ng,num_urban_nwr ,num_urban_ngb , & + num_urban_nf ,num_urban_nz,num_urban_nbui,num_urban_ngr , & + split_output_count, & + khour, kday, zlvl, hrldas_setup_file, & + spatial_filename, agdata_flnm, tdinput_flnm, & + external_veg_filename_template, external_lai_filename_template + + + !--------------------------------------------------------------- + ! Initialize namelist variables to dummy values, so we can tell + ! if they have not been set properly. + !--------------------------------------------------------------- + if (.not. allocated(NoahmpIO%soil_thick_input)) allocate(NoahmpIO%soil_thick_input(1:MAX_SOIL_LEVELS)) + NoahmpIO%nsoil = undefined_int + NoahmpIO%soil_thick_input = undefined_real + NoahmpIO%DTBL = undefined_real + NoahmpIO%soiltstep = undefined_real + NoahmpIO%start_year = undefined_int + NoahmpIO%start_month = undefined_int + NoahmpIO%start_day = undefined_int + NoahmpIO%start_hour = undefined_int + NoahmpIO%start_min = undefined_int + NoahmpIO%khour = undefined_int + NoahmpIO%kday = undefined_int + NoahmpIO%zlvl = undefined_real + NoahmpIO%forcing_timestep = undefined_int + NoahmpIO%noah_timestep = undefined_int + NoahmpIO%output_timestep = undefined_int + NoahmpIO%restart_frequency_hours = undefined_int + NoahmpIO%spinup_loops = 0 + NoahmpIO%noahmp_output = 0 + + !--------------------------------------------------------------- + ! read namelist.input + !--------------------------------------------------------------- + + open(30, file="namelist.hrldas", form="FORMATTED") + read(30, NOAHLSM_OFFLINE, iostat=ierr) + if (ierr /= 0) then + write(*,'(/," ***** ERROR: Problem reading namelist NOAHLSM_OFFLINE",/)') + rewind(30) + read(30, NOAHLSM_OFFLINE) + stop " ***** ERROR: Problem reading namelist NOAHLSM_OFFLINE" + endif + close(30) + + NoahmpIO%DTBL = real(noah_timestep) + NoahmpIO%soiltstep = soil_timestep + NoahmpIO%NSOIL = nsoil + + !--------------------------------------------------------------------- + ! NAMELIST end + !--------------------------------------------------------------------- + + !--------------------------------------------------------------------- + ! NAMELIST check begin + !--------------------------------------------------------------------- + NoahmpIO%update_lai = .true. ! default: use LAI if present in forcing file + if(dynamic_veg_option == 1 .or. dynamic_veg_option == 2 .or. & + dynamic_veg_option == 3 .or. dynamic_veg_option == 4 .or. & + dynamic_veg_option == 5 .or. dynamic_veg_option == 6) & ! remove dveg=10 and add dveg=1,3,4 into the update_lai flag false condition + NoahmpIO%update_lai = .false. + + NoahmpIO%update_veg = .false. ! default: don't use VEGFRA if present in forcing file + if (dynamic_veg_option == 1 .or. dynamic_veg_option == 6 .or. dynamic_veg_option == 7) & + NoahmpIO%update_veg = .true. + + if (nsoil < 0) then + stop " ***** ERROR: NSOIL must be set in the namelist." + endif + + if ((khour < 0) .and. (kday < 0)) then + write(*, '(" ***** Namelist error: ************************************")') + write(*, '(" ***** ")') + write(*, '(" ***** Either KHOUR or KDAY must be defined.")') + write(*, '(" ***** ")') + stop + else if (( khour < 0 ) .and. (kday > 0)) then + khour = kday * 24 + else if ((khour > 0) .and. (kday > 0)) then + write(*, '("Namelist warning: KHOUR and KDAY both defined.")') + else + ! all is well. KHOUR defined + endif + + if (forcing_timestep < 0) then + write(*, *) + write(*, '(" ***** Namelist error: *****************************************")') + write(*, '(" ***** ")') + write(*, '(" ***** FORCING_TIMESTEP needs to be set greater than zero.")') + write(*, '(" ***** ")') + write(*, *) + stop + endif + + if (noah_timestep < 0) then + write(*, *) + write(*, '(" ***** Namelist error: *****************************************")') + write(*, '(" ***** ")') + write(*, '(" ***** NOAH_TIMESTEP needs to be set greater than zero.")') + write(*, '(" ***** 900 seconds is recommended. ")') + write(*, '(" ***** ")') + write(*, *) + stop + endif + + ! + ! Check that OUTPUT_TIMESTEP fits into NOAH_TIMESTEP: + ! + if (output_timestep /= 0) then + if (mod(output_timestep, noah_timestep) > 0) then + write(*, *) + write(*, '(" ***** Namelist error: *********************************************************")') + write(*, '(" ***** ")') + write(*, '(" ***** OUTPUT_TIMESTEP should set to an integer multiple of NOAH_TIMESTEP.")') + write(*, '(" ***** OUTPUT_TIMESTEP = ", I12, " seconds")') output_timestep + write(*, '(" ***** NOAH_TIMESTEP = ", I12, " seconds")') noah_timestep + write(*, '(" ***** ")') + write(*, *) + stop + endif + endif + + ! + ! Check that RESTART_FREQUENCY_HOURS fits into NOAH_TIMESTEP: + ! + if (restart_frequency_hours /= 0) then + if (mod(restart_frequency_hours*3600, noah_timestep) > 0) then + write(*, *) + write(*, '(" ***** Namelist error: ******************************************************")') + write(*, '(" ***** ")') + write(*, '(" ***** RESTART_FREQUENCY_HOURS (converted to seconds) should set to an ")') + write(*, '(" ***** integer multiple of NOAH_TIMESTEP.")') + write(*, '(" ***** RESTART_FREQUENCY_HOURS = ", I12, " hours: ", I12, " seconds")') & + restart_frequency_hours, restart_frequency_hours*3600 + write(*, '(" ***** NOAH_TIMESTEP = ", I12, " seconds")') noah_timestep + write(*, '(" ***** ")') + write(*, *) + stop + endif + endif + + if (dynamic_veg_option == 2 .or. dynamic_veg_option == 5 .or. dynamic_veg_option == 6) then + if ( canopy_stomatal_resistance_option /= 1) then + write(*, *) + write(*, '(" ***** Namelist error: ******************************************************")') + write(*, '(" ***** ")') + write(*, '(" ***** CANOPY_STOMATAL_RESISTANCE_OPTION must be 1 when DYNAMIC_VEG_OPTION == 2/5/6")') + write(*, *) + stop + endif + endif + + if (soil_data_option == 4 .and. spatial_filename == " ") then + write(*, *) + write(*, '(" ***** Namelist error: ******************************************************")') + write(*, '(" ***** ")') + write(*, '(" ***** SPATIAL_FILENAME must be provided when SOIL_DATA_OPTION == 4")') + write(*, *) + stop + endif + + if (sf_urban_physics == 2 .or. sf_urban_physics == 3) then + if ( urban_atmosphere_thickness <= 0.0) then + write(*, *) + write(*, '(" ***** Namelist error: ******************************************************")') + write(*, '(" ***** ")') + write(*, '(" ***** When running BEP/BEM, URBAN_ATMOSPHERE_LEVELS must contain at least 3 levels")') + write(*, *) + stop + endif + NoahmpIO%num_urban_atmosphere = int(zlvl/urban_atmosphere_thickness) + if (zlvl - NoahmpIO%num_urban_atmosphere*urban_atmosphere_thickness >= 0.5*urban_atmosphere_thickness) & + NoahmpIO%num_urban_atmosphere = NoahmpIO%num_urban_atmosphere + 1 + if ( NoahmpIO%num_urban_atmosphere <= 2) then + write(*, *) + write(*, '(" ***** Namelist error: ******************************************************")') + write(*, '(" ***** ")') + write(*, '(" ***** When running BEP/BEM, num_urban_atmosphere must contain at least 3 levels, ")') + write(*, '(" ***** decrease URBAN_ATMOSPHERE_THICKNESS")') + write(*, *) + stop + endif + endif + + !--------------------------------------------------------------------- + ! Transfer Namelist locals to input data structure + !--------------------------------------------------------------------- + ! physics option + NoahmpIO%IOPT_DVEG = dynamic_veg_option + NoahmpIO%IOPT_CRS = canopy_stomatal_resistance_option + NoahmpIO%IOPT_BTR = btr_option + NoahmpIO%IOPT_RUNSRF = surface_runoff_option + NoahmpIO%IOPT_RUNSUB = subsurface_runoff_option + NoahmpIO%IOPT_SFC = surface_drag_option + NoahmpIO%IOPT_FRZ = supercooled_water_option + NoahmpIO%IOPT_INF = frozen_soil_option + NoahmpIO%IOPT_RAD = radiative_transfer_option + NoahmpIO%IOPT_ALB = snow_albedo_option + NoahmpIO%IOPT_SNF = pcp_partition_option + NoahmpIO%IOPT_TKSNO = snow_thermal_conductivity + NoahmpIO%IOPT_TBOT = tbot_option + NoahmpIO%IOPT_STC = temp_time_scheme_option + NoahmpIO%IOPT_GLA = glacier_option + NoahmpIO%IOPT_RSF = surface_resistance_option + NoahmpIO%IOPT_SOIL = soil_data_option + NoahmpIO%IOPT_PEDO = pedotransfer_option + NoahmpIO%IOPT_CROP = crop_option + NoahmpIO%IOPT_IRR = irrigation_option + NoahmpIO%IOPT_IRRM = irrigation_method + NoahmpIO%IOPT_INFDV = dvic_infiltration_option + NoahmpIO%IOPT_TDRN = tile_drainage_option + ! basic model setup variables + NoahmpIO%indir = indir + NoahmpIO%forcing_timestep = forcing_timestep + NoahmpIO%noah_timestep = noah_timestep + NoahmpIO%start_year = start_year + NoahmpIO%start_month = start_month + NoahmpIO%start_day = start_day + NoahmpIO%start_hour = start_hour + NoahmpIO%start_min = start_min + NoahmpIO%outdir = outdir + NoahmpIO%noahmp_output = noahmp_output + NoahmpIO%restart_filename_requested = restart_filename_requested + NoahmpIO%restart_frequency_hours = restart_frequency_hours + NoahmpIO%output_timestep = output_timestep + NoahmpIO%spinup_loops = spinup_loops + NoahmpIO%sf_urban_physics = sf_urban_physics + NoahmpIO%use_wudapt_lcz = use_wudapt_lcz + NoahmpIO%num_urban_ndm = num_urban_ndm + NoahmpIO%num_urban_ng = num_urban_ng + NoahmpIO%num_urban_nwr = num_urban_nwr + NoahmpIO%num_urban_ngb = num_urban_ngb + NoahmpIO%num_urban_nf = num_urban_nf + NoahmpIO%num_urban_nz = num_urban_nz + NoahmpIO%num_urban_nbui = num_urban_nbui + NoahmpIO%num_urban_hi = num_urban_hi + NoahmpIO%urban_atmosphere_thickness = urban_atmosphere_thickness + NoahmpIO%num_urban_ngr = num_urban_ngr + NoahmpIO%forcing_name_T = forcing_name_T + NoahmpIO%forcing_name_Q = forcing_name_Q + NoahmpIO%forcing_name_U = forcing_name_U + NoahmpIO%forcing_name_V = forcing_name_V + NoahmpIO%forcing_name_P = forcing_name_P + NoahmpIO%forcing_name_LW = forcing_name_LW + NoahmpIO%forcing_name_SW = forcing_name_SW + NoahmpIO%forcing_name_PR = forcing_name_PR + NoahmpIO%forcing_name_SN = forcing_name_SN + NoahmpIO%split_output_count = split_output_count + NoahmpIO%skip_first_output = skip_first_output + NoahmpIO%khour = khour + NoahmpIO%kday = kday + NoahmpIO%zlvl = zlvl + NoahmpIO%hrldas_setup_file = hrldas_setup_file + NoahmpIO%spatial_filename = spatial_filename + NoahmpIO%external_veg_filename_template = external_veg_filename_template + NoahmpIO%external_lai_filename_template = external_lai_filename_template + NoahmpIO%agdata_flnm = agdata_flnm + NoahmpIO%tdinput_flnm = tdinput_flnm + NoahmpIO%MAX_SOIL_LEVELS = MAX_SOIL_LEVELS + NoahmpIO%soil_thick_input = soil_thick_input + +!--------------------------------------------------------------------- +! NAMELIST check end +!--------------------------------------------------------------------- + + end subroutine NoahmpReadNamelist + +end module NoahmpReadNamelistMod diff --git a/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/NoahmpReadTableMod.F90 b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/NoahmpReadTableMod.F90 new file mode 100644 index 0000000000..eb01ceb2fa --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/NoahmpReadTableMod.F90 @@ -0,0 +1,1182 @@ +module NoahmpReadTableMod + +!!! Initialize Noah-MP look-up table variables +!!! Table variables should be first defined in NoahmpIOVarType.F90 + +! ------------------------ Code history ----------------------------------- +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + use Machine + use NoahmpIOVarType + + implicit none + +contains + +!=== read Noahmp Table values + + subroutine NoahmpReadTable(NoahmpIO) + + implicit none + + type(NoahmpIO_type), intent(inout) :: NoahmpIO + + !------------------------------------------------------- + !=== define key dimensional variables + !------------------------------------------------------- + integer, parameter :: MVT = 27 ! number of vegetation types + integer, parameter :: MBAND = 2 ! number of radiation bands + integer, parameter :: MSC = 8 ! number of soil texture + integer, parameter :: MAX_SOILTYP = 30 ! max number of soil types + integer, parameter :: NCROP = 5 ! number of crop types + integer, parameter :: NSTAGE = 8 ! number of crop growth stages + integer, parameter :: NUM_SLOPE = 9 ! number of slope + + !------------------------------------------------------- + !=== define local variables to store NoahmpTable values + !------------------------------------------------------- + + ! vegetation parameters + character(len=256) :: DATASET_IDENTIFIER + character(len=256) :: VEG_DATASET_DESCRIPTION + logical :: file_named + integer :: ierr, IK, IM + integer :: NVEG, ISURBAN, ISWATER, ISBARREN, ISICE, ISCROP, EBLFOREST, NATURAL, URBTYPE_beg + integer :: LCZ_1, LCZ_2, LCZ_3, LCZ_4, LCZ_5, LCZ_6, LCZ_7, LCZ_8, LCZ_9, LCZ_10, LCZ_11 + real(kind=kind_noahmp), dimension(MVT) :: SAI_JAN, SAI_FEB, SAI_MAR, SAI_APR, SAI_MAY, SAI_JUN, SAI_JUL, SAI_AUG, & + SAI_SEP, SAI_OCT, SAI_NOV, SAI_DEC, LAI_JAN, LAI_FEB, LAI_MAR, LAI_APR, & + LAI_MAY, LAI_JUN, LAI_JUL, LAI_AUG, LAI_SEP, LAI_OCT, LAI_NOV, LAI_DEC, & + RHOL_VIS, RHOL_NIR, RHOS_VIS, RHOS_NIR, TAUL_VIS, TAUL_NIR, TAUS_VIS, TAUS_NIR,& + CH2OP, DLEAF, Z0MVT, HVT, HVB, DEN, RC, MFSNO, SCFFAC, XL, CWPVT, C3PSN, KC25, & + AKC, KO25, AKO, AVCMX, AQE, LTOVRC, DILEFC, DILEFW, RMF25, SLA, FRAGR, TMIN, & + VCMX25, TDLEF, BP, MP, QE25, RMS25, RMR25, ARM, FOLNMX, WDPOOL, WRRAT, MRP, & + NROOT, RGL, RS, HS, TOPT, RSMAX, RTOVRC, RSWOODC, BF, WSTRC, LAIMIN, CBIOM, & + XSAMIN + namelist / noahmp_usgs_veg_categories / VEG_DATASET_DESCRIPTION, NVEG + namelist / noahmp_usgs_parameters / ISURBAN, ISWATER, ISBARREN, ISICE, ISCROP, EBLFOREST, NATURAL, URBTYPE_beg, & + LCZ_1, LCZ_2, LCZ_3, LCZ_4, LCZ_5, LCZ_6, LCZ_7, LCZ_8, LCZ_9, LCZ_10, LCZ_11, & + CH2OP, DLEAF, Z0MVT, HVT, HVB, DEN, RC, MFSNO, SCFFAC, XL, CWPVT, C3PSN, KC25, & + AKC, KO25, AKO, AVCMX, AQE, LTOVRC, DILEFC, DILEFW, RMF25, SLA, FRAGR, TMIN, & + VCMX25, TDLEF, BP, MP, QE25, RMS25, RMR25, ARM, FOLNMX, WDPOOL, WRRAT, MRP, & + NROOT, RGL, RS, HS, TOPT, RSMAX, RTOVRC, RSWOODC, BF, WSTRC, LAIMIN, CBIOM, & + XSAMIN, SAI_JAN, SAI_FEB, SAI_MAR, SAI_APR, SAI_MAY, & + SAI_JUN, SAI_JUL, SAI_AUG, SAI_SEP, SAI_OCT, SAI_NOV, SAI_DEC, LAI_JAN, & + LAI_FEB, LAI_MAR, LAI_APR, LAI_MAY, LAI_JUN, LAI_JUL, LAI_AUG, LAI_SEP, & + LAI_OCT, LAI_NOV, LAI_DEC, RHOL_VIS, RHOL_NIR, RHOS_VIS, RHOS_NIR, TAUL_VIS, & + TAUL_NIR, TAUS_VIS, TAUS_NIR + namelist / noahmp_modis_veg_categories / VEG_DATASET_DESCRIPTION, NVEG + namelist / noahmp_modis_parameters / ISURBAN, ISWATER, ISBARREN, ISICE, ISCROP, EBLFOREST, NATURAL, URBTYPE_beg, & + LCZ_1, LCZ_2, LCZ_3, LCZ_4, LCZ_5, LCZ_6, LCZ_7, LCZ_8, LCZ_9, LCZ_10, LCZ_11, & + CH2OP, DLEAF, Z0MVT, HVT, HVB, DEN, RC, MFSNO, SCFFAC, XL, CWPVT, C3PSN, KC25, & + AKC, KO25, AKO, AVCMX, AQE, LTOVRC, DILEFC, DILEFW, RMF25, SLA, FRAGR, TMIN, & + VCMX25, TDLEF, BP, MP, QE25, RMS25, RMR25, ARM, FOLNMX, WDPOOL, WRRAT, MRP, & + NROOT, RGL, RS, HS, TOPT, RSMAX, RTOVRC, RSWOODC, BF, WSTRC, LAIMIN, CBIOM, & + XSAMIN, SAI_JAN, SAI_FEB, SAI_MAR, SAI_APR, SAI_MAY, & + SAI_JUN, SAI_JUL, SAI_AUG, SAI_SEP, SAI_OCT, SAI_NOV, SAI_DEC, LAI_JAN, & + LAI_FEB, LAI_MAR, LAI_APR, LAI_MAY, LAI_JUN, LAI_JUL, LAI_AUG, LAI_SEP, & + LAI_OCT, LAI_NOV, LAI_DEC, RHOL_VIS, RHOL_NIR, RHOS_VIS, RHOS_NIR, TAUL_VIS, & + TAUL_NIR, TAUS_VIS, TAUS_NIR + + ! soil parameters + character(len=256) :: message + character(len=10) :: SLTYPE + integer :: SLCATS + real(kind=kind_noahmp), dimension(MAX_SOILTYP) :: BB, DRYSMC, MAXSMC, REFSMC, SATPSI, SATDK, SATDW, WLTSMC, QTZ, & + BVIC, AXAJ, BXAJ, XXAJ, BDVIC, BBVIC, GDVIC, HC + namelist / noahmp_stas_soil_categories / SLTYPE, SLCATS + namelist / noahmp_soil_stas_parameters / BB, DRYSMC, MAXSMC, REFSMC, SATPSI, SATDK, SATDW, WLTSMC, QTZ, & + BVIC, AXAJ, BXAJ, XXAJ, BDVIC, BBVIC, GDVIC + namelist / noahmp_soil_stas_ruc_parameters / BB, DRYSMC, HC, MAXSMC, REFSMC, SATPSI, SATDK, SATDW, WLTSMC, QTZ, & + BVIC, AXAJ, BXAJ, XXAJ, BDVIC, BBVIC, GDVIC + + ! general parameters + real(kind=kind_noahmp) :: CSOIL_DATA, REFDK_DATA, REFKDT_DATA, FRZK_DATA, ZBOT_DATA, CZIL_DATA + real(kind=kind_noahmp), dimension(NUM_SLOPE) :: SLOPE_DATA + namelist / noahmp_general_parameters / SLOPE_DATA, CSOIL_DATA, REFDK_DATA, REFKDT_DATA, FRZK_DATA, ZBOT_DATA, & + CZIL_DATA + + ! radiation parameters + real(kind=kind_noahmp) :: BETADS, BETAIS, EICE + real(kind=kind_noahmp), dimension(MBAND) :: ALBICE, ALBLAK, OMEGAS + real(kind=kind_noahmp), dimension(2) :: EG + real(kind=kind_noahmp), dimension(MSC) :: ALBSAT_VIS, ALBSAT_NIR, ALBDRY_VIS, ALBDRY_NIR + namelist / noahmp_rad_parameters / ALBSAT_VIS, ALBSAT_NIR, ALBDRY_VIS, ALBDRY_NIR, ALBICE, ALBLAK, OMEGAS, & + BETADS, BETAIS, EG, EICE + + ! global parameters + real(kind=kind_noahmp) :: CO2, O2, TIMEAN, FSATMX, Z0SNO, SSI, SNOW_RET_FAC ,SNOW_EMIS, SWEMX, TAU0, & + GRAIN_GROWTH, EXTRA_GROWTH, DIRT_SOOT, BATS_COSZ, BATS_VIS_NEW, & + BATS_NIR_NEW, BATS_VIS_AGE, BATS_NIR_AGE, BATS_VIS_DIR, BATS_NIR_DIR, & + RSURF_SNOW, RSURF_EXP, C2_SNOWCOMPACT, C3_SNOWCOMPACT, C4_SNOWCOMPACT, & + C5_SNOWCOMPACT, DM_SNOWCOMPACT, ETA0_SNOWCOMPACT, SNLIQMAXFRAC, SWEMAXGLA, & + WSLMAX, ROUS, CMIC, SNOWDEN_MAX, CLASS_ALB_REF, CLASS_SNO_AGE, CLASS_ALB_NEW,& + PSIWLT, Z0SOIL, Z0LAKE + namelist / noahmp_global_parameters / CO2, O2, TIMEAN, FSATMX, Z0SNO, SSI, SNOW_RET_FAC ,SNOW_EMIS, SWEMX, TAU0, & + GRAIN_GROWTH, EXTRA_GROWTH, DIRT_SOOT, BATS_COSZ, BATS_VIS_NEW, & + BATS_NIR_NEW, BATS_VIS_AGE, BATS_NIR_AGE, BATS_VIS_DIR, BATS_NIR_DIR, & + RSURF_SNOW, RSURF_EXP, C2_SNOWCOMPACT, C3_SNOWCOMPACT, C4_SNOWCOMPACT, & + C5_SNOWCOMPACT, DM_SNOWCOMPACT, ETA0_SNOWCOMPACT, SNLIQMAXFRAC, SWEMAXGLA, & + WSLMAX, ROUS, CMIC, SNOWDEN_MAX, CLASS_ALB_REF, CLASS_SNO_AGE, CLASS_ALB_NEW,& + PSIWLT, Z0SOIL, Z0LAKE + + ! irrigation parameters + integer :: IRR_HAR + real(kind=kind_noahmp) :: IRR_FRAC, IRR_LAI, IRR_MAD, FILOSS, SPRIR_RATE, MICIR_RATE, FIRTFAC, IR_RAIN + namelist / noahmp_irrigation_parameters / IRR_FRAC, IRR_HAR, IRR_LAI, IRR_MAD, FILOSS, SPRIR_RATE, MICIR_RATE, FIRTFAC,& + IR_RAIN + + ! crop parameters + integer :: DEFAULT_CROP + integer , dimension(NCROP) :: PLTDAY, HSDAY + real(kind=kind_noahmp), dimension(NCROP) :: PLANTPOP, IRRI, GDDTBASE, GDDTCUT, GDDS1, GDDS2, GDDS3, GDDS4, GDDS5, C3PSNI,& + KC25I, AKCI, KO25I, AKOI, AVCMXI, VCMX25I, BPI, MPI, FOLNMXI, QE25I, AREF, & + PSNRF, I2PAR, TASSIM0, TASSIM1, TASSIM2, K, EPSI, Q10MR, LEFREEZ, & + DILE_FC_S1, DILE_FC_S2, DILE_FC_S3, DILE_FC_S4, DILE_FC_S5, DILE_FC_S6, & + DILE_FC_S7, DILE_FC_S8, DILE_FW_S1, DILE_FW_S2, DILE_FW_S3, DILE_FW_S4, & + DILE_FW_S5, DILE_FW_S6, DILE_FW_S7, DILE_FW_S8, FRA_GR, LF_OVRC_S1, & + LF_OVRC_S2, LF_OVRC_S3, LF_OVRC_S4, LF_OVRC_S5, LF_OVRC_S6, LF_OVRC_S7, & + LF_OVRC_S8, ST_OVRC_S1, ST_OVRC_S2, ST_OVRC_S3, ST_OVRC_S4, ST_OVRC_S5, & + ST_OVRC_S6, ST_OVRC_S7, ST_OVRC_S8, RT_OVRC_S1, RT_OVRC_S2, RT_OVRC_S3, & + RT_OVRC_S4, RT_OVRC_S5, RT_OVRC_S6, RT_OVRC_S7, RT_OVRC_S8, LFMR25, STMR25, & + RTMR25, GRAINMR25, LFPT_S1, LFPT_S2, LFPT_S3, LFPT_S4, LFPT_S5, LFPT_S6, & + LFPT_S7, LFPT_S8, STPT_S1, STPT_S2, STPT_S3, STPT_S4, STPT_S5, STPT_S6, & + STPT_S7, STPT_S8, RTPT_S1, RTPT_S2, RTPT_S3, RTPT_S4, RTPT_S5, RTPT_S6, & + RTPT_S7, RTPT_S8, GRAINPT_S1, GRAINPT_S2, GRAINPT_S3, GRAINPT_S4, GRAINPT_S5,& + GRAINPT_S6, GRAINPT_S7, GRAINPT_S8, LFCT_S1, LFCT_S2, LFCT_S3, LFCT_S4, & + LFCT_S5, LFCT_S6, LFCT_S7, LFCT_S8, STCT_S1, STCT_S2, STCT_S3, STCT_S4, & + STCT_S5, STCT_S6, STCT_S7, STCT_S8, RTCT_S1, RTCT_S2, RTCT_S3, RTCT_S4, & + RTCT_S5, RTCT_S6, RTCT_S7, RTCT_S8, BIO2LAI + namelist / noahmp_crop_parameters / DEFAULT_CROP, PLTDAY, HSDAY, PLANTPOP, IRRI, GDDTBASE, GDDTCUT, GDDS1, GDDS2,& + GDDS3, GDDS4, GDDS5, C3PSNI, KC25I, AKCI, KO25I, AKOI, AVCMXI, VCMX25I, BPI, & + MPI, FOLNMXI, QE25I, AREF, PSNRF, I2PAR, TASSIM0, TASSIM1, TASSIM2, K, & + EPSI,Q10MR, LEFREEZ, DILE_FC_S1, DILE_FC_S2, DILE_FC_S3, DILE_FC_S4, & + DILE_FC_S5, DILE_FC_S6, DILE_FC_S7, DILE_FC_S8, DILE_FW_S1, DILE_FW_S2, & + DILE_FW_S3, DILE_FW_S4, DILE_FW_S5, DILE_FW_S6, DILE_FW_S7, DILE_FW_S8, & + FRA_GR, LF_OVRC_S1, LF_OVRC_S2, LF_OVRC_S3, LF_OVRC_S4, LF_OVRC_S5, & + LF_OVRC_S6, LF_OVRC_S7, LF_OVRC_S8, ST_OVRC_S1, ST_OVRC_S2, ST_OVRC_S3, & + ST_OVRC_S4, ST_OVRC_S5, ST_OVRC_S6, ST_OVRC_S7, ST_OVRC_S8, RT_OVRC_S1, & + RT_OVRC_S2, RT_OVRC_S3, RT_OVRC_S4, RT_OVRC_S5, RT_OVRC_S6, RT_OVRC_S7, & + RT_OVRC_S8, LFMR25, STMR25, RTMR25, GRAINMR25, LFPT_S1, LFPT_S2, LFPT_S3, & + LFPT_S4, LFPT_S5, LFPT_S6, LFPT_S7, LFPT_S8, STPT_S1, STPT_S2, STPT_S3, & + STPT_S4, STPT_S5, STPT_S6, STPT_S7, STPT_S8, RTPT_S1, RTPT_S2, RTPT_S3, & + RTPT_S4, RTPT_S5, RTPT_S6, RTPT_S7, RTPT_S8, GRAINPT_S1, GRAINPT_S2, & + GRAINPT_S3, GRAINPT_S4, GRAINPT_S5, GRAINPT_S6, GRAINPT_S7, GRAINPT_S8, & + LFCT_S1, LFCT_S2, LFCT_S3, LFCT_S4, LFCT_S5, LFCT_S6, LFCT_S7, LFCT_S8, & + STCT_S1, STCT_S2, STCT_S3, STCT_S4, STCT_S5, STCT_S6, STCT_S7, STCT_S8, & + RTCT_S1, RTCT_S2, RTCT_S3, RTCT_S4, RTCT_S5, RTCT_S6, RTCT_S7, RTCT_S8, & + BIO2LAI + + ! tile drainage parameters + integer :: NSOILTYPE, DRAIN_LAYER_OPT + integer , dimension(MAX_SOILTYP) :: TD_DEPTH + real(kind=kind_noahmp), dimension(MAX_SOILTYP) :: TDSMC_FAC, TD_DC, TD_DCOEF, TD_D, TD_ADEPTH, TD_RADI, TD_SPAC, & + TD_DDRAIN, KLAT_FAC + namelist / noahmp_tiledrain_parameters / NSOILTYPE, DRAIN_LAYER_OPT, TDSMC_FAC, TD_DEPTH, TD_DC, TD_DCOEF, TD_D,& + TD_ADEPTH, TD_RADI, TD_SPAC, TD_DDRAIN, KLAT_FAC + + ! optional parameters + real(kind=kind_noahmp) :: sr2006_theta_1500t_a, sr2006_theta_1500t_b, sr2006_theta_1500t_c, & + sr2006_theta_1500t_d, sr2006_theta_1500t_e, sr2006_theta_1500t_f, & + sr2006_theta_1500t_g, sr2006_theta_1500_a , sr2006_theta_1500_b, & + sr2006_theta_33t_a, sr2006_theta_33t_b, sr2006_theta_33t_c, & + sr2006_theta_33t_d, sr2006_theta_33t_e, sr2006_theta_33t_f, & + sr2006_theta_33t_g, sr2006_theta_33_a, sr2006_theta_33_b, & + sr2006_theta_33_c, sr2006_theta_s33t_a, sr2006_theta_s33t_b, & + sr2006_theta_s33t_c, sr2006_theta_s33t_d, sr2006_theta_s33t_e, & + sr2006_theta_s33t_f, sr2006_theta_s33t_g, sr2006_theta_s33_a, & + sr2006_theta_s33_b, sr2006_psi_et_a, sr2006_psi_et_b, sr2006_psi_et_c, & + sr2006_psi_et_d, sr2006_psi_et_e, sr2006_psi_et_f, sr2006_psi_et_g, & + sr2006_psi_e_a, sr2006_psi_e_b, sr2006_psi_e_c, sr2006_smcmax_a, & + sr2006_smcmax_b + namelist / noahmp_optional_parameters / sr2006_theta_1500t_a, sr2006_theta_1500t_b, sr2006_theta_1500t_c, & + sr2006_theta_1500t_d, sr2006_theta_1500t_e, sr2006_theta_1500t_f, & + sr2006_theta_1500t_g, sr2006_theta_1500_a, sr2006_theta_1500_b, & + sr2006_theta_33t_a, sr2006_theta_33t_b, sr2006_theta_33t_c, & + sr2006_theta_33t_d, sr2006_theta_33t_e, sr2006_theta_33t_f, & + sr2006_theta_33t_g, sr2006_theta_33_a, sr2006_theta_33_b, & + sr2006_theta_33_c, sr2006_theta_s33t_a, sr2006_theta_s33t_b, & + sr2006_theta_s33t_c, sr2006_theta_s33t_d, sr2006_theta_s33t_e, & + sr2006_theta_s33t_f, sr2006_theta_s33t_g, sr2006_theta_s33_a, & + sr2006_theta_s33_b, sr2006_psi_et_a, sr2006_psi_et_b, sr2006_psi_et_c, & + sr2006_psi_et_d, sr2006_psi_et_e, sr2006_psi_et_f, sr2006_psi_et_g, & + sr2006_psi_e_a, sr2006_psi_e_b, sr2006_psi_e_c, sr2006_smcmax_a, & + sr2006_smcmax_b + + !-------------------------------------------------- + !=== allocate multi-dim input table variables + !-------------------------------------------------- + + ! vegetation parameters + if ( .not. allocated (NoahmpIO%CH2OP_TABLE) ) allocate( NoahmpIO%CH2OP_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%DLEAF_TABLE) ) allocate( NoahmpIO%DLEAF_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%Z0MVT_TABLE) ) allocate( NoahmpIO%Z0MVT_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%HVT_TABLE) ) allocate( NoahmpIO%HVT_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%HVB_TABLE) ) allocate( NoahmpIO%HVB_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%DEN_TABLE) ) allocate( NoahmpIO%DEN_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%RC_TABLE) ) allocate( NoahmpIO%RC_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%MFSNO_TABLE) ) allocate( NoahmpIO%MFSNO_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%SCFFAC_TABLE) ) allocate( NoahmpIO%SCFFAC_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%CBIOM_TABLE) ) allocate( NoahmpIO%CBIOM_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%SAIM_TABLE) ) allocate( NoahmpIO%SAIM_TABLE (MVT,12) ) + if ( .not. allocated (NoahmpIO%LAIM_TABLE) ) allocate( NoahmpIO%LAIM_TABLE (MVT,12) ) + if ( .not. allocated (NoahmpIO%SLA_TABLE) ) allocate( NoahmpIO%SLA_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%DILEFC_TABLE) ) allocate( NoahmpIO%DILEFC_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%DILEFW_TABLE) ) allocate( NoahmpIO%DILEFW_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%FRAGR_TABLE) ) allocate( NoahmpIO%FRAGR_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%LTOVRC_TABLE) ) allocate( NoahmpIO%LTOVRC_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%C3PSN_TABLE) ) allocate( NoahmpIO%C3PSN_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%KC25_TABLE) ) allocate( NoahmpIO%KC25_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%AKC_TABLE) ) allocate( NoahmpIO%AKC_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%KO25_TABLE) ) allocate( NoahmpIO%KO25_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%AKO_TABLE) ) allocate( NoahmpIO%AKO_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%VCMX25_TABLE) ) allocate( NoahmpIO%VCMX25_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%AVCMX_TABLE) ) allocate( NoahmpIO%AVCMX_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%BP_TABLE) ) allocate( NoahmpIO%BP_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%MP_TABLE) ) allocate( NoahmpIO%MP_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%QE25_TABLE) ) allocate( NoahmpIO%QE25_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%AQE_TABLE) ) allocate( NoahmpIO%AQE_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%RMF25_TABLE) ) allocate( NoahmpIO%RMF25_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%RMS25_TABLE) ) allocate( NoahmpIO%RMS25_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%RMR25_TABLE) ) allocate( NoahmpIO%RMR25_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%ARM_TABLE) ) allocate( NoahmpIO%ARM_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%FOLNMX_TABLE) ) allocate( NoahmpIO%FOLNMX_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%TMIN_TABLE) ) allocate( NoahmpIO%TMIN_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%XL_TABLE) ) allocate( NoahmpIO%XL_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%RHOL_TABLE) ) allocate( NoahmpIO%RHOL_TABLE (MVT,MBAND) ) + if ( .not. allocated (NoahmpIO%RHOS_TABLE) ) allocate( NoahmpIO%RHOS_TABLE (MVT,MBAND) ) + if ( .not. allocated (NoahmpIO%TAUL_TABLE) ) allocate( NoahmpIO%TAUL_TABLE (MVT,MBAND) ) + if ( .not. allocated (NoahmpIO%TAUS_TABLE) ) allocate( NoahmpIO%TAUS_TABLE (MVT,MBAND) ) + if ( .not. allocated (NoahmpIO%MRP_TABLE) ) allocate( NoahmpIO%MRP_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%CWPVT_TABLE) ) allocate( NoahmpIO%CWPVT_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%WRRAT_TABLE) ) allocate( NoahmpIO%WRRAT_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%WDPOOL_TABLE) ) allocate( NoahmpIO%WDPOOL_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%TDLEF_TABLE) ) allocate( NoahmpIO%TDLEF_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%NROOT_TABLE) ) allocate( NoahmpIO%NROOT_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%RGL_TABLE) ) allocate( NoahmpIO%RGL_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%RS_TABLE) ) allocate( NoahmpIO%RS_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%HS_TABLE) ) allocate( NoahmpIO%HS_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%TOPT_TABLE) ) allocate( NoahmpIO%TOPT_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%RSMAX_TABLE) ) allocate( NoahmpIO%RSMAX_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%RTOVRC_TABLE) ) allocate( NoahmpIO%RTOVRC_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%RSWOODC_TABLE)) allocate( NoahmpIO%RSWOODC_TABLE(MVT) ) + if ( .not. allocated (NoahmpIO%BF_TABLE) ) allocate( NoahmpIO%BF_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%WSTRC_TABLE) ) allocate( NoahmpIO%WSTRC_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%LAIMIN_TABLE) ) allocate( NoahmpIO%LAIMIN_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%XSAMIN_TABLE) ) allocate( NoahmpIO%XSAMIN_TABLE (MVT) ) + + ! soil parameters + if ( .not. allocated (NoahmpIO%BEXP_TABLE) ) allocate( NoahmpIO%BEXP_TABLE (MAX_SOILTYP) ) + if ( .not. allocated (NoahmpIO%SMCDRY_TABLE) ) allocate( NoahmpIO%SMCDRY_TABLE(MAX_SOILTYP) ) + if ( .not. allocated (NoahmpIO%SMCMAX_TABLE) ) allocate( NoahmpIO%SMCMAX_TABLE(MAX_SOILTYP) ) + if ( .not. allocated (NoahmpIO%SMCREF_TABLE) ) allocate( NoahmpIO%SMCREF_TABLE(MAX_SOILTYP) ) + if ( .not. allocated (NoahmpIO%PSISAT_TABLE) ) allocate( NoahmpIO%PSISAT_TABLE(MAX_SOILTYP) ) + if ( .not. allocated (NoahmpIO%DKSAT_TABLE) ) allocate( NoahmpIO%DKSAT_TABLE (MAX_SOILTYP) ) + if ( .not. allocated (NoahmpIO%DWSAT_TABLE) ) allocate( NoahmpIO%DWSAT_TABLE (MAX_SOILTYP) ) + if ( .not. allocated (NoahmpIO%SMCWLT_TABLE) ) allocate( NoahmpIO%SMCWLT_TABLE(MAX_SOILTYP) ) + if ( .not. allocated (NoahmpIO%QUARTZ_TABLE) ) allocate( NoahmpIO%QUARTZ_TABLE(MAX_SOILTYP) ) + if ( .not. allocated (NoahmpIO%BVIC_TABLE) ) allocate( NoahmpIO%BVIC_TABLE (MAX_SOILTYP) ) + if ( .not. allocated (NoahmpIO%AXAJ_TABLE) ) allocate( NoahmpIO%AXAJ_TABLE (MAX_SOILTYP) ) + if ( .not. allocated (NoahmpIO%BXAJ_TABLE) ) allocate( NoahmpIO%BXAJ_TABLE (MAX_SOILTYP) ) + if ( .not. allocated (NoahmpIO%XXAJ_TABLE) ) allocate( NoahmpIO%XXAJ_TABLE (MAX_SOILTYP) ) + if ( .not. allocated (NoahmpIO%BDVIC_TABLE) ) allocate( NoahmpIO%BDVIC_TABLE (MAX_SOILTYP) ) + if ( .not. allocated (NoahmpIO%GDVIC_TABLE) ) allocate( NoahmpIO%GDVIC_TABLE (MAX_SOILTYP) ) + if ( .not. allocated (NoahmpIO%BBVIC_TABLE) ) allocate( NoahmpIO%BBVIC_TABLE (MAX_SOILTYP) ) + + ! general parameters + if ( .not. allocated (NoahmpIO%SLOPE_TABLE) ) allocate( NoahmpIO%SLOPE_TABLE(NUM_SLOPE) ) + + ! radiation parameters + if ( .not. allocated (NoahmpIO%ALBSAT_TABLE) ) allocate( NoahmpIO%ALBSAT_TABLE(MSC,MBAND) ) + if ( .not. allocated (NoahmpIO%ALBDRY_TABLE) ) allocate( NoahmpIO%ALBDRY_TABLE(MSC,MBAND) ) + if ( .not. allocated (NoahmpIO%ALBICE_TABLE) ) allocate( NoahmpIO%ALBICE_TABLE(MBAND) ) + if ( .not. allocated (NoahmpIO%ALBLAK_TABLE) ) allocate( NoahmpIO%ALBLAK_TABLE(MBAND) ) + if ( .not. allocated (NoahmpIO%OMEGAS_TABLE) ) allocate( NoahmpIO%OMEGAS_TABLE(MBAND) ) + if ( .not. allocated (NoahmpIO%EG_TABLE) ) allocate( NoahmpIO%EG_TABLE(2) ) + + ! tile drainage parameters + if ( .not. allocated (NoahmpIO%TDSMC_FAC_TABLE) ) allocate( NoahmpIO%TDSMC_FAC_TABLE(MAX_SOILTYP) ) + if ( .not. allocated (NoahmpIO%TD_DC_TABLE) ) allocate( NoahmpIO%TD_DC_TABLE (MAX_SOILTYP) ) + if ( .not. allocated (NoahmpIO%TD_DEPTH_TABLE) ) allocate( NoahmpIO%TD_DEPTH_TABLE (MAX_SOILTYP) ) + if ( .not. allocated (NoahmpIO%TD_DCOEF_TABLE) ) allocate( NoahmpIO%TD_DCOEF_TABLE (MAX_SOILTYP) ) + if ( .not. allocated (NoahmpIO%TD_D_TABLE) ) allocate( NoahmpIO%TD_D_TABLE (MAX_SOILTYP) ) + if ( .not. allocated (NoahmpIO%TD_ADEPTH_TABLE) ) allocate( NoahmpIO%TD_ADEPTH_TABLE(MAX_SOILTYP) ) + if ( .not. allocated (NoahmpIO%TD_RADI_TABLE) ) allocate( NoahmpIO%TD_RADI_TABLE (MAX_SOILTYP) ) + if ( .not. allocated (NoahmpIO%TD_SPAC_TABLE) ) allocate( NoahmpIO%TD_SPAC_TABLE (MAX_SOILTYP) ) + if ( .not. allocated (NoahmpIO%TD_DDRAIN_TABLE) ) allocate( NoahmpIO%TD_DDRAIN_TABLE(MAX_SOILTYP) ) + if ( .not. allocated (NoahmpIO%KLAT_FAC_TABLE) ) allocate( NoahmpIO%KLAT_FAC_TABLE (MAX_SOILTYP) ) + + ! crop parameters + if ( .not. allocated (NoahmpIO%PLTDAY_TABLE) ) allocate( NoahmpIO%PLTDAY_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%HSDAY_TABLE) ) allocate( NoahmpIO%HSDAY_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%PLANTPOP_TABLE) ) allocate( NoahmpIO%PLANTPOP_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%IRRI_TABLE) ) allocate( NoahmpIO%IRRI_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%GDDTBASE_TABLE) ) allocate( NoahmpIO%GDDTBASE_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%GDDTCUT_TABLE) ) allocate( NoahmpIO%GDDTCUT_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%GDDS1_TABLE) ) allocate( NoahmpIO%GDDS1_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%GDDS2_TABLE) ) allocate( NoahmpIO%GDDS2_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%GDDS3_TABLE) ) allocate( NoahmpIO%GDDS3_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%GDDS4_TABLE) ) allocate( NoahmpIO%GDDS4_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%GDDS5_TABLE) ) allocate( NoahmpIO%GDDS5_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%C3PSNI_TABLE) ) allocate( NoahmpIO%C3PSNI_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%KC25I_TABLE) ) allocate( NoahmpIO%KC25I_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%AKCI_TABLE) ) allocate( NoahmpIO%AKCI_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%KO25I_TABLE) ) allocate( NoahmpIO%KO25I_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%AKOI_TABLE) ) allocate( NoahmpIO%AKOI_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%VCMX25I_TABLE) ) allocate( NoahmpIO%VCMX25I_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%AVCMXI_TABLE) ) allocate( NoahmpIO%AVCMXI_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%BPI_TABLE) ) allocate( NoahmpIO%BPI_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%MPI_TABLE) ) allocate( NoahmpIO%MPI_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%QE25I_TABLE) ) allocate( NoahmpIO%QE25I_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%FOLNMXI_TABLE) ) allocate( NoahmpIO%FOLNMXI_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%AREF_TABLE) ) allocate( NoahmpIO%AREF_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%PSNRF_TABLE) ) allocate( NoahmpIO%PSNRF_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%I2PAR_TABLE) ) allocate( NoahmpIO%I2PAR_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%TASSIM0_TABLE) ) allocate( NoahmpIO%TASSIM0_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%TASSIM1_TABLE) ) allocate( NoahmpIO%TASSIM1_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%TASSIM2_TABLE) ) allocate( NoahmpIO%TASSIM2_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%K_TABLE) ) allocate( NoahmpIO%K_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%EPSI_TABLE) ) allocate( NoahmpIO%EPSI_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%Q10MR_TABLE) ) allocate( NoahmpIO%Q10MR_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%LEFREEZ_TABLE) ) allocate( NoahmpIO%LEFREEZ_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%DILE_FC_TABLE) ) allocate( NoahmpIO%DILE_FC_TABLE (NCROP,NSTAGE) ) + if ( .not. allocated (NoahmpIO%DILE_FW_TABLE) ) allocate( NoahmpIO%DILE_FW_TABLE (NCROP,NSTAGE) ) + if ( .not. allocated (NoahmpIO%FRA_GR_TABLE) ) allocate( NoahmpIO%FRA_GR_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%LF_OVRC_TABLE) ) allocate( NoahmpIO%LF_OVRC_TABLE (NCROP,NSTAGE) ) + if ( .not. allocated (NoahmpIO%ST_OVRC_TABLE) ) allocate( NoahmpIO%ST_OVRC_TABLE (NCROP,NSTAGE) ) + if ( .not. allocated (NoahmpIO%RT_OVRC_TABLE) ) allocate( NoahmpIO%RT_OVRC_TABLE (NCROP,NSTAGE) ) + if ( .not. allocated (NoahmpIO%LFMR25_TABLE) ) allocate( NoahmpIO%LFMR25_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%STMR25_TABLE) ) allocate( NoahmpIO%STMR25_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%RTMR25_TABLE) ) allocate( NoahmpIO%RTMR25_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%GRAINMR25_TABLE) ) allocate( NoahmpIO%GRAINMR25_TABLE(NCROP) ) + if ( .not. allocated (NoahmpIO%LFPT_TABLE) ) allocate( NoahmpIO%LFPT_TABLE (NCROP,NSTAGE) ) + if ( .not. allocated (NoahmpIO%STPT_TABLE) ) allocate( NoahmpIO%STPT_TABLE (NCROP,NSTAGE) ) + if ( .not. allocated (NoahmpIO%RTPT_TABLE) ) allocate( NoahmpIO%RTPT_TABLE (NCROP,NSTAGE) ) + if ( .not. allocated (NoahmpIO%GRAINPT_TABLE) ) allocate( NoahmpIO%GRAINPT_TABLE (NCROP,NSTAGE) ) + if ( .not. allocated (NoahmpIO%LFCT_TABLE) ) allocate( NoahmpIO%LFCT_TABLE (NCROP,NSTAGE) ) + if ( .not. allocated (NoahmpIO%STCT_TABLE) ) allocate( NoahmpIO%STCT_TABLE (NCROP,NSTAGE) ) + if ( .not. allocated (NoahmpIO%RTCT_TABLE) ) allocate( NoahmpIO%RTCT_TABLE (NCROP,NSTAGE) ) + if ( .not. allocated (NoahmpIO%BIO2LAI_TABLE) ) allocate( NoahmpIO%BIO2LAI_TABLE (NCROP) ) + + !--------------------------------------------------------------- + ! intialization to bad value, so that if the namelist read fails, + ! we come to a screeching halt as soon as we try to use anything + !--------------------------------------------------------------- + + ! vegetation parameters + NoahmpIO%ISURBAN_TABLE = undefined_int + NoahmpIO%ISWATER_TABLE = undefined_int + NoahmpIO%ISBARREN_TABLE = undefined_int + NoahmpIO%ISICE_TABLE = undefined_int + NoahmpIO%ISCROP_TABLE = undefined_int + NoahmpIO%EBLFOREST_TABLE = undefined_int + NoahmpIO%NATURAL_TABLE = undefined_int + NoahmpIO%URBTYPE_beg = undefined_int + NoahmpIO%LCZ_1_TABLE = undefined_int + NoahmpIO%LCZ_2_TABLE = undefined_int + NoahmpIO%LCZ_3_TABLE = undefined_int + NoahmpIO%LCZ_4_TABLE = undefined_int + NoahmpIO%LCZ_5_TABLE = undefined_int + NoahmpIO%LCZ_6_TABLE = undefined_int + NoahmpIO%LCZ_7_TABLE = undefined_int + NoahmpIO%LCZ_8_TABLE = undefined_int + NoahmpIO%LCZ_9_TABLE = undefined_int + NoahmpIO%LCZ_10_TABLE = undefined_int + NoahmpIO%LCZ_11_TABLE = undefined_int + NoahmpIO%CH2OP_TABLE = undefined_real + NoahmpIO%DLEAF_TABLE = undefined_real + NoahmpIO%Z0MVT_TABLE = undefined_real + NoahmpIO%HVT_TABLE = undefined_real + NoahmpIO%HVB_TABLE = undefined_real + NoahmpIO%DEN_TABLE = undefined_real + NoahmpIO%RC_TABLE = undefined_real + NoahmpIO%MFSNO_TABLE = undefined_real + NoahmpIO%SCFFAC_TABLE = undefined_real + NoahmpIO%CBIOM_TABLE = undefined_real + NoahmpIO%RHOL_TABLE = undefined_real + NoahmpIO%RHOS_TABLE = undefined_real + NoahmpIO%TAUL_TABLE = undefined_real + NoahmpIO%TAUS_TABLE = undefined_real + NoahmpIO%XL_TABLE = undefined_real + NoahmpIO%CWPVT_TABLE = undefined_real + NoahmpIO%C3PSN_TABLE = undefined_real + NoahmpIO%KC25_TABLE = undefined_real + NoahmpIO%AKC_TABLE = undefined_real + NoahmpIO%KO25_TABLE = undefined_real + NoahmpIO%AKO_TABLE = undefined_real + NoahmpIO%AVCMX_TABLE = undefined_real + NoahmpIO%AQE_TABLE = undefined_real + NoahmpIO%LTOVRC_TABLE = undefined_real + NoahmpIO%DILEFC_TABLE = undefined_real + NoahmpIO%DILEFW_TABLE = undefined_real + NoahmpIO%RMF25_TABLE = undefined_real + NoahmpIO%SLA_TABLE = undefined_real + NoahmpIO%FRAGR_TABLE = undefined_real + NoahmpIO%TMIN_TABLE = undefined_real + NoahmpIO%VCMX25_TABLE = undefined_real + NoahmpIO%TDLEF_TABLE = undefined_real + NoahmpIO%BP_TABLE = undefined_real + NoahmpIO%MP_TABLE = undefined_real + NoahmpIO%QE25_TABLE = undefined_real + NoahmpIO%RMS25_TABLE = undefined_real + NoahmpIO%RMR25_TABLE = undefined_real + NoahmpIO%ARM_TABLE = undefined_real + NoahmpIO%FOLNMX_TABLE = undefined_real + NoahmpIO%WDPOOL_TABLE = undefined_real + NoahmpIO%WRRAT_TABLE = undefined_real + NoahmpIO%MRP_TABLE = undefined_real + NoahmpIO%SAIM_TABLE = undefined_real + NoahmpIO%LAIM_TABLE = undefined_real + NoahmpIO%NROOT_TABLE = undefined_real + NoahmpIO%RGL_TABLE = undefined_real + NoahmpIO%RS_TABLE = undefined_real + NoahmpIO%HS_TABLE = undefined_real + NoahmpIO%TOPT_TABLE = undefined_real + NoahmpIO%RSMAX_TABLE = undefined_real + NoahmpIO%RTOVRC_TABLE = undefined_real + NoahmpIO%RSWOODC_TABLE = undefined_real + NoahmpIO%BF_TABLE = undefined_real + NoahmpIO%WSTRC_TABLE = undefined_real + NoahmpIO%LAIMIN_TABLE = undefined_real + NoahmpIO%XSAMIN_TABLE = undefined_real + + ! soil parameters + NoahmpIO%SLCATS_TABLE = undefined_int + NoahmpIO%BEXP_TABLE = undefined_real + NoahmpIO%SMCDRY_TABLE = undefined_real + NoahmpIO%SMCMAX_TABLE = undefined_real + NoahmpIO%SMCREF_TABLE = undefined_real + NoahmpIO%PSISAT_TABLE = undefined_real + NoahmpIO%DKSAT_TABLE = undefined_real + NoahmpIO%DWSAT_TABLE = undefined_real + NoahmpIO%SMCWLT_TABLE = undefined_real + NoahmpIO%QUARTZ_TABLE = undefined_real + NoahmpIO%BVIC_TABLE = undefined_real + NoahmpIO%AXAJ_TABLE = undefined_real + NoahmpIO%BXAJ_TABLE = undefined_real + NoahmpIO%XXAJ_TABLE = undefined_real + NoahmpIO%BDVIC_TABLE = undefined_real + NoahmpIO%GDVIC_TABLE = undefined_real + NoahmpIO%BBVIC_TABLE = undefined_real + + ! general parameters + NoahmpIO%SLOPE_TABLE = undefined_real + NoahmpIO%CSOIL_TABLE = undefined_real + NoahmpIO%REFDK_TABLE = undefined_real + NoahmpIO%REFKDT_TABLE = undefined_real + NoahmpIO%FRZK_TABLE = undefined_real + NoahmpIO%ZBOT_TABLE = undefined_real + NoahmpIO%CZIL_TABLE = undefined_real + + ! radiation parameters + NoahmpIO%ALBSAT_TABLE = undefined_real + NoahmpIO%ALBDRY_TABLE = undefined_real + NoahmpIO%ALBICE_TABLE = undefined_real + NoahmpIO%ALBLAK_TABLE = undefined_real + NoahmpIO%OMEGAS_TABLE = undefined_real + NoahmpIO%BETADS_TABLE = undefined_real + NoahmpIO%BETAIS_TABLE = undefined_real + NoahmpIO%EG_TABLE = undefined_real + NoahmpIO%EICE_TABLE = undefined_real + + ! global parameters + NoahmpIO%CO2_TABLE = undefined_real + NoahmpIO%O2_TABLE = undefined_real + NoahmpIO%TIMEAN_TABLE = undefined_real + NoahmpIO%FSATMX_TABLE = undefined_real + NoahmpIO%Z0SNO_TABLE = undefined_real + NoahmpIO%SSI_TABLE = undefined_real + NoahmpIO%SNOW_RET_FAC_TABLE = undefined_real + NoahmpIO%SNOW_EMIS_TABLE = undefined_real + NoahmpIO%SWEMX_TABLE = undefined_real + NoahmpIO%TAU0_TABLE = undefined_real + NoahmpIO%GRAIN_GROWTH_TABLE = undefined_real + NoahmpIO%EXTRA_GROWTH_TABLE = undefined_real + NoahmpIO%DIRT_SOOT_TABLE = undefined_real + NoahmpIO%BATS_COSZ_TABLE = undefined_real + NoahmpIO%BATS_VIS_NEW_TABLE = undefined_real + NoahmpIO%BATS_NIR_NEW_TABLE = undefined_real + NoahmpIO%BATS_VIS_AGE_TABLE = undefined_real + NoahmpIO%BATS_NIR_AGE_TABLE = undefined_real + NoahmpIO%BATS_VIS_DIR_TABLE = undefined_real + NoahmpIO%BATS_NIR_DIR_TABLE = undefined_real + NoahmpIO%RSURF_SNOW_TABLE = undefined_real + NoahmpIO%RSURF_EXP_TABLE = undefined_real + NoahmpIO%C2_SNOWCOMPACT_TABLE = undefined_real + NoahmpIO%C3_SNOWCOMPACT_TABLE = undefined_real + NoahmpIO%C4_SNOWCOMPACT_TABLE = undefined_real + NoahmpIO%C5_SNOWCOMPACT_TABLE = undefined_real + NoahmpIO%DM_SNOWCOMPACT_TABLE = undefined_real + NoahmpIO%ETA0_SNOWCOMPACT_TABLE = undefined_real + NoahmpIO%SNLIQMAXFRAC_TABLE = undefined_real + NoahmpIO%SWEMAXGLA_TABLE = undefined_real + NoahmpIO%WSLMAX_TABLE = undefined_real + NoahmpIO%ROUS_TABLE = undefined_real + NoahmpIO%CMIC_TABLE = undefined_real + NoahmpIO%SNOWDEN_MAX_TABLE = undefined_real + NoahmpIO%CLASS_ALB_REF_TABLE = undefined_real + NoahmpIO%CLASS_SNO_AGE_TABLE = undefined_real + NoahmpIO%CLASS_ALB_NEW_TABLE = undefined_real + NoahmpIO%PSIWLT_TABLE = undefined_real + NoahmpIO%Z0SOIL_TABLE = undefined_real + NoahmpIO%Z0LAKE_TABLE = undefined_real + + ! irrigation parameters + NoahmpIO%IRR_HAR_TABLE = undefined_int + NoahmpIO%IRR_FRAC_TABLE = undefined_real + NoahmpIO%IRR_LAI_TABLE = undefined_real + NoahmpIO%IRR_MAD_TABLE = undefined_real + NoahmpIO%FILOSS_TABLE = undefined_real + NoahmpIO%SPRIR_RATE_TABLE = undefined_real + NoahmpIO%MICIR_RATE_TABLE = undefined_real + NoahmpIO%FIRTFAC_TABLE = undefined_real + NoahmpIO%IR_RAIN_TABLE = undefined_real + + ! crop parameters + NoahmpIO%DEFAULT_CROP_TABLE = undefined_int + NoahmpIO%PLTDAY_TABLE = undefined_int + NoahmpIO%HSDAY_TABLE = undefined_int + NoahmpIO%PLANTPOP_TABLE = undefined_real + NoahmpIO%IRRI_TABLE = undefined_real + NoahmpIO%GDDTBASE_TABLE = undefined_real + NoahmpIO%GDDTCUT_TABLE = undefined_real + NoahmpIO%GDDS1_TABLE = undefined_real + NoahmpIO%GDDS2_TABLE = undefined_real + NoahmpIO%GDDS3_TABLE = undefined_real + NoahmpIO%GDDS4_TABLE = undefined_real + NoahmpIO%GDDS5_TABLE = undefined_real + NoahmpIO%C3PSNI_TABLE = undefined_real + NoahmpIO%KC25I_TABLE = undefined_real + NoahmpIO%AKCI_TABLE = undefined_real + NoahmpIO%KO25I_TABLE = undefined_real + NoahmpIO%AKOI_TABLE = undefined_real + NoahmpIO%AVCMXI_TABLE = undefined_real + NoahmpIO%VCMX25I_TABLE = undefined_real + NoahmpIO%BPI_TABLE = undefined_real + NoahmpIO%MPI_TABLE = undefined_real + NoahmpIO%FOLNMXI_TABLE = undefined_real + NoahmpIO%QE25I_TABLE = undefined_real + NoahmpIO%AREF_TABLE = undefined_real + NoahmpIO%PSNRF_TABLE = undefined_real + NoahmpIO%I2PAR_TABLE = undefined_real + NoahmpIO%TASSIM0_TABLE = undefined_real + NoahmpIO%TASSIM1_TABLE = undefined_real + NoahmpIO%TASSIM2_TABLE = undefined_real + NoahmpIO%K_TABLE = undefined_real + NoahmpIO%EPSI_TABLE = undefined_real + NoahmpIO%Q10MR_TABLE = undefined_real + NoahmpIO%LEFREEZ_TABLE = undefined_real + NoahmpIO%DILE_FC_TABLE = undefined_real + NoahmpIO%DILE_FW_TABLE = undefined_real + NoahmpIO%FRA_GR_TABLE = undefined_real + NoahmpIO%LF_OVRC_TABLE = undefined_real + NoahmpIO%ST_OVRC_TABLE = undefined_real + NoahmpIO%RT_OVRC_TABLE = undefined_real + NoahmpIO%LFMR25_TABLE = undefined_real + NoahmpIO%STMR25_TABLE = undefined_real + NoahmpIO%RTMR25_TABLE = undefined_real + NoahmpIO%GRAINMR25_TABLE = undefined_real + NoahmpIO%LFPT_TABLE = undefined_real + NoahmpIO%STPT_TABLE = undefined_real + NoahmpIO%RTPT_TABLE = undefined_real + NoahmpIO%GRAINPT_TABLE = undefined_real + NoahmpIO%LFCT_TABLE = undefined_real + NoahmpIO%STCT_TABLE = undefined_real + NoahmpIO%RTCT_TABLE = undefined_real + NoahmpIO%BIO2LAI_TABLE = undefined_real + + ! tile drainage parameters + NoahmpIO%DRAIN_LAYER_OPT_TABLE = undefined_int + NoahmpIO%TD_DEPTH_TABLE = undefined_int + NoahmpIO%TDSMC_FAC_TABLE = undefined_real + NoahmpIO%TD_DC_TABLE = undefined_real + NoahmpIO%TD_DCOEF_TABLE = undefined_real + NoahmpIO%TD_D_TABLE = undefined_real + NoahmpIO%TD_ADEPTH_TABLE = undefined_real + NoahmpIO%TD_RADI_TABLE = undefined_real + NoahmpIO%TD_SPAC_TABLE = undefined_real + NoahmpIO%TD_DDRAIN_TABLE = undefined_real + NoahmpIO%KLAT_FAC_TABLE = undefined_real + + ! optional parameters + NoahmpIO%sr2006_theta_1500t_a_TABLE = undefined_real + NoahmpIO%sr2006_theta_1500t_b_TABLE = undefined_real + NoahmpIO%sr2006_theta_1500t_c_TABLE = undefined_real + NoahmpIO%sr2006_theta_1500t_d_TABLE = undefined_real + NoahmpIO%sr2006_theta_1500t_e_TABLE = undefined_real + NoahmpIO%sr2006_theta_1500t_f_TABLE = undefined_real + NoahmpIO%sr2006_theta_1500t_g_TABLE = undefined_real + NoahmpIO%sr2006_theta_1500_a_TABLE = undefined_real + NoahmpIO%sr2006_theta_1500_b_TABLE = undefined_real + NoahmpIO%sr2006_theta_33t_a_TABLE = undefined_real + NoahmpIO%sr2006_theta_33t_b_TABLE = undefined_real + NoahmpIO%sr2006_theta_33t_c_TABLE = undefined_real + NoahmpIO%sr2006_theta_33t_d_TABLE = undefined_real + NoahmpIO%sr2006_theta_33t_e_TABLE = undefined_real + NoahmpIO%sr2006_theta_33t_f_TABLE = undefined_real + NoahmpIO%sr2006_theta_33t_g_TABLE = undefined_real + NoahmpIO%sr2006_theta_33_a_TABLE = undefined_real + NoahmpIO%sr2006_theta_33_b_TABLE = undefined_real + NoahmpIO%sr2006_theta_33_c_TABLE = undefined_real + NoahmpIO%sr2006_theta_s33t_a_TABLE = undefined_real + NoahmpIO%sr2006_theta_s33t_b_TABLE = undefined_real + NoahmpIO%sr2006_theta_s33t_c_TABLE = undefined_real + NoahmpIO%sr2006_theta_s33t_d_TABLE = undefined_real + NoahmpIO%sr2006_theta_s33t_e_TABLE = undefined_real + NoahmpIO%sr2006_theta_s33t_f_TABLE = undefined_real + NoahmpIO%sr2006_theta_s33t_g_TABLE = undefined_real + NoahmpIO%sr2006_theta_s33_a_TABLE = undefined_real + NoahmpIO%sr2006_theta_s33_b_TABLE = undefined_real + NoahmpIO%sr2006_psi_et_a_TABLE = undefined_real + NoahmpIO%sr2006_psi_et_b_TABLE = undefined_real + NoahmpIO%sr2006_psi_et_c_TABLE = undefined_real + NoahmpIO%sr2006_psi_et_d_TABLE = undefined_real + NoahmpIO%sr2006_psi_et_e_TABLE = undefined_real + NoahmpIO%sr2006_psi_et_f_TABLE = undefined_real + NoahmpIO%sr2006_psi_et_g_TABLE = undefined_real + NoahmpIO%sr2006_psi_e_a_TABLE = undefined_real + NoahmpIO%sr2006_psi_e_b_TABLE = undefined_real + NoahmpIO%sr2006_psi_e_c_TABLE = undefined_real + NoahmpIO%sr2006_smcmax_a_TABLE = undefined_real + NoahmpIO%sr2006_smcmax_b_TABLE = undefined_real + + !--------------------------------------------------------------- + ! transfer values from table to input variables + !--------------------------------------------------------------- + + !---------------- NoahmpTable.TBL vegetation parameters + + DATASET_IDENTIFIER = NoahmpIO%LLANDUSE + + inquire( file='NoahmpTable.TBL', exist=file_named ) + if ( file_named ) then + open(15, file="NoahmpTable.TBL", status='old', form='formatted', action='read', iostat=ierr) + else + open(15, status='old', form='formatted', action='read', iostat=ierr) + end if + if ( ierr /= 0 ) then + write(*,'("WARNING: Cannot find file NoahmpTable.TBL")') + endif + + if ( trim(DATASET_IDENTIFIER) == "USGS" ) then + read(15, noahmp_usgs_veg_categories) + read(15, noahmp_usgs_parameters) + elseif ( trim(DATASET_IDENTIFIER) == "MODIFIED_IGBP_MODIS_NOAH" ) then + read(15,noahmp_modis_veg_categories) + read(15,noahmp_modis_parameters) + else + write(*,'("WARNING: Unrecognized DATASET_IDENTIFIER in subroutine ReadNoahmpTable")') + write(*,'("WARNING: DATASET_IDENTIFIER = ''", A, "''")') trim(DATASET_IDENTIFIER) + endif + close(15) + + ! assign values + NoahmpIO%ISURBAN_TABLE = ISURBAN + NoahmpIO%ISWATER_TABLE = ISWATER + NoahmpIO%ISBARREN_TABLE = ISBARREN + NoahmpIO%ISICE_TABLE = ISICE + NoahmpIO%ISCROP_TABLE = ISCROP + NoahmpIO%EBLFOREST_TABLE = EBLFOREST + NoahmpIO%NATURAL_TABLE = NATURAL + NoahmpIO%URBTYPE_beg = URBTYPE_beg + NoahmpIO%LCZ_1_TABLE = LCZ_1 + NoahmpIO%LCZ_2_TABLE = LCZ_2 + NoahmpIO%LCZ_3_TABLE = LCZ_3 + NoahmpIO%LCZ_4_TABLE = LCZ_4 + NoahmpIO%LCZ_5_TABLE = LCZ_5 + NoahmpIO%LCZ_6_TABLE = LCZ_6 + NoahmpIO%LCZ_7_TABLE = LCZ_7 + NoahmpIO%LCZ_8_TABLE = LCZ_8 + NoahmpIO%LCZ_9_TABLE = LCZ_9 + NoahmpIO%LCZ_10_TABLE = LCZ_10 + NoahmpIO%LCZ_11_TABLE = LCZ_11 + NoahmpIO%CH2OP_TABLE (1:NVEG) = CH2OP (1:NVEG) + NoahmpIO%DLEAF_TABLE (1:NVEG) = DLEAF (1:NVEG) + NoahmpIO%Z0MVT_TABLE (1:NVEG) = Z0MVT (1:NVEG) + NoahmpIO%HVT_TABLE (1:NVEG) = HVT (1:NVEG) + NoahmpIO%HVB_TABLE (1:NVEG) = HVB (1:NVEG) + NoahmpIO%DEN_TABLE (1:NVEG) = DEN (1:NVEG) + NoahmpIO%RC_TABLE (1:NVEG) = RC (1:NVEG) + NoahmpIO%MFSNO_TABLE (1:NVEG) = MFSNO (1:NVEG) + NoahmpIO%SCFFAC_TABLE (1:NVEG) = SCFFAC (1:NVEG) + NoahmpIO%CBIOM_TABLE (1:NVEG) = CBIOM (1:NVEG) + NoahmpIO%XL_TABLE (1:NVEG) = XL (1:NVEG) + NoahmpIO%CWPVT_TABLE (1:NVEG) = CWPVT (1:NVEG) + NoahmpIO%C3PSN_TABLE (1:NVEG) = C3PSN (1:NVEG) + NoahmpIO%KC25_TABLE (1:NVEG) = KC25 (1:NVEG) + NoahmpIO%AKC_TABLE (1:NVEG) = AKC (1:NVEG) + NoahmpIO%KO25_TABLE (1:NVEG) = KO25 (1:NVEG) + NoahmpIO%AKO_TABLE (1:NVEG) = AKO (1:NVEG) + NoahmpIO%AVCMX_TABLE (1:NVEG) = AVCMX (1:NVEG) + NoahmpIO%AQE_TABLE (1:NVEG) = AQE (1:NVEG) + NoahmpIO%LTOVRC_TABLE (1:NVEG) = LTOVRC (1:NVEG) + NoahmpIO%DILEFC_TABLE (1:NVEG) = DILEFC (1:NVEG) + NoahmpIO%DILEFW_TABLE (1:NVEG) = DILEFW (1:NVEG) + NoahmpIO%RMF25_TABLE (1:NVEG) = RMF25 (1:NVEG) + NoahmpIO%SLA_TABLE (1:NVEG) = SLA (1:NVEG) + NoahmpIO%FRAGR_TABLE (1:NVEG) = FRAGR (1:NVEG) + NoahmpIO%TMIN_TABLE (1:NVEG) = TMIN (1:NVEG) + NoahmpIO%VCMX25_TABLE (1:NVEG) = VCMX25 (1:NVEG) + NoahmpIO%TDLEF_TABLE (1:NVEG) = TDLEF (1:NVEG) + NoahmpIO%BP_TABLE (1:NVEG) = BP (1:NVEG) + NoahmpIO%MP_TABLE (1:NVEG) = MP (1:NVEG) + NoahmpIO%QE25_TABLE (1:NVEG) = QE25 (1:NVEG) + NoahmpIO%RMS25_TABLE (1:NVEG) = RMS25 (1:NVEG) + NoahmpIO%RMR25_TABLE (1:NVEG) = RMR25 (1:NVEG) + NoahmpIO%ARM_TABLE (1:NVEG) = ARM (1:NVEG) + NoahmpIO%FOLNMX_TABLE (1:NVEG) = FOLNMX (1:NVEG) + NoahmpIO%WDPOOL_TABLE (1:NVEG) = WDPOOL (1:NVEG) + NoahmpIO%WRRAT_TABLE (1:NVEG) = WRRAT (1:NVEG) + NoahmpIO%MRP_TABLE (1:NVEG) = MRP (1:NVEG) + NoahmpIO%NROOT_TABLE (1:NVEG) = NROOT (1:NVEG) + NoahmpIO%RGL_TABLE (1:NVEG) = RGL (1:NVEG) + NoahmpIO%RS_TABLE (1:NVEG) = RS (1:NVEG) + NoahmpIO%HS_TABLE (1:NVEG) = HS (1:NVEG) + NoahmpIO%TOPT_TABLE (1:NVEG) = TOPT (1:NVEG) + NoahmpIO%RSMAX_TABLE (1:NVEG) = RSMAX (1:NVEG) + NoahmpIO%RTOVRC_TABLE (1:NVEG) = RTOVRC (1:NVEG) + NoahmpIO%RSWOODC_TABLE(1:NVEG) = RSWOODC(1:NVEG) + NoahmpIO%BF_TABLE (1:NVEG) = BF (1:NVEG) + NoahmpIO%WSTRC_TABLE (1:NVEG) = WSTRC (1:NVEG) + NoahmpIO%LAIMIN_TABLE (1:NVEG) = LAIMIN (1:NVEG) + NoahmpIO%XSAMIN_TABLE (1:NVEG) = XSAMIN (1:NVEG) + + NoahmpIO%SAIM_TABLE(1:NVEG, 1) = SAI_JAN(1:NVEG) + NoahmpIO%SAIM_TABLE(1:NVEG, 2) = SAI_FEB(1:NVEG) + NoahmpIO%SAIM_TABLE(1:NVEG, 3) = SAI_MAR(1:NVEG) + NoahmpIO%SAIM_TABLE(1:NVEG, 4) = SAI_APR(1:NVEG) + NoahmpIO%SAIM_TABLE(1:NVEG, 5) = SAI_MAY(1:NVEG) + NoahmpIO%SAIM_TABLE(1:NVEG, 6) = SAI_JUN(1:NVEG) + NoahmpIO%SAIM_TABLE(1:NVEG, 7) = SAI_JUL(1:NVEG) + NoahmpIO%SAIM_TABLE(1:NVEG, 8) = SAI_AUG(1:NVEG) + NoahmpIO%SAIM_TABLE(1:NVEG, 9) = SAI_SEP(1:NVEG) + NoahmpIO%SAIM_TABLE(1:NVEG,10) = SAI_OCT(1:NVEG) + NoahmpIO%SAIM_TABLE(1:NVEG,11) = SAI_NOV(1:NVEG) + NoahmpIO%SAIM_TABLE(1:NVEG,12) = SAI_DEC(1:NVEG) + NoahmpIO%LAIM_TABLE(1:NVEG, 1) = LAI_JAN(1:NVEG) + NoahmpIO%LAIM_TABLE(1:NVEG, 2) = LAI_FEB(1:NVEG) + NoahmpIO%LAIM_TABLE(1:NVEG, 3) = LAI_MAR(1:NVEG) + NoahmpIO%LAIM_TABLE(1:NVEG, 4) = LAI_APR(1:NVEG) + NoahmpIO%LAIM_TABLE(1:NVEG, 5) = LAI_MAY(1:NVEG) + NoahmpIO%LAIM_TABLE(1:NVEG, 6) = LAI_JUN(1:NVEG) + NoahmpIO%LAIM_TABLE(1:NVEG, 7) = LAI_JUL(1:NVEG) + NoahmpIO%LAIM_TABLE(1:NVEG, 8) = LAI_AUG(1:NVEG) + NoahmpIO%LAIM_TABLE(1:NVEG, 9) = LAI_SEP(1:NVEG) + NoahmpIO%LAIM_TABLE(1:NVEG,10) = LAI_OCT(1:NVEG) + NoahmpIO%LAIM_TABLE(1:NVEG,11) = LAI_NOV(1:NVEG) + NoahmpIO%LAIM_TABLE(1:NVEG,12) = LAI_DEC(1:NVEG) + NoahmpIO%RHOL_TABLE(1:NVEG,1) = RHOL_VIS(1:NVEG) !leaf reflectance: 1=vis, 2=nir + NoahmpIO%RHOL_TABLE(1:NVEG,2) = RHOL_NIR(1:NVEG) !leaf reflectance: 1=vis, 2=nir + NoahmpIO%RHOS_TABLE(1:NVEG,1) = RHOS_VIS(1:NVEG) !stem reflectance: 1=vis, 2=nir + NoahmpIO%RHOS_TABLE(1:NVEG,2) = RHOS_NIR(1:NVEG) !stem reflectance: 1=vis, 2=nir + NoahmpIO%TAUL_TABLE(1:NVEG,1) = TAUL_VIS(1:NVEG) !leaf transmittance: 1=vis, 2=nir + NoahmpIO%TAUL_TABLE(1:NVEG,2) = TAUL_NIR(1:NVEG) !leaf transmittance: 1=vis, 2=nir + NoahmpIO%TAUS_TABLE(1:NVEG,1) = TAUS_VIS(1:NVEG) !stem transmittance: 1=vis, 2=nir + NoahmpIO%TAUS_TABLE(1:NVEG,2) = TAUS_NIR(1:NVEG) !stem transmittance: 1=vis, 2=nir + + !---------------- NoahmpTable.TBL soil parameters + inquire( file='NoahmpTable.TBL', exist=file_named ) + if ( file_named ) then + open(15, file="NoahmpTable.TBL", status='old', form='formatted', action='read', iostat=ierr) + else + open(15, status='old', form='formatted', action='read', iostat=ierr) + end if + if ( ierr /= 0 ) then + write(*,'("WARNING: Cannot find file NoahmpTable.TBL")') + endif + read(15, noahmp_stas_soil_categories) + if ( trim(SLTYPE) == "STAS" ) then + read(15, noahmp_soil_stas_parameters) + elseif ( trim(SLTYPE) == "STAS_RUC" ) then + read(15, noahmp_soil_stas_ruc_parameters) + else + write(*,'("WARNING: Unrecognized SOILTYPE in subroutine ReadNoahmpTable")') + write(*,'("WARNING: DATASET_IDENTIFIER = ''", A, "''")') trim(SLTYPE) + endif + close(15) + + ! assign values + NoahmpIO%SLCATS_TABLE = SLCATS + NoahmpIO%BEXP_TABLE (1:SLCATS) = BB (1:SLCATS) + NoahmpIO%SMCDRY_TABLE(1:SLCATS) = DRYSMC(1:SLCATS) + NoahmpIO%SMCMAX_TABLE(1:SLCATS) = MAXSMC(1:SLCATS) + NoahmpIO%SMCREF_TABLE(1:SLCATS) = REFSMC(1:SLCATS) + NoahmpIO%PSISAT_TABLE(1:SLCATS) = SATPSI(1:SLCATS) + NoahmpIO%DKSAT_TABLE (1:SLCATS) = SATDK (1:SLCATS) + NoahmpIO%DWSAT_TABLE (1:SLCATS) = SATDW (1:SLCATS) + NoahmpIO%SMCWLT_TABLE(1:SLCATS) = WLTSMC(1:SLCATS) + NoahmpIO%QUARTZ_TABLE(1:SLCATS) = QTZ (1:SLCATS) + NoahmpIO%BVIC_TABLE (1:SLCATS) = BVIC (1:SLCATS) + NoahmpIO%AXAJ_TABLE (1:SLCATS) = AXAJ (1:SLCATS) + NoahmpIO%BXAJ_TABLE (1:SLCATS) = BXAJ (1:SLCATS) + NoahmpIO%XXAJ_TABLE (1:SLCATS) = XXAJ (1:SLCATS) + NoahmpIO%BDVIC_TABLE (1:SLCATS) = BDVIC (1:SLCATS) + NoahmpIO%GDVIC_TABLE (1:SLCATS) = GDVIC (1:SLCATS) + NoahmpIO%BBVIC_TABLE (1:SLCATS) = BBVIC (1:SLCATS) + + !---------------- NoahmpTable.TBL general parameters + inquire( file='NoahmpTable.TBL', exist=file_named ) + if ( file_named ) then + open(15, file="NoahmpTable.TBL", status='old', form='formatted', action='read', iostat=ierr) + else + open(15, status='old', form='formatted', action='read', iostat=ierr) + end if + if ( ierr /= 0 ) then + write(*,'("WARNING: Cannot find file NoahmpTable.TBL")') + endif + read(15, noahmp_general_parameters) + close(15) + + ! assign values + NoahmpIO%SLOPE_TABLE(1:NUM_SLOPE) = SLOPE_DATA(1:NUM_SLOPE) + NoahmpIO%CSOIL_TABLE = CSOIL_DATA + NoahmpIO%REFDK_TABLE = REFDK_DATA + NoahmpIO%REFKDT_TABLE = REFKDT_DATA + NoahmpIO%FRZK_TABLE = FRZK_DATA + NoahmpIO%ZBOT_TABLE = ZBOT_DATA + NoahmpIO%CZIL_TABLE = CZIL_DATA + + !---------------- NoahmpTable.TBL radiation parameters + inquire( file='NoahmpTable.TBL', exist=file_named ) + if ( file_named ) then + open(15, file="NoahmpTable.TBL", status='old', form='formatted', action='read', iostat=ierr) + else + open(15, status='old', form='formatted', action='read', iostat=ierr) + end if + if (ierr /= 0) then + write(*,'("WARNING: Cannot find file NoahmpTable.TBL")') + endif + read(15,noahmp_rad_parameters) + close(15) + + ! assign values + NoahmpIO%ALBSAT_TABLE(:,1) = ALBSAT_VIS ! saturated soil albedos: 1=vis, 2=nir + NoahmpIO%ALBSAT_TABLE(:,2) = ALBSAT_NIR ! saturated soil albedos: 1=vis, 2=nir + NoahmpIO%ALBDRY_TABLE(:,1) = ALBDRY_VIS ! dry soil albedos: 1=vis, 2=nir + NoahmpIO%ALBDRY_TABLE(:,2) = ALBDRY_NIR ! dry soil albedos: 1=vis, 2=nir + NoahmpIO%ALBICE_TABLE = ALBICE + NoahmpIO%ALBLAK_TABLE = ALBLAK + NoahmpIO%OMEGAS_TABLE = OMEGAS + NoahmpIO%BETADS_TABLE = BETADS + NoahmpIO%BETAIS_TABLE = BETAIS + NoahmpIO%EG_TABLE = EG + NoahmpIO%EICE_TABLE = EICE + + !---------------- NoahmpTable.TBL global parameters + inquire( file='NoahmpTable.TBL', exist=file_named ) + if ( file_named ) then + open(15, file="NoahmpTable.TBL", status='old', form='formatted', action='read', iostat=ierr) + else + open(15, status='old', form='formatted', action='read', iostat=ierr) + end if + if (ierr /= 0) then + write(*,'("WARNING: Cannot find file NoahmpTable.TBL")') + endif + read(15,noahmp_global_parameters) + close(15) + + ! assign values + NoahmpIO%CO2_TABLE = CO2 + NoahmpIO%O2_TABLE = O2 + NoahmpIO%TIMEAN_TABLE = TIMEAN + NoahmpIO%FSATMX_TABLE = FSATMX + NoahmpIO%Z0SNO_TABLE = Z0SNO + NoahmpIO%SSI_TABLE = SSI + NoahmpIO%SNOW_RET_FAC_TABLE = SNOW_RET_FAC + NoahmpIO%SNOW_EMIS_TABLE = SNOW_EMIS + NoahmpIO%SWEMX_TABLE = SWEMX + NoahmpIO%TAU0_TABLE = TAU0 + NoahmpIO%GRAIN_GROWTH_TABLE = GRAIN_GROWTH + NoahmpIO%EXTRA_GROWTH_TABLE = EXTRA_GROWTH + NoahmpIO%DIRT_SOOT_TABLE = DIRT_SOOT + NoahmpIO%BATS_COSZ_TABLE = BATS_COSZ + NoahmpIO%BATS_VIS_NEW_TABLE = BATS_VIS_NEW + NoahmpIO%BATS_NIR_NEW_TABLE = BATS_NIR_NEW + NoahmpIO%BATS_VIS_AGE_TABLE = BATS_VIS_AGE + NoahmpIO%BATS_NIR_AGE_TABLE = BATS_NIR_AGE + NoahmpIO%BATS_VIS_DIR_TABLE = BATS_VIS_DIR + NoahmpIO%BATS_NIR_DIR_TABLE = BATS_NIR_DIR + NoahmpIO%RSURF_SNOW_TABLE = RSURF_SNOW + NoahmpIO%RSURF_EXP_TABLE = RSURF_EXP + NoahmpIO%C2_SNOWCOMPACT_TABLE = C2_SNOWCOMPACT + NoahmpIO%C3_SNOWCOMPACT_TABLE = C3_SNOWCOMPACT + NoahmpIO%C4_SNOWCOMPACT_TABLE = C4_SNOWCOMPACT + NoahmpIO%C5_SNOWCOMPACT_TABLE = C5_SNOWCOMPACT + NoahmpIO%DM_SNOWCOMPACT_TABLE = DM_SNOWCOMPACT + NoahmpIO%ETA0_SNOWCOMPACT_TABLE = ETA0_SNOWCOMPACT + NoahmpIO%SNLIQMAXFRAC_TABLE = SNLIQMAXFRAC + NoahmpIO%SWEMAXGLA_TABLE = SWEMAXGLA + NoahmpIO%WSLMAX_TABLE = WSLMAX + NoahmpIO%ROUS_TABLE = ROUS + NoahmpIO%CMIC_TABLE = CMIC + NoahmpIO%SNOWDEN_MAX_TABLE = SNOWDEN_MAX + NoahmpIO%CLASS_ALB_REF_TABLE = CLASS_ALB_REF + NoahmpIO%CLASS_SNO_AGE_TABLE = CLASS_SNO_AGE + NoahmpIO%CLASS_ALB_NEW_TABLE = CLASS_ALB_NEW + NoahmpIO%PSIWLT_TABLE = PSIWLT + NoahmpIO%Z0SOIL_TABLE = Z0SOIL + NoahmpIO%Z0LAKE_TABLE = Z0LAKE + + !---------------- NoahmpTable.TBL irrigation parameters + inquire( file='NoahmpTable.TBL', exist=file_named ) + if ( file_named ) then + open(15, file="NoahmpTable.TBL", status='old', form='formatted', action='read', iostat=ierr) + else + open(15, status='old', form='formatted', action='read', iostat=ierr) + end if + if (ierr /= 0) then + write(*,'("WARNING: Cannot find file NoahmpTable.TBL")') + endif + read(15,noahmp_irrigation_parameters) + close(15) + if ( (FILOSS < 0.0) .or. (FILOSS > 0.99) ) then + write(*,'("WARNING: FILOSS should be >=0.0 and <=0.99")') + stop "STOP in NoahMP_irrigation_parameters" + endif + + ! assign values + NoahmpIO%IRR_FRAC_TABLE = IRR_FRAC + NoahmpIO%IRR_HAR_TABLE = IRR_HAR + NoahmpIO%IRR_LAI_TABLE = IRR_LAI + NoahmpIO%IRR_MAD_TABLE = IRR_MAD + NoahmpIO%FILOSS_TABLE = FILOSS + NoahmpIO%SPRIR_RATE_TABLE = SPRIR_RATE + NoahmpIO%MICIR_RATE_TABLE = MICIR_RATE + NoahmpIO%FIRTFAC_TABLE = FIRTFAC + NoahmpIO%IR_RAIN_TABLE = IR_RAIN + + !---------------- NoahmpTable.TBL crop parameters + inquire( file='NoahmpTable.TBL', exist=file_named ) + if ( file_named ) then + open(15, file="NoahmpTable.TBL", status='old', form='formatted', action='read', iostat=ierr) + else + open(15, status='old', form='formatted', action='read', iostat=ierr) + end if + if (ierr /= 0) then + write(*,'("WARNING: Cannot find file NoahmpTable.TBL")') + endif + read(15,noahmp_crop_parameters) + close(15) + + ! assign values + NoahmpIO%DEFAULT_CROP_TABLE = DEFAULT_CROP + NoahmpIO%PLTDAY_TABLE = PLTDAY + NoahmpIO%HSDAY_TABLE = HSDAY + NoahmpIO%PLANTPOP_TABLE = PLANTPOP + NoahmpIO%IRRI_TABLE = IRRI + NoahmpIO%GDDTBASE_TABLE = GDDTBASE + NoahmpIO%GDDTCUT_TABLE = GDDTCUT + NoahmpIO%GDDS1_TABLE = GDDS1 + NoahmpIO%GDDS2_TABLE = GDDS2 + NoahmpIO%GDDS3_TABLE = GDDS3 + NoahmpIO%GDDS4_TABLE = GDDS4 + NoahmpIO%GDDS5_TABLE = GDDS5 + NoahmpIO%C3PSNI_TABLE (1:5) = C3PSNI (1:5) + NoahmpIO%KC25I_TABLE (1:5) = KC25I (1:5) + NoahmpIO%AKCI_TABLE (1:5) = AKCI (1:5) + NoahmpIO%KO25I_TABLE (1:5) = KO25I (1:5) + NoahmpIO%AKOI_TABLE (1:5) = AKOI (1:5) + NoahmpIO%AVCMXI_TABLE (1:5) = AVCMXI (1:5) + NoahmpIO%VCMX25I_TABLE(1:5) = VCMX25I(1:5) + NoahmpIO%BPI_TABLE (1:5) = BPI (1:5) + NoahmpIO%MPI_TABLE (1:5) = MPI (1:5) + NoahmpIO%FOLNMXI_TABLE(1:5) = FOLNMXI(1:5) + NoahmpIO%QE25I_TABLE (1:5) = QE25I (1:5) + NoahmpIO%AREF_TABLE = AREF + NoahmpIO%PSNRF_TABLE = PSNRF + NoahmpIO%I2PAR_TABLE = I2PAR + NoahmpIO%TASSIM0_TABLE = TASSIM0 + NoahmpIO%TASSIM1_TABLE = TASSIM1 + NoahmpIO%TASSIM2_TABLE = TASSIM2 + NoahmpIO%K_TABLE = K + NoahmpIO%EPSI_TABLE = EPSI + NoahmpIO%Q10MR_TABLE = Q10MR + NoahmpIO%LEFREEZ_TABLE = LEFREEZ + NoahmpIO%FRA_GR_TABLE = FRA_GR + NoahmpIO%LFMR25_TABLE = LFMR25 + NoahmpIO%STMR25_TABLE = STMR25 + NoahmpIO%RTMR25_TABLE = RTMR25 + NoahmpIO%GRAINMR25_TABLE = GRAINMR25 + NoahmpIO%BIO2LAI_TABLE = BIO2LAI + NoahmpIO%DILE_FC_TABLE(:,1) = DILE_FC_S1 + NoahmpIO%DILE_FC_TABLE(:,2) = DILE_FC_S2 + NoahmpIO%DILE_FC_TABLE(:,3) = DILE_FC_S3 + NoahmpIO%DILE_FC_TABLE(:,4) = DILE_FC_S4 + NoahmpIO%DILE_FC_TABLE(:,5) = DILE_FC_S5 + NoahmpIO%DILE_FC_TABLE(:,6) = DILE_FC_S6 + NoahmpIO%DILE_FC_TABLE(:,7) = DILE_FC_S7 + NoahmpIO%DILE_FC_TABLE(:,8) = DILE_FC_S8 + NoahmpIO%DILE_FW_TABLE(:,1) = DILE_FW_S1 + NoahmpIO%DILE_FW_TABLE(:,2) = DILE_FW_S2 + NoahmpIO%DILE_FW_TABLE(:,3) = DILE_FW_S3 + NoahmpIO%DILE_FW_TABLE(:,4) = DILE_FW_S4 + NoahmpIO%DILE_FW_TABLE(:,5) = DILE_FW_S5 + NoahmpIO%DILE_FW_TABLE(:,6) = DILE_FW_S6 + NoahmpIO%DILE_FW_TABLE(:,7) = DILE_FW_S7 + NoahmpIO%DILE_FW_TABLE(:,8) = DILE_FW_S8 + NoahmpIO%LF_OVRC_TABLE(:,1) = LF_OVRC_S1 + NoahmpIO%LF_OVRC_TABLE(:,2) = LF_OVRC_S2 + NoahmpIO%LF_OVRC_TABLE(:,3) = LF_OVRC_S3 + NoahmpIO%LF_OVRC_TABLE(:,4) = LF_OVRC_S4 + NoahmpIO%LF_OVRC_TABLE(:,5) = LF_OVRC_S5 + NoahmpIO%LF_OVRC_TABLE(:,6) = LF_OVRC_S6 + NoahmpIO%LF_OVRC_TABLE(:,7) = LF_OVRC_S7 + NoahmpIO%LF_OVRC_TABLE(:,8) = LF_OVRC_S8 + NoahmpIO%ST_OVRC_TABLE(:,1) = ST_OVRC_S1 + NoahmpIO%ST_OVRC_TABLE(:,2) = ST_OVRC_S2 + NoahmpIO%ST_OVRC_TABLE(:,3) = ST_OVRC_S3 + NoahmpIO%ST_OVRC_TABLE(:,4) = ST_OVRC_S4 + NoahmpIO%ST_OVRC_TABLE(:,5) = ST_OVRC_S5 + NoahmpIO%ST_OVRC_TABLE(:,6) = ST_OVRC_S6 + NoahmpIO%ST_OVRC_TABLE(:,7) = ST_OVRC_S7 + NoahmpIO%ST_OVRC_TABLE(:,8) = ST_OVRC_S8 + NoahmpIO%RT_OVRC_TABLE(:,1) = RT_OVRC_S1 + NoahmpIO%RT_OVRC_TABLE(:,2) = RT_OVRC_S2 + NoahmpIO%RT_OVRC_TABLE(:,3) = RT_OVRC_S3 + NoahmpIO%RT_OVRC_TABLE(:,4) = RT_OVRC_S4 + NoahmpIO%RT_OVRC_TABLE(:,5) = RT_OVRC_S5 + NoahmpIO%RT_OVRC_TABLE(:,6) = RT_OVRC_S6 + NoahmpIO%RT_OVRC_TABLE(:,7) = RT_OVRC_S7 + NoahmpIO%RT_OVRC_TABLE(:,8) = RT_OVRC_S8 + NoahmpIO%LFPT_TABLE (:,1) = LFPT_S1 + NoahmpIO%LFPT_TABLE (:,2) = LFPT_S2 + NoahmpIO%LFPT_TABLE (:,3) = LFPT_S3 + NoahmpIO%LFPT_TABLE (:,4) = LFPT_S4 + NoahmpIO%LFPT_TABLE (:,5) = LFPT_S5 + NoahmpIO%LFPT_TABLE (:,6) = LFPT_S6 + NoahmpIO%LFPT_TABLE (:,7) = LFPT_S7 + NoahmpIO%LFPT_TABLE (:,8) = LFPT_S8 + NoahmpIO%STPT_TABLE (:,1) = STPT_S1 + NoahmpIO%STPT_TABLE (:,2) = STPT_S2 + NoahmpIO%STPT_TABLE (:,3) = STPT_S3 + NoahmpIO%STPT_TABLE (:,4) = STPT_S4 + NoahmpIO%STPT_TABLE (:,5) = STPT_S5 + NoahmpIO%STPT_TABLE (:,6) = STPT_S6 + NoahmpIO%STPT_TABLE (:,7) = STPT_S7 + NoahmpIO%STPT_TABLE (:,8) = STPT_S8 + NoahmpIO%RTPT_TABLE (:,1) = RTPT_S1 + NoahmpIO%RTPT_TABLE (:,2) = RTPT_S2 + NoahmpIO%RTPT_TABLE (:,3) = RTPT_S3 + NoahmpIO%RTPT_TABLE (:,4) = RTPT_S4 + NoahmpIO%RTPT_TABLE (:,5) = RTPT_S5 + NoahmpIO%RTPT_TABLE (:,6) = RTPT_S6 + NoahmpIO%RTPT_TABLE (:,7) = RTPT_S7 + NoahmpIO%RTPT_TABLE (:,8) = RTPT_S8 + NoahmpIO%GRAINPT_TABLE(:,1) = GRAINPT_S1 + NoahmpIO%GRAINPT_TABLE(:,2) = GRAINPT_S2 + NoahmpIO%GRAINPT_TABLE(:,3) = GRAINPT_S3 + NoahmpIO%GRAINPT_TABLE(:,4) = GRAINPT_S4 + NoahmpIO%GRAINPT_TABLE(:,5) = GRAINPT_S5 + NoahmpIO%GRAINPT_TABLE(:,6) = GRAINPT_S6 + NoahmpIO%GRAINPT_TABLE(:,7) = GRAINPT_S7 + NoahmpIO%GRAINPT_TABLE(:,8) = GRAINPT_S8 + NoahmpIO%LFCT_TABLE (:,1) = LFCT_S1 + NoahmpIO%LFCT_TABLE (:,2) = LFCT_S2 + NoahmpIO%LFCT_TABLE (:,3) = LFCT_S3 + NoahmpIO%LFCT_TABLE (:,4) = LFCT_S4 + NoahmpIO%LFCT_TABLE (:,5) = LFCT_S5 + NoahmpIO%LFCT_TABLE (:,6) = LFCT_S6 + NoahmpIO%LFCT_TABLE (:,7) = LFCT_S7 + NoahmpIO%LFCT_TABLE (:,8) = LFCT_S8 + NoahmpIO%STCT_TABLE (:,1) = STCT_S1 + NoahmpIO%STCT_TABLE (:,2) = STCT_S2 + NoahmpIO%STCT_TABLE (:,3) = STCT_S3 + NoahmpIO%STCT_TABLE (:,4) = STCT_S4 + NoahmpIO%STCT_TABLE (:,5) = STCT_S5 + NoahmpIO%STCT_TABLE (:,6) = STCT_S6 + NoahmpIO%STCT_TABLE (:,7) = STCT_S7 + NoahmpIO%STCT_TABLE (:,8) = STCT_S8 + NoahmpIO%RTCT_TABLE (:,1) = RTCT_S1 + NoahmpIO%RTCT_TABLE (:,2) = RTCT_S2 + NoahmpIO%RTCT_TABLE (:,3) = RTCT_S3 + NoahmpIO%RTCT_TABLE (:,4) = RTCT_S4 + NoahmpIO%RTCT_TABLE (:,5) = RTCT_S5 + NoahmpIO%RTCT_TABLE (:,6) = RTCT_S6 + NoahmpIO%RTCT_TABLE (:,7) = RTCT_S7 + NoahmpIO%RTCT_TABLE (:,8) = RTCT_S8 + + !---------------- NoahmpTable.TBL tile drainage parameters + inquire( file='NoahmpTable.TBL', exist=file_named ) + if ( file_named ) then + open(15, file="NoahmpTable.TBL", status='old', form='formatted', action='read', iostat=ierr) + else + open(15, status='old', form='formatted', action='read', iostat=ierr) + end if + if (ierr /= 0) then + write(*,'("WARNING: Cannot find file NoahmpTable.TBL")') + endif + read(15,noahmp_tiledrain_parameters) + close(15) + + ! assign values + NoahmpIO%DRAIN_LAYER_OPT_TABLE = DRAIN_LAYER_OPT + NoahmpIO%TDSMC_FAC_TABLE(1:NSOILTYPE) = TDSMC_FAC(1:NSOILTYPE) + NoahmpIO%TD_DEPTH_TABLE (1:NSOILTYPE) = TD_DEPTH (1:NSOILTYPE) + NoahmpIO%TD_DC_TABLE (1:NSOILTYPE) = TD_DC (1:NSOILTYPE) + NoahmpIO%TD_DCOEF_TABLE (1:NSOILTYPE) = TD_DCOEF (1:NSOILTYPE) + NoahmpIO%TD_D_TABLE (1:NSOILTYPE) = TD_D (1:NSOILTYPE) + NoahmpIO%TD_ADEPTH_TABLE(1:NSOILTYPE) = TD_ADEPTH(1:NSOILTYPE) + NoahmpIO%TD_RADI_TABLE (1:NSOILTYPE) = TD_RADI (1:NSOILTYPE) + NoahmpIO%TD_SPAC_TABLE (1:NSOILTYPE) = TD_SPAC (1:NSOILTYPE) + NoahmpIO%TD_DDRAIN_TABLE(1:NSOILTYPE) = TD_DDRAIN(1:NSOILTYPE) + NoahmpIO%KLAT_FAC_TABLE (1:NSOILTYPE) = KLAT_FAC (1:NSOILTYPE) + + !---------------- NoahmpTable.TBL optional parameters + inquire( file='NoahmpTable.TBL', exist=file_named ) + if ( file_named ) then + open(15, file="NoahmpTable.TBL", status='old', form='formatted', action='read', iostat=ierr) + else + open(15, status='old', form='formatted', action='read', iostat=ierr) + end if + if (ierr /= 0) then + write(*,'("WARNING: Cannot find file NoahmpTable.TBL")') + endif + read(15,noahmp_optional_parameters) + close(15) + + ! assign values + NoahmpIO%sr2006_theta_1500t_a_TABLE = sr2006_theta_1500t_a + NoahmpIO%sr2006_theta_1500t_b_TABLE = sr2006_theta_1500t_b + NoahmpIO%sr2006_theta_1500t_c_TABLE = sr2006_theta_1500t_c + NoahmpIO%sr2006_theta_1500t_d_TABLE = sr2006_theta_1500t_d + NoahmpIO%sr2006_theta_1500t_e_TABLE = sr2006_theta_1500t_e + NoahmpIO%sr2006_theta_1500t_f_TABLE = sr2006_theta_1500t_f + NoahmpIO%sr2006_theta_1500t_g_TABLE = sr2006_theta_1500t_g + NoahmpIO%sr2006_theta_1500_a_TABLE = sr2006_theta_1500_a + NoahmpIO%sr2006_theta_1500_b_TABLE = sr2006_theta_1500_b + NoahmpIO%sr2006_theta_33t_a_TABLE = sr2006_theta_33t_a + NoahmpIO%sr2006_theta_33t_b_TABLE = sr2006_theta_33t_b + NoahmpIO%sr2006_theta_33t_c_TABLE = sr2006_theta_33t_c + NoahmpIO%sr2006_theta_33t_d_TABLE = sr2006_theta_33t_d + NoahmpIO%sr2006_theta_33t_e_TABLE = sr2006_theta_33t_e + NoahmpIO%sr2006_theta_33t_f_TABLE = sr2006_theta_33t_f + NoahmpIO%sr2006_theta_33t_g_TABLE = sr2006_theta_33t_g + NoahmpIO%sr2006_theta_33_a_TABLE = sr2006_theta_33_a + NoahmpIO%sr2006_theta_33_b_TABLE = sr2006_theta_33_b + NoahmpIO%sr2006_theta_33_c_TABLE = sr2006_theta_33_c + NoahmpIO%sr2006_theta_s33t_a_TABLE = sr2006_theta_s33t_a + NoahmpIO%sr2006_theta_s33t_b_TABLE = sr2006_theta_s33t_b + NoahmpIO%sr2006_theta_s33t_c_TABLE = sr2006_theta_s33t_c + NoahmpIO%sr2006_theta_s33t_d_TABLE = sr2006_theta_s33t_d + NoahmpIO%sr2006_theta_s33t_e_TABLE = sr2006_theta_s33t_e + NoahmpIO%sr2006_theta_s33t_f_TABLE = sr2006_theta_s33t_f + NoahmpIO%sr2006_theta_s33t_g_TABLE = sr2006_theta_s33t_g + NoahmpIO%sr2006_theta_s33_a_TABLE = sr2006_theta_s33_a + NoahmpIO%sr2006_theta_s33_b_TABLE = sr2006_theta_s33_b + NoahmpIO%sr2006_psi_et_a_TABLE = sr2006_psi_et_a + NoahmpIO%sr2006_psi_et_b_TABLE = sr2006_psi_et_b + NoahmpIO%sr2006_psi_et_c_TABLE = sr2006_psi_et_c + NoahmpIO%sr2006_psi_et_d_TABLE = sr2006_psi_et_d + NoahmpIO%sr2006_psi_et_e_TABLE = sr2006_psi_et_e + NoahmpIO%sr2006_psi_et_f_TABLE = sr2006_psi_et_f + NoahmpIO%sr2006_psi_et_g_TABLE = sr2006_psi_et_g + NoahmpIO%sr2006_psi_e_a_TABLE = sr2006_psi_e_a + NoahmpIO%sr2006_psi_e_b_TABLE = sr2006_psi_e_b + NoahmpIO%sr2006_psi_e_c_TABLE = sr2006_psi_e_c + NoahmpIO%sr2006_smcmax_a_TABLE = sr2006_smcmax_a + NoahmpIO%sr2006_smcmax_b_TABLE = sr2006_smcmax_b + + end subroutine NoahmpReadTable + +end module NoahmpReadTableMod diff --git a/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/NoahmpSnowInitMod.F90 b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/NoahmpSnowInitMod.F90 new file mode 100644 index 0000000000..56a9aeb96c --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/NoahmpSnowInitMod.F90 @@ -0,0 +1,115 @@ + module NoahmpSnowInitMod + +! Module to initialize Noah-MP Snow variables + + use Machine + use NoahmpIOVarType + + implicit none + + contains + + subroutine NoahmpSnowInitMain(NoahmpIO) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: SNOW_INIT +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(NoahmpIO_type), intent(inout) :: NoahmpIO + +!local variables + integer :: i,its,ite,iz + real(kind=kind_noahmp), dimension(-NoahmpIO%nsnow+1: 0) :: dzsno + real(kind=kind_noahmp), dimension(-NoahmpIO%nsnow+1:NoahmpIO%nsoil) :: dzsnso + +!------------------------------------------------------------------------------------------ +! Initialize snow arrays for Noah-MP LSM, based in input SNOWDEP, NSNOW +! ISNOWXY is an index array, indicating the index of the top snow layer. Valid indices +! for snow layers range from 0 (no snow) and -1 (shallow snow) to (-NSNOW)+1 (deep snow). +! TSNOXY holds the temperature of the snow layer. Snow layers are initialized with +! temperature = ground temperature [?]. Snow-free levels in the array have value 0.0 +! SNICEXY is the frozen content of a snow layer. Initial estimate based on SNOWH and SNOW +! SNLIQXY is the liquid content of a snow layer. Initialized to 0.0 +! ZNSNOXY is the layer depth from the surface. +!------------------------------------------------------------------------------------------ + + its = NoahmpIO%its + ite = NoahmpIO%ite + + do i = its, ite + + ! initialize snow layers and thickness + ! no explicit snow layer + if ( NoahmpIO%snowh(i) < 0.025 ) then + NoahmpIO%isnowxy(i) = 0 + dzsno(-NoahmpIO%nsnow+1:0) = 0.0 + else + ! 1 layer snow + if ( (NoahmpIO%snowh(i) >= 0.025) .and. (NoahmpIO%snowh(i) <= 0.05) ) then + NoahmpIO%isnowxy(i) = -1 + dzsno(0) = NoahmpIO%snowh(i) + ! 2 layer snow + elseif ( (NoahmpIO%snowh(i) > 0.05) .and. (NoahmpIO%snowh(i) <= 0.10) ) then + NoahmpIO%isnowxy(i) = -2 + dzsno(-1) = NoahmpIO%snowh(i) / 2.0 + dzsno( 0) = NoahmpIO%snowh(i) / 2.0 + ! 2 layer thick snow + elseif ( (NoahmpIO%snowh(i) > 0.10) .and. (NoahmpIO%snowh(i) <= 0.25) ) then + NoahmpIO%isnowxy(i) = -2 + dzsno(-1) = 0.05 + dzsno( 0) = NoahmpIO%snowh(i) - dzsno(-1) + ! 3 layer snow + elseif ( (NoahmpIO%snowh(i) > 0.25) .and. (NoahmpIO%snowh(i) <= 0.45) ) then + NoahmpIO%isnowxy(i) = -3 + dzsno(-2) = 0.05 + dzsno(-1) = 0.5 * (NoahmpIO%snowh(i)-dzsno(-2)) + dzsno( 0) = 0.5 * (NoahmpIO%snowh(i)-dzsno(-2)) + ! 3 layer thick snow + elseif ( NoahmpIO%snowh(i) > 0.45 ) then + NoahmpIO%isnowxy(i) = -3 + dzsno(-2) = 0.05 + dzsno(-1) = 0.20 + dzsno( 0) = NoahmpIO%snowh(i) - dzsno(-1) - dzsno(-2) + else + print*, "problem with the logic assigning snow layers." + stop + endif + endif + + ! initialize snow temperatuer and ice/liquid content + NoahmpIO%tsnoxy (i,-NoahmpIO%nsnow+1:0) = 0.0 + NoahmpIO%snicexy(i,-NoahmpIO%nsnow+1:0) = 0.0 + NoahmpIO%snliqxy(i,-NoahmpIO%nsnow+1:0) = 0.0 + do iz = NoahmpIO%isnowxy(i)+1, 0 + NoahmpIO%tsnoxy(i,iz) = NoahmpIO%tgxy(i) + NoahmpIO%snliqxy(i,iz) = 0.0 + NoahmpIO%snicexy(i,iz) = 1.0 * dzsno(iz) * (NoahmpIO%snow(i)/NoahmpIO%snowh(i)) + enddo + + ! assign local variable dzsnso, the soil/snow layer thicknesses, for snow layers + do iz = NoahmpIO%isnowxy(i)+1, 0 + dzsnso(iz) = -dzsno(iz) + enddo + + ! assign local variable dzsnso, the soil/snow layer thicknesses, for soil layers + dzsnso(1) = NoahmpIO%zsoil(1) + do iz = 2, NoahmpIO%nsoil + dzsnso(iz) = NoahmpIO%zsoil(iz) - NoahmpIO%zsoil(iz-1) + enddo + + ! assign zsnsoxy, the layer depths, for soil and snow layers + NoahmpIO%zsnsoxy(i,NoahmpIO%isnowxy(i)+1) = dzsnso(NoahmpIO%isnowxy(i)+1) + do iz = NoahmpIO%isnowxy(i)+2, NoahmpIO%nsoil + NoahmpIO%zsnsoxy(i,iz) = NoahmpIO%zsnsoxy(i,iz-1) + dzsnso(iz) + enddo + + enddo + + end subroutine NoahmpSnowInitMain + + end module NoahmpSnowInitMod + diff --git a/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/PedoTransferSR2006Mod.F90 b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/PedoTransferSR2006Mod.F90 new file mode 100644 index 0000000000..02090e82aa --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/PedoTransferSR2006Mod.F90 @@ -0,0 +1,210 @@ +module PedoTransferSR2006Mod + +!!! Compute soil water infiltration based on different soil composition + + use Machine + use NoahmpIOVarType + use NoahmpVarType + + implicit none + +contains + + subroutine PedoTransferSR2006(NoahmpIO, noahmp, Sand, Clay, Orgm) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: PEDOTRANSFER_SR2006 +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(NoahmpIO_type), intent(inout) :: NoahmpIO + type(noahmp_type) , intent(inout) :: noahmp + + real(kind=kind_noahmp), dimension(1:NoahmpIO%NSOIL), intent(inout) :: Sand + real(kind=kind_noahmp), dimension(1:NoahmpIO%NSOIL), intent(inout) :: Clay + real(kind=kind_noahmp), dimension(1:NoahmpIO%NSOIL), intent(inout) :: Orgm + +! local + integer :: k + real(kind=kind_noahmp), dimension( 1:NoahmpIO%NSOIL ) :: theta_1500t + real(kind=kind_noahmp), dimension( 1:NoahmpIO%NSOIL ) :: theta_1500 + real(kind=kind_noahmp), dimension( 1:NoahmpIO%NSOIL ) :: theta_33t + real(kind=kind_noahmp), dimension( 1:NoahmpIO%NSOIL ) :: theta_33 + real(kind=kind_noahmp), dimension( 1:NoahmpIO%NSOIL ) :: theta_s33t + real(kind=kind_noahmp), dimension( 1:NoahmpIO%NSOIL ) :: theta_s33 + real(kind=kind_noahmp), dimension( 1:NoahmpIO%NSOIL ) :: psi_et + real(kind=kind_noahmp), dimension( 1:NoahmpIO%NSOIL ) :: psi_e + real(kind=kind_noahmp), dimension( 1:NoahmpIO%NSOIL ) :: smcmax + real(kind=kind_noahmp), dimension( 1:NoahmpIO%NSOIL ) :: smcref + real(kind=kind_noahmp), dimension( 1:NoahmpIO%NSOIL ) :: smcwlt + real(kind=kind_noahmp), dimension( 1:NoahmpIO%NSOIL ) :: smcdry + real(kind=kind_noahmp), dimension( 1:NoahmpIO%NSOIL ) :: bexp + real(kind=kind_noahmp), dimension( 1:NoahmpIO%NSOIL ) :: psisat + real(kind=kind_noahmp), dimension( 1:NoahmpIO%NSOIL ) :: dksat + real(kind=kind_noahmp), dimension( 1:NoahmpIO%NSOIL ) :: dwsat + real(kind=kind_noahmp), dimension( 1:NoahmpIO%NSOIL ) :: quartz + +! ------------------------------------------------------------------------------ + associate( & + sr2006_theta_1500t_a => NoahmpIO%sr2006_theta_1500t_a_TABLE ,& + sr2006_theta_1500t_b => NoahmpIO%sr2006_theta_1500t_b_TABLE ,& + sr2006_theta_1500t_c => NoahmpIO%sr2006_theta_1500t_c_TABLE ,& + sr2006_theta_1500t_d => NoahmpIO%sr2006_theta_1500t_d_TABLE ,& + sr2006_theta_1500t_e => NoahmpIO%sr2006_theta_1500t_e_TABLE ,& + sr2006_theta_1500t_f => NoahmpIO%sr2006_theta_1500t_f_TABLE ,& + sr2006_theta_1500t_g => NoahmpIO%sr2006_theta_1500t_g_TABLE ,& + sr2006_theta_1500_a => NoahmpIO%sr2006_theta_1500_a_TABLE ,& + sr2006_theta_1500_b => NoahmpIO%sr2006_theta_1500_b_TABLE ,& + sr2006_theta_33t_a => NoahmpIO%sr2006_theta_33t_a_TABLE ,& + sr2006_theta_33t_b => NoahmpIO%sr2006_theta_33t_b_TABLE ,& + sr2006_theta_33t_c => NoahmpIO%sr2006_theta_33t_c_TABLE ,& + sr2006_theta_33t_d => NoahmpIO%sr2006_theta_33t_d_TABLE ,& + sr2006_theta_33t_e => NoahmpIO%sr2006_theta_33t_e_TABLE ,& + sr2006_theta_33t_f => NoahmpIO%sr2006_theta_33t_f_TABLE ,& + sr2006_theta_33t_g => NoahmpIO%sr2006_theta_33t_g_TABLE ,& + sr2006_theta_33_a => NoahmpIO%sr2006_theta_33_a_TABLE ,& + sr2006_theta_33_b => NoahmpIO%sr2006_theta_33_b_TABLE ,& + sr2006_theta_33_c => NoahmpIO%sr2006_theta_33_c_TABLE ,& + sr2006_theta_s33t_a => NoahmpIO%sr2006_theta_s33t_a_TABLE ,& + sr2006_theta_s33t_b => NoahmpIO%sr2006_theta_s33t_b_TABLE ,& + sr2006_theta_s33t_c => NoahmpIO%sr2006_theta_s33t_c_TABLE ,& + sr2006_theta_s33t_d => NoahmpIO%sr2006_theta_s33t_d_TABLE ,& + sr2006_theta_s33t_e => NoahmpIO%sr2006_theta_s33t_e_TABLE ,& + sr2006_theta_s33t_f => NoahmpIO%sr2006_theta_s33t_f_TABLE ,& + sr2006_theta_s33t_g => NoahmpIO%sr2006_theta_s33t_g_TABLE ,& + sr2006_theta_s33_a => NoahmpIO%sr2006_theta_s33_a_TABLE ,& + sr2006_theta_s33_b => NoahmpIO%sr2006_theta_s33_b_TABLE ,& + sr2006_psi_et_a => NoahmpIO%sr2006_psi_et_a_TABLE ,& + sr2006_psi_et_b => NoahmpIO%sr2006_psi_et_b_TABLE ,& + sr2006_psi_et_c => NoahmpIO%sr2006_psi_et_c_TABLE ,& + sr2006_psi_et_d => NoahmpIO%sr2006_psi_et_d_TABLE ,& + sr2006_psi_et_e => NoahmpIO%sr2006_psi_et_e_TABLE ,& + sr2006_psi_et_f => NoahmpIO%sr2006_psi_et_f_TABLE ,& + sr2006_psi_et_g => NoahmpIO%sr2006_psi_et_g_TABLE ,& + sr2006_psi_e_a => NoahmpIO%sr2006_psi_e_a_TABLE ,& + sr2006_psi_e_b => NoahmpIO%sr2006_psi_e_b_TABLE ,& + sr2006_psi_e_c => NoahmpIO%sr2006_psi_e_c_TABLE ,& + sr2006_smcmax_a => NoahmpIO%sr2006_smcmax_a_TABLE ,& + sr2006_smcmax_b => NoahmpIO%sr2006_smcmax_b_TABLE & + ) +! ------------------------------------------------------------------------------- + + ! initialize + smcmax = 0.0 + smcref = 0.0 + smcwlt = 0.0 + smcdry = 0.0 + bexp = 0.0 + psisat = 0.0 + dksat = 0.0 + dwsat = 0.0 + quartz = 0.0 + + do k = 1,4 + if(Sand(k) <= 0 .or. Clay(k) <= 0) then + Sand(k) = 0.41 + Clay(k) = 0.18 + end if + if(Orgm(k) <= 0 ) Orgm(k) = 0.0 + end do + + ! compute soil properties + theta_1500t = sr2006_theta_1500t_a*Sand & + + sr2006_theta_1500t_b*Clay & + + sr2006_theta_1500t_c*Orgm & + + sr2006_theta_1500t_d*Sand*Orgm & + + sr2006_theta_1500t_e*Clay*Orgm & + + sr2006_theta_1500t_f*Sand*Clay & + + sr2006_theta_1500t_g + + theta_1500 = theta_1500t & + + sr2006_theta_1500_a*theta_1500t & + + sr2006_theta_1500_b + + theta_33t = sr2006_theta_33t_a*Sand & + + sr2006_theta_33t_b*Clay & + + sr2006_theta_33t_c*Orgm & + + sr2006_theta_33t_d*Sand*Orgm & + + sr2006_theta_33t_e*Clay*Orgm & + + sr2006_theta_33t_f*Sand*Clay & + + sr2006_theta_33t_g + + theta_33 = theta_33t & + + sr2006_theta_33_a*theta_33t*theta_33t & + + sr2006_theta_33_b*theta_33t & + + sr2006_theta_33_c + + theta_s33t = sr2006_theta_s33t_a*Sand & + + sr2006_theta_s33t_b*Clay & + + sr2006_theta_s33t_c*Orgm & + + sr2006_theta_s33t_d*Sand*Orgm & + + sr2006_theta_s33t_e*Clay*Orgm & + + sr2006_theta_s33t_f*Sand*Clay & + + sr2006_theta_s33t_g + + theta_s33 = theta_s33t & + + sr2006_theta_s33_a*theta_s33t & + + sr2006_theta_s33_b + + psi_et = sr2006_psi_et_a*Sand & + + sr2006_psi_et_b*Clay & + + sr2006_psi_et_c*theta_s33 & + + sr2006_psi_et_d*Sand*theta_s33 & + + sr2006_psi_et_e*Clay*theta_s33 & + + sr2006_psi_et_f*Sand*Clay & + + sr2006_psi_et_g + + psi_e = psi_et & + + sr2006_psi_e_a*psi_et*psi_et & + + sr2006_psi_e_b*psi_et & + + sr2006_psi_e_c + + ! assign property values + smcwlt = theta_1500 + smcref = theta_33 + smcmax = theta_33 & + + theta_s33 & + + sr2006_smcmax_a*Sand & + + sr2006_smcmax_b + + bexp = 3.816712826 / (log(theta_33) - log(theta_1500) ) + psisat = psi_e + dksat = 1930.0 * (smcmax - theta_33) ** (3.0 - 1.0/bexp) + quartz = Sand + + ! Units conversion + psisat = max(0.1, psisat) ! arbitrarily impose a limit of 0.1kpa + psisat = 0.101997 * psisat ! convert kpa to m + dksat = dksat / 3600000.0 ! convert mm/h to m/s + dwsat = dksat * psisat * bexp / smcmax ! units should be m*m/s + smcdry = smcwlt + + ! Introducing somewhat arbitrary limits (based on NoahmpTable soil) to prevent bad things + smcmax = max(0.32 ,min(smcmax, 0.50 )) + smcref = max(0.17 ,min(smcref, smcmax)) + smcwlt = max(0.01 ,min(smcwlt, smcref)) + smcdry = max(0.01 ,min(smcdry, smcref)) + bexp = max(2.50 ,min(bexp, 12.0 )) + psisat = max(0.03 ,min(psisat, 1.00 )) + dksat = max(5.e-7,min(dksat, 1.e-5)) + dwsat = max(1.e-6,min(dwsat, 3.e-5)) + quartz = max(0.05 ,min(quartz, 0.95 )) + + noahmp%water%param%SoilMoistureWilt = smcwlt + noahmp%water%param%SoilMoistureFieldCap = smcref + noahmp%water%param%SoilMoistureSat = smcmax + noahmp%water%param%SoilMoistureDry = smcdry + noahmp%water%param%SoilExpCoeffB = bexp + noahmp%water%param%SoilMatPotentialSat = psisat + noahmp%water%param%SoilWatConductivitySat = dksat + noahmp%water%param%SoilWatDiffusivitySat = dwsat + noahmp%energy%param%SoilQuartzFrac = quartz + + end associate + + end subroutine PedoTransferSR2006 + +end module PedoTransferSR2006Mod diff --git a/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/WaterVarInTransferMod.F90 b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/WaterVarInTransferMod.F90 new file mode 100644 index 0000000000..add4dcec56 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/WaterVarInTransferMod.F90 @@ -0,0 +1,241 @@ +module WaterVarInTransferMod + +!!! Transfer input 2-D NoahmpIO Water variables to 1-D column variable +!!! 1-D variables should be first defined in /src/WaterVarType.F90 +!!! 2-D variables should be first defined in NoahmpIOVarType.F90 + +! ------------------------ Code history ----------------------------------- +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + use Machine + use NoahmpIOVarType + use NoahmpVarType + use PedoTransferSR2006Mod + + implicit none + +contains + +!=== initialize with input data or table values + + subroutine WaterVarInTransfer(noahmp, NoahmpIO) + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + type(NoahmpIO_type), intent(inout) :: NoahmpIO + + ! local variables + integer :: IndexSoilLayer + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilSand + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilClay + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilOrg + +! ------------------------------------------------------------------------- + associate( & + I => noahmp%config%domain%GridIndexI ,& + NumSnowLayerMax => noahmp%config%domain%NumSnowLayerMax ,& + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& + VegType => noahmp%config%domain%VegType ,& + SoilType => noahmp%config%domain%SoilType ,& + FlagUrban => noahmp%config%domain%FlagUrban ,& + RunoffSlopeType => noahmp%config%domain%RunoffSlopeType ,& + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg & + ) +! ------------------------------------------------------------------------- + + ! water state variables + noahmp%water%state%CanopyLiqWater = NoahmpIO%CANLIQXY (I) + noahmp%water%state%CanopyIce = NoahmpIO%CANICEXY (I) + noahmp%water%state%CanopyWetFrac = NoahmpIO%FWETXY (I) + noahmp%water%state%SnowWaterEquiv = NoahmpIO%SNOW (I) + noahmp%water%state%SnowWaterEquivPrev = NoahmpIO%SNEQVOXY (I) + noahmp%water%state%SnowDepth = NoahmpIO%SNOWH (I) + noahmp%water%state%IrrigationFracFlood = NoahmpIO%FIFRACT (I) + noahmp%water%state%IrrigationAmtFlood = NoahmpIO%IRWATFI (I) + noahmp%water%state%IrrigationFracMicro = NoahmpIO%MIFRACT (I) + noahmp%water%state%IrrigationAmtMicro = NoahmpIO%IRWATMI (I) + noahmp%water%state%IrrigationFracSprinkler = NoahmpIO%SIFRACT (I) + noahmp%water%state%IrrigationAmtSprinkler = NoahmpIO%IRWATSI (I) + noahmp%water%state%WaterTableDepth = NoahmpIO%ZWTXY (I) + noahmp%water%state%SoilMoistureToWT = NoahmpIO%SMCWTDXY (I) + noahmp%water%state%TileDrainFrac = NoahmpIO%TD_FRACTION(I) + noahmp%water%state%WaterStorageAquifer = NoahmpIO%WAXY (I) + noahmp%water%state%WaterStorageSoilAqf = NoahmpIO%WTXY (I) + noahmp%water%state%WaterStorageLake = NoahmpIO%WSLAKEXY (I) + noahmp%water%state%IrrigationFracGrid = NoahmpIO%IRFRACT (I) + noahmp%water%state%IrrigationCntSprinkler = NoahmpIO%IRNUMSI (I) + noahmp%water%state%IrrigationCntMicro = NoahmpIO%IRNUMMI (I) + noahmp%water%state%IrrigationCntFlood = NoahmpIO%IRNUMFI (I) + noahmp%water%state%SnowIce (-NumSnowLayerMax+1:0) = NoahmpIO%SNICEXY (I,-NumSnowLayerMax+1:0) + noahmp%water%state%SnowLiqWater(-NumSnowLayerMax+1:0) = NoahmpIO%SNLIQXY (I,-NumSnowLayerMax+1:0) + noahmp%water%state%SoilLiqWater (1:NumSoilLayer) = NoahmpIO%SH2O (I,1:NumSoilLayer) + noahmp%water%state%SoilMoisture (1:NumSoilLayer) = NoahmpIO%SMOIS (I,1:NumSoilLayer) + noahmp%water%state%SoilMoistureEqui (1:NumSoilLayer) = NoahmpIO%SMOISEQ (I,1:NumSoilLayer) + noahmp%water%state%RechargeGwDeepWT = 0.0 + noahmp%water%state%RechargeGwShallowWT = 0.0 +#ifdef WRF_HYDRO + noahmp%water%state%WaterTableHydro = NoahmpIO%ZWATBLE2D (I) + noahmp%water%state%WaterHeadSfc = NoahmpIO%sfcheadrt (I) +#endif + + ! water flux variables + noahmp%water%flux%EvapSoilSfcLiqAcc = NoahmpIO%ACC_QSEVAXY (I) + noahmp%water%flux%SoilSfcInflowAcc = NoahmpIO%ACC_QINSURXY(I) + noahmp%water%flux%SfcWaterTotChgAcc = NoahmpIO%ACC_DWATERXY(I) + noahmp%water%flux%PrecipTotAcc = NoahmpIO%ACC_PRCPXY (I) + noahmp%water%flux%EvapCanopyNetAcc = NoahmpIO%ACC_ECANXY (I) + noahmp%water%flux%TranspirationAcc = NoahmpIO%ACC_ETRANXY (I) + noahmp%water%flux%EvapGroundNetAcc = NoahmpIO%ACC_EDIRXY (I) + noahmp%water%flux%TranspWatLossSoilAcc(1:NumSoilLayer)= NoahmpIO%ACC_ETRANIXY(I,1:NumSoilLayer) + + ! water parameter variables + noahmp%water%param%DrainSoilLayerInd = NoahmpIO%DRAIN_LAYER_OPT_TABLE + noahmp%water%param%CanopyLiqHoldCap = NoahmpIO%CH2OP_TABLE(VegType) + noahmp%water%param%SnowCompactBurdenFac = NoahmpIO%C2_SNOWCOMPACT_TABLE + noahmp%water%param%SnowCompactAgingFac1 = NoahmpIO%C3_SNOWCOMPACT_TABLE + noahmp%water%param%SnowCompactAgingFac2 = NoahmpIO%C4_SNOWCOMPACT_TABLE + noahmp%water%param%SnowCompactAgingFac3 = NoahmpIO%C5_SNOWCOMPACT_TABLE + noahmp%water%param%SnowCompactAgingMax = NoahmpIO%DM_SNOWCOMPACT_TABLE + noahmp%water%param%SnowViscosityCoeff = NoahmpIO%ETA0_SNOWCOMPACT_TABLE + noahmp%water%param%SnowLiqFracMax = NoahmpIO%SNLIQMAXFRAC_TABLE + noahmp%water%param%SnowLiqHoldCap = NoahmpIO%SSI_TABLE + noahmp%water%param%SnowLiqReleaseFac = NoahmpIO%SNOW_RET_FAC_TABLE + noahmp%water%param%IrriFloodRateFac = NoahmpIO%FIRTFAC_TABLE + noahmp%water%param%IrriMicroRate = NoahmpIO%MICIR_RATE_TABLE + noahmp%water%param%SoilConductivityRef = NoahmpIO%REFDK_TABLE + noahmp%water%param%SoilInfilFacRef = NoahmpIO%REFKDT_TABLE + noahmp%water%param%GroundFrzCoeff = NoahmpIO%FRZK_TABLE + noahmp%water%param%GridTopoIndex = NoahmpIO%TIMEAN_TABLE + noahmp%water%param%SoilSfcSatFracMax = NoahmpIO%FSATMX_TABLE + noahmp%water%param%SpecYieldGw = NoahmpIO%ROUS_TABLE + noahmp%water%param%MicroPoreContent = NoahmpIO%CMIC_TABLE + noahmp%water%param%WaterStorageLakeMax = NoahmpIO%WSLMAX_TABLE + noahmp%water%param%SnoWatEqvMaxGlacier = NoahmpIO%SWEMAXGLA_TABLE + noahmp%water%param%IrriStopDayBfHarvest = NoahmpIO%IRR_HAR_TABLE + noahmp%water%param%IrriTriggerLaiMin = NoahmpIO%IRR_LAI_TABLE + noahmp%water%param%SoilWatDeficitAllow = NoahmpIO%IRR_MAD_TABLE + noahmp%water%param%IrriFloodLossFrac = NoahmpIO%FILOSS_TABLE + noahmp%water%param%IrriSprinklerRate = NoahmpIO%SPRIR_RATE_TABLE + noahmp%water%param%IrriFracThreshold = NoahmpIO%IRR_FRAC_TABLE + noahmp%water%param%IrriStopPrecipThr = NoahmpIO%IR_RAIN_TABLE + noahmp%water%param%SnowfallDensityMax = NoahmpIO%SNOWDEN_MAX_TABLE + noahmp%water%param%SnowMassFullCoverOld = NoahmpIO%SWEMX_TABLE + noahmp%water%param%SoilMatPotentialWilt = NoahmpIO%PSIWLT_TABLE + noahmp%water%param%SnowMeltFac = NoahmpIO%MFSNO_TABLE(VegType) + noahmp%water%param%SnowCoverFac = NoahmpIO%SCFFAC_TABLE(VegType) + noahmp%water%param%InfilFacVic = NoahmpIO%BVIC_TABLE(SoilType(1)) + noahmp%water%param%TensionWatDistrInfl = NoahmpIO%AXAJ_TABLE(SoilType(1)) + noahmp%water%param%TensionWatDistrShp = NoahmpIO%BXAJ_TABLE(SoilType(1)) + noahmp%water%param%FreeWatDistrShp = NoahmpIO%XXAJ_TABLE(SoilType(1)) + noahmp%water%param%InfilHeteroDynVic = NoahmpIO%BBVIC_TABLE(SoilType(1)) + noahmp%water%param%InfilCapillaryDynVic = NoahmpIO%GDVIC_TABLE(SoilType(1)) + noahmp%water%param%InfilFacDynVic = NoahmpIO%BDVIC_TABLE(SoilType(1)) + noahmp%water%param%TileDrainCoeffSp = NoahmpIO%TD_DC_TABLE(SoilType(1)) + noahmp%water%param%TileDrainTubeDepth = NoahmpIO%TD_DEPTH_TABLE(SoilType(1)) + noahmp%water%param%DrainFacSoilWat = NoahmpIO%TDSMC_FAC_TABLE(SoilType(1)) + noahmp%water%param%TileDrainCoeff = NoahmpIO%TD_DCOEF_TABLE(SoilType(1)) + noahmp%water%param%DrainDepthToImperv = NoahmpIO%TD_ADEPTH_TABLE(SoilType(1)) + noahmp%water%param%LateralWatCondFac = NoahmpIO%KLAT_FAC_TABLE(SoilType(1)) + noahmp%water%param%TileDrainDepth = NoahmpIO%TD_DDRAIN_TABLE(SoilType(1)) + noahmp%water%param%DrainTubeDist = NoahmpIO%TD_SPAC_TABLE(SoilType(1)) + noahmp%water%param%DrainTubeRadius = NoahmpIO%TD_RADI_TABLE(SoilType(1)) + noahmp%water%param%DrainWatDepToImperv = NoahmpIO%TD_D_TABLE(SoilType(1)) + noahmp%water%param%NumSoilLayerRoot = NoahmpIO%NROOT_TABLE(VegType) + noahmp%water%param%SoilDrainSlope = NoahmpIO%SLOPE_TABLE(RunoffSlopeType) + + do IndexSoilLayer = 1, size(SoilType) + noahmp%water%param%SoilMoistureSat (IndexSoilLayer) = NoahmpIO%SMCMAX_TABLE(SoilType(IndexSoilLayer)) + noahmp%water%param%SoilMoistureWilt (IndexSoilLayer) = NoahmpIO%SMCWLT_TABLE(SoilType(IndexSoilLayer)) + noahmp%water%param%SoilMoistureFieldCap (IndexSoilLayer) = NoahmpIO%SMCREF_TABLE(SoilType(IndexSoilLayer)) + noahmp%water%param%SoilMoistureDry (IndexSoilLayer) = NoahmpIO%SMCDRY_TABLE(SoilType(IndexSoilLayer)) + noahmp%water%param%SoilWatDiffusivitySat (IndexSoilLayer) = NoahmpIO%DWSAT_TABLE (SoilType(IndexSoilLayer)) + noahmp%water%param%SoilWatConductivitySat(IndexSoilLayer) = NoahmpIO%DKSAT_TABLE (SoilType(IndexSoilLayer)) + noahmp%water%param%SoilExpCoeffB (IndexSoilLayer) = NoahmpIO%BEXP_TABLE (SoilType(IndexSoilLayer)) + noahmp%water%param%SoilMatPotentialSat (IndexSoilLayer) = NoahmpIO%PSISAT_TABLE(SoilType(IndexSoilLayer)) + enddo + + ! spatial varying soil texture and properties directly from input + if ( noahmp%config%nmlist%OptSoilProperty == 4 ) then + ! 3D soil properties + noahmp%water%param%SoilExpCoeffB = NoahmpIO%BEXP_3D (I,1:NumSoilLayer) ! C-H B exponent + noahmp%water%param%SoilMoistureDry = NoahmpIO%SMCDRY_3D(I,1:NumSoilLayer) ! Soil Moisture Limit: Dry + noahmp%water%param%SoilMoistureWilt = NoahmpIO%SMCWLT_3D(I,1:NumSoilLayer) ! Soil Moisture Limit: Wilt + noahmp%water%param%SoilMoistureFieldCap = NoahmpIO%SMCREF_3D(I,1:NumSoilLayer) ! Soil Moisture Limit: Reference + noahmp%water%param%SoilMoistureSat = NoahmpIO%SMCMAX_3D(I,1:NumSoilLayer) ! Soil Moisture Limit: Max + noahmp%water%param%SoilWatConductivitySat = NoahmpIO%DKSAT_3D (I,1:NumSoilLayer) ! Saturated Soil Conductivity + noahmp%water%param%SoilWatDiffusivitySat = NoahmpIO%DWSAT_3D (I,1:NumSoilLayer) ! Saturated Soil Diffusivity + noahmp%water%param%SoilMatPotentialSat = NoahmpIO%PSISAT_3D(I,1:NumSoilLayer) ! Saturated Matric Potential + noahmp%water%param%SoilConductivityRef = NoahmpIO%REFDK_2D (I) ! Reference Soil Conductivity + noahmp%water%param%SoilInfilFacRef = NoahmpIO%REFKDT_2D(I) ! Soil Infiltration Parameter + ! 2D additional runoff6~8 parameters + noahmp%water%param%InfilFacVic = NoahmpIO%BVIC_2D (I) ! VIC model infiltration parameter + noahmp%water%param%TensionWatDistrInfl = NoahmpIO%AXAJ_2D (I) ! Xinanjiang: Tension water distribution inflection parameter + noahmp%water%param%TensionWatDistrShp = NoahmpIO%BXAJ_2D (I) ! Xinanjiang: Tension water distribution shape parameter + noahmp%water%param%FreeWatDistrShp = NoahmpIO%XXAJ_2D (I) ! Xinanjiang: Free water distribution shape parameter + noahmp%water%param%InfilFacDynVic = NoahmpIO%BDVIC_2D(I) ! VIC model infiltration parameter + noahmp%water%param%InfilCapillaryDynVic = NoahmpIO%GDVIC_2D(I) ! Mean Capillary Drive for infiltration models + noahmp%water%param%InfilHeteroDynVic = NoahmpIO%BBVIC_2D(I) ! DVIC heterogeniety parameter for infiltraton + ! 2D irrigation params + noahmp%water%param%IrriFracThreshold = NoahmpIO%IRR_FRAC_2D (I) ! irrigation Fraction + noahmp%water%param%IrriStopDayBfHarvest = NoahmpIO%IRR_HAR_2D (I) ! number of days before harvest date to stop irrigation + noahmp%water%param%IrriTriggerLaiMin = NoahmpIO%IRR_LAI_2D (I) ! Minimum lai to trigger irrigation + noahmp%water%param%SoilWatDeficitAllow = NoahmpIO%IRR_MAD_2D (I) ! management allowable deficit (0-1) + noahmp%water%param%IrriFloodLossFrac = NoahmpIO%FILOSS_2D (I) ! fraction of flood irrigation loss (0-1) + noahmp%water%param%IrriSprinklerRate = NoahmpIO%SPRIR_RATE_2D(I) ! mm/h, sprinkler irrigation rate + noahmp%water%param%IrriMicroRate = NoahmpIO%MICIR_RATE_2D(I) ! mm/h, micro irrigation rate + noahmp%water%param%IrriFloodRateFac = NoahmpIO%FIRTFAC_2D (I) ! flood application rate factor + noahmp%water%param%IrriStopPrecipThr = NoahmpIO%IR_RAIN_2D (I) ! maximum precipitation to stop irrigation trigger + ! 2D tile drainage parameters + noahmp%water%param%LateralWatCondFac = NoahmpIO%KLAT_FAC (I) ! factor multiplier to hydraulic conductivity + noahmp%water%param%DrainFacSoilWat = NoahmpIO%TDSMC_FAC(I) ! factor multiplier to field capacity + noahmp%water%param%TileDrainCoeffSp = NoahmpIO%TD_DC (I) ! drainage coefficient for simple + noahmp%water%param%TileDrainCoeff = NoahmpIO%TD_DCOEF (I) ! drainge coefficient for Hooghoudt + noahmp%water%param%TileDrainDepth = NoahmpIO%TD_DDRAIN(I) ! depth of drain + noahmp%water%param%DrainTubeRadius = NoahmpIO%TD_RADI (I) ! tile tube radius + noahmp%water%param%DrainTubeDist = NoahmpIO%TD_SPAC (I) ! tile spacing + endif + + ! derived water parameters + noahmp%water%param%SoilInfilMaxCoeff = noahmp%water%param%SoilInfilFacRef * & + noahmp%water%param%SoilWatConductivitySat(1) / & + noahmp%water%param%SoilConductivityRef + if ( FlagUrban .eqv. .true. ) then + noahmp%water%param%SoilMoistureSat = 0.45 + noahmp%water%param%SoilMoistureFieldCap = 0.42 + noahmp%water%param%SoilMoistureWilt = 0.40 + noahmp%water%param%SoilMoistureDry = 0.40 + endif + + if ( SoilType(1) /= 14 ) then + noahmp%water%param%SoilImpervFracCoeff = noahmp%water%param%GroundFrzCoeff * & + ((noahmp%water%param%SoilMoistureSat(1) / & + noahmp%water%param%SoilMoistureFieldCap(1)) * (0.412/0.468)) + endif + + noahmp%water%state%SnowIceFracPrev = 0.0 + noahmp%water%state%SnowIceFracPrev(NumSnowLayerNeg+1:0) = NoahmpIO%SNICEXY(I,NumSnowLayerNeg+1:0) / & + (NoahmpIO%SNICEXY(I,NumSnowLayerNeg+1:0) + & + NoahmpIO%SNLIQXY(I,NumSnowLayerNeg+1:0)) + + if ( (noahmp%config%nmlist%OptSoilProperty == 3) .and. (.not. noahmp%config%domain%FlagUrban) ) then + if (.not. allocated(SoilSand)) allocate( SoilSand(1:NumSoilLayer) ) + if (.not. allocated(SoilClay)) allocate( SoilClay(1:NumSoilLayer) ) + if (.not. allocated(SoilOrg) ) allocate( SoilOrg (1:NumSoilLayer) ) + SoilSand = 0.01 * NoahmpIO%soilcomp(I,1:NumSoilLayer) + SoilClay = 0.01 * NoahmpIO%soilcomp(I,(NumSoilLayer+1):(NumSoilLayer*2)) + SoilOrg = 0.0 + if (noahmp%config%nmlist%OptPedotransfer == 1) & + call PedoTransferSR2006(NoahmpIO,noahmp,SoilSand,SoilClay,SoilOrg) + deallocate(SoilSand) + deallocate(SoilClay) + deallocate(SoilOrg ) + endif + + end associate + + end subroutine WaterVarInTransfer + +end module WaterVarInTransferMod diff --git a/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/WaterVarOutTransferMod.F90 b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/WaterVarOutTransferMod.F90 new file mode 100644 index 0000000000..feaa7e996b --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/WaterVarOutTransferMod.F90 @@ -0,0 +1,153 @@ +module WaterVarOutTransferMod + +!!! Transfer column (1-D) Noah-MP water variables to 2D NoahmpIO for output + +! ------------------------ Code history ----------------------------------- +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + use Machine + use NoahmpIOVarType + use NoahmpVarType + + implicit none + +contains + +!=== Transfer model states to output ===== + + subroutine WaterVarOutTransfer(noahmp, NoahmpIO) + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + type(NoahmpIO_type), intent(inout) :: NoahmpIO + +! ------------------------------------------------------------------------- + associate( & + I => noahmp%config%domain%GridIndexI ,& + NumSnowLayerMax => noahmp%config%domain%NumSnowLayerMax ,& + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& + IndicatorIceSfc => noahmp%config%domain%IndicatorIceSfc & + ) +! ------------------------------------------------------------------------- + + ! special treatment for glacier point output + if ( IndicatorIceSfc == -1 ) then ! land ice point + noahmp%water%state%SnowCoverFrac = 1.0 + noahmp%water%flux%EvapCanopyNet = 0.0 + noahmp%water%flux%Transpiration = 0.0 + noahmp%water%flux%InterceptCanopySnow = 0.0 + noahmp%water%flux%InterceptCanopyRain = 0.0 + noahmp%water%flux%DripCanopySnow = 0.0 + noahmp%water%flux%DripCanopyRain = 0.0 + noahmp%water%flux%ThroughfallSnow = noahmp%water%flux%SnowfallRefHeight + noahmp%water%flux%ThroughfallRain = noahmp%water%flux%RainfallRefHeight + noahmp%water%flux%SublimCanopyIce = 0.0 + noahmp%water%flux%FrostCanopyIce = 0.0 + noahmp%water%flux%FreezeCanopyLiq = 0.0 + noahmp%water%flux%MeltCanopyIce = 0.0 + noahmp%water%flux%EvapCanopyLiq = 0.0 + noahmp%water%flux%DewCanopyLiq = 0.0 + noahmp%water%state%CanopyIce = 0.0 + noahmp%water%state%CanopyLiqWater = 0.0 + noahmp%water%flux%TileDrain = 0.0 + noahmp%water%flux%RunoffSurface = noahmp%water%flux%RunoffSurface * noahmp%config%domain%MainTimeStep + noahmp%water%flux%RunoffSubsurface = noahmp%water%flux%RunoffSubsurface * noahmp%config%domain%MainTimeStep + NoahmpIO%QFX(I) = noahmp%water%flux%EvapGroundNet + endif + + if ( IndicatorIceSfc == 0 ) then ! land soil point + NoahmpIO%QFX(I) = noahmp%water%flux%EvapCanopyNet + noahmp%water%flux%EvapGroundNet + & + noahmp%water%flux%Transpiration + noahmp%water%flux%EvapIrriSprinkler + endif + + NoahmpIO%SMSTAV (I) = 0.0 ! [maintained as Noah consistency] water + NoahmpIO%SMSTOT (I) = 0.0 ! [maintained as Noah consistency] water + NoahmpIO%SFCRUNOFF (I) = NoahmpIO%SFCRUNOFF(I) + noahmp%water%flux%RunoffSurface + NoahmpIO%UDRUNOFF (I) = NoahmpIO%UDRUNOFF (I) + noahmp%water%flux%RunoffSubsurface + NoahmpIO%QTDRAIN (I) = NoahmpIO%QTDRAIN (I) + noahmp%water%flux%TileDrain + NoahmpIO%SNOWC (I) = noahmp%water%state%SnowCoverFrac + NoahmpIO%SNOW (I) = noahmp%water%state%SnowWaterEquiv + NoahmpIO%SNOWH (I) = noahmp%water%state%SnowDepth + NoahmpIO%CANWAT (I) = noahmp%water%state%CanopyLiqWater + noahmp%water%state%CanopyIce + NoahmpIO%ACSNOW (I) = NoahmpIO%ACSNOW(I) + (NoahmpIO%RAINBL (I) * noahmp%water%state%FrozenPrecipFrac) + NoahmpIO%ACSNOM (I) = NoahmpIO%ACSNOM(I) + (noahmp%water%flux%MeltGroundSnow * NoahmpIO%DTBL) + & + noahmp%water%state%PondSfcThinSnwMelt + noahmp%water%state%PondSfcThinSnwComb + & + noahmp%water%state%PondSfcThinSnwTrans + NoahmpIO%CANLIQXY (I) = noahmp%water%state%CanopyLiqWater + NoahmpIO%CANICEXY (I) = noahmp%water%state%CanopyIce + NoahmpIO%FWETXY (I) = noahmp%water%state%CanopyWetFrac + NoahmpIO%SNEQVOXY (I) = noahmp%water%state%SnowWaterEquivPrev + NoahmpIO%QSNOWXY (I) = noahmp%water%flux%SnowfallGround + NoahmpIO%QRAINXY (I) = noahmp%water%flux%RainfallGround + NoahmpIO%WSLAKEXY (I) = noahmp%water%state%WaterStorageLake + NoahmpIO%ZWTXY (I) = noahmp%water%state%WaterTableDepth + NoahmpIO%WAXY (I) = noahmp%water%state%WaterStorageAquifer + NoahmpIO%WTXY (I) = noahmp%water%state%WaterStorageSoilAqf + NoahmpIO%RUNSFXY (I) = noahmp%water%flux%RunoffSurface + NoahmpIO%RUNSBXY (I) = noahmp%water%flux%RunoffSubsurface + NoahmpIO%ECANXY (I) = noahmp%water%flux%EvapCanopyNet + NoahmpIO%EDIRXY (I) = noahmp%water%flux%EvapGroundNet + NoahmpIO%ETRANXY (I) = noahmp%water%flux%Transpiration + NoahmpIO%QINTSXY (I) = noahmp%water%flux%InterceptCanopySnow + NoahmpIO%QINTRXY (I) = noahmp%water%flux%InterceptCanopyRain + NoahmpIO%QDRIPSXY (I) = noahmp%water%flux%DripCanopySnow + NoahmpIO%QDRIPRXY (I) = noahmp%water%flux%DripCanopyRain + NoahmpIO%QTHROSXY (I) = noahmp%water%flux%ThroughfallSnow + NoahmpIO%QTHRORXY (I) = noahmp%water%flux%ThroughfallRain + NoahmpIO%QSNSUBXY (I) = noahmp%water%flux%SublimSnowSfcIce + NoahmpIO%QSNFROXY (I) = noahmp%water%flux%FrostSnowSfcIce + NoahmpIO%QSUBCXY (I) = noahmp%water%flux%SublimCanopyIce + NoahmpIO%QFROCXY (I) = noahmp%water%flux%FrostCanopyIce + NoahmpIO%QEVACXY (I) = noahmp%water%flux%EvapCanopyLiq + NoahmpIO%QDEWCXY (I) = noahmp%water%flux%DewCanopyLiq + NoahmpIO%QFRZCXY (I) = noahmp%water%flux%FreezeCanopyLiq + NoahmpIO%QMELTCXY (I) = noahmp%water%flux%MeltCanopyIce + NoahmpIO%QSNBOTXY (I) = noahmp%water%flux%SnowBotOutflow + NoahmpIO%QMELTXY (I) = noahmp%water%flux%MeltGroundSnow + NoahmpIO%PONDINGXY (I) = noahmp%water%state%PondSfcThinSnwTrans + & + noahmp%water%state%PondSfcThinSnwComb + noahmp%water%state%PondSfcThinSnwMelt + NoahmpIO%FPICEXY (I) = noahmp%water%state%FrozenPrecipFrac + NoahmpIO%RAINLSM (I) = noahmp%water%flux%RainfallRefHeight + NoahmpIO%SNOWLSM (I) = noahmp%water%flux%SnowfallRefHeight + NoahmpIO%ACC_QINSURXY(I) = noahmp%water%flux%SoilSfcInflowAcc + NoahmpIO%ACC_QSEVAXY (I) = noahmp%water%flux%EvapSoilSfcLiqAcc + NoahmpIO%ACC_DWATERXY(I) = noahmp%water%flux%SfcWaterTotChgAcc + NoahmpIO%ACC_PRCPXY (I) = noahmp%water%flux%PrecipTotAcc + NoahmpIO%ACC_ECANXY (I) = noahmp%water%flux%EvapCanopyNetAcc + NoahmpIO%ACC_ETRANXY (I) = noahmp%water%flux%TranspirationAcc + NoahmpIO%ACC_EDIRXY (I) = noahmp%water%flux%EvapGroundNetAcc + NoahmpIO%RECHXY (I) = NoahmpIO%RECHXY(I) + (noahmp%water%state%RechargeGwShallowWT*1.0e3) + NoahmpIO%DEEPRECHXY (I) = NoahmpIO%DEEPRECHXY(I) + noahmp%water%state%RechargeGwDeepWT + NoahmpIO%SMCWTDXY (I) = noahmp%water%state%SoilMoistureToWT + NoahmpIO%SMOIS (I,1:NumSoilLayer) = noahmp%water%state%SoilMoisture(1:NumSoilLayer) + NoahmpIO%SH2O (I,1:NumSoilLayer) = noahmp%water%state%SoilLiqWater(1:NumSoilLayer) + NoahmpIO%ACC_ETRANIXY(I,1:NumSoilLayer) = noahmp%water%flux%TranspWatLossSoilAcc(1:NumSoilLayer) + NoahmpIO%SNICEXY (I,-NumSnowLayerMax+1:0) = noahmp%water%state%SnowIce(-NumSnowLayerMax+1:0) + NoahmpIO%SNLIQXY (I,-NumSnowLayerMax+1:0) = noahmp%water%state%SnowLiqWater(-NumSnowLayerMax+1:0) + + ! irrigation + NoahmpIO%IRNUMSI (I) = noahmp%water%state%IrrigationCntSprinkler + NoahmpIO%IRNUMMI (I) = noahmp%water%state%IrrigationCntMicro + NoahmpIO%IRNUMFI (I) = noahmp%water%state%IrrigationCntFlood + NoahmpIO%IRWATSI (I) = noahmp%water%state%IrrigationAmtSprinkler + NoahmpIO%IRWATMI (I) = noahmp%water%state%IrrigationAmtMicro + NoahmpIO%IRWATFI (I) = noahmp%water%state%IrrigationAmtFlood + NoahmpIO%IRSIVOL (I) = NoahmpIO%IRSIVOL(I)+(noahmp%water%flux%IrrigationRateSprinkler*1000.0) + NoahmpIO%IRMIVOL (I) = NoahmpIO%IRMIVOL(I)+(noahmp%water%flux%IrrigationRateMicro*1000.0) + NoahmpIO%IRFIVOL (I) = NoahmpIO%IRFIVOL(I)+(noahmp%water%flux%IrrigationRateFlood*1000.0) + NoahmpIO%IRELOSS (I) = NoahmpIO%IRELOSS(I)+(noahmp%water%flux%EvapIrriSprinkler*NoahmpIO%DTBL) + +#ifdef WRF_HYDRO + NoahmpIO%infxsrt (I) = max(noahmp%water%flux%RunoffSurface, 0.0) ! mm, surface runoff + NoahmpIO%soldrain (I) = max(noahmp%water%flux%RunoffSubsurface, 0.0) ! mm, underground runoff + NoahmpIO%qtiledrain(I) = max(noahmp%water%flux%TileDrain, 0.0) ! mm, tile drainage +#endif + + end associate + + end subroutine WaterVarOutTransfer + +end module WaterVarOutTransferMod diff --git a/src/core_atmosphere/physics/physics_noahmp/parameters/NoahmpTable.TBL b/src/core_atmosphere/physics/physics_noahmp/parameters/NoahmpTable.TBL new file mode 100644 index 0000000000..c9d37c5b40 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/parameters/NoahmpTable.TBL @@ -0,0 +1,856 @@ +! ---------------- Noah-MP Parameter Look-up Table History ------------------------ +! Original Table: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Updated Table: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! Updated table reformats and merges original MPTABLE.TBL, SOILPARM.TBL, GENPARM.TBL +! ---------------------------------------------------------------------------------- + +&noahmp_usgs_veg_categories + VEG_DATASET_DESCRIPTION = "USGS" ! land type dataset + NVEG = 27 ! total number of land categories in USGS +/ + +&noahmp_usgs_parameters + ! NVEG = 27 + ! 1: Urban and Built-Up Land + ! 2: Dryland Cropland and Pasture + ! 3: Irrigated Cropland and Pasture + ! 4: Mixed Dryland/Irrigated Cropland and Pasture + ! 5: Cropland/Grassland Mosaic + ! 6: Cropland/Woodland Mosaic + ! 7: Grassland + ! 8: Shrubland + ! 9: Mixed Shrubland/Grassland + ! 10: Savanna + ! 11: Deciduous Broadleaf Forest + ! 12: Deciduous Needleleaf Forest + ! 13: Evergreen Broadleaf Forest + ! 14: Evergreen Needleleaf Forest + ! 15: Mixed Forest + ! 16: Water Bodies + ! 17: Herbaceous Wetland + ! 18: Wooded Wetland + ! 19: Barren or Sparsely Vegetated + ! 20: Herbaceous Tundra + ! 21: Wooded Tundra + ! 22: Mixed Tundra + ! 23: Bare Ground Tundra + ! 24: Snow or Ice + ! 25: Playa + ! 26: Lava + ! 27: White Sand + + ! specify some key land category indicators + ISURBAN = 1 ! urban land type in USGS + ISWATER = 16 ! water land type in USGS + ISBARREN = 19 ! bare soil land type in USGS + ISICE = 24 ! ice land type in USGS + ISCROP = 2 ! crop land type in USGS + EBLFOREST = 13 ! evergreen broadleaf forest land type in USGS + NATURAL = 5 ! natural vegation type in urban pixel in USGS + URBTYPE_beg = 50 ! land type number above which are urban (e.g., LCZ) + LCZ_1 = 51 ! urban local climate zone (LCZ) type 1: compact highrise + LCZ_2 = 52 ! urban local climate zone (LCZ) type 2: compact midrise + LCZ_3 = 53 ! urban local climate zone (LCZ) type 3: compact lowrise + LCZ_4 = 54 ! urban local climate zone (LCZ) type 4: open highrise + LCZ_5 = 55 ! urban local climate zone (LCZ) type 5: open midrise + LCZ_6 = 56 ! urban local climate zone (LCZ) type 6: open lowrise + LCZ_7 = 57 ! urban local climate zone (LCZ) type 7: lightweight lowrise + LCZ_8 = 58 ! urban local climate zone (LCZ) type 8: large lowrise + LCZ_9 = 59 ! urban local climate zone (LCZ) type 9: sparsely built + LCZ_10 = 60 ! urban local climate zone (LCZ) type 10: heavy industry + LCZ_11 = 61 ! urban local climate zone (LCZ) type 11: bare rock or paved + + ! start the vegetation-dependent parameters + !----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- + ! VegType: 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 + !----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- + ! CH2OP: maximum intercepted h2o per unit lai+sai (mm) + CH2OP = 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, + ! DLEAF: characteristic leaf dimension (m) + DLEAF = 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, + ! Z0MVT: momentum roughness length (m) + Z0MVT = 1.00, 0.15, 0.15, 0.15, 0.14, 0.50, 0.12, 0.06, 0.09, 0.50, 0.80, 0.85, 1.10, 1.09, 0.80, 0.00, 0.12, 0.50, 0.00, 0.10, 0.30, 0.20, 0.03, 0.00, 0.01, 0.00, 0.00, + ! HVT: top of canopy (m) + HVT = 15.0, 2.00, 2.00, 2.00, 1.50, 8.00, 1.00, 1.10, 1.10, 10.0, 16.0, 18.0, 20.0, 20.0, 16.0, 0.00, 0.50, 10.0, 0.00, 0.50, 4.00, 2.00, 0.50, 0.00, 0.10, 0.00, 0.00, + ! HVB: bottom of canopy (m) + HVB = 1.00, 0.10, 0.10, 0.10, 0.10, 0.15, 0.05, 0.10, 0.10, 0.10, 11.5, 7.00, 8.00, 8.50, 10.0, 0.00, 0.05, 0.10, 0.00, 0.10, 0.10, 0.10, 0.10, 0.00, 0.10, 0.00, 0.00, + ! DEN: tree density (no. of trunks per m2) + DEN = 0.01, 25.0, 25.0, 25.0, 25.0, 25.0, 100., 10.0, 10.0, 0.02, 0.10, 0.28, 0.02, 0.28, 0.10, 0.01, 10.0, 0.10, 0.01, 1.00, 1.00, 1.00, 1.00, 0.00, 0.01, 0.01, 0.01, + ! RC: tree crown radius (m) + RC = 1.00, 0.08, 0.08, 0.08, 0.08, 0.08, 0.03, 0.12, 0.12, 3.00, 1.40, 1.20, 3.60, 1.20, 1.40, 0.01, 0.10, 1.40, 0.01, 0.30, 0.30, 0.30, 0.30, 0.00, 0.01, 0.01, 0.01, + ! MFSNO: snowmelt curve parameter, originally =2.5 everywhere, currently optimized dependent on land type based on SNOTEL SWE & MODIS SCF, surface albedo (He et al. 2019 JGR) + MFSNO = 4.00, 3.00, 3.00, 3.00, 4.00, 4.00, 2.00, 2.00, 2.00, 2.00, 1.00, 1.00, 1.00, 1.00, 1.00, 3.00, 3.00, 3.00, 3.00, 3.50, 3.50, 3.50, 3.50, 2.50, 3.50, 3.50, 3.50, + ! SCFFAC: snow cover factor (m) (replace original hard-coded 2.5*z0, z0=0.002m everywhere), currently optimized based on SNOTEL SWE & MODIS SCF, surface albedo (He et al. 2021 JGR) + SCFFAC = 0.042, 0.014, 0.014, 0.014, 0.026, 0.026, 0.020, 0.018, 0.016, 0.020, 0.008, 0.008, 0.008, 0.008, 0.008, 0.030, 0.020, 0.020, 0.016, 0.030, 0.030, 0.030, 0.030, 0.030, 0.030, 0.030, 0.030, + ! CBIOM: canopy biomass heat capacity parameter (m), C. He 12/23/2022 bring hard-coded parameter to here + CBIOM = 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, + ! RHOL_VIS: leaf reflectance at visible (VIS) band + RHOL_VIS = 0.00, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, 0.07, 0.10, 0.10, 0.10, 0.07, 0.10, 0.07, 0.10, 0.00, 0.11, 0.10, 0.00, 0.10, 0.10, 0.10, 0.10, 0.00, 0.10, 0.00, 0.00, + ! RHOL_NIR: leaf reflectance at near-infra (NIR) band + RHOL_NIR = 0.00, 0.58, 0.58, 0.58, 0.58, 0.58, 0.58, 0.35, 0.45, 0.45, 0.45, 0.35, 0.45, 0.35, 0.45, 0.00, 0.58, 0.45, 0.00, 0.45, 0.45, 0.45, 0.45, 0.00, 0.45, 0.00, 0.00, + ! RHOS_VIS: stem reflectance at visible (VIS) band + RHOS_VIS = 0.00, 0.36, 0.36, 0.36, 0.36, 0.36, 0.36, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.00, 0.36, 0.16, 0.00, 0.16, 0.16, 0.16, 0.16, 0.00, 0.16, 0.00, 0.00, + ! RHOS_NIR: stem reflectance at near-infra (NIR) band + RHOS_NIR = 0.00, 0.58, 0.58, 0.58, 0.58, 0.58, 0.58, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.00, 0.58, 0.39, 0.00, 0.39, 0.39, 0.39, 0.39, 0.00, 0.39, 0.00, 0.00, + ! TAUL_VIS: leaf transmittance at visible (VIS) band + TAUL_VIS = 0.00, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.00, 0.07, 0.05, 0.00, 0.05, 0.05, 0.05, 0.05, 0.00, 0.05, 0.00, 0.00, + ! TAUL_NIR: leaf transmittance at near-infra (NIR) band + TAUL_NIR = 0.00, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.10, 0.10, 0.25, 0.25, 0.10, 0.25, 0.10, 0.25, 0.00, 0.25, 0.25, 0.00, 0.25, 0.25, 0.25, 0.25, 0.00, 0.25, 0.00, 0.00, + ! TAUS_VIS: stem transmittance at visible (VIS) band + TAUS_VIS = 0.00, 0.220, 0.220, 0.220, 0.220, 0.220, 0.220, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.000, 0.220, 0.001, 0.000, 0.220, 0.001, 0.001, 0.001, 0.000, 0.001, 0.000, 0.000, + ! TAUS_NIR: stem transmittance at near-infra (NIR) band + TAUS_NIR = 0.00, 0.380, 0.380, 0.380, 0.380, 0.380, 0.380, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.000, 0.380, 0.001, 0.000, 0.380, 0.001, 0.001, 0.001, 0.000, 0.001, 0.000, 0.000, + ! XL: leaf/stem orientation index + XL = 0.000, -0.30, -0.30, -0.30, -0.30, -0.30, -0.30, 0.010, 0.250, 0.010, 0.250, 0.010, 0.010, 0.010, 0.250, 0.000, -0.30, 0.250, 0.000, -0.30, 0.250, 0.250, 0.250, 0.000, 0.250, 0.000, 0.000, + ! CWPVT: empirical canopy wind absorption parameter (J. Goudriaan, Crop Micrometeorology: A Simulation Study (Simulation monographs), 1977) + CWPVT = 0.18, 1.67, 1.67, 1.67, 1.67, 0.5, 5.0, 1.0, 2.0, 1.0, 0.67, 0.18, 0.67, 0.18, 0.29, 0.18, 1.67, 0.67, 0.18, 1.67, 0.67, 1.00, 0.18, 0.18, 0.18, 0.18, 0.18, + ! C3PSN: photosynthetic pathway: 0.0 = c4, 1.0 = c3 + C3PSN = 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, + ! KC25: CO2 michaelis-menten constant at 25degC (Pa) + KC25 = 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, + ! AKC: q10 for KC25, change in CO2 Michaelis-Menten constant for every 10-degC temperature change + AKC = 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, + ! KO25: O2 michaelis-menten constant at 25degC (Pa) + KO25 = 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, + ! AKO: q10 for KO25, change in O2 Michaelis-Menten constant for every 10-degC temperature change + AKO = 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, + ! VCMX25: maximum rate of carboxylation at 25 degC (umol CO2/m2/s) + VCMX25 = 0.00, 80.0, 80.0, 80.0, 60.0, 70.0, 40.0, 40.0, 40.0, 40.0, 60.0, 60.0, 60.0, 50.0, 55.0, 0.00, 50.0, 50.0, 0.00, 50.0, 50.0, 50.0, 50.0, 0.00, 50.0, 0.00, 0.00, + ! AVCMX: q10 for VCMX25, change in maximum rate of carboxylation at 25degC for every 10-degC temperature change + AVCMX = 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, + ! AQE: q10 for QE25, change in quantum efficiency at 25degC (umol CO2/umol photon) + AQE = 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, + ! LTOVRC: leaf turnover [1/s] + LTOVRC = 0.0, 1.2, 1.2, 1.2, 1.2, 1.30, 0.50, 0.65, 0.70, 0.65, 0.55, 0.2, 0.55, 0.5, 0.5, 0.0, 1.4, 1.4, 0.0, 1.2, 1.3, 1.4, 1.0, 0.0, 1.0, 0.0, 0.0, + ! DILEFC: coeficient for leaf stress death [1/s] + DILEFC = 0.00, 0.50, 0.50, 0.50, 0.35, 0.20, 0.20, 0.20, 0.50, 0.50, 0.60, 1.80, 0.50, 1.20, 0.80, 0.00, 0.40, 0.40, 0.00, 0.40, 0.30, 0.40, 0.30, 0.00, 0.30, 0.00, 0.00, + ! DILEFW: coeficient for leaf stress death [1/s] + DILEFW = 0.00, 0.20, 0.20, 0.20, 0.20, 0.20, 0.10, 0.20, 0.20, 0.50, 0.20, 0.20, 4.00, 0.20, 0.20, 0.00, 0.20, 0.20, 0.00, 0.20, 0.20, 0.20, 0.20, 0.00, 0.20, 0.00, 0.00, + ! RMF25: leaf maintenance respiration at 25degC (umol co2/m2/s) + RMF25 = 0.00, 1.00, 1.40, 1.45, 1.45, 1.45, 1.80, 0.26, 0.26, 0.80, 3.00, 4.00, 0.65, 3.00, 3.00, 0.00, 3.20, 3.20, 0.00, 3.20, 3.00, 3.00, 3.00, 0.00, 3.00, 0.00, 0.00, + ! SLA: single-side leaf area per mass [m2/kg] + SLA = 60, 80, 80, 80, 80, 80, 60, 60, 60, 50, 80, 80, 80, 80, 80, 0, 80, 80, 0, 80, 80, 80, 80, 0, 80, 0, 0, + ! FRAGR: fraction of growth respiration + FRAGR = 0.00, 0.20, 0.20, 0.20, 0.20, 0.20, 0.20, 0.20, 0.20, 0.20, 0.20, 0.10, 0.20, 0.10, 0.10, 0.00, 0.10, 0.10, 0.10, 0.10, 0.10, 0.10, 0.10, 0.00, 0.10, 0.00, 0.00, + ! TMIN: minimum temperature for photosynthesis (K) + TMIN = 0, 273, 273, 273, 273, 273, 273, 273, 273, 273, 273, 268, 273, 265, 268, 0, 268, 268, 0, 268, 268, 268, 268, 0, 268, 0, 0, + ! TDLEF: characteristic temperature for leaf freezing [K] + TDLEF = 278, 278, 278, 278, 278, 278, 278, 278, 278, 278, 278, 268, 278, 278, 268, 0, 268, 268, 0, 268, 268, 268, 268, 0, 268, 0, 0, + ! BP: minimum leaf conductance (umol/m2/s) + BP = 1.E15, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 1.E15, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 1.E15, 2.E3, 1.E15, 1.E15, + ! MP: slope of conductance-to-photosynthesis relationship + MP = 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 6.0, 9.0, 6.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, + ! QE25: quantum efficiency at 25degC (umol CO2/umol photon) + QE25 = 0.00, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.00, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.00, 0.06, 0.00, 0.00, + ! RMS25: stem maintenance respiration at 25c (umol CO2/Kg bio/s) + RMS25 = 0.00, 0.10, 0.10, 0.10, 0.10, 0.10, 0.10, 0.10, 0.10, 0.32, 0.10, 0.64, 0.30, 0.90, 0.80, 0.00, 0.10, 0.10, 0.00, 0.10, 0.10, 0.10, 0.00, 0.00, 0.00, 0.00, 0.00, + ! RMR25: root maintenance respiration at 25c (umol CO2/Kg bio/s) + RMR25 = 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 1.20, 0.00, 0.00, 0.01, 0.01, 0.05, 0.05, 0.36, 0.03, 0.00, 0.00, 0.00, 0.00, 2.11, 2.11, 2.11, 0.00, 0.00, 0.00, 0.00, 0.00, + ! ARM: q10 for maintenance respiration, change in maintenance respiration for every 10-degC temperature change + ARM = 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, + ! FOLNMX: foliage nitrogen concentration when f(n)=1 (%) + FOLNMX = 0.0, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 0.00, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 0.00, 1.5, 0.0, 0.0, + ! WDPOOL: ood pool (switch 1 or 0) depending on woody or not + WDPOOL = 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 0.00, 0.00, 1.00, 0.00, 0.00, 1.00, 1.00, 0.00, 0.00, 0.00, 0.00, 0.00, + ! WRRAT: wood to non-wood ratio + WRRAT = 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 3.00, 3.00, 3.00, 30.0, 30.0, 30.0, 30.0, 30.0, 0.00, 0.00, 30.0, 0.00, 0.00, 3.00, 3.00, 0.00, 0.00, 0.00, 0.00, 0.00, + ! MRP: microbial respiration parameter (umol CO2/kgC/s) + MRP = 0.00, 0.23, 0.23, 0.23, 0.23, 0.23, 0.17, 0.19, 0.19, 0.40, 0.40, 0.37, 0.23, 0.37, 0.30, 0.00, 0.17, 0.40, 0.00, 0.17, 0.23, 0.20, 0.00, 0.00, 0.20, 0.00, 0.00, + ! NROOT: number of soil layers with root present + NROOT = 1, 3, 3, 3, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 0, 2, 2, 1, 3, 3, 3, 2, 1, 1, 0, 0, + ! RGL: Parameter used in radiation stress function + RGL = 999.0, 100.0, 100.0, 100.0, 100.0, 65.0, 100.0, 100.0, 100.0, 65.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 100.0, 30.0, 999.0, 100.0, 100.0, 100.0, 100.0, 999.0, 100.0, 999.0, 999.0, + ! RS: Minimum stomatal resistance (s/m) + RS = 200.0, 40.0, 40.0, 40.0, 40.0, 70.0, 40.0, 300.0, 170.0, 70.0, 100.0, 150.0, 150.0, 125.0, 125.0, 100.0, 40.0, 100.0, 999.0, 150.0, 150.0, 150.0, 200.0, 999.0, 40.0, 999.0, 999.0, + ! HS: Parameter used in vapor pressure deficit function + HS = 999.0, 36.25, 36.25, 36.25, 36.25, 44.14, 36.35, 42.00, 39.18, 54.53, 54.53, 47.35, 41.69, 47.35, 51.93, 51.75, 60.00, 51.93, 999.0, 42.00, 42.00, 42.00, 42.00, 999.0, 36.25, 999.0, 999.0, + ! TOPT: Optimum transpiration air temperature [K] + TOPT = 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, + ! RSMAX: Maximal stomatal resistance [s/m] + RSMAX = 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., + ! RTOVRC: root turnover coefficient [1/s] + RTOVRC = 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, + ! RSWOODC: wood respiration coeficient [1/s] + RSWOODC = 3.E-10,3.E-10,3.E-10,3.E-10,3.E-10,3.E-10,3.E-10,3.E-10,3.E-10,3.E-10,3.E-10,3.E-10,3.E-10,3.E-10,3.E-10,3.E-10,3.E-10,3.E-10,3.E-10,3.E-10,3.E-10,3.E-10,3.E-10,3.E-10,3.E-10,3.E-10,3.E-10, + ! BF: parameter for present wood allocation + BF = 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, + ! WSTRC: water stress coeficient + WSTRC = 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, + ! LAIMIN: minimum leaf area index [m2/m2] + LAIMIN = 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, + ! XSAMIN: minimum stem area index [m2/m2] + XSAMIN = 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, + ! SAI: MODIS monthly climatology (2000-2008) stem area index (one row for each month) (Yang et al., 2011) + SAI_JAN = 0.0, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.2, 0.2, 0.3, 0.4, 0.3, 0.5, 0.4, 0.4, 0.0, 0.2, 0.3, 0.0, 0.1, 0.2, 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, + SAI_FEB = 0.0, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.2, 0.2, 0.3, 0.4, 0.3, 0.5, 0.4, 0.4, 0.0, 0.2, 0.3, 0.0, 0.1, 0.2, 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, + SAI_MAR = 0.0, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.2, 0.2, 0.3, 0.4, 0.3, 0.5, 0.4, 0.4, 0.0, 0.2, 0.3, 0.0, 0.1, 0.2, 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, + SAI_APR = 0.0, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.2, 0.2, 0.3, 0.4, 0.4, 0.5, 0.3, 0.4, 0.0, 0.2, 0.3, 0.0, 0.1, 0.2, 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, + SAI_MAY = 0.0, 0.2, 0.2, 0.2, 0.3, 0.3, 0.3, 0.2, 0.2, 0.3, 0.4, 0.4, 0.5, 0.4, 0.4, 0.0, 0.3, 0.3, 0.0, 0.1, 0.2, 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, + SAI_JUN = 0.0, 0.3, 0.3, 0.3, 0.4, 0.4, 0.4, 0.2, 0.3, 0.4, 0.4, 0.7, 0.5, 0.5, 0.4, 0.0, 0.4, 0.4, 0.0, 0.2, 0.2, 0.2, 0.0, 0.0, 0.0, 0.0, 0.0, + SAI_JUL = 0.0, 0.4, 0.4, 0.4, 0.6, 0.6, 0.8, 0.4, 0.6, 0.8, 0.9, 1.3, 0.5, 0.5, 0.7, 0.0, 0.6, 0.6, 0.0, 0.4, 0.4, 0.4, 0.0, 0.0, 0.0, 0.0, 0.0, + SAI_AUG = 0.0, 0.5, 0.5, 0.5, 0.9, 0.9, 1.3, 0.6, 0.9, 1.2, 1.2, 1.2, 0.5, 0.6, 0.8, 0.0, 0.9, 0.9, 0.0, 0.6, 0.6, 0.6, 0.0, 0.0, 0.0, 0.0, 0.0, + SAI_SEP = 0.0, 0.4, 0.4, 0.4, 0.7, 1.0, 1.1, 0.8, 1.0, 1.3, 1.6, 1.0, 0.5, 0.6, 1.0, 0.0, 0.7, 1.0, 0.0, 0.7, 0.8, 0.7, 0.0, 0.0, 0.0, 0.0, 0.0, + SAI_OCT = 0.0, 0.3, 0.3, 0.3, 0.3, 0.8, 0.4, 0.7, 0.6, 0.7, 1.4, 0.8, 0.5, 0.7, 1.0, 0.0, 0.3, 0.8, 0.0, 0.5, 0.7, 0.5, 0.0, 0.0, 0.0, 0.0, 0.0, + SAI_NOV = 0.0, 0.3, 0.3, 0.3, 0.3, 0.4, 0.4, 0.3, 0.3, 0.4, 0.6, 0.6, 0.5, 0.6, 0.5, 0.0, 0.3, 0.4, 0.0, 0.3, 0.3, 0.3, 0.0, 0.0, 0.0, 0.0, 0.0, + SAI_DEC = 0.0, 0.3, 0.3, 0.3, 0.3, 0.3, 0.4, 0.2, 0.3, 0.4, 0.4, 0.5, 0.5, 0.5, 0.4, 0.0, 0.3, 0.4, 0.0, 0.2, 0.2, 0.2, 0.0, 0.0, 0.0, 0.0, 0.0, + ! LAI: MODIS monthly climatology (2000-2008) leaf area index (one row for each month) (Yang et al., 2011) + LAI_JAN = 0.0, 0.0, 0.0, 0.0, 0.2, 0.0, 0.4, 0.0, 0.2, 0.3, 0.0, 0.0, 4.5, 4.0, 2.0, 0.0, 0.2, 0.2, 0.0, 0.2, 1.0, 0.6, 0.0, 0.0, 0.0, 0.0, 0.0, + LAI_FEB = 0.0, 0.0, 0.0, 0.0, 0.3, 0.0, 0.5, 0.0, 0.3, 0.3, 0.0, 0.0, 4.5, 4.0, 2.0, 0.0, 0.3, 0.3, 0.0, 0.3, 1.0, 0.6, 0.0, 0.0, 0.0, 0.0, 0.0, + LAI_MAR = 0.0, 0.0, 0.0, 0.0, 0.3, 0.2, 0.6, 0.2, 0.4, 0.5, 0.3, 0.0, 4.5, 4.0, 2.2, 0.0, 0.3, 0.3, 0.0, 0.3, 1.1, 0.7, 0.0, 0.0, 0.0, 0.0, 0.0, + LAI_APR = 0.0, 0.0, 0.0, 0.0, 0.4, 0.6, 0.7, 0.6, 0.7, 0.8, 1.2, 0.6, 4.5, 4.0, 2.6, 0.0, 0.4, 0.6, 0.0, 0.4, 1.3, 0.8, 0.0, 0.0, 0.0, 0.0, 0.0, + LAI_MAY = 0.0, 1.0, 1.0, 1.0, 1.1, 2.0, 1.2, 1.5, 1.4, 1.8, 3.0, 1.2, 4.5, 4.0, 3.5, 0.0, 1.1, 2.0, 0.0, 0.6, 1.7, 1.2, 0.0, 0.0, 0.0, 0.0, 0.0, + LAI_JUN = 0.0, 2.0, 2.0, 2.0, 2.5, 3.3, 3.0, 2.3, 2.6, 3.6, 4.7, 2.0, 4.5, 4.0, 4.3, 0.0, 2.5, 3.3, 0.0, 1.5, 2.1, 1.8, 0.0, 0.0, 0.0, 0.0, 0.0, + LAI_JUL = 0.0, 3.0, 3.0, 3.0, 3.2, 3.7, 3.5, 2.3, 2.9, 3.8, 4.5, 2.6, 4.5, 4.0, 4.3, 0.0, 3.2, 3.7, 0.0, 1.7, 2.1, 1.8, 0.0, 0.0, 0.0, 0.0, 0.0, + LAI_AUG = 0.0, 3.0, 3.0, 3.0, 2.2, 3.2, 1.5, 1.7, 1.6, 2.1, 3.4, 1.7, 4.5, 4.0, 3.7, 0.0, 2.2, 3.2, 0.0, 0.8, 1.8, 1.3, 0.0, 0.0, 0.0, 0.0, 0.0, + LAI_SEP = 0.0, 1.5, 1.5, 1.5, 1.1, 1.3, 0.7, 0.6, 0.7, 0.9, 1.2, 1.0, 4.5, 4.0, 2.6, 0.0, 1.1, 1.3, 0.0, 0.4, 1.3, 0.8, 0.0, 0.0, 0.0, 0.0, 0.0, + LAI_OCT = 0.0, 0.0, 0.0, 0.0, 0.3, 0.2, 0.6, 0.2, 0.4, 0.5, 0.3, 0.5, 4.5, 4.0, 2.2, 0.0, 0.3, 0.3, 0.0, 0.3, 1.1, 0.7, 0.0, 0.0, 0.0, 0.0, 0.0, + LAI_NOV = 0.0, 0.0, 0.0, 0.0, 0.3, 0.0, 0.5, 0.0, 0.3, 0.3, 0.0, 0.2, 4.5, 4.0, 2.0, 0.0, 0.3, 0.3, 0.0, 0.2, 1.0, 0.6, 0.0, 0.0, 0.0, 0.0, 0.0, + LAI_DEC = 0.0, 0.0, 0.0, 0.0, 0.2, 0.0, 0.4, 0.0, 0.2, 0.3, 0.0, 0.0, 4.5, 4.0, 2.0, 0.0, 0.2, 0.2, 0.0, 0.2, 1.0, 0.6, 0.0, 0.0, 0.0, 0.0, 0.0, +/ + +&noahmp_modis_veg_categories + VEG_DATASET_DESCRIPTION = "modified igbp modis noah" ! land type dataset + NVEG = 20 ! total number of land categories in MODIS (no lake) +/ + +&noahmp_modis_parameters + ! 1, 'Evergreen Needleleaf Forest' -> USGS 14 "Evergreen Needleleaf Forest" + ! 2, 'Evergreen Broadleaf Forest' -> USGS 13 "Evergreen Broadleaf Forest" + ! 3, 'Deciduous Needleleaf Forest' -> USGS 12 "Deciduous Needleleaf Forest" + ! 4, 'Deciduous Broadleaf Forest' -> USGS 11 "Deciduous Broadleaf Forest" + ! 5, 'Mixed Forests' -> USGS 15 "Mixed Forest" + ! 6, 'Closed Shrublands' -> USGS 8 "shrubland" + ! 7, 'Open Shrublands' -> USGS 9 "mixed shrubland/grassland" + ! 8, 'Woody Savannas' -> USGS 8 "shrubland" + ! 9, 'Savannas' -> USGS 10 "Savanna" + ! 10, 'Grasslands' -> USGS 7 "Grassland" + ! 11 'Permanent wetlands' -> USGS 17 & 18 mean "Herbaceous & wooded wetland" + ! 12, 'Croplands' -> USGS 2 "dryland cropland" + ! 13, 'Urban and Built-Up' -> USGS 1 "Urban and Built-Up Land" + ! 14 'cropland/natural vegetation mosaic' -> USGS 5 "Cropland/Grassland Mosaic" + ! 15, 'Snow and Ice' -> USGS 24 "Snow or Ice" + ! 16, 'Barren or Sparsely Vegetated' -> USGS 19 "Barren or Sparsely Vegetated" + ! 17, 'Water' -> USGS 16 "Water Bodies" + ! 18, 'Wooded Tundra' -> USGS 21 "Wooded Tundra" + ! 19, 'Mixed Tundra' -> USGS 22 "Mixed Tundra" + ! 20, 'Barren Tundra' -> USGS 23 "Bare Ground Tundra" + + ! specify some key land category indicators + ISURBAN = 13 ! urban land type in MODIS + ISWATER = 17 ! water land type in MODIS + ISBARREN = 16 ! bare soil land type in MODIS + ISICE = 15 ! ice land type in MODIS + ISCROP = 12 ! crop land type in MODIS + EBLFOREST = 2 ! evergreen broadleaf forest land type in MODIS + NATURAL = 14 ! natural vegation type in urban pixel in MODIS + URBTYPE_beg = 50 ! land type number above which are urban (e.g., LCZ) + LCZ_1 = 51 ! urban local climate zone (LCZ) type 1: compact highrise + LCZ_2 = 52 ! urban local climate zone (LCZ) type 2: compact midrise + LCZ_3 = 53 ! urban local climate zone (LCZ) type 3: compact lowrise + LCZ_4 = 54 ! urban local climate zone (LCZ) type 4: open highrise + LCZ_5 = 55 ! urban local climate zone (LCZ) type 5: open midrise + LCZ_6 = 56 ! urban local climate zone (LCZ) type 6: open lowrise + LCZ_7 = 57 ! urban local climate zone (LCZ) type 7: lightweight lowrise + LCZ_8 = 58 ! urban local climate zone (LCZ) type 8: large lowrise + LCZ_9 = 59 ! urban local climate zone (LCZ) type 9: sparsely built + LCZ_10 = 60 ! urban local climate zone (LCZ) type 10: heavy industry + LCZ_11 = 61 ! urban local climate zone (LCZ) type 11: bare rock or paved + + ! start the vegetation-dependent parameters + !----------------------------------------------------------------------------------------------------------------------------------------------------------------------- + ! VegType: 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 + !----------------------------------------------------------------------------------------------------------------------------------------------------------------------- + ! CH2OP: maximum intercepted h2o per unit lai+sai (mm) + CH2OP = 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, + ! DLEAF: characteristic leaf dimension (m) + DLEAF = 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, + ! Z0MVT: momentum roughness length (m) + Z0MVT = 1.09, 1.10, 0.85, 0.80, 0.80, 0.20, 0.06, 0.60, 0.50, 0.12, 0.30, 0.15, 1.00, 0.14, 0.00, 0.00, 0.00, 0.30, 0.20, 0.03, + ! HVT: top of canopy (m) + HVT = 20.0, 20.0, 18.0, 16.0, 16.0, 1.10, 1.10, 13.0, 10.0, 1.00, 5.00, 2.00, 15.0, 1.50, 0.00, 0.00, 0.00, 4.00, 2.00, 0.50, + ! HVB: bottom of canopy (m) + HVB = 8.50, 8.00, 7.00, 11.5, 10.0, 0.10, 0.10, 0.10, 0.10, 0.05, 0.10, 0.10, 1.00, 0.10, 0.00, 0.00, 0.00, 0.30, 0.20, 0.10, + ! DEN: tree density (no. of trunks per m2) + DEN = 0.28, 0.02, 0.28, 0.10, 0.10, 10.0, 10.0, 10.0, 0.02, 100., 5.05, 25.0, 0.01, 25.0, 0.00, 0.01, 0.01, 1.00, 1.00, 1.00, + ! RC: tree crown radius (m) + RC = 1.20, 3.60, 1.20, 1.40, 1.40, 0.12, 0.12, 0.12, 3.00, 0.03, 0.75, 0.08, 1.00, 0.08, 0.00, 0.01, 0.01, 0.30, 0.30, 0.30, + ! MFSNO: snowmelt curve parameter, originally =2.5 everywhere, currently optimized dependent on land type based on SNOTEL SWE & MODIS SCF, surface albedo (He et al. 2019 JGR) + MFSNO = 1.00, 1.00, 1.00, 1.00, 1.00, 2.00, 2.00, 2.00, 2.00, 2.00, 3.00, 3.00, 4.00, 4.00, 2.50, 3.00, 3.00, 3.50, 3.50, 3.50, + ! SCFFAC: snow cover factor (m) (replace original hard-coded 2.5*z0, z0=0.002m everywhere), currently optimized based on SNOTEL SWE & MODIS SCF, surface albedo (He et al. 2021 JGR) + SCFFAC = 0.008, 0.008, 0.008, 0.008, 0.008, 0.016, 0.016, 0.020, 0.020, 0.020, 0.020, 0.014, 0.042, 0.026, 0.030, 0.016, 0.030, 0.030, 0.030, 0.030, + ! CBIOM: canopy biomass heat capacity parameter (m), C. He 12/23/2022 bring hard-coded parameter to here + CBIOM = 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, + ! RHOL_VIS: leaf reflectance at visible (VIS) band + RHOL_VIS = 0.07, 0.10, 0.07, 0.10, 0.10, 0.07, 0.07, 0.07, 0.10, 0.11, 0.105, 0.11, 0.00, 0.11, 0.00, 0.00, 0.00, 0.10, 0.10, 0.10, + ! RHOL_NIR: leaf reflectance at near-infra (NIR) band + RHOL_NIR = 0.35, 0.45, 0.35, 0.45, 0.45, 0.35, 0.35, 0.35, 0.45, 0.58, 0.515, 0.58, 0.00, 0.58, 0.00, 0.00, 0.00, 0.45, 0.45, 0.45, + ! RHOS_VIS: stem reflectance at visible (VIS) band + RHOS_VIS = 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.36, 0.26, 0.36, 0.00, 0.36, 0.00, 0.00, 0.00, 0.16, 0.16, 0.16, + ! RHOS_NIR: stem reflectance at near-infra (NIR) band + RHOS_NIR = 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.58, 0.485, 0.58, 0.00, 0.58, 0.00, 0.00, 0.00, 0.39, 0.39, 0.39, + ! TAUL_VIS: leaf transmittance at visible (VIS) band + TAUL_VIS = 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.07, 0.06, 0.07, 0.00, 0.07, 0.00, 0.00, 0.00, 0.05, 0.05, 0.05, + ! TAUL_NIR: leaf transmittance at near-infra (NIR) band + TAUL_NIR = 0.10, 0.25, 0.10, 0.25, 0.25, 0.10, 0.10, 0.10, 0.25, 0.25, 0.25, 0.25, 0.00, 0.25, 0.00, 0.00, 0.00, 0.25, 0.25, 0.25, + ! TAUS_VIS: stem transmittance at visible (VIS) band + TAUS_VIS = 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.220, 0.1105, 0.220, 0.000, 0.220, 0.000, 0.000, 0.000, 0.001, 0.001, 0.001, + ! TAUS_NIR: stem transmittance at near-infra (NIR) band + TAUS_NIR = 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.380, 0.1905, 0.380, 0.000, 0.380, 0.000, 0.000, 0.000, 0.001, 0.001, 0.001, + ! XL: leaf/stem orientation index + XL = 0.010, 0.010, 0.010, 0.250, 0.250, 0.010, 0.010, 0.010, 0.010, -0.30, -0.025, -0.30, 0.000, -0.30, 0.000, 0.000, 0.000, 0.250, 0.250, 0.250, + ! CWPVT: empirical canopy wind absorption parameter (J. Goudriaan, Crop Micrometeorology: A Simulation Study (Simulation monographs), 1977) + CWPVT = 0.18, 0.67, 0.18, 0.67, 0.29, 1.0, 2.0, 1.3, 1.0, 5.0, 1.17, 1.67, 1.67, 1.67, 0.18, 0.18, 0.18, 0.67, 1.0, 0.18, + ! C3PSN: photosynthetic pathway: 0.0 = c4, 1.0 = c3 + C3PSN = 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, + ! KC25: CO2 michaelis-menten constant at 25degC (Pa) + KC25 = 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, + ! AKC: q10 for KC25, change in CO2 Michaelis-Menten constant for every 10-degC temperature change + AKC = 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, + ! KO25: O2 michaelis-menten constant at 25degC (Pa) + KO25 = 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, + ! AKO: q10 for KO25, change in O2 Michaelis-Menten constant for every 10-degC temperature change + AKO = 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, + ! AVCMX: q10 for VCMX25, change in maximum rate of carboxylation at 25degC for every 10-degC temperature change + AVCMX = 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, + ! AQE: q10 for QE25, change in quantum efficiency at 25degC (umol CO2/umol photon) + AQE = 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, + ! LTOVRC: leaf turnover [1/s] + LTOVRC = 0.5, 0.55, 0.2, 0.55, 0.5, 0.65, 0.65, 0.65, 0.65, 0.50, 1.4, 1.6, 0.0, 1.2, 0.0, 0.0, 0.0, 1.3, 1.4, 1.0, + ! DILEFC: coeficient for leaf stress death [1/s] + DILEFC = 1.20, 0.50, 1.80, 0.60, 0.80, 0.20, 0.20, 0.20, 0.50, 0.20, 0.4, 0.50, 0.00, 0.35, 0.00, 0.00, 0.00, 0.30, 0.40, 0.30, + ! DILEFW: coeficient for leaf stress death [1/s] + DILEFW = 0.20, 4.00, 0.20, 0.20, 0.20, 0.20, 0.20, 0.20, 0.50, 0.10, 0.2, 0.20, 0.00, 0.20, 0.00, 0.00, 0.00, 0.20, 0.20, 0.20, + ! RMF25: leaf maintenance respiration at 25degC (umol co2/m2/s) + RMF25 = 3.00, 0.65, 4.00, 3.00, 3.00, 0.26, 0.26, 0.26, 0.80, 1.80, 3.2, 1.00, 0.00, 1.45, 0.00, 0.00, 0.00, 3.00, 3.00, 3.00, + ! SLA: single-side leaf area per mass [m2/kg] + SLA = 80, 80, 80, 80, 80, 60, 60, 60, 50, 60, 80, 80, 60, 80, 0, 0, 0, 80, 80, 80, + ! FRAGR: fraction of growth respiration + FRAGR = 0.10, 0.20, 0.10, 0.20, 0.10, 0.20, 0.20, 0.20, 0.20, 0.20, 0.1, 0.20, 0.00, 0.20, 0.00, 0.10, 0.00, 0.10, 0.10, 0.10, + ! TMIN: minimum temperature for photosynthesis (K) + TMIN = 265, 273, 268, 273, 268, 273, 273, 273, 273, 273, 268, 273, 0, 273, 0, 0, 0, 268, 268, 268, + ! VCMX25: maximum rate of carboxylation at 25 degC (umol CO2/m2/s) + VCMX25 = 50.0, 60.0, 60.0, 60.0, 55.0, 40.0, 40.0, 40.0, 40.0, 40.0, 50.0, 80.0, 0.00, 60.0, 0.00, 0.00, 0.00, 50.0, 50.0, 50.0, + ! TDLEF: characteristic temperature for leaf freezing [K] + TDLEF = 278, 278, 268, 278, 268, 278, 278, 278, 278, 278, 268, 278, 278, 278, 0, 0, 0, 268, 268, 268, + ! BP: minimum leaf conductance (umol/m2/s) + BP = 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 1.E15, 2.E3, 1.E15, 2.E3, 1.E15, 2.E3, 2.E3, 2.E3, + ! MP: slope of conductance-to-photosynthesis relationship + MP = 6.0, 9.0, 6.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, + ! QE25: quantum efficiency at 25degC (umol CO2/umol photon) + QE25 = 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.00, 0.06, 0.00, 0.06, 0.00, 0.06, 0.06, 0.06, + ! RMS25: stem maintenance respiration at 25c (umol CO2/Kg bio/s) + RMS25 = 0.90, 0.30, 0.64, 0.10, 0.80, 0.10, 0.10, 0.10, 0.32, 0.10, 0.10, 0.10, 0.00, 0.10, 0.00, 0.00, 0.00, 0.10, 0.10, 0.00, + ! RMR25: root maintenance respiration at 25c (umol CO2/Kg bio/s) + RMR25 = 0.36, 0.05, 0.05, 0.01, 0.03, 0.00, 0.00, 0.00, 0.01, 1.20, 0.0, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 2.11, 2.11, 0.00, + ! ARM: q10 for maintenance respiration, change in maintenance respiration for every 10-degC temperature change + ARM = 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, + ! FOLNMX: foliage nitrogen concentration when f(n)=1 (%) + FOLNMX = 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 0.00, 1.5, 0.00, 1.5, 0.00, 1.5, 1.5, 1.5, + ! WDPOOL: ood pool (switch 1 or 0) depending on woody or not + WDPOOL = 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 0.00, 0.5, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 1.00, 1.00, 0.00, + ! WRRAT: wood to non-wood ratio + WRRAT = 30.0, 30.0, 30.0, 30.0, 30.0, 3.00, 3.00, 3.00, 3.00, 0.00, 15.0, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 3.00, 3.00, 0.00, + ! MRP: microbial respiration parameter (umol CO2/kgC/s) + MRP = 0.37, 0.23, 0.37, 0.40, 0.30, 0.19, 0.19, 0.19, 0.40, 0.17, 0.285, 0.23, 0.00, 0.23, 0.00, 0.00, 0.00, 0.23, 0.20, 0.00, + ! NROOT: number of soil layers with root present + NROOT = 4, 4, 4, 4, 4, 3, 3, 3, 3, 3, 2, 3, 1, 3, 1, 1, 0, 3, 3, 2, + ! RGL: Parameter used in radiation stress function + RGL = 30.0, 30.0, 30.0, 30.0, 30.0, 100.0, 100.0, 100.0, 65.0, 100.0, 65.0, 100.0, 999.0, 100.0, 999.0, 999.0, 30.0, 100.0, 100.0, 100.0, + ! RS: Minimum stomatal resistance (s/m) + RS = 125.0, 150.0, 150.0, 100.0, 125.0, 300.0, 170.0, 300.0, 70.0, 40.0, 70.0, 40.0, 200.0, 40.0, 999.0, 999.0, 100.0, 150.0, 150.0, 200.0, + ! HS: Parameter used in vapor pressure deficit function + HS = 47.35, 41.69, 47.35, 54.53, 51.93, 42.00, 39.18, 42.00, 54.53, 36.35, 55.97, 36.25, 999.0, 36.25, 999.0, 999.0, 51.75, 42.00, 42.00, 42.00, + ! TOPT: Optimum transpiration air temperature [K] + TOPT = 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, + ! RSMAX: Maximal stomatal resistance [s/m] + RSMAX = 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., + ! RTOVRC: root turnover coefficient [1/s] + RTOVRC = 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, + ! RSWOODC: wood respiration coeficient [1/s] + RSWOODC = 3.E-10,3.E-10, 3.E-10, 3.E-10, 3.E-10, 3.E-10, 3.E-10, 3.E-10, 3.E-10, 3.E-10, 3.E-10, 3.E-10, 3.E-10, 3.E-10, 3.E-10, 3.E-10, 3.E-10, 3.E-10, 3.E-10, 3.E-10, + ! BF: parameter for present wood allocation + BF = 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, + ! WSTRC: water stress coeficient + WSTRC = 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, + ! LAIMIN: minimum leaf area index [m2/m2] + LAIMIN = 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, + ! XSAMIN: minimum stem area index [m2/m2] + XSAMIN = 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, + ! SAI: MODIS monthly climatology (2000-2008) stem area index (one row for each month) (Yang et al., 2011) + SAI_JAN = 0.4, 0.5, 0.3, 0.4, 0.4, 0.3, 0.2, 0.4, 0.3, 0.3, 0.3, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, 0.1, 0.0, + SAI_FEB = 0.4, 0.5, 0.3, 0.4, 0.4, 0.3, 0.2, 0.4, 0.3, 0.3, 0.3, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, 0.1, 0.0, + SAI_MAR = 0.4, 0.5, 0.3, 0.4, 0.4, 0.3, 0.2, 0.4, 0.3, 0.3, 0.3, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, 0.1, 0.0, + SAI_APR = 0.3, 0.5, 0.4, 0.4, 0.4, 0.3, 0.2, 0.4, 0.3, 0.3, 0.3, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, 0.1, 0.0, + SAI_MAY = 0.4, 0.5, 0.4, 0.4, 0.4, 0.3, 0.2, 0.4, 0.3, 0.3, 0.3, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, 0.1, 0.0, + SAI_JUN = 0.5, 0.5, 0.7, 0.4, 0.4, 0.3, 0.2, 0.4, 0.4, 0.4, 0.4, 0.3, 0.0, 0.4, 0.0, 0.0, 0.0, 0.2, 0.2, 0.0, + SAI_JUL = 0.5, 0.5, 1.3, 0.9, 0.7, 0.6, 0.4, 0.7, 0.8, 0.8, 0.6, 0.4, 0.0, 0.6, 0.0, 0.0, 0.0, 0.4, 0.4, 0.0, + SAI_AUG = 0.6, 0.5, 1.2, 1.2, 0.8, 0.9, 0.6, 1.2, 1.2, 1.3, 0.9, 0.5, 0.0, 0.9, 0.0, 0.0, 0.0, 0.6, 0.6, 0.0, + SAI_SEP = 0.6, 0.5, 1.0, 1.6, 1.0, 1.2, 0.8, 1.4, 1.3, 1.1, 0.9, 0.4, 0.0, 0.7, 0.0, 0.0, 0.0, 0.8, 0.7, 0.0, + SAI_OCT = 0.7, 0.5, 0.8, 1.4, 1.0, 0.9, 0.7, 1.1, 0.7, 0.4, 0.6, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.7, 0.5, 0.0, + SAI_NOV = 0.6, 0.5, 0.6, 0.6, 0.5, 0.4, 0.3, 0.5, 0.4, 0.4, 0.4, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.3, 0.3, 0.0, + SAI_DEC = 0.5, 0.5, 0.5, 0.4, 0.4, 0.3, 0.2, 0.4, 0.4, 0.4, 0.3, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, 0.2, 0.0, + ! LAI: MODIS monthly climatology (2000-2008) leaf area index (one row for each month) (Yang et al., 2011) + LAI_JAN = 4.0, 4.5, 0.0, 0.0, 2.0, 0.0, 0.0, 0.2, 0.3, 0.4, 0.2, 0.0, 0.0, 0.2, 0.0, 0.0, 0.0, 1.0, 0.6, 0.0, + LAI_FEB = 4.0, 4.5, 0.0, 0.0, 2.0, 0.0, 0.0, 0.2, 0.3, 0.5, 0.3, 0.0, 0.0, 0.3, 0.0, 0.0, 0.0, 1.0, 0.6, 0.0, + LAI_MAR = 4.0, 4.5, 0.0, 0.3, 2.2, 0.3, 0.2, 0.4, 0.5, 0.6, 0.3, 0.0, 0.0, 0.3, 0.0, 0.0, 0.0, 1.1, 0.7, 0.0, + LAI_APR = 4.0, 4.5, 0.6, 1.2, 2.6, 0.9, 0.6, 1.0, 0.8, 0.7, 0.5, 0.0, 0.0, 0.4, 0.0, 0.0, 0.0, 1.3, 0.8, 0.0, + LAI_MAY = 4.0, 4.5, 1.2, 3.0, 3.5, 2.2, 1.5, 2.4, 1.8, 1.2, 1.5, 1.0, 0.0, 1.1, 0.0, 0.0, 0.0, 1.7, 1.2, 0.0, + LAI_JUN = 4.0, 4.5, 2.0, 4.7, 4.3, 3.5, 2.3, 4.1, 3.6, 3.0, 2.9, 2.0, 0.0, 2.5, 0.0, 0.0, 0.0, 2.1, 1.8, 0.0, + LAI_JUL = 4.0, 4.5, 2.6, 4.5, 4.3, 3.5, 2.3, 4.1, 3.8, 3.5, 3.5, 3.0, 0.0, 3.2, 0.0, 0.0, 0.0, 2.1, 1.8, 0.0, + LAI_AUG = 4.0, 4.5, 1.7, 3.4, 3.7, 2.5, 1.7, 2.7, 2.1, 1.5, 2.7, 3.0, 0.0, 2.2, 0.0, 0.0, 0.0, 1.8, 1.3, 0.0, + LAI_SEP = 4.0, 4.5, 1.0, 1.2, 2.6, 0.9, 0.6, 1.0, 0.9, 0.7, 1.2, 1.5, 0.0, 1.1, 0.0, 0.0, 0.0, 1.3, 0.8, 0.0, + LAI_OCT = 4.0, 4.5, 0.5, 0.3, 2.2, 0.3, 0.2, 0.4, 0.5, 0.6, 0.3, 0.0, 0.0, 0.3, 0.0, 0.0, 0.0, 1.1, 0.7, 0.0, + LAI_NOV = 4.0, 4.5, 0.2, 0.0, 2.0, 0.0, 0.0, 0.2, 0.3, 0.5, 0.3, 0.0, 0.0, 0.3, 0.0, 0.0, 0.0, 1.0, 0.6, 0.0, + LAI_DEC = 4.0, 4.5, 0.0, 0.0, 2.0, 0.0, 0.0, 0.2, 0.3, 0.4, 0.2, 0.0, 0.0, 0.2, 0.0, 0.0, 0.0, 1.0, 0.6, 0.0, +/ + +&noahmp_rad_parameters + !------------------------------------------------------------------------------ + ! soil color: 1 2 3 4 5 6 7 8 soil color index for soil albedo + !------------------------------------------------------------------------------ + ALBSAT_VIS = 0.15, 0.11, 0.10, 0.09, 0.08, 0.07, 0.06, 0.05 ! saturated soil albedo at visible band + ALBSAT_NIR = 0.30, 0.22, 0.20, 0.18, 0.16, 0.14, 0.12, 0.10 ! saturated soil albedo at NIR band + ALBDRY_VIS = 0.27, 0.22, 0.20, 0.18, 0.16, 0.14, 0.12, 0.10 ! dry soil albedo at visible band + ALBDRY_NIR = 0.54, 0.44, 0.40, 0.36, 0.32, 0.28, 0.24, 0.20 ! dry soil albedo at NIR band + ALBICE = 0.80, 0.55 ! albedo land ice: 1=vis, 2=nir + ALBLAK = 0.60, 0.40 ! albedo frozen lakes: 1=vis, 2=nir + OMEGAS = 0.8 , 0.4 ! two-stream parameter omega for snow + BETADS = 0.5 ! two-stream parameter betad for snow + BETAIS = 0.5 ! two-stream parameter betaI for snow + EG = 0.97, 0.98 ! emissivity soil surface 1-soil;2-lake + EICE = 0.98 ! emissivity ice surface +/ + +&noahmp_global_parameters + ! atmospheric constituants + CO2 = 395.0e-06 ! CO2 partial pressure + O2 = 0.209 ! O2 partial pressure + ! runoff parameters used for SIMTOP and SIMGM + TIMEAN = 10.5 ! gridcell mean topgraphic index (global mean) + FSATMX = 0.38 ! maximum surface saturated fraction (global mean) + ROUS = 0.20 ! specific yield [-] for Niu et al. 2007 groundwater scheme (OptRunoffSubsurface=1) + CMIC = 0.80 ! microprore content (0.0-1.0), 0.0: close to free drainage + ! parameters for snow processes + SSI = 0.03 ! liquid water holding capacity for snowpack (m3/m3) + SNOW_RET_FAC = 5.0e-5 ! snowpack water release timescale factor (1/s) + SNOW_EMIS = 0.95 ! snow emissivity + SWEMX = 1.00 ! new snow mass to fully cover old snow (mm), equivalent to 10mm depth (density = 100 kg/m3) + TAU0 = 1.0e6 ! tau0 from Yang97 eqn. 10a for BATS snow aging + GRAIN_GROWTH = 5000.0 ! growth from vapor diffusion Yang97 eqn. 10b for BATS snow aging + EXTRA_GROWTH = 10.0 ! extra growth near freezing Yang97 eqn. 10c for BATS snow aging + DIRT_SOOT = 0.3 ! dirt and soot term Yang97 eqn. 10d for BATS snow aging + BATS_COSZ = 2.0 ! zenith angle snow albedo adjustment; b in Yang97 eqn. 15 for BATS snow albedo + BATS_VIS_NEW = 0.95 ! new snow visible albedo for BATS snow albedo + BATS_NIR_NEW = 0.65 ! new snow NIR albedo for BATS snow albedo + BATS_VIS_AGE = 0.2 ! age factor for diffuse visible snow albedo Yang97 eqn. 17 for BATS snow albedo + BATS_NIR_AGE = 0.5 ! age factor for diffuse NIR snow albedo Yang97 eqn. 18 for BATS snow albedo + BATS_VIS_DIR = 0.4 ! cosz factor for direct visible snow albedo Yang97 eqn. 15 for BATS snow albedo + BATS_NIR_DIR = 0.4 ! cosz factor for direct NIR snow albedo Yang97 eqn. 16 for BATS snow albedo + C2_SNOWCOMPACT = 21.0e-3 ! overburden snow compaction parameter (m3/kg) + C3_SNOWCOMPACT = 2.5e-6 ! snow desctructive metamorphism compaction parameter1 [1/s] + C4_SNOWCOMPACT = 0.04 ! snow desctructive metamorphism compaction parameter2 [1/k] + C5_SNOWCOMPACT = 2.0 ! snow desctructive metamorphism compaction parameter3 + DM_SNOWCOMPACT = 100.0 ! upper Limit on destructive metamorphism compaction [kg/m3] + ETA0_SNOWCOMPACT = 1.33e+6 ! snow viscosity coefficient [kg-s/m2], Anderson1979: 0.52e6~1.38e6; 1.33e+6 optimized based on SNOTEL obs (He et al. 2021 JGR) + SNLIQMAXFRAC = 0.4 ! maximum liquid water fraction in snow + SWEMAXGLA = 5000.0 ! Maximum SWE allowed at glaciers (mm) + SNOWDEN_MAX = 120.0 ! maximum fresh snowfall density (kg/m3) + CLASS_ALB_REF = 0.55 ! reference snow albedo in CLASS scheme + CLASS_SNO_AGE = 3600.0 ! snow aging e-folding time (s) in CLASS albedo scheme + CLASS_ALB_NEW = 0.84 ! fresh snow albedo in CLASS scheme + RSURF_SNOW = 50.0 ! surface resistence for snow [s/m] + Z0SNO = 0.002 ! snow surface roughness length (m) + ! other soil and hydrological parameters + RSURF_EXP = 5.0 ! exponent in the shape parameter for soil resistance option 1 + WSLMAX = 5000.0 ! maximum lake water storage (mm) + PSIWLT = -150.0 ! metric potential for wilting point (m) + Z0SOIL = 0.002 ! Bare-soil roughness length (m) (i.e., under the canopy) + Z0LAKE = 0.01 ! Lake surface roughness length (m) +/ + +&noahmp_irrigation_parameters + IRR_FRAC = 0.10 ! irrigation Fraction + IRR_HAR = 20 ! number of days before harvest date to stop irrigation + IRR_LAI = 0.10 ! Minimum lai to trigger irrigation + IRR_MAD = 0.60 ! management allowable deficit (0.0-1.0) + FILOSS = 0.50 ! flood irrigation loss fraction (0.0-0.99) + SPRIR_RATE = 6.40 ! mm/h, sprinkler irrigation rate + MICIR_RATE = 1.38 ! mm/h, micro irrigation rate + FIRTFAC = 1.20 ! flood application rate factor + IR_RAIN = 1.00 ! maximum precipitation [mm/hr] to stop irrigation trigger +/ + +&noahmp_crop_parameters + ! NCROP = 5 + ! 1: Corn + ! 2: Soybean + ! 3: Sorghum + ! 4: Rice + ! 5: Winter wheat + + DEFAULT_CROP = 0 ! default crop type (1-5); if =0, use generic dynamic vegetation + +!------------------------------------------------------- +! CropType: 1 2 3 4 5 +!------------------------------------------------------- + PLTDAY = 111, 131, 111, 111, 111, ! Planting date + HSDAY = 300, 280, 300, 300, 300, ! Harvest date + PLANTPOP = 78.0, 78.0, 78.0, 78.0, 78.0, ! Plant density [per ha] + GDDTBASE = 10.0, 10.0, 10.0, 10.0, 10.0, ! Base temperature for Grow Degree Day (GDD) accumulation [C] + GDDTCUT = 30.0, 30.0, 30.0, 30.0, 30.0, ! Upper temperature for Grow Degree Day (GDD) accumulation [C] + GDDS1 = 50.0, 60.0, 50.0, 50.0, 50.0, ! Grow Degree Day (GDD) from seeding to emergence + GDDS2 = 625.0, 675.0, 718.0, 718.0, 718.0, ! Grow Degree Day (GDD) from seeding to initial vegetative + GDDS3 = 933.0, 1183.0, 933.0, 933.0, 933.0, ! Grow Degree Day (GDD) from seeding to post vegetative + GDDS4 = 1103.0, 1253.0, 1103.0, 1103.0, 1103.0, ! Grow Degree Day (GDD) from seeding to intial reproductive + GDDS5 = 1555.0, 1605.0, 1555.0, 1555.0, 1555.0, ! Grow Degree Day (GDD) from seeding to pysical maturity + C3PSNI = 0.0, 1.0, 1.0, 1.0, 1.0, ! photosynthetic pathway: 0.0 = c4, 1.0 = c3; the following 11 *I parameters added by Z. Zhang, 2020/02 + KC25I = 30.0, 30.0, 30.0, 30.0, 30.0, ! CO2 michaelis-menten constant at 25 degC (pa) + AKCI = 2.1, 2.1, 2.1, 2.1, 2.1, ! q10 for KC25; change in CO2 Michaelis-Menten constant for every 10-degC temperature change + KO25I = 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, ! O2 michaelis-menten constant at 25 degC (pa) + AKOI = 1.2, 1.2, 1.2, 1.2, 1.2, ! q10 for KO25; change in O2 Michaelis-Menten constant for every 10-degC temperature change + AVCMXI = 2.4, 2.4, 2.4, 2.4, 2.4, ! q10 for VCMZ25; change in maximum rate of carboxylation for every 10-degC temperature change + VCMX25I = 60.0, 80.0, 60.0, 60.0, 55.0, ! maximum rate of carboxylation at 25c (umol CO2/m2/s) + BPI = 4.E4, 1.E4, 2.E3, 2.E3, 2.E3, ! minimum leaf conductance (umol/m2/s) + MPI = 4., 9., 6., 9., 9., ! slope of conductance-to-photosynthesis relationship + FOLNMXI = 1.5, 1.5, 1.5, 1.5, 1.5, ! foliage nitrogen concentration when f(n)=1 (%) + QE25I = 0.05, 0.06, 0.06, 0.06, 0.06, ! quantum efficiency at 25 degC (umol CO2/umol photon) + Aref = 7.0, 7.0, 7.0, 7.0, 7.0, ! reference maximum CO2 assimilation rate + PSNRF = 0.85, 0.85, 0.85, 0.85, 0.85, ! CO2 assimilation reduction factor(0-1) (caused by non-modeling part,e.g.pest,weeds) + I2PAR = 0.5, 0.5, 0.5, 0.5, 0.5, ! Fraction of incoming solar radiation to photosynthetically active radiation + TASSIM0 = 8.0, 8.0, 8.0, 8.0, 8.0, ! Minimum temperature for CO2 assimilation [C] + TASSIM1 = 18.0, 18.0, 18.0, 18.0, 18.0, ! CO2 assimilation linearly increasing until temperature reaches T1 [C] + TASSIM2 = 30.0, 30.0, 30.0, 30.0, 30.0, ! CO2 assmilation rate remain at Aref until temperature reaches T2 [C] + K = 0.55, 0.55, 0.55, 0.55, 0.55, ! light extinction coefficient + EPSI = 12.5, 12.5, 12.5, 12.5, 12.5, ! initial light use efficiency + Q10MR = 2.0, 2.0, 2.0, 2.0, 2.0, ! q10 for maintainance respiration; change in maintainance respiration for every 10-degC temperature change + LEFREEZ = 268, 268, 268, 268, 268, ! characteristic T for leaf freezing [K] + DILE_FC_S1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! coeficient for temperature leaf stress death [1/s] at growth stage 1 + DILE_FC_S2 = 0.0, 0.0, 0.0, 0.0, 0.0, ! coeficient for temperature leaf stress death [1/s] at growth stage 2 + DILE_FC_S3 = 0.0, 0.0, 0.0, 0.0, 0.0, ! coeficient for temperature leaf stress death [1/s] at growth stage 3 + DILE_FC_S4 = 0.0, 0.0, 0.0, 0.0, 0.0, ! coeficient for temperature leaf stress death [1/s] at growth stage 4 + DILE_FC_S5 = 0.5, 0.5, 0.5, 0.5, 0.5, ! coeficient for temperature leaf stress death [1/s] at growth stage 5 + DILE_FC_S6 = 0.5, 0.5, 0.5, 0.5, 0.5, ! coeficient for temperature leaf stress death [1/s] at growth stage 6 + DILE_FC_S7 = 0.0, 0.0, 0.0, 0.0, 0.0, ! coeficient for temperature leaf stress death [1/s] at growth stage 7 + DILE_FC_S8 = 0.0, 0.0, 0.0, 0.0, 0.0, ! coeficient for temperature leaf stress death [1/s] at growth stage 8 + DILE_FW_S1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! coeficient for water leaf stress death [1/s] at growth stage 1 + DILE_FW_S2 = 0.0, 0.0, 0.0, 0.0, 0.0, ! coeficient for water leaf stress death [1/s] at growth stage 2 + DILE_FW_S3 = 0.0, 0.0, 0.0, 0.0, 0.0, ! coeficient for water leaf stress death [1/s] at growth stage 3 + DILE_FW_S4 = 0.0, 0.0, 0.0, 0.0, 0.0, ! coeficient for water leaf stress death [1/s] at growth stage 4 + DILE_FW_S5 = 0.2, 0.2, 0.2, 0.2, 0.2, ! coeficient for water leaf stress death [1/s] at growth stage 5 + DILE_FW_S6 = 0.2, 0.2, 0.2, 0.2, 0.2, ! coeficient for water leaf stress death [1/s] at growth stage 6 + DILE_FW_S7 = 0.0, 0.0, 0.0, 0.0, 0.0, ! coeficient for water leaf stress death [1/s] at growth stage 7 + DILE_FW_S8 = 0.0, 0.0, 0.0, 0.0, 0.0, ! coeficient for water leaf stress death [1/s] at growth stage 8 + FRA_GR = 0.2, 0.2, 0.2, 0.2, 0.2, ! fraction of growth respiration + LF_OVRC_S1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of leaf turnover [1/s] at growth stage 1 + LF_OVRC_S2 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of leaf turnover [1/s] at growth stage 2 + LF_OVRC_S3 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of leaf turnover [1/s] at growth stage 3 + LF_OVRC_S4 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of leaf turnover [1/s] at growth stage 4 + LF_OVRC_S5 = 0.2, 0.2, 0.48, 0.48, 0.48, ! fraction of leaf turnover [1/s] at growth stage 5 + LF_OVRC_S6 = 0.3, 0.3, 0.48, 0.48, 0.48, ! fraction of leaf turnover [1/s] at growth stage 6 + LF_OVRC_S7 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of leaf turnover [1/s] at growth stage 7 + LF_OVRC_S8 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of leaf turnover [1/s] at growth stage 8 + ST_OVRC_S1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of stem turnover [1/s] at growth stage 1 + ST_OVRC_S2 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of stem turnover [1/s] at growth stage 2 + ST_OVRC_S3 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of stem turnover [1/s] at growth stage 3 + ST_OVRC_S4 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of stem turnover [1/s] at growth stage 4 + ST_OVRC_S5 = 0.2, 0.12, 0.12, 0.12, 0.12, ! fraction of stem turnover [1/s] at growth stage 5 + ST_OVRC_S6 = 0.3, 0.06, 0.06, 0.06, 0.06, ! fraction of stem turnover [1/s] at growth stage 6 + ST_OVRC_S7 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of stem turnover [1/s] at growth stage 7 + ST_OVRC_S8 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of stem turnover [1/s] at growth stage 8 + RT_OVRC_S1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of root tunrover [1/s] at growth stage 1 + RT_OVRC_S2 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of root tunrover [1/s] at growth stage 2 + RT_OVRC_S3 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of root tunrover [1/s] at growth stage 3 + RT_OVRC_S4 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of root tunrover [1/s] at growth stage 4 + RT_OVRC_S5 = 0.12, 0.12, 0.12, 0.12, 0.12, ! fraction of root tunrover [1/s] at growth stage 5 + RT_OVRC_S6 = 0.06, 0.06, 0.06, 0.06, 0.06, ! fraction of root tunrover [1/s] at growth stage 6 + RT_OVRC_S7 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of root tunrover [1/s] at growth stage 7 + RT_OVRC_S8 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of root tunrover [1/s] at growth stage 8 + LFMR25 = 0.8, 1.0, 1.0, 1.0, 1.0, ! leaf maintenance respiration at 25C [umol CO2/m2/s] + STMR25 = 0.05, 0.05, 0.1, 0.1, 0.1, ! stem maintenance respiration at 25C [umol CO2/kg bio/s] + RTMR25 = 0.05, 0.05, 0.0, 0.0, 0.0, ! root maintenance respiration at 25C [umol CO2/kg bio/s] + GRAINMR25 = 0.0, 0.0, 0.1, 0.1, 0.1, ! grain maintenance respiration at 25C [umol CO2/kg bio/s] + LFPT_S1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate flux to leaf at growth stage 1 + LFPT_S2 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate flux to leaf at growth stage 2 + LFPT_S3 = 0.36, 0.4, 0.4, 0.4, 0.4, ! fraction of carbohydrate flux to leaf at growth stage 3 + LFPT_S4 = 0.1, 0.2, 0.2, 0.2, 0.2, ! fraction of carbohydrate flux to leaf at growth stage 4 + LFPT_S5 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate flux to leaf at growth stage 5 + LFPT_S6 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate flux to leaf at growth stage 6 + LFPT_S7 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate flux to leaf at growth stage 7 + LFPT_S8 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate flux to leaf at growth stage 8 + STPT_S1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate flux to stem at growth stage 1 + STPT_S2 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate flux to stem at growth stage 2 + STPT_S3 = 0.24, 0.2, 0.2, 0.2, 0.2, ! fraction of carbohydrate flux to stem at growth stage 3 + STPT_S4 = 0.6, 0.5, 0.5, 0.5, 0.5, ! fraction of carbohydrate flux to stem at growth stage 4 + STPT_S5 = 0.0, 0.0, 0.15, 0.15, 0.15, ! fraction of carbohydrate flux to stem at growth stage 5 + STPT_S6 = 0.0, 0.0, 0.05, 0.05, 0.05, ! fraction of carbohydrate flux to stem at growth stage 6 + STPT_S7 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate flux to stem at growth stage 7 + STPT_S8 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate flux to stem at growth stage 8 + RTPT_S1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate flux to root at growth stage 1 + RTPT_S2 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate flux to root at growth stage 2 + RTPT_S3 = 0.4, 0.4, 0.4, 0.4, 0.4, ! fraction of carbohydrate flux to root at growth stage 3 + RTPT_S4 = 0.3, 0.3, 0.3, 0.3, 0.3, ! fraction of carbohydrate flux to root at growth stage 4 + RTPT_S5 = 0.05, 0.05, 0.05, 0.05, 0.05, ! fraction of carbohydrate flux to root at growth stage 5 + RTPT_S6 = 0.0, 0.0, 0.05, 0.05, 0.05, ! fraction of carbohydrate flux to root at growth stage 6 + RTPT_S7 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate flux to root at growth stage 7 + RTPT_S8 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate flux to root at growth stage 8 + GRAINPT_S1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate flux to grain at growth stage 1 + GRAINPT_S2 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate flux to grain at growth stage 2 + GRAINPT_S3 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate flux to grain at growth stage 3 + GRAINPT_S4 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate flux to grain at growth stage 4 + GRAINPT_S5 = 0.95, 0.95, 0.8, 0.8, 0.8, ! fraction of carbohydrate flux to grain at growth stage 5 + GRAINPT_S6 = 1.0, 1.0, 0.9, 0.9, 0.9, ! fraction of carbohydrate flux to grain at growth stage 6 + GRAINPT_S7 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate flux to grain at growth stage 7 + GRAINPT_S8 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate flux to grain at growth stage 8 + LFCT_S1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate translocation from leaf to grain at growth stage 1 + LFCT_S2 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate translocation from leaf to grain at growth stage 2 + LFCT_S3 = 0.0, 0.0, 0.4, 0.4, 0.4, ! fraction of carbohydrate translocation from leaf to grain at growth stage 3 + LFCT_S4 = 0.0, 0.0, 0.3, 0.3, 0.3, ! fraction of carbohydrate translocation from leaf to grain at growth stage 4 + LFCT_S5 = 0.0, 0.0, 0.05, 0.05, 0.05, ! fraction of carbohydrate translocation from leaf to grain at growth stage 5 + LFCT_S6 = 0.0, 0.0, 0.05, 0.05, 0.05, ! fraction of carbohydrate translocation from leaf to grain at growth stage 6 + LFCT_S7 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate translocation from leaf to grain at growth stage 7 + LFCT_S8 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate translocation from leaf to grain at growth stage 8 + STCT_S1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate translocation from stem to grain at growth stage 1 + STCT_S2 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate translocation from stem to grain at growth stage 2 + STCT_S3 = 0.0, 0.0, 0.4, 0.4, 0.4, ! fraction of carbohydrate translocation from stem to grain at growth stage 3 + STCT_S4 = 0.0, 0.0, 0.3, 0.3, 0.3, ! fraction of carbohydrate translocation from stem to grain at growth stage 4 + STCT_S5 = 0.0, 0.0, 0.05, 0.05, 0.05, ! fraction of carbohydrate translocation from stem to grain at growth stage 5 + STCT_S6 = 0.0, 0.0, 0.05, 0.05, 0.05, ! fraction of carbohydrate translocation from stem to grain at growth stage 6 + STCT_S7 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate translocation from stem to grain at growth stage 7 + STCT_S8 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate translocation from stem to grain at growth stage 8 + RTCT_S1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate translocation from root to grain at growth stage 1 + RTCT_S2 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate translocation from root to grain at growth stage 2 + RTCT_S3 = 0.0, 0.0, 0.4, 0.4, 0.4, ! fraction of carbohydrate translocation from root to grain at growth stage 3 + RTCT_S4 = 0.0, 0.0, 0.3, 0.3, 0.3, ! fraction of carbohydrate translocation from root to grain at growth stage 4 + RTCT_S5 = 0.0, 0.0, 0.05, 0.05, 0.05, ! fraction of carbohydrate translocation from root to grain at growth stage 5 + RTCT_S6 = 0.0, 0.0, 0.05, 0.05, 0.05, ! fraction of carbohydrate translocation from root to grain at growth stage 6 + RTCT_S7 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate translocation from root to grain at growth stage 7 + RTCT_S8 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate translocation from root to grain at growth stage 8 + BIO2LAI = 0.015, 0.030, 0.015, 0.015, 0.015, ! leaf area per living leaf biomass [m2/kg] +/ + +&noahmp_tiledrain_parameters + NSOILTYPE = 19 ! num_soil_types + + !-----------------------------------! + ! For simple drainage model ! + !-----------------------------------! + DRAIN_LAYER_OPT = 4 ! soil layer which is applied by drainage + ! 0 - from one specified layer by TD_DEPTH, + ! 1 - from layers 1 & 2, + ! 2 - from layer layers 1, 2, and 3 + ! 3 - from layer 2 and 3 + ! 4 - from layer layers 3, 4 + ! 5 - from all the four layers + !-------------------------------------------------------------------------------------------------------------------------------------------------------------------- ! + ! SoilType: 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 ! + !-------------------------------------------------------------------------------------------------------------------------------------------------------------------- ! + ! TDSMC_FAC: tile drainage soil moisture factor + TDSMC_FAC = 0.90, 0.90, 0.90, 0.90, 0.90, 1.25, 0.90, 1.0, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, + ! TD_DEPTH: depth of drain tube from the soil surface + TD_DEPTH = 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, + ! TD_DC: drainage coefficient (mm/d) + TD_DC = 20.0, 20.0, 20.0, 20.0, 20.0, 20.0, 20.0, 20.0, 20.0, 20.0, 20.0, 20.0, 20.0, 20.0, 20.0, 20.0, 20.0, 20.0, 20.0, + + !-------------------------------------! + ! For Hooghoudt tile drain model ! + !-------------------------------------! + !-------------------------------------------------------------------------------------------------------------------------------------------------------------------- ! + ! SoilType: 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 ! + !-------------------------------------------------------------------------------------------------------------------------------------------------------------------- ! + ! TD_DCOEF: tile drainage coefficient (mm/d) + TD_DCOEF = 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, + ! TD_D: depth to impervious layer from drain water level [m] + TD_D = 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, + ! TD_ADEPTH: actual depth of impervious layer from land surface [m] + TD_ADEPTH = 2.00, 2.00, 2.00, 2.00, 2.00, 2.00, 2.00, 2.00, 2.00, 2.00, 2.00, 2.00, 2.00, 2.00, 2.00, 2.00, 2.00, 2.00, 2.00, + ! TD_RADI: effective radius of drain tubes [m] + TD_RADI = 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, + ! TD_SPAC: distance between two drain tubes or tiles [m] + TD_SPAC = 60.0, 55.0, 45.0, 20.0, 25.0, 30.0, 40.0, 16.0, 18.0, 50.0, 15.0, 10.0, 35.0, 10.0, 60.0, 60.0, 10.0, 60.0, 60.0, + ! TD_DDRAIN: Depth of drain [m] + TD_DDRAIN = 1.20, 1.20, 1.20, 1.20, 1.20, 1.20, 1.20, 1.20, 1.20, 1.20, 1.20, 1.20, 1.20, 1.20, 1.20, 1.20, 1.20, 1.20, 1.20, + ! KLAT_FAC: multiplication factor to lateral hydrological conductivity + KLAT_FAC = 1.30, 1.80, 2.10, 2.60, 2.90, 2.50, 2.30, 3.00, 2.70, 2.00, 3.10, 3.30, 2.50, 1.00, 1.00, 1.80, 4.00, 1.00, 1.30, +/ + +&noahmp_optional_parameters + !------------------------------------------------------------------------------ + ! Saxton and Rawls 2006 Pedo-transfer function coefficients + !------------------------------------------------------------------------------ + sr2006_theta_1500t_a = -0.024 ! sand coefficient + sr2006_theta_1500t_b = 0.487 ! clay coefficient + sr2006_theta_1500t_c = 0.006 ! orgm coefficient + sr2006_theta_1500t_d = 0.005 ! sand*orgm coefficient + sr2006_theta_1500t_e = -0.013 ! clay*orgm coefficient + sr2006_theta_1500t_f = 0.068 ! sand*clay coefficient + sr2006_theta_1500t_g = 0.031 ! constant adjustment + sr2006_theta_1500_a = 0.14 ! theta_1500t coefficient + sr2006_theta_1500_b = -0.02 ! constant adjustment + sr2006_theta_33t_a = -0.251 ! sand coefficient + sr2006_theta_33t_b = 0.195 ! clay coefficient + sr2006_theta_33t_c = 0.011 ! orgm coefficient + sr2006_theta_33t_d = 0.006 ! sand*orgm coefficient + sr2006_theta_33t_e = -0.027 ! clay*orgm coefficient + sr2006_theta_33t_f = 0.452 ! sand*clay coefficient + sr2006_theta_33t_g = 0.299 ! constant adjustment + sr2006_theta_33_a = 1.283 ! theta_33t*theta_33t coefficient + sr2006_theta_33_b = -0.374 ! theta_33t coefficient + sr2006_theta_33_c = -0.015 ! constant adjustment + sr2006_theta_s33t_a = 0.278 ! sand coefficient + sr2006_theta_s33t_b = 0.034 ! clay coefficient + sr2006_theta_s33t_c = 0.022 ! orgm coefficient + sr2006_theta_s33t_d = -0.018 ! sand*orgm coefficient + sr2006_theta_s33t_e = -0.027 ! clay*orgm coefficient + sr2006_theta_s33t_f = -0.584 ! sand*clay coefficient + sr2006_theta_s33t_g = 0.078 ! constant adjustment + sr2006_theta_s33_a = 0.636 ! theta_s33t coefficient + sr2006_theta_s33_b = -0.107 ! constant adjustment + sr2006_psi_et_a = -21.67 ! sand coefficient + sr2006_psi_et_b = -27.93 ! clay coefficient + sr2006_psi_et_c = -81.97 ! theta_s33 coefficient + sr2006_psi_et_d = 71.12 ! sand*theta_s33 coefficient + sr2006_psi_et_e = 8.29 ! clay*theta_s33 coefficient + sr2006_psi_et_f = 14.05 ! sand*clay coefficient + sr2006_psi_et_g = 27.16 ! constant adjustment + sr2006_psi_e_a = 0.02 ! psi_et*psi_et coefficient + sr2006_psi_e_b = -0.113 ! psi_et coefficient + sr2006_psi_e_c = -0.7 ! constant adjustment + sr2006_smcmax_a = -0.097 ! sand adjustment + sr2006_smcmax_b = 0.043 ! constant adjustment +/ + +&noahmp_general_parameters + !------------------------------------------------- + ! this part is originally from GENPARM.TBL + !------------------------------------------------- + SLOPE_DATA = 0.1, 0.6, 1.0, 0.35, 0.55, 0.8, 0.63, 0.0, 0.0 ! slope factor for soil drainage (9 different slope types) + CSOIL_DATA = 2.00E+6 ! Soil heat capacity [J m-3 K-1] + REFDK_DATA = 2.0E-6 ! Parameter in the surface runoff parameterization + REFKDT_DATA = 3.0 ! Parameter in the surface runoff parameterization + FRZK_DATA = 0.15 ! Frozen ground parameter + ZBOT_DATA = -8.0 ! Depth [m] of lower boundary soil temperature + CZIL_DATA = 0.1 ! Parameter used in the calculation of the roughness length for heat +/ + +&noahmp_stas_soil_categories + SLTYPE = "STAS" ! soil dataset: "STAS" or "STAS_RUC" + SLCATS = 19 ! num_soil_types +/ + +&noahmp_soil_stas_parameters + ! 19 total soil types considered by NoahMP + ! 1: SAND + ! 2: LOAMY SAND + ! 3: SANDY LOAM + ! 4: SILT LOAM + ! 5: SILT + ! 6: LOAM + ! 7: SANDY CLAY LOAM + ! 8: SILTY CLAY LOAM + ! 9: CLAY LOAM + ! 10: SANDY CLAY + ! 11: SILTY CLAY + ! 12: CLAY + ! 13: ORGANIC MATERIAL + ! 14: WATER + ! 15: BEDROCK + ! 16: OTHER(land-ice) + ! 17: PLAYA + ! 18: LAVA + ! 19: WHITE SAND + !----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- ! + ! SOIL TYPE: 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 ! + !----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- ! + ! BB: soil B parameter + BB = 2.790, 4.260, 4.740, 5.330, 3.860, 5.250, 6.770, 8.720, 8.170, 10.730, 10.390, 11.550, 5.250, 0.000, 2.790, 4.260, 11.550, 2.790, 2.790 + ! DRYSMC: dry soil moisture threshold + DRYSMC = 0.010, 0.028, 0.047, 0.084, 0.061, 0.066, 0.069, 0.120, 0.103, 0.100, 0.126, 0.138, 0.066, 0.000, 0.006, 0.028, 0.030, 0.006, 0.010 + ! MAXSMC: saturated value of soil moisture (volumetric) + MAXSMC = 0.339, 0.421, 0.434, 0.476, 0.484, 0.439, 0.404, 0.464, 0.465, 0.406, 0.468, 0.468, 0.439, 1.000, 0.200, 0.421, 0.468, 0.200, 0.339 + ! REFSMC: reference soil moisture (field capacity) (volumetric) + REFSMC = 0.192, 0.283, 0.312, 0.360, 0.347, 0.329, 0.315, 0.387, 0.382, 0.338, 0.404, 0.412, 0.329, 0.000, 0.170, 0.283, 0.454, 0.170, 0.192 + ! SATPSI: saturated soil matric potential + SATPSI = 0.069, 0.036, 0.141, 0.759, 0.955, 0.355, 0.135, 0.617, 0.263, 0.098, 0.324, 0.468, 0.355, 0.000, 0.069, 0.036, 0.468, 0.069, 0.069 + ! SATDK: saturated soil hydraulic conductivity + SATDK = 4.66E-05, 1.41E-05, 5.23E-06, 2.81E-06, 2.18E-06, 3.38E-06, 4.45E-06, 2.03E-06, 2.45E-06, 7.22E-06, 1.34E-06, 9.74E-07, 3.38E-06, 0.00E+00, 1.41E-04, 1.41E-05, 9.74E-07, 1.41E-04, 4.66E-05 + ! SATDW: saturated soil hydraulic diffusivity + SATDW = 2.65E-05, 5.14E-06, 8.05E-06, 2.39E-05, 1.66E-05, 1.43E-05, 1.01E-05, 2.35E-05, 1.13E-05, 1.87E-05, 9.64E-06, 1.12E-05, 1.43E-05, 0.00E+00, 1.36E-04, 5.14E-06, 1.12E-05, 1.36E-04, 2.65E-05 + ! WLTSMC: wilting point soil moisture (volumetric) + WLTSMC = 0.010, 0.028, 0.047, 0.084, 0.061, 0.066, 0.069, 0.120, 0.103, 0.100, 0.126, 0.138, 0.066, 0.000, 0.006, 0.028, 0.030, 0.006, 0.010 + ! QTZ: soil quartz content + QTZ = 0.920, 0.820, 0.600, 0.250, 0.100, 0.400, 0.600, 0.100, 0.350, 0.520, 0.100, 0.250, 0.050, 0.600, 0.070, 0.250, 0.600, 0.520, 0.920 + ! BVIC: VIC model infiltration parameter for VIC runoff + BVIC = 0.050, 0.080, 0.090, 0.250, 0.150, 0.180, 0.200, 0.220, 0.230, 0.250, 0.280, 0.300, 0.260, 0.000, 1.000, 1.000, 1.000, 0.350, 0.150 + ! AXAJ: Tension water distribution inflection parameter for Xinanjiang runoff + AXAJ = 0.009, 0.010, 0.009, 0.010, 0.012, 0.013, 0.014, 0.015, 0.016, 0.015, 0.016, 0.017, 0.012, 0.001, 0.017, 0.017, 0.017, 0.015, 0.009 + ! BXAJ: Tension water distribution shape parameter for Xinanjiang runoff + BXAJ = 0.050, 0.080, 0.090, 0.250, 0.150, 0.180, 0.200, 0.220, 0.230, 0.250, 0.280, 0.300, 0.260, 0.000, 1.000, 1.000, 1.000, 0.350, 0.150 + ! XXAJ: Free water distribution shape parameter for Xinanjiang runoff + XXAJ = 0.050, 0.080, 0.090, 0.250, 0.150, 0.180, 0.200, 0.220, 0.230, 0.250, 0.280, 0.300, 0.260, 0.000, 1.000, 1.000, 1.000, 0.350, 0.150 + ! BDVIC: VIC model infiltration parameter for dynamic VIC runoff + BDVIC = 0.050, 0.080, 0.090, 0.250, 0.150, 0.180, 0.200, 0.220, 0.230, 0.250, 0.280, 0.300, 0.260, 0.000, 1.000, 1.000, 1.000, 0.350, 0.150 + ! BBVIC: heterogeniety parameter for infiltration for dynamic VIC runoff + BBVIC = 1.000, 1.010, 1.020, 1.025, 1.000, 1.000, 1.032, 1.035, 1.040, 1.042, 1.045, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000 + ! GDVIC: mean capilary drive (m) for dynamic VIC runoff + GDVIC = 0.050, 0.070, 0.130, 0.200, 0.170, 0.110, 0.260, 0.350, 0.260, 0.300, 0.380, 0.410, 0.500, 0.001, 0.010, 0.001, 0.001, 0.050, 0.020 +/ + +&noahmp_soil_stas_ruc_parameters + ! 19 total soil types considered by NoahMP + ! 1: SAND + ! 2: LOAMY SAND + ! 3: SANDY LOAM + ! 4: SILT LOAM + ! 5: SILT + ! 6: LOAM + ! 7: SANDY CLAY LOAM + ! 8: SILTY CLAY LOAM + ! 9: CLAY LOAM + ! 10: SANDY CLAY + ! 11: SILTY CLAY + ! 12: CLAY + ! 13: ORGANIC MATERIAL + ! 14: WATER + ! 15: BEDROCK + ! 16: OTHER(land-ice) + ! 17: PLAYA + ! 18: LAVA + ! 19: WHITE SAND + !----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- ! + ! SOIL TYPE: 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 ! + !----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- ! + ! BB: soil B parameter + BB = 4.050, 4.380, 4.900, 5.300, 5.300, 5.390, 7.120, 7.750, 5.390, 10.400, 10.400, 11.400, 5.390, 0.000, 4.050, 4.900, 11.400, 4.050, 4.050 + ! DRYSMC: dry soil moisture threshold + DRYSMC = 0.002, 0.035, 0.041, 0.034, 0.034, 0.050, 0.068, 0.060, 0.050, 0.070, 0.070, 0.068, 0.027, 0.000, 0.004, 0.065, 0.030, 0.006, 0.010 + ! HC: not used in current Noah-MP + HC = 1.470, 1.410, 1.340, 1.270, 1.270, 1.210, 1.180, 1.320, 1.210, 1.180, 1.150, 1.090, 1.210, 4.180, 2.030, 2.100, 1.410, 1.410, 1.470 + ! MAXSMC: saturated value of soil moisture (volumetric) + MAXSMC = 0.395, 0.410, 0.435, 0.485, 0.485, 0.451, 0.420, 0.477, 0.451, 0.426, 0.492, 0.482, 0.451, 1.000, 0.200, 0.435, 0.468, 0.200, 0.339 + ! REFSMC: reference soil moisture (field capacity) (volumetric) + REFSMC = 0.174, 0.179, 0.249, 0.369, 0.369, 0.314, 0.299, 0.357, 0.314, 0.316, 0.409, 0.400, 0.314, 1.000, 0.100, 0.249, 0.454, 0.170, 0.236 + ! SATPSI: saturated soil matric potential + SATPSI = 0.121, 0.090, 0.218, 0.786, 0.786, 0.478, 0.299, 0.356, 0.478, 0.153, 0.490, 0.405, 0.478, 0.000, 0.121, 0.218, 0.468, 0.069, 0.069 + ! SATDK: saturated soil hydraulic conductivity + SATDK = 1.76E-04, 1.56E-04, 3.47E-05, 7.20E-06, 7.20E-06, 6.95E-06, 6.30E-06, 1.70E-06, 6.95E-06, 2.17E-06, 1.03E-06, 1.28E-06, 6.95E-06, 0.00E+00, 1.41E-04, 3.47E-05, 9.74E-07, 1.41E-04, 1.76E-04 + ! SATDW: saturated soil hydraulic diffusivity + SATDW = 6.08E-07, 5.14E-06, 8.05E-06, 2.39E-05, 2.39E-05, 1.43E-05, 9.90E-06, 2.37E-05, 1.43E-05, 1.87E-05, 9.64E-06, 1.12E-05, 1.43E-05, 0.00E+00, 1.36E-04, 5.14E-06, 1.12E-05, 1.36E-04, 6.08E-07 + ! WLTSMC: wilting point soil moisture (volumetric) + WLTSMC = 0.033, 0.055, 0.095, 0.143, 0.143, 0.137, 0.148, 0.170, 0.137, 0.158, 0.190, 0.198, 0.117, 0.000, 0.006, 0.114, 0.030, 0.006, 0.060 + ! QTZ: soil quartz content + QTZ = 0.920, 0.820, 0.600, 0.250, 0.100, 0.400, 0.600, 0.100, 0.400, 0.520, 0.100, 0.250, 0.050, 0.000, 0.600, 0.050, 0.600, 0.520, 0.920 + ! BVIC: VIC model infiltration parameter for VIC runoff + BVIC = 0.050, 0.080, 0.090, 0.100, 0.150, 0.180, 0.200, 0.220, 0.230, 0.250, 0.280, 0.300, 0.260, 0.000, 1.000, 1.000, 1.000, 0.350, 0.150 + ! AXAJ: Tension water distribution inflection parameter for Xinanjiang runoff + AXAJ = 0.009, 0.010, 0.009, 0.010, 0.012, 0.013, 0.014, 0.015, 0.016, 0.015, 0.016, 0.017, 0.012, 0.001, 0.017, 0.017, 0.017, 0.015, 0.009 + ! BXAJ: Tension water distribution shape parameter for Xinanjiang runoff + BXAJ = 0.050, 0.080, 0.090, 0.250, 0.150, 0.180, 0.200, 0.220, 0.230, 0.250, 0.280, 0.300, 0.260, 0.000, 1.000, 1.000, 1.000, 0.350, 0.150 + ! XXAJ: Free water distribution shape parameter for Xinanjiang runoff + XXAJ = 0.050, 0.080, 0.090, 0.250, 0.150, 0.180, 0.200, 0.220, 0.230, 0.250, 0.280, 0.300, 0.260, 0.000, 1.000, 1.000, 1.000, 0.350, 0.150 + ! BDVIC: VIC model infiltration parameter for dynamic VIC runoff + BDVIC = 0.050, 0.080, 0.090, 0.100, 0.150, 0.180, 0.200, 0.220, 0.230, 0.250, 0.280, 0.300, 0.260, 0.000, 1.000, 1.000, 1.000, 0.350, 0.150 + ! BBVIC: heterogeniety parameter for infiltration for dynamic VIC runoff + BBVIC = 1.000, 1.010, 1.020, 1.025, 1.000, 1.000, 1.032, 1.035, 1.040, 1.042, 1.045, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000 + ! GDVIC: mean capilary drive (m) for dynamic VIC runoff + GDVIC = 0.050, 0.070, 0.130, 0.200, 0.170, 0.110, 0.260, 0.350, 0.260, 0.300, 0.380, 0.410, 0.500, 0.001, 0.010, 0.001, 0.001, 0.050, 0.020 +/ diff --git a/src/core_atmosphere/physics/physics_noahmp/src/AtmosForcingMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/AtmosForcingMod.F90 new file mode 100644 index 0000000000..96a7105b12 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/AtmosForcingMod.F90 @@ -0,0 +1,182 @@ +module AtmosForcingMod + +!!! Process input atmospheric forcing variables + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine ProcessAtmosForcing(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: ATM +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local varibles + integer :: LoopInd ! loop index + integer, parameter :: LoopNum = 10 ! iterations for Twet calculation + real(kind=kind_noahmp) :: PrecipFrozenTot ! total frozen precipitation [mm/s] ! MB/AN : v3.7 + real(kind=kind_noahmp) :: RadDirFrac ! direct solar radiation fraction + real(kind=kind_noahmp) :: RadVisFrac ! visible band solar radiation fraction + real(kind=kind_noahmp) :: VapPresSat ! saturated vapor pressure of air + real(kind=kind_noahmp) :: LatHeatVap ! latent heat of vapor/sublimation + real(kind=kind_noahmp) :: PsychConst ! (cp*p)/(eps*L), psychrometric coefficient + real(kind=kind_noahmp) :: TemperatureDegC ! air temperature [C] + real(kind=kind_noahmp) :: TemperatureWetBulb ! wetbulb temperature + +! ------------------------------------------------------------------------ + associate( & + CosSolarZenithAngle => noahmp%config%domain%CosSolarZenithAngle ,& ! in, cosine solar zenith angle [0-1] + OptRainSnowPartition => noahmp%config%nmlist%OptRainSnowPartition ,& ! in, rain-snow partition physics option + PressureAirRefHeight => noahmp%forcing%PressureAirRefHeight ,& ! in, air pressure [Pa] at reference height + TemperatureAirRefHeight => noahmp%forcing%TemperatureAirRefHeight ,& ! in, air temperature [K] at reference height + SpecHumidityRefHeight => noahmp%forcing%SpecHumidityRefHeight ,& ! in, specific humidity [kg/kg] forcing at reference height + PrecipConvRefHeight => noahmp%forcing%PrecipConvRefHeight ,& ! in, convective precipitation rate [mm/s] at reference height + PrecipNonConvRefHeight => noahmp%forcing%PrecipNonConvRefHeight ,& ! in, non-convective precipitation rate [mm/s] at reference height + PrecipShConvRefHeight => noahmp%forcing%PrecipShConvRefHeight ,& ! in, shallow convective precipitation rate [mm/s] at reference height + PrecipSnowRefHeight => noahmp%forcing%PrecipSnowRefHeight ,& ! in, snowfall rate [mm/s] at reference height + PrecipGraupelRefHeight => noahmp%forcing%PrecipGraupelRefHeight ,& ! in, graupel rate [mm/s] at reference height + PrecipHailRefHeight => noahmp%forcing%PrecipHailRefHeight ,& ! in, hail rate [mm/s] at reference height + RadSwDownRefHeight => noahmp%forcing%RadSwDownRefHeight ,& ! in, downward shortwave radiation [W/m2] at reference height + WindEastwardRefHeight => noahmp%forcing%WindEastwardRefHeight ,& ! in, wind speed [m/s] in eastward direction at reference height + WindNorthwardRefHeight => noahmp%forcing%WindNorthwardRefHeight ,& ! in, wind speed [m/s] in northward direction at reference height + SnowfallDensityMax => noahmp%water%param%SnowfallDensityMax ,& ! in, maximum fresh snowfall density [kg/m3] + TemperaturePotRefHeight => noahmp%energy%state%TemperaturePotRefHeight ,& ! out, surface potential temperature [K] + PressureVaporRefHeight => noahmp%energy%state%PressureVaporRefHeight ,& ! out, vapor pressure air [Pa] at reference height + DensityAirRefHeight => noahmp%energy%state%DensityAirRefHeight ,& ! out, density air [kg/m3] + WindSpdRefHeight => noahmp%energy%state%WindSpdRefHeight ,& ! out, wind speed [m/s] at reference height + RadSwDownDir => noahmp%energy%flux%RadSwDownDir ,& ! out, incoming direct solar radiation [W/m2] + RadSwDownDif => noahmp%energy%flux%RadSwDownDif ,& ! out, incoming diffuse solar radiation [W/m2] + RainfallRefHeight => noahmp%water%flux%RainfallRefHeight ,& ! out, rainfall [mm/s] at reference height + SnowfallRefHeight => noahmp%water%flux%SnowfallRefHeight ,& ! out, liquid equivalent snowfall [mm/s] at reference height + PrecipTotRefHeight => noahmp%water%flux%PrecipTotRefHeight ,& ! out, total precipitation [mm/s] at reference height + PrecipConvTotRefHeight => noahmp%water%flux%PrecipConvTotRefHeight ,& ! out, total convective precipitation [mm/s] at reference height + PrecipLargeSclRefHeight => noahmp%water%flux%PrecipLargeSclRefHeight ,& ! out, large-scale precipitation [mm/s] at reference height + PrecipAreaFrac => noahmp%water%state%PrecipAreaFrac ,& ! out, fraction of area receiving precipitation + FrozenPrecipFrac => noahmp%water%state%FrozenPrecipFrac ,& ! out, frozen precipitation fraction + SnowfallDensity => noahmp%water%state%SnowfallDensity & ! out, bulk density of snowfall [kg/m3] + ) +! ------------------------------------------------------------------------ + + ! surface air variables + TemperaturePotRefHeight = TemperatureAirRefHeight * & + (PressureAirRefHeight / PressureAirRefHeight) ** (ConstGasDryAir / ConstHeatCapacAir) + PressureVaporRefHeight = SpecHumidityRefHeight * PressureAirRefHeight / (0.622 + 0.378*SpecHumidityRefHeight) + DensityAirRefHeight = (PressureAirRefHeight - 0.378*PressureVaporRefHeight) / & + (ConstGasDryAir * TemperatureAirRefHeight) + + ! downward solar radiation + RadDirFrac = 0.7 + RadVisFrac = 0.5 + if ( CosSolarZenithAngle <= 0.0 ) RadSwDownRefHeight = 0.0 ! filter by solar zenith angle + RadSwDownDir(1) = RadSwDownRefHeight * RadDirFrac * RadVisFrac ! direct vis + RadSwDownDir(2) = RadSwDownRefHeight * RadDirFrac * (1.0-RadVisFrac) ! direct nir + RadSwDownDif(1) = RadSwDownRefHeight * (1.0-RadDirFrac) * RadVisFrac ! diffuse vis + RadSwDownDif(2) = RadSwDownRefHeight * (1.0-RadDirFrac) * (1.0-RadVisFrac) ! diffuse nir + + ! precipitation + PrecipTotRefHeight = PrecipConvRefHeight + PrecipNonConvRefHeight + PrecipShConvRefHeight + if ( OptRainSnowPartition == 4 ) then + PrecipConvTotRefHeight = PrecipConvRefHeight + PrecipShConvRefHeight + PrecipLargeSclRefHeight = PrecipNonConvRefHeight + else + PrecipConvTotRefHeight = 0.10 * PrecipTotRefHeight + PrecipLargeSclRefHeight = 0.90 * PrecipTotRefHeight + endif + + ! fractional area that receives precipitation (see, Niu et al. 2005) + PrecipAreaFrac = 0.0 + if ( (PrecipConvTotRefHeight+PrecipLargeSclRefHeight) > 0.0 ) then + PrecipAreaFrac = (PrecipConvTotRefHeight + PrecipLargeSclRefHeight) / & + (10.0*PrecipConvTotRefHeight + PrecipLargeSclRefHeight) + endif + + ! partition precipitation into rain and snow. Moved from CANWAT MB/AN: v3.7 + ! Jordan (1991) + if ( OptRainSnowPartition == 1 ) then + if ( TemperatureAirRefHeight > (ConstFreezePoint+2.5) ) then + FrozenPrecipFrac = 0.0 + else + if ( TemperatureAirRefHeight <= (ConstFreezePoint+0.5) ) then + FrozenPrecipFrac = 1.0 + elseif ( TemperatureAirRefHeight <= (ConstFreezePoint+2.0) ) then + FrozenPrecipFrac = 1.0 - (-54.632 + 0.2*TemperatureAirRefHeight) + else + FrozenPrecipFrac = 0.6 + endif + endif + endif + + ! BATS scheme + if ( OptRainSnowPartition == 2 ) then + if ( TemperatureAirRefHeight >= (ConstFreezePoint+2.2) ) then + FrozenPrecipFrac = 0.0 + else + FrozenPrecipFrac = 1.0 + endif + endif + + ! Simple temperature scheme + if ( OptRainSnowPartition == 3 ) then + if ( TemperatureAirRefHeight >= ConstFreezePoint ) then + FrozenPrecipFrac = 0.0 + else + FrozenPrecipFrac = 1.0 + endif + endif + + ! Use WRF microphysics output + ! Hedstrom NR and JW Pomeroy (1998), Hydrol. Processes, 12, 1611-1625 + SnowfallDensity = min( SnowfallDensityMax, 67.92+51.25*exp((TemperatureAirRefHeight-ConstFreezePoint)/2.59) ) ! fresh snow density !MB/AN: change to MIN + if ( OptRainSnowPartition == 4 ) then + PrecipFrozenTot = PrecipSnowRefHeight + PrecipGraupelRefHeight + PrecipHailRefHeight + if ( (PrecipNonConvRefHeight > 0.0) .and. (PrecipFrozenTot > 0.0) ) then + FrozenPrecipFrac = min( 1.0, PrecipFrozenTot/PrecipNonConvRefHeight ) + FrozenPrecipFrac = max( 0.0, FrozenPrecipFrac ) + SnowfallDensity = SnowfallDensity * (PrecipSnowRefHeight/PrecipFrozenTot) + & + ConstDensityGraupel * (PrecipGraupelRefHeight/PrecipFrozenTot) + & + ConstDensityHail * (PrecipHailRefHeight/PrecipFrozenTot) + else + FrozenPrecipFrac = 0.0 + endif + endif + + ! wet-bulb scheme (Wang et al., 2019 GRL), C.He, 12/18/2020 + if ( OptRainSnowPartition == 5 ) then + TemperatureDegC = min( 50.0, max(-50.0,(TemperatureAirRefHeight-ConstFreezePoint)) ) ! Kelvin to degree Celsius with limit -50 to +50 + if ( TemperatureAirRefHeight > ConstFreezePoint ) then + LatHeatVap = ConstLatHeatEvap + else + LatHeatVap = ConstLatHeatSublim + endif + PsychConst = ConstHeatCapacAir * PressureAirRefHeight / (0.622 * LatHeatVap) + TemperatureWetBulb = TemperatureDegC - 5.0 ! first guess wetbulb temperature + do LoopInd = 1, LoopNum + VapPresSat = 610.8 * exp( (17.27*TemperatureWetBulb) / (237.3+TemperatureWetBulb) ) + TemperatureWetBulb = TemperatureWetBulb - (VapPresSat - PressureVaporRefHeight) / PsychConst ! Wang et al., 2019 GRL Eq.2 + enddo + FrozenPrecipFrac = 1.0 / (1.0 + 6.99e-5 * exp(2.0*(TemperatureWetBulb+3.97))) ! Wang et al., 2019 GRL Eq. 1 + endif + + ! rain-snow partitioning + RainfallRefHeight = PrecipTotRefHeight * (1.0 - FrozenPrecipFrac) + SnowfallRefHeight = PrecipTotRefHeight * FrozenPrecipFrac + + ! wind speed at reference height for turbulence calculation + WindSpdRefHeight = max(sqrt(WindEastwardRefHeight**2.0 + WindNorthwardRefHeight**2.0), 1.0) + + end associate + + end subroutine ProcessAtmosForcing + +end module AtmosForcingMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/BalanceErrorCheckGlacierMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/BalanceErrorCheckGlacierMod.F90 new file mode 100644 index 0000000000..7b5e839130 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/BalanceErrorCheckGlacierMod.F90 @@ -0,0 +1,163 @@ +module BalanceErrorCheckGlacierMod + +!!! Check glacier water and energy balance and report error + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + +!!!! Water balance check initialization + subroutine BalanceWaterInitGlacier(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: None (embedded in NOAHMP_GLACIER) +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! -------------------------------------------------------------------- + associate( & + SnowWaterEquiv => noahmp%water%state%SnowWaterEquiv ,& ! in, snow water equivalent [mm] + WaterStorageTotBeg => noahmp%water%state%WaterStorageTotBeg & ! out, total water storage [mm] at the beginning + ) +! ---------------------------------------------------------------------- + + ! compute total glacier water storage before NoahMP processes + ! need more work on including glacier ice mass underneath snow + WaterStorageTotBeg = SnowWaterEquiv + + end associate + + end subroutine BalanceWaterInitGlacier + + +!!!! Water balance check and report error + subroutine BalanceWaterCheckGlacier(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: ERROR_GLACIER +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! -------------------------------------------------------------------- + associate( & + GridIndexI => noahmp%config%domain%GridIndexI ,& ! in, grid index in x-direction + GridIndexJ => noahmp%config%domain%GridIndexJ ,& ! in, grid index in y-direction + MainTimeStep => noahmp%config%domain%MainTimeStep ,& ! in, main noahmp timestep [s] + SnowWaterEquiv => noahmp%water%state%SnowWaterEquiv ,& ! in, snow water equivalent [mm] + WaterStorageTotBeg => noahmp%water%state%WaterStorageTotBeg ,& ! in, total water storage [mm] at the beginning + PrecipTotRefHeight => noahmp%water%flux%PrecipTotRefHeight ,& ! in, total precipitation [mm/s] at reference height + EvapGroundNet => noahmp%water%flux%EvapGroundNet ,& ! in, net ground evaporation [mm/s] + RunoffSurface => noahmp%water%flux%RunoffSurface ,& ! in, surface runoff [mm/s] + RunoffSubsurface => noahmp%water%flux%RunoffSubsurface ,& ! in, subsurface runoff [mm/s] + WaterStorageTotEnd => noahmp%water%state%WaterStorageTotEnd ,& ! out, total water storage [mm] at the end + WaterBalanceError => noahmp%water%state%WaterBalanceError & ! out, water balance error [mm] per time step + ) +! ---------------------------------------------------------------------- + + ! Error in water balance should be < 0.1 mm + ! compute total glacier water storage before NoahMP processes + ! need more work on including glacier ice mass underneath snow + WaterStorageTotEnd = SnowWaterEquiv + WaterBalanceError = WaterStorageTotEnd - WaterStorageTotBeg - & + (PrecipTotRefHeight - EvapGroundNet - RunoffSurface - RunoffSubsurface) * MainTimeStep + +#ifndef WRF_HYDRO + if ( abs(WaterBalanceError) > 0.1 ) then + if ( WaterBalanceError > 0) then + write(*,*) "The model is gaining water (WaterBalanceError is positive)" + else + write(*,*) "The model is losing water (WaterBalanceError is negative)" + endif + write(*,*) "WaterBalanceError = ",WaterBalanceError, "kg m{-2} timestep{-1}" + write(*, & + '(" GridIndexI GridIndexJ WaterStorageTotEnd WaterStorageTotBeg PrecipTotRefHeight & + EvapGroundNet RunoffSurface RunoffSubsurface")') + write(*,'(i6,1x,i6,1x,2f15.3,9f11.5)') GridIndexI, GridIndexJ, WaterStorageTotEnd, WaterStorageTotBeg, & + PrecipTotRefHeight*MainTimeStep, EvapGroundNet*MainTimeStep, & + RunoffSurface*MainTimeStep, RunoffSubsurface*MainTimeStep + stop "Error: Water budget problem in NoahMP LSM" + endif +#endif + + end associate + + end subroutine BalanceWaterCheckGlacier + + +!!!! Energy balance check and error report + subroutine BalanceEnergyCheckGlacier(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: ERROR_GLACIER +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! -------------------------------------------------------------------- + associate( & + GridIndexI => noahmp%config%domain%GridIndexI ,& ! in, grid index in x-direction + GridIndexJ => noahmp%config%domain%GridIndexJ ,& ! in, grid index in y-direction + RadSwDownRefHeight => noahmp%forcing%RadSwDownRefHeight ,& ! in, downward shortwave radiation [W/m2] at reference height + RadSwAbsSfc => noahmp%energy%flux%RadSwAbsSfc ,& ! in, total absorbed solar radiation [W/m2] + RadSwReflSfc => noahmp%energy%flux%RadSwReflSfc ,& ! in, total reflected solar radiation [W/m2] + RadLwNetSfc => noahmp%energy%flux%RadLwNetSfc ,& ! in, total net longwave rad [W/m2] (+ to atm) + HeatSensibleSfc => noahmp%energy%flux%HeatSensibleSfc ,& ! in, total sensible heat [W/m2] (+ to atm) + HeatLatentGrd => noahmp%energy%flux%HeatLatentGrd ,& ! in, total ground latent heat [W/m2] (+ to atm) + HeatGroundTot => noahmp%energy%flux%HeatGroundTot ,& ! in, total ground heat flux [W/m2] (+ to soil/snow) + RadSwAbsGrd => noahmp%energy%flux%RadSwAbsGrd ,& ! in, solar radiation absorbed by ground [W/m2] + HeatPrecipAdvSfc => noahmp%energy%flux%HeatPrecipAdvSfc ,& ! in, precipitation advected heat - total [W/m2] + EnergyBalanceError => noahmp%energy%state%EnergyBalanceError ,& ! out, error in surface energy balance [W/m2] + RadSwBalanceError => noahmp%energy%state%RadSwBalanceError & ! out, error in shortwave radiation balance [W/m2] + ) +! ---------------------------------------------------------------------- + + ! error in shortwave radiation balance should be <0.01 W/m2 + RadSwBalanceError = RadSwDownRefHeight - (RadSwAbsSfc + RadSwReflSfc) + ! print out diagnostics when error is large + if ( abs(RadSwBalanceError) > 0.01 ) then + write(*,*) "GridIndexI, GridIndexJ = ", GridIndexI, GridIndexJ + write(*,*) "RadSwBalanceError = ", RadSwBalanceError + write(*,*) "RadSwDownRefHeight = ", RadSwDownRefHeight + write(*,*) "RadSwReflSfc = ", RadSwReflSfc + write(*,*) "RadSwAbsGrd = ", RadSwAbsGrd + write(*,*) "RadSwAbsSfc = ", RadSwAbsSfc + stop "Error: Solar radiation budget problem in NoahMP LSM" + endif + + ! error in surface energy balance should be <0.01 W/m2 + EnergyBalanceError = RadSwAbsGrd + HeatPrecipAdvSfc - (RadLwNetSfc + HeatSensibleSfc + HeatLatentGrd + HeatGroundTot) + ! print out diagnostics when error is large + if ( abs(EnergyBalanceError) > 0.01 ) then + write(*,*) 'EnergyBalanceError = ', EnergyBalanceError, ' at GridIndexI,GridIndexJ: ', GridIndexI, GridIndexJ + write(*,'(a17,F10.4)' ) "Net longwave: ", RadLwNetSfc + write(*,'(a17,F10.4)' ) "Total sensible: ", HeatSensibleSfc + write(*,'(a17,F10.4)' ) "Ground evap: ", HeatLatentGrd + write(*,'(a17,F10.4)' ) "Total ground: ", HeatGroundTot + write(*,'(a17,4F10.4)') "Precip advected: ", HeatPrecipAdvSfc + write(*,'(a17,F10.4)' ) "absorbed shortwave: ", RadSwAbsGrd + stop "Error: Surface energy budget problem in NoahMP LSM" + endif + + end associate + + end subroutine BalanceEnergyCheckGlacier + +end module BalanceErrorCheckGlacierMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/BalanceErrorCheckMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/BalanceErrorCheckMod.F90 new file mode 100644 index 0000000000..f076e2a5e5 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/BalanceErrorCheckMod.F90 @@ -0,0 +1,255 @@ +module BalanceErrorCheckMod + +!!! Check water and energy balance and report error + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + +!!!! Water balance check initialization + subroutine BalanceWaterInit(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: None (embedded in NOAHMP_SFLX) +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: LoopInd ! loop index + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + SurfaceType => noahmp%config%domain%SurfaceType ,& ! in, surface type 1-soil; 2-lake + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! in, thickness of snow/soil layers [m] + CanopyLiqWater => noahmp%water%state%CanopyLiqWater ,& ! in, canopy intercepted liquid water [mm] + CanopyIce => noahmp%water%state%CanopyIce ,& ! in, canopy intercepted ice [mm] + SnowWaterEquiv => noahmp%water%state%SnowWaterEquiv ,& ! in, snow water equivalent [mm] + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! in, total soil moisture [m3/m3] + WaterStorageAquifer => noahmp%water%state%WaterStorageAquifer ,& ! in, water storage in aquifer [mm] + WaterStorageTotBeg => noahmp%water%state%WaterStorageTotBeg & ! out, total water storage [mm] at the beginning + ) +! ---------------------------------------------------------------------- + + ! compute total water storage before NoahMP processes + if ( SurfaceType == 1 ) then ! soil + WaterStorageTotBeg = CanopyLiqWater + CanopyIce + SnowWaterEquiv + WaterStorageAquifer + do LoopInd = 1, NumSoilLayer + WaterStorageTotBeg = WaterStorageTotBeg + SoilMoisture(LoopInd) * ThicknessSnowSoilLayer(LoopInd) * 1000.0 + enddo + endif + + end associate + + end subroutine BalanceWaterInit + + +!!!! Water balance check and report error + subroutine BalanceWaterCheck(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: ERROR +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: LoopInd ! loop index + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + SurfaceType => noahmp%config%domain%SurfaceType ,& ! in, surface type 1-soil; 2-lake + GridIndexI => noahmp%config%domain%GridIndexI ,& ! in, grid index in x-direction + GridIndexJ => noahmp%config%domain%GridIndexJ ,& ! in, grid index in y-direction + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! in, thickness of snow/soil layers [m] + MainTimeStep => noahmp%config%domain%MainTimeStep ,& ! in, main noahmp timestep [s] + FlagCropland => noahmp%config%domain%FlagCropland ,& ! in, flag to identify croplands + FlagSoilProcess => noahmp%config%domain%FlagSoilProcess ,& ! in, flag to calculate soil process + IrriFracThreshold => noahmp%water%param%IrriFracThreshold ,& ! in, irrigation fraction parameter + IrrigationFracGrid => noahmp%water%state%IrrigationFracGrid ,& ! in, total input irrigation fraction + WaterTableDepth => noahmp%water%state%WaterTableDepth ,& ! in, water table depth [m] + CanopyLiqWater => noahmp%water%state%CanopyLiqWater ,& ! in, canopy intercepted liquid water [mm] + CanopyIce => noahmp%water%state%CanopyIce ,& ! in, canopy intercepted ice [mm] + SnowWaterEquiv => noahmp%water%state%SnowWaterEquiv ,& ! in, snow water equivalent [mm] + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! in, total soil moisture [m3/m3] + WaterStorageAquifer => noahmp%water%state%WaterStorageAquifer ,& ! in, water storage in aquifer [mm] + WaterStorageTotBeg => noahmp%water%state%WaterStorageTotBeg ,& ! in, total water storage [mm] at the beginning + PrecipTotRefHeight => noahmp%water%flux%PrecipTotRefHeight ,& ! in, total precipitation [mm/s] at reference height + EvapCanopyNet => noahmp%water%flux%EvapCanopyNet ,& ! in, evaporation of intercepted water [mm/s] + Transpiration => noahmp%water%flux%Transpiration ,& ! in, transpiration rate [mm/s] + EvapGroundNet => noahmp%water%flux%EvapGroundNet ,& ! in, net ground (soil/snow) evaporation [mm/s] + RunoffSurface => noahmp%water%flux%RunoffSurface ,& ! in, surface runoff [mm/dt_soil] per soil timestep + RunoffSubsurface => noahmp%water%flux%RunoffSubsurface ,& ! in, subsurface runoff [mm/dt_soil] per soil timestep + TileDrain => noahmp%water%flux%TileDrain ,& ! in, tile drainage [mm/dt_soil] per soil timestep + IrrigationRateSprinkler => noahmp%water%flux%IrrigationRateSprinkler ,& ! in, rate of irrigation by sprinkler [m/timestep] + IrrigationRateMicro => noahmp%water%flux%IrrigationRateMicro ,& ! in, micro irrigation water rate [m/timestep] + IrrigationRateFlood => noahmp%water%flux%IrrigationRateFlood ,& ! in, flood irrigation water rate [m/timestep] + SfcWaterTotChgAcc => noahmp%water%flux%SfcWaterTotChgAcc ,& ! inout, accumulated snow,soil,canopy water change per soil timestep [mm] + PrecipTotAcc => noahmp%water%flux%PrecipTotAcc ,& ! inout, accumulated precipitation per soil timestep [mm] + EvapCanopyNetAcc => noahmp%water%flux%EvapCanopyNetAcc ,& ! inout, accumulated net canopy evaporation per soil timestep [mm] + TranspirationAcc => noahmp%water%flux%TranspirationAcc ,& ! inout, accumulated transpiration per soil timestep [mm] + EvapGroundNetAcc => noahmp%water%flux%EvapGroundNetAcc ,& ! inout, accumulated net ground evaporation per soil timestep [mm] + WaterStorageTotEnd => noahmp%water%state%WaterStorageTotEnd ,& ! out, total water storage [mm] at the end + WaterBalanceError => noahmp%water%state%WaterBalanceError & ! out, water balance error [mm] per time step + ) +! ---------------------------------------------------------------------- + + ! before water balance check, add irrigation water to precipitation + if ( (FlagCropland .eqv. .true.) .and. (IrrigationFracGrid >= IrriFracThreshold) ) then + PrecipTotRefHeight = PrecipTotRefHeight + IrrigationRateSprinkler * 1000.0 / MainTimeStep ! irrigation + endif + + ! only water balance check for every soil timestep + ! Error in water balance should be < 0.1 mm + if ( SurfaceType == 1 ) then ! soil + WaterStorageTotEnd = CanopyLiqWater + CanopyIce + SnowWaterEquiv + WaterStorageAquifer + do LoopInd = 1, NumSoilLayer + WaterStorageTotEnd = WaterStorageTotEnd + SoilMoisture(LoopInd) * ThicknessSnowSoilLayer(LoopInd) * 1000.0 + enddo + ! accumualted water change (only for canopy and snow during non-soil timestep) + SfcWaterTotChgAcc = SfcWaterTotChgAcc + (WaterStorageTotEnd - WaterStorageTotBeg) ! snow, canopy, and soil water change + PrecipTotAcc = PrecipTotAcc + PrecipTotRefHeight * MainTimeStep ! accumulated precip + EvapCanopyNetAcc = EvapCanopyNetAcc + EvapCanopyNet * MainTimeStep ! accumulated canopy evapo + TranspirationAcc = TranspirationAcc + Transpiration * MainTimeStep ! accumulated transpiration + EvapGroundNetAcc = EvapGroundNetAcc + EvapGroundNet * MainTimeStep ! accumulated soil evapo + + ! check water balance at soil timestep + if ( FlagSoilProcess .eqv. .true. ) then + WaterBalanceError = SfcWaterTotChgAcc - (PrecipTotAcc + IrrigationRateMicro*1000.0 + IrrigationRateFlood*1000.0 - & + EvapCanopyNetAcc - TranspirationAcc - EvapGroundNetAcc - RunoffSurface - RunoffSubsurface - & + TileDrain) +#ifndef WRF_HYDRO + if ( abs(WaterBalanceError) > 0.1 ) then + if ( WaterBalanceError > 0 ) then + write(*,*) "The model is gaining water (WaterBalanceError is positive)" + else + write(*,*) "The model is losing water (WaterBalanceError is negative)" + endif + write(*,*) 'WaterBalanceError = ',WaterBalanceError, "kg m{-2} timestep{-1}" + write(*, & + '(" GridIndexI GridIndexJ SfcWaterTotChgAcc PrecipTotRefHeightAcc IrrigationRateMicro & + IrrigationRateFlood EvapCanopyNetAcc EvapGroundNetAcc TranspirationAcc RunoffSurface & + RunoffSubsurface WaterTableDepth TileDrain")') + write(*,'(i6,i6,f10.3,10f10.5)') GridIndexI, GridIndexJ, SfcWaterTotChgAcc, PrecipTotAcc, & + IrrigationRateMicro*1000.0, IrrigationRateFlood*1000.0, & + EvapCanopyNetAcc, EvapGroundNetAcc, TranspirationAcc, RunoffSurface, & + RunoffSubsurface, WaterTableDepth, TileDrain + stop "Error: Water budget problem in NoahMP LSM" + endif +#endif + endif ! FlagSoilProcess + + else ! water point + WaterBalanceError = 0.0 + endif + + end associate + + end subroutine BalanceWaterCheck + + +!!!! Energy balance check and error report + subroutine BalanceEnergyCheck(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: ERROR +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! -------------------------------------------------------------------- + associate( & + GridIndexI => noahmp%config%domain%GridIndexI ,& ! in, grid index in x-direction + GridIndexJ => noahmp%config%domain%GridIndexJ ,& ! in, grid index in y-direction + RadSwDownRefHeight => noahmp%forcing%RadSwDownRefHeight ,& ! in, downward shortwave radiation [W/m2] at reference height + VegFrac => noahmp%energy%state%VegFrac ,& ! in, greeness vegetation fraction + RadSwAbsSfc => noahmp%energy%flux%RadSwAbsSfc ,& ! in, total absorbed solar radiation [W/m2] + RadSwReflSfc => noahmp%energy%flux%RadSwReflSfc ,& ! in, total reflected solar radiation [W/m2] + RadSwReflVeg => noahmp%energy%flux%RadSwReflVeg ,& ! in, reflected solar radiation by vegetation [W/m2] + RadSwReflGrd => noahmp%energy%flux%RadSwReflGrd ,& ! in, reflected solar radiation by ground [W/m2] + RadLwNetSfc => noahmp%energy%flux%RadLwNetSfc ,& ! in, total net longwave rad [W/m2] (+ to atm) + HeatSensibleSfc => noahmp%energy%flux%HeatSensibleSfc ,& ! in, total sensible heat [W/m2] (+ to atm) + HeatLatentCanopy => noahmp%energy%flux%HeatLatentCanopy ,& ! in, canopy latent heat flux [W/m2] (+ to atm) + HeatLatentGrd => noahmp%energy%flux%HeatLatentGrd ,& ! in, total ground latent heat [W/m2] (+ to atm) + HeatLatentTransp => noahmp%energy%flux%HeatLatentTransp ,& ! in, latent heat flux from transpiration [W/m2] (+ to atm) + HeatGroundTot => noahmp%energy%flux%HeatGroundTot ,& ! in, total ground heat flux [W/m2] (+ to soil/snow) + RadSwAbsVeg => noahmp%energy%flux%RadSwAbsVeg ,& ! in, solar radiation absorbed by vegetation [W/m2] + RadSwAbsGrd => noahmp%energy%flux%RadSwAbsGrd ,& ! in, solar radiation absorbed by ground [W/m2] + HeatPrecipAdvSfc => noahmp%energy%flux%HeatPrecipAdvSfc ,& ! in, precipitation advected heat - total [W/m2] + HeatPrecipAdvBareGrd => noahmp%energy%flux%HeatPrecipAdvBareGrd ,& ! in, precipitation advected heat - bare ground net [W/m2] + HeatPrecipAdvVegGrd => noahmp%energy%flux%HeatPrecipAdvVegGrd ,& ! in, precipitation advected heat - under canopy net [W/m2] + HeatPrecipAdvCanopy => noahmp%energy%flux%HeatPrecipAdvCanopy ,& ! in, precipitation advected heat - vegetation net [W/m2] + HeatLatentIrriEvap => noahmp%energy%flux%HeatLatentIrriEvap ,& ! in, latent heating due to sprinkler evaporation [W/m2] + HeatCanStorageChg => noahmp%energy%flux%HeatCanStorageChg ,& ! in, canopy heat storage change [W/m2] + EnergyBalanceError => noahmp%energy%state%EnergyBalanceError ,& ! out, error in surface energy balance [W/m2] + RadSwBalanceError => noahmp%energy%state%RadSwBalanceError & ! out, error in shortwave radiation balance [W/m2] + ) +! ---------------------------------------------------------------------- + + ! error in shortwave radiation balance should be <0.01 W/m2 + RadSwBalanceError = RadSwDownRefHeight - (RadSwAbsSfc + RadSwReflSfc) + ! print out diagnostics when error is large + if ( abs(RadSwBalanceError) > 0.01 ) then + write(*,*) "GridIndexI, GridIndexJ = ", GridIndexI, GridIndexJ + write(*,*) "RadSwBalanceError = ", RadSwBalanceError + write(*,*) "VEGETATION ---------" + write(*,*) "RadSwDownRefHeight * VegFrac = ", RadSwDownRefHeight*VegFrac + write(*,*) "VegFrac*RadSwAbsVeg + RadSwAbsGrd = ", VegFrac*RadSwAbsVeg+RadSwAbsGrd + write(*,*) "VegFrac*RadSwReflVeg + RadSwReflGrd = ", VegFrac*RadSwReflVeg+RadSwReflGrd + write(*,*) "GROUND -------" + write(*,*) "(1 - VegFrac) * RadSwDownRefHeight = ", (1.0-VegFrac)*RadSwDownRefHeight + write(*,*) "(1 - VegFrac) * RadSwAbsGrd = ", (1.0-VegFrac)*RadSwAbsGrd + write(*,*) "(1 - VegFrac) * RadSwReflGrd = ", (1.0-VegFrac)*RadSwReflGrd + write(*,*) "RadSwReflVeg = ", RadSwReflVeg + write(*,*) "RadSwReflGrd = ", RadSwReflGrd + write(*,*) "RadSwReflSfc = ", RadSwReflSfc + write(*,*) "RadSwAbsVeg = ", RadSwAbsVeg + write(*,*) "RadSwAbsGrd = ", RadSwAbsGrd + write(*,*) "RadSwAbsSfc = ", RadSwAbsSfc + stop "Error: Solar radiation budget problem in NoahMP LSM" + endif + + ! error in surface energy balance should be <0.01 W/m2 + EnergyBalanceError = RadSwAbsVeg + RadSwAbsGrd + HeatPrecipAdvSfc - & + (RadLwNetSfc + HeatSensibleSfc + HeatLatentCanopy + HeatLatentGrd + & + HeatLatentTransp + HeatGroundTot + HeatLatentIrriEvap + HeatCanStorageChg) + ! print out diagnostics when error is large + if ( abs(EnergyBalanceError) > 0.01 ) then + write(*,*) 'EnergyBalanceError = ', EnergyBalanceError, ' at GridIndexI,GridIndexJ: ', GridIndexI, GridIndexJ + write(*,'(a17,F10.4)' ) "Net solar: ", RadSwAbsSfc + write(*,'(a17,F10.4)' ) "Net longwave: ", RadLwNetSfc + write(*,'(a17,F10.4)' ) "Total sensible: ", HeatSensibleSfc + write(*,'(a17,F10.4)' ) "Canopy evap: ", HeatLatentCanopy + write(*,'(a17,F10.4)' ) "Ground evap: ", HeatLatentGrd + write(*,'(a17,F10.4)' ) "Transpiration: ", HeatLatentTransp + write(*,'(a17,F10.4)' ) "Total ground: ", HeatGroundTot + write(*,'(a17,F10.4)' ) "Sprinkler: ", HeatLatentIrriEvap + write(*,'(a17,F10.4)' ) "Canopy heat storage change: ", HeatCanStorageChg + write(*,'(a17,4F10.4)') "Precip advected: ", HeatPrecipAdvSfc,HeatPrecipAdvCanopy,HeatPrecipAdvVegGrd,HeatPrecipAdvBareGrd + write(*,'(a17,F10.4)' ) "Veg fraction: ", VegFrac + stop "Error: Energy budget problem in NoahMP LSM" + endif + + end associate + + end subroutine BalanceEnergyCheck + +end module BalanceErrorCheckMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/BiochemCropMainMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/BiochemCropMainMod.F90 new file mode 100644 index 0000000000..c0afe27ea7 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/BiochemCropMainMod.F90 @@ -0,0 +1,115 @@ +module BiochemCropMainMod + +!!! Main Biogeochemistry module for dynamic crop (as opposed to natural vegetation) +!!! currently only include carbon processes (RE Dickinson et al.(1998) and Liu et al., 2014)) + + use Machine + use NoahmpVarType + use ConstantDefineMod + use CarbonFluxCropMod, only : CarbonFluxCrop + use CropGrowDegreeDayMod, only : CropGrowDegreeDay + use CropPhotosynthesisMod, only : CropPhotosynthesis + + implicit none + +contains + + subroutine BiochemCropMain(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: CARBON_CROP +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Modified by Xing Liu, 2014 +! Refactered code: C. He, P. Valayamkunnath & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variables + integer :: LoopInd ! loop index + +!------------------------------------------------------------------------- + associate( & + VegType => noahmp%config%domain%VegType ,& ! in, vegetation type + DepthSoilLayer => noahmp%config%domain%DepthSoilLayer ,& ! in, depth [m] of layer-bottom from soil surface + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! in, snow/soil layer thickness [m] + IndexWaterPoint => noahmp%config%domain%IndexWaterPoint ,& ! in, water point flag + IndexIcePoint => noahmp%config%domain%IndexIcePoint ,& ! in, land ice flag + IndexBarrenPoint => noahmp%config%domain%IndexBarrenPoint ,& ! in, bare soil flag + FlagUrban => noahmp%config%domain%FlagUrban ,& ! in, urban point flag + NumSoilLayerRoot => noahmp%water%param%NumSoilLayerRoot ,& ! in, number of soil layers with root present + SoilMoistureSat => noahmp%water%param%SoilMoistureSat ,& ! in, saturated value of soil moisture [m3/m3] + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! in, soil moisture (ice + liq.) [m3/m3] + SoilTranspFacAcc => noahmp%water%state%SoilTranspFacAcc ,& ! in, accumulated soil water transpiration factor (0 to 1) + LeafMass => noahmp%biochem%state%LeafMass ,& ! inout, leaf mass [g/m2] + RootMass => noahmp%biochem%state%RootMass ,& ! inout, mass of fine roots [g/m2] + StemMass => noahmp%biochem%state%StemMass ,& ! inout, stem mass [g/m2] + WoodMass => noahmp%biochem%state%WoodMass ,& ! inout, mass of wood (incl. woody roots) [g/m2] + CarbonMassDeepSoil => noahmp%biochem%state%CarbonMassDeepSoil ,& ! inout, stable carbon in deep soil [g/m2] + CarbonMassShallowSoil => noahmp%biochem%state%CarbonMassShallowSoil ,& ! inout, short-lived carbon in shallow soil [g/m2] + LeafAreaIndex => noahmp%energy%state%LeafAreaIndex ,& ! inout, leaf area index + StemAreaIndex => noahmp%energy%state%StemAreaIndex ,& ! inout, stem area index + GrossPriProduction => noahmp%biochem%flux%GrossPriProduction ,& ! out, net instantaneous assimilation [g/m2/s C] + NetPriProductionTot => noahmp%biochem%flux%NetPriProductionTot ,& ! out, net primary productivity [g/m2/s C] + NetEcoExchange => noahmp%biochem%flux%NetEcoExchange ,& ! out, net ecosystem exchange [g/m2/s CO2] + RespirationPlantTot => noahmp%biochem%flux%RespirationPlantTot ,& ! out, total plant respiration [g/m2/s C] + RespirationSoilOrg => noahmp%biochem%flux%RespirationSoilOrg ,& ! out, soil organic respiration [g/m2/s C] + CarbonMassSoilTot => noahmp%biochem%state%CarbonMassSoilTot ,& ! out, total soil carbon [g/m2 C] + CarbonMassLiveTot => noahmp%biochem%state%CarbonMassLiveTot ,& ! out, total living carbon ([g/m2 C] + GrainMass => noahmp%biochem%state%GrainMass ,& ! out, mass of grain [g/m2] + SoilWaterRootZone => noahmp%water%state%SoilWaterRootZone ,& ! out, root zone soil water + SoilWaterStress => noahmp%water%state%SoilWaterStress & ! out, water stress coeficient (1.0 for wilting) + ) +!------------------------------------------------------------------------ + + ! initialize + NetEcoExchange = 0.0 + NetPriProductionTot = 0.0 + GrossPriProduction = 0.0 + + ! no biogeochemistry in non-vegetated points + if ( (VegType == IndexWaterPoint) .or. (VegType == IndexBarrenPoint) .or. & + (VegType == IndexIcePoint ) .or. (FlagUrban .eqv. .true.) ) then + LeafAreaIndex = 0.0 + StemAreaIndex = 0.0 + GrossPriProduction = 0.0 + NetPriProductionTot = 0.0 + NetEcoExchange = 0.0 + RespirationPlantTot = 0.0 + RespirationSoilOrg = 0.0 + CarbonMassSoilTot = 0.0 + CarbonMassLiveTot = 0.0 + LeafMass = 0.0 + RootMass = 0.0 + StemMass = 0.0 + WoodMass = 0.0 + CarbonMassDeepSoil = 0.0 + CarbonMassShallowSoil = 0.0 + GrainMass = 0.0 + return + endif + + ! start biogeochemistry process + ! water stress + SoilWaterStress = 1.0 - SoilTranspFacAcc + SoilWaterRootZone = 0.0 + do LoopInd = 1, NumSoilLayerRoot + SoilWaterRootZone = SoilWaterRootZone + SoilMoisture(LoopInd) / SoilMoistureSat(LoopInd) * & + ThicknessSnowSoilLayer(LoopInd) / (-DepthSoilLayer(NumSoilLayerRoot)) + enddo + + ! start crop carbon process + ! Note: The following CropPhotosynthesis is not used currently. + ! Photosynthesis rate is directly from calculations in the energy part (similar to the treatment in CARBON subroutine) + + !call CropPhotosynthesis(noahmp) + call CropGrowDegreeDay(noahmp) + call CarbonFluxCrop(noahmp) + + end associate + + end subroutine BiochemCropMain + +end module BiochemCropMainMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/BiochemNatureVegMainMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/BiochemNatureVegMainMod.F90 new file mode 100644 index 0000000000..93a0a9769e --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/BiochemNatureVegMainMod.F90 @@ -0,0 +1,109 @@ +module BiochemNatureVegMainMod + +!!! Main Biogeochemistry module for dynamic generic vegetation (as opposed to explicit crop scheme) +!!! currently only include carbon processes (RE Dickinson et al.(1998) and Guo-Yue Niu(2004)) + + use Machine + use NoahmpVarType + use ConstantDefineMod + use CarbonFluxNatureVegMod, only : CarbonFluxNatureVeg + + implicit none + +contains + + subroutine BiochemNatureVegMain(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: CARBON +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variables + integer :: LoopInd ! loop index + +!------------------------------------------------------------------------ + associate( & + VegType => noahmp%config%domain%VegType ,& ! in, vegetation type + DepthSoilLayer => noahmp%config%domain%DepthSoilLayer ,& ! in, depth [m] of layer-bottom from soil surface + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! in, snow/soil layer thickness [m] + IndexWaterPoint => noahmp%config%domain%IndexWaterPoint ,& ! in, water point flag + IndexIcePoint => noahmp%config%domain%IndexIcePoint ,& ! in, land ice flag + IndexBarrenPoint => noahmp%config%domain%IndexBarrenPoint ,& ! in, bare soil flag + FlagUrban => noahmp%config%domain%FlagUrban ,& ! in, urban point flag + NumSoilLayerRoot => noahmp%water%param%NumSoilLayerRoot ,& ! in, number of soil layers with root present + SoilMoistureSat => noahmp%water%param%SoilMoistureSat ,& ! in, saturated value of soil moisture [m3/m3] + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! in, soil moisture (ice + liq.) [m3/m3] + SoilTranspFacAcc => noahmp%water%state%SoilTranspFacAcc ,& ! in, accumulated soil water transpiration factor (0 to 1) + LeafAreaPerMass1side => noahmp%biochem%param%LeafAreaPerMass1side ,& ! in, single-side leaf area per Kg [m2/kg] + LeafMass => noahmp%biochem%state%LeafMass ,& ! inout, leaf mass [g/m2] + RootMass => noahmp%biochem%state%RootMass ,& ! inout, mass of fine roots [g/m2] + StemMass => noahmp%biochem%state%StemMass ,& ! inout, stem mass [g/m2] + WoodMass => noahmp%biochem%state%WoodMass ,& ! inout, mass of wood (incl. woody roots) [g/m2] + CarbonMassDeepSoil => noahmp%biochem%state%CarbonMassDeepSoil ,& ! inout, stable carbon in deep soil [g/m2] + CarbonMassShallowSoil => noahmp%biochem%state%CarbonMassShallowSoil ,& ! inout, short-lived carbon in shallow soil [g/m2] + LeafAreaIndex => noahmp%energy%state%LeafAreaIndex ,& ! inout, leaf area index + StemAreaIndex => noahmp%energy%state%StemAreaIndex ,& ! inout, stem area index + GrossPriProduction => noahmp%biochem%flux%GrossPriProduction ,& ! out, net instantaneous assimilation [g/m2/s C] + NetPriProductionTot => noahmp%biochem%flux%NetPriProductionTot ,& ! out, net primary productivity [g/m2/s C] + NetEcoExchange => noahmp%biochem%flux%NetEcoExchange ,& ! out, net ecosystem exchange [g/m2/s CO2] + RespirationPlantTot => noahmp%biochem%flux%RespirationPlantTot ,& ! out, total plant respiration [g/m2/s C] + RespirationSoilOrg => noahmp%biochem%flux%RespirationSoilOrg ,& ! out, soil organic respiration [g/m2/s C] + CarbonMassSoilTot => noahmp%biochem%state%CarbonMassSoilTot ,& ! out, total soil carbon [g/m2 C] + CarbonMassLiveTot => noahmp%biochem%state%CarbonMassLiveTot ,& ! out, total living carbon ([g/m2 C] + SoilWaterRootZone => noahmp%water%state%SoilWaterRootZone ,& ! out, root zone soil water + SoilWaterStress => noahmp%water%state%SoilWaterStress ,& ! out, water stress coeficient (1. for wilting) + LeafAreaPerMass => noahmp%biochem%state%LeafAreaPerMass & ! out, leaf area per unit mass [m2/g] + ) +!----------------------------------------------------------------------- + + ! initialize + NetEcoExchange = 0.0 + NetPriProductionTot = 0.0 + GrossPriProduction = 0.0 + + ! no biogeochemistry in non-vegetated points + if ( (VegType == IndexWaterPoint) .or. (VegType == IndexBarrenPoint) .or. & + (VegType == IndexIcePoint ) .or. (FlagUrban .eqv. .true.) ) then + LeafAreaIndex = 0.0 + StemAreaIndex = 0.0 + GrossPriProduction = 0.0 + NetPriProductionTot = 0.0 + NetEcoExchange = 0.0 + RespirationPlantTot = 0.0 + RespirationSoilOrg = 0.0 + CarbonMassSoilTot = 0.0 + CarbonMassLiveTot = 0.0 + LeafMass = 0.0 + RootMass = 0.0 + StemMass = 0.0 + WoodMass = 0.0 + CarbonMassDeepSoil = 0.0 + CarbonMassShallowSoil = 0.0 + return + endif + + ! start biogeochemistry process + LeafAreaPerMass = LeafAreaPerMass1side / 1000.0 ! m2/kg -> m2/g + + ! water stress + SoilWaterStress = 1.0 - SoilTranspFacAcc + SoilWaterRootZone = 0.0 + do LoopInd = 1, NumSoilLayerRoot + SoilWaterRootZone = SoilWaterRootZone + SoilMoisture(LoopInd) / SoilMoistureSat(LoopInd) * & + ThicknessSnowSoilLayer(LoopInd) / (-DepthSoilLayer(NumSoilLayerRoot)) + enddo + + ! start carbon process + call CarbonFluxNatureVeg(noahmp) + + end associate + + end subroutine BiochemNatureVegMain + +end module BiochemNatureVegMainMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/BiochemVarInitMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/BiochemVarInitMod.F90 new file mode 100644 index 0000000000..e53aa108cf --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/BiochemVarInitMod.F90 @@ -0,0 +1,193 @@ +module BiochemVarInitMod + +!!! Initialize column (1-D) Noah-MP biochemistry (carbon,nitrogen,etc) variables +!!! Biochemistry variables should be first defined in BiochemVarType.F90 + +! ------------------------ Code history ----------------------------------- +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + use Machine + use NoahmpVarType + + implicit none + +contains + +!=== initialize with default values + + subroutine BiochemVarInitDefault(noahmp) + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + + associate( NumCropGrowStage => noahmp%config%domain%NumCropGrowStage ) + + ! biochem state variables + noahmp%biochem%state%PlantGrowStage = undefined_int + noahmp%biochem%state%IndexPlanting = undefined_int + noahmp%biochem%state%IndexHarvest = undefined_int + noahmp%biochem%state%IndexGrowSeason = undefined_real + noahmp%biochem%state%NitrogenConcFoliage = undefined_real + noahmp%biochem%state%LeafMass = undefined_real + noahmp%biochem%state%RootMass = undefined_real + noahmp%biochem%state%StemMass = undefined_real + noahmp%biochem%state%WoodMass = undefined_real + noahmp%biochem%state%CarbonMassDeepSoil = undefined_real + noahmp%biochem%state%CarbonMassShallowSoil = undefined_real + noahmp%biochem%state%CarbonMassSoilTot = undefined_real + noahmp%biochem%state%CarbonMassLiveTot = undefined_real + noahmp%biochem%state%LeafAreaPerMass = undefined_real + noahmp%biochem%state%StemAreaPerMass = undefined_real + noahmp%biochem%state%LeafMassMin = undefined_real + noahmp%biochem%state%StemMassMin = undefined_real + noahmp%biochem%state%CarbonFracToLeaf = undefined_real + noahmp%biochem%state%CarbonFracToRoot = undefined_real + noahmp%biochem%state%CarbonFracToWood = undefined_real + noahmp%biochem%state%CarbonFracToStem = undefined_real + noahmp%biochem%state%WoodCarbonFrac = undefined_real + noahmp%biochem%state%CarbonFracToWoodRoot = undefined_real + noahmp%biochem%state%MicroRespFactorSoilWater = undefined_real + noahmp%biochem%state%MicroRespFactorSoilTemp = undefined_real + noahmp%biochem%state%RespFacNitrogenFoliage = undefined_real + noahmp%biochem%state%RespFacTemperature = undefined_real + noahmp%biochem%state%RespReductionFac = undefined_real + noahmp%biochem%state%GrainMass = undefined_real + noahmp%biochem%state%GrowDegreeDay = undefined_real + + ! biochem flux variables + noahmp%biochem%flux%PhotosynLeafSunlit = undefined_real + noahmp%biochem%flux%PhotosynLeafShade = undefined_real + noahmp%biochem%flux%PhotosynCrop = undefined_real + noahmp%biochem%flux%PhotosynTotal = undefined_real + noahmp%biochem%flux%GrossPriProduction = undefined_real + noahmp%biochem%flux%NetPriProductionTot = undefined_real + noahmp%biochem%flux%NetEcoExchange = undefined_real + noahmp%biochem%flux%RespirationPlantTot = undefined_real + noahmp%biochem%flux%RespirationSoilOrg = undefined_real + noahmp%biochem%flux%CarbonToAtmos = undefined_real + noahmp%biochem%flux%NetPriProductionLeaf = undefined_real + noahmp%biochem%flux%NetPriProductionRoot = undefined_real + noahmp%biochem%flux%NetPriProductionWood = undefined_real + noahmp%biochem%flux%NetPriProductionStem = undefined_real + noahmp%biochem%flux%GrowthRespLeaf = undefined_real + noahmp%biochem%flux%GrowthRespRoot = undefined_real + noahmp%biochem%flux%GrowthRespWood = undefined_real + noahmp%biochem%flux%GrowthRespStem = undefined_real + noahmp%biochem%flux%LeafMassMaxChg = undefined_real + noahmp%biochem%flux%StemMassMaxChg = undefined_real + noahmp%biochem%flux%CarbonDecayToStable = undefined_real + noahmp%biochem%flux%RespirationLeaf = undefined_real + noahmp%biochem%flux%RespirationStem = undefined_real + noahmp%biochem%flux%GrowthRespGrain = undefined_real + noahmp%biochem%flux%NetPriProductionGrain = undefined_real + noahmp%biochem%flux%ConvRootToGrain = undefined_real + noahmp%biochem%flux%ConvStemToGrain = undefined_real + noahmp%biochem%flux%RespirationWood = undefined_real + noahmp%biochem%flux%RespirationLeafMaint = undefined_real + noahmp%biochem%flux%RespirationRoot = undefined_real + noahmp%biochem%flux%DeathLeaf = undefined_real + noahmp%biochem%flux%DeathStem = undefined_real + noahmp%biochem%flux%CarbonAssim = undefined_real + noahmp%biochem%flux%TurnoverLeaf = undefined_real + noahmp%biochem%flux%TurnoverStem = undefined_real + noahmp%biochem%flux%TurnoverWood = undefined_real + noahmp%biochem%flux%RespirationSoil = undefined_real + noahmp%biochem%flux%TurnoverRoot = undefined_real + noahmp%biochem%flux%CarbohydrAssim = undefined_real + noahmp%biochem%flux%TurnoverGrain = undefined_real + noahmp%biochem%flux%ConvLeafToGrain = undefined_real + noahmp%biochem%flux%RespirationGrain = undefined_real + + ! biochem parameter variables + noahmp%biochem%param%DatePlanting = undefined_int + noahmp%biochem%param%DateHarvest = undefined_int + noahmp%biochem%param%QuantumEfficiency25C = undefined_real + noahmp%biochem%param%CarboxylRateMax25C = undefined_real + noahmp%biochem%param%CarboxylRateMaxQ10 = undefined_real + noahmp%biochem%param%PhotosynPathC3 = undefined_real + noahmp%biochem%param%SlopeConductToPhotosyn = undefined_real + noahmp%biochem%param%TemperatureMinPhotosyn = undefined_real + noahmp%biochem%param%LeafAreaPerMass1side = undefined_real + noahmp%biochem%param%NitrogenConcFoliageMax = undefined_real + noahmp%biochem%param%WoodToRootRatio = undefined_real + noahmp%biochem%param%WoodPoolIndex = undefined_real + noahmp%biochem%param%TurnoverCoeffLeafVeg = undefined_real + noahmp%biochem%param%LeafDeathWaterCoeffVeg = undefined_real + noahmp%biochem%param%LeafDeathTempCoeffVeg = undefined_real + noahmp%biochem%param%MicroRespCoeff = undefined_real + noahmp%biochem%param%RespMaintQ10 = undefined_real + noahmp%biochem%param%RespMaintLeaf25C = undefined_real + noahmp%biochem%param%RespMaintStem25C = undefined_real + noahmp%biochem%param%RespMaintRoot25C = undefined_real + noahmp%biochem%param%RespMaintGrain25C = undefined_real + noahmp%biochem%param%GrowthRespFrac = undefined_real + noahmp%biochem%param%TemperaureLeafFreeze = undefined_real + noahmp%biochem%param%LeafAreaPerBiomass = undefined_real + noahmp%biochem%param%TempBaseGrowDegDay = undefined_real + noahmp%biochem%param%TempMaxGrowDegDay = undefined_real + noahmp%biochem%param%GrowDegDayEmerg = undefined_real + noahmp%biochem%param%GrowDegDayInitVeg = undefined_real + noahmp%biochem%param%GrowDegDayPostVeg = undefined_real + noahmp%biochem%param%GrowDegDayInitReprod = undefined_real + noahmp%biochem%param%GrowDegDayMature = undefined_real + noahmp%biochem%param%PhotosynRadFrac = undefined_real + noahmp%biochem%param%TempMinCarbonAssim = undefined_real + noahmp%biochem%param%TempMaxCarbonAssim = undefined_real + noahmp%biochem%param%TempMaxCarbonAssimMax = undefined_real + noahmp%biochem%param%CarbonAssimRefMax = undefined_real + noahmp%biochem%param%LightExtCoeff = undefined_real + noahmp%biochem%param%LightUseEfficiency = undefined_real + noahmp%biochem%param%CarbonAssimReducFac = undefined_real + noahmp%biochem%param%StemAreaIndexMin = undefined_real + noahmp%biochem%param%WoodAllocFac = undefined_real + noahmp%biochem%param%WaterStressCoeff = undefined_real + noahmp%biochem%param%LeafAreaIndexMin = undefined_real + noahmp%biochem%param%TurnoverCoeffRootVeg = undefined_real + noahmp%biochem%param%WoodRespCoeff = undefined_real + + if ( .not. allocated(noahmp%biochem%param%LeafDeathTempCoeffCrop) ) & + allocate( noahmp%biochem%param%LeafDeathTempCoeffCrop(1:NumCropGrowStage) ) + if ( .not. allocated(noahmp%biochem%param%LeafDeathWaterCoeffCrop) ) & + allocate( noahmp%biochem%param%LeafDeathWaterCoeffCrop(1:NumCropGrowStage) ) + if ( .not. allocated(noahmp%biochem%param%CarbohydrLeafToGrain) ) & + allocate( noahmp%biochem%param%CarbohydrLeafToGrain(1:NumCropGrowStage) ) + if ( .not. allocated(noahmp%biochem%param%CarbohydrStemToGrain) ) & + allocate( noahmp%biochem%param%CarbohydrStemToGrain(1:NumCropGrowStage) ) + if ( .not. allocated(noahmp%biochem%param%CarbohydrRootToGrain) ) & + allocate( noahmp%biochem%param%CarbohydrRootToGrain(1:NumCropGrowStage) ) + if ( .not. allocated(noahmp%biochem%param%CarbohydrFracToLeaf) ) & + allocate( noahmp%biochem%param%CarbohydrFracToLeaf(1:NumCropGrowStage) ) + if ( .not. allocated(noahmp%biochem%param%CarbohydrFracToStem) ) & + allocate( noahmp%biochem%param%CarbohydrFracToStem(1:NumCropGrowStage) ) + if ( .not. allocated(noahmp%biochem%param%CarbohydrFracToRoot) ) & + allocate( noahmp%biochem%param%CarbohydrFracToRoot(1:NumCropGrowStage) ) + if ( .not. allocated(noahmp%biochem%param%CarbohydrFracToGrain) ) & + allocate( noahmp%biochem%param%CarbohydrFracToGrain(1:NumCropGrowStage) ) + if ( .not. allocated(noahmp%biochem%param%TurnoverCoeffLeafCrop) ) & + allocate( noahmp%biochem%param%TurnoverCoeffLeafCrop(1:NumCropGrowStage) ) + if ( .not. allocated(noahmp%biochem%param%TurnoverCoeffStemCrop) ) & + allocate( noahmp%biochem%param%TurnoverCoeffStemCrop(1:NumCropGrowStage) ) + if ( .not. allocated(noahmp%biochem%param%TurnoverCoeffRootCrop) ) & + allocate( noahmp%biochem%param%TurnoverCoeffRootCrop(1:NumCropGrowStage) ) + + noahmp%biochem%param%LeafDeathTempCoeffCrop (:) = undefined_real + noahmp%biochem%param%LeafDeathWaterCoeffCrop(:) = undefined_real + noahmp%biochem%param%CarbohydrLeafToGrain (:) = undefined_real + noahmp%biochem%param%CarbohydrStemToGrain (:) = undefined_real + noahmp%biochem%param%CarbohydrRootToGrain (:) = undefined_real + noahmp%biochem%param%CarbohydrFracToLeaf (:) = undefined_real + noahmp%biochem%param%CarbohydrFracToStem (:) = undefined_real + noahmp%biochem%param%CarbohydrFracToRoot (:) = undefined_real + noahmp%biochem%param%CarbohydrFracToGrain (:) = undefined_real + noahmp%biochem%param%TurnoverCoeffLeafCrop (:) = undefined_real + noahmp%biochem%param%TurnoverCoeffStemCrop (:) = undefined_real + noahmp%biochem%param%TurnoverCoeffRootCrop (:) = undefined_real + + end associate + + end subroutine BiochemVarInitDefault + +end module BiochemVarInitMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/BiochemVarType.F90 b/src/core_atmosphere/physics/physics_noahmp/src/BiochemVarType.F90 new file mode 100644 index 0000000000..9e9cd3e44c --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/BiochemVarType.F90 @@ -0,0 +1,177 @@ +module BiochemVarType + +!!! Define column (1-D) Noah-MP Biochemistry (carbon,nitrogen,etc) variables +!!! Biochemistry variable initialization is done in BiochemVarInitMod.F90 + +! ------------------------ Code history ----------------------------------- +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + use Machine + + implicit none + save + private + +!=== define "flux" sub-type of biochem (biochem%flux%variable) + type :: flux_type + + real(kind=kind_noahmp) :: PhotosynTotal ! total leaf photosynthesis [umol co2/m2/s] + real(kind=kind_noahmp) :: PhotosynLeafSunlit ! sunlit leaf photosynthesis [umol co2/m2/s] + real(kind=kind_noahmp) :: PhotosynLeafShade ! shaded leaf photosynthesis [umol co2/m2/s] + real(kind=kind_noahmp) :: PhotosynCrop ! crop photosynthesis rate [umol co2/m2/s] + real(kind=kind_noahmp) :: GrossPriProduction ! gross primary production [g/m2/s C] + real(kind=kind_noahmp) :: NetEcoExchange ! net ecosystem exchange [g/m2/s CO2] + real(kind=kind_noahmp) :: NetPriProductionTot ! total net primary production [g/m2/s C] + real(kind=kind_noahmp) :: NetPriProductionLeaf ! leaf net primary production [g/m2/s] + real(kind=kind_noahmp) :: NetPriProductionRoot ! root net primary production [g/m2/s] + real(kind=kind_noahmp) :: NetPriProductionWood ! wood net primary production [g/m2/s] + real(kind=kind_noahmp) :: NetPriProductionStem ! stem net primary production [g/m2/s] + real(kind=kind_noahmp) :: NetPriProductionGrain ! grain net primary production [g/m2/s] + real(kind=kind_noahmp) :: RespirationPlantTot ! total plant respiration (leaf,stem,root,wood,grain) [g/m2/s C] + real(kind=kind_noahmp) :: RespirationSoilOrg ! soil heterotrophic (organic) respiration [g/m2/s C] + real(kind=kind_noahmp) :: CarbonToAtmos ! carbon flux to atmosphere [g/m2/s] + real(kind=kind_noahmp) :: GrowthRespLeaf ! growth respiration rate for leaf [g/m2/s] + real(kind=kind_noahmp) :: GrowthRespRoot ! growth respiration rate for root [g/m2/s] + real(kind=kind_noahmp) :: GrowthRespWood ! growth respiration rate for wood [g/m2/s] + real(kind=kind_noahmp) :: GrowthRespStem ! growth respiration rate for stem [g/m2/s] + real(kind=kind_noahmp) :: GrowthRespGrain ! growth respiration rate for grain [g/m2/s] + real(kind=kind_noahmp) :: LeafMassMaxChg ! maximum leaf mass available to change [g/m2/s] + real(kind=kind_noahmp) :: StemMassMaxChg ! maximum stem mass available to change [g/m2/s] + real(kind=kind_noahmp) :: CarbonDecayToStable ! decay rate of fast carbon to slow carbon [g/m2/s] + real(kind=kind_noahmp) :: RespirationLeaf ! leaf respiration [umol CO2/m2/s] + real(kind=kind_noahmp) :: RespirationStem ! stem respiration [g/m2/s] + real(kind=kind_noahmp) :: RespirationWood ! wood respiration rate [g/m2/s] + real(kind=kind_noahmp) :: RespirationLeafMaint ! leaf maintenance respiration rate [g/m2/s] + real(kind=kind_noahmp) :: RespirationRoot ! fine root respiration rate [g/m2/s] + real(kind=kind_noahmp) :: RespirationSoil ! soil respiration rate [g/m2/s] + real(kind=kind_noahmp) :: RespirationGrain ! grain respiration rate [g/m2/s] + real(kind=kind_noahmp) :: ConvRootToGrain ! root to grain conversion [g/m2/s] + real(kind=kind_noahmp) :: ConvStemToGrain ! stem to grain conversion [g/m2/s] + real(kind=kind_noahmp) :: ConvLeafToGrain ! leaf to grain conversion [g/m2/s] + real(kind=kind_noahmp) :: TurnoverLeaf ! leaf turnover rate [g/m2/s] + real(kind=kind_noahmp) :: TurnoverStem ! stem turnover rate [g/m2/s] + real(kind=kind_noahmp) :: TurnoverWood ! wood turnover rate [g/m2/s] + real(kind=kind_noahmp) :: TurnoverRoot ! root turnover rate [g/m2/s] + real(kind=kind_noahmp) :: TurnoverGrain ! grain turnover rate [g/m2/s] + real(kind=kind_noahmp) :: DeathLeaf ! death rate of leaf mass [g/m2/s] + real(kind=kind_noahmp) :: DeathStem ! death rate of stem mass [g/m2/s] + real(kind=kind_noahmp) :: CarbonAssim ! carbon assimilated rate [g/m2/s] + real(kind=kind_noahmp) :: CarbohydrAssim ! carbohydrate assimilated rate [g/m2/s] + + end type flux_type + + +!=== define "state" sub-type of biochem (biochem%state%variable) + type :: state_type + + integer :: PlantGrowStage ! plant growing stage + integer :: IndexPlanting ! Planting index (0=off, 1=on) + integer :: IndexHarvest ! Harvest index (0=on,1=off) + real(kind=kind_noahmp) :: IndexGrowSeason ! growing season index (0=off, 1=on) + real(kind=kind_noahmp) :: NitrogenConcFoliage ! foliage nitrogen concentration [%] + real(kind=kind_noahmp) :: LeafMass ! leaf mass [g/m2] + real(kind=kind_noahmp) :: RootMass ! mass of fine roots [g/m2] + real(kind=kind_noahmp) :: StemMass ! stem mass [g/m2] + real(kind=kind_noahmp) :: WoodMass ! mass of wood (include woody roots) [g/m2] + real(kind=kind_noahmp) :: GrainMass ! mass of grain [g/m2] + real(kind=kind_noahmp) :: CarbonMassDeepSoil ! stable carbon in deep soil [g/m2] + real(kind=kind_noahmp) :: CarbonMassShallowSoil ! short-lived carbon in shallow soil [g/m2] + real(kind=kind_noahmp) :: CarbonMassSoilTot ! total soil carbon mass [g/m2 C] + real(kind=kind_noahmp) :: CarbonMassLiveTot ! total living carbon mass ([g/m2 C] + real(kind=kind_noahmp) :: LeafAreaPerMass ! leaf area per unit mass [m2/g] + real(kind=kind_noahmp) :: StemAreaPerMass ! stem area per unit mass (m2/g) + real(kind=kind_noahmp) :: LeafMassMin ! minimum leaf mass [g/m2] + real(kind=kind_noahmp) :: StemMassMin ! minimum stem mass [g/m2] + real(kind=kind_noahmp) :: CarbonFracToLeaf ! fraction of carbon flux allocated to leaves + real(kind=kind_noahmp) :: CarbonFracToRoot ! fraction of carbon flux allocated to roots + real(kind=kind_noahmp) :: CarbonFracToWood ! fraction of carbon flux allocated to wood + real(kind=kind_noahmp) :: CarbonFracToStem ! fraction of carbon flux allocated to stem + real(kind=kind_noahmp) :: WoodCarbonFrac ! wood carbon fraction in (root + wood) carbon + real(kind=kind_noahmp) :: CarbonFracToWoodRoot ! fraction of carbon to root and wood + real(kind=kind_noahmp) :: MicroRespFactorSoilWater ! soil water factor for microbial respiration + real(kind=kind_noahmp) :: MicroRespFactorSoilTemp ! soil temperature factor for microbial respiration + real(kind=kind_noahmp) :: RespFacNitrogenFoliage ! foliage nitrogen adjustemt factor to respiration (<= 1) + real(kind=kind_noahmp) :: RespFacTemperature ! temperature factor for respiration + real(kind=kind_noahmp) :: RespReductionFac ! respiration reduction factor (<= 1) + real(kind=kind_noahmp) :: GrowDegreeDay ! growing degree days + + end type state_type + + +!=== define "parameter" sub-type of biochem (biochem%param%variable) + type :: parameter_type + + integer :: DatePlanting ! planting date + integer :: DateHarvest ! harvest date + real(kind=kind_noahmp) :: QuantumEfficiency25C ! quantum efficiency at 25c [umol CO2/umol photon] + real(kind=kind_noahmp) :: CarboxylRateMax25C ! maximum rate of carboxylation at 25c [umol CO2/m2/s] + real(kind=kind_noahmp) :: CarboxylRateMaxQ10 ! change in maximum rate of carboxylation for every 10-deg C temperature change + real(kind=kind_noahmp) :: PhotosynPathC3 ! C3 photosynthetic pathway indicator: 0.0 = c4, 1.0 = c3 + real(kind=kind_noahmp) :: SlopeConductToPhotosyn ! slope of conductance-to-photosynthesis relationship + real(kind=kind_noahmp) :: TemperatureMinPhotosyn ! minimum temperature for photosynthesis [K] + real(kind=kind_noahmp) :: LeafAreaPerMass1side ! single-side leaf area per mass [m2/kg] + real(kind=kind_noahmp) :: NitrogenConcFoliageMax ! foliage nitrogen concentration when f(n)=1 (%) + real(kind=kind_noahmp) :: WoodToRootRatio ! wood to root ratio + real(kind=kind_noahmp) :: WoodPoolIndex ! wood pool index (0~1) depending on woody or not + real(kind=kind_noahmp) :: TurnoverCoeffLeafVeg ! leaf turnover coefficient [1/s] for generic vegetation + real(kind=kind_noahmp) :: LeafDeathWaterCoeffVeg ! coeficient for leaf water stress death [1/s] for generic vegetation + real(kind=kind_noahmp) :: LeafDeathTempCoeffVeg ! coeficient for leaf temperature stress death [1/s] for generic vegetation + real(kind=kind_noahmp) :: MicroRespCoeff ! microbial respiration coefficient [umol co2 /kg c/ s] + real(kind=kind_noahmp) :: RespMaintQ10 ! change in maintenance respiration for every 10-deg C temperature change + real(kind=kind_noahmp) :: RespMaintLeaf25C ! leaf maintenance respiration at 25C [umol CO2/m2 /s] + real(kind=kind_noahmp) :: RespMaintStem25C ! stem maintenance respiration at 25C [umol CO2/kg bio/s], bio: C or CH2O + real(kind=kind_noahmp) :: RespMaintRoot25C ! root maintenance respiration at 25C [umol CO2/kg bio/s], bio: C or CH2O + real(kind=kind_noahmp) :: RespMaintGrain25C ! grain maintenance respiration at 25C [umol CO2/kg bio/s], bio: C or CH2O + real(kind=kind_noahmp) :: GrowthRespFrac ! fraction of growth respiration + real(kind=kind_noahmp) :: TemperaureLeafFreeze ! characteristic temperature for leaf freezing [K] + real(kind=kind_noahmp) :: LeafAreaPerBiomass ! leaf area per living leaf biomass [m2/g] + real(kind=kind_noahmp) :: TempBaseGrowDegDay ! Base temperature for growing degree day (GDD) accumulation [C] + real(kind=kind_noahmp) :: TempMaxGrowDegDay ! Maximum temperature for growing degree day (GDD) accumulation [C] + real(kind=kind_noahmp) :: GrowDegDayEmerg ! growing degree day (GDD) from seeding to emergence + real(kind=kind_noahmp) :: GrowDegDayInitVeg ! growing degree day (GDD) from seeding to initial vegetative + real(kind=kind_noahmp) :: GrowDegDayPostVeg ! growing degree day (GDD) from seeding to post vegetative + real(kind=kind_noahmp) :: GrowDegDayInitReprod ! growing degree day (GDD) from seeding to intial reproductive + real(kind=kind_noahmp) :: GrowDegDayMature ! growing degree day (GDD) from seeding to pysical maturity + real(kind=kind_noahmp) :: PhotosynRadFrac ! Fraction of incoming solar radiation to photosynthetically active radiation + real(kind=kind_noahmp) :: TempMinCarbonAssim ! Minimum temperature for CO2 assimulation [C] + real(kind=kind_noahmp) :: TempMaxCarbonAssim ! CO2 assimulation linearly increasing until reaching this temperature [C] + real(kind=kind_noahmp) :: TempMaxCarbonAssimMax ! CO2 assmilation rate remain at CarbonAssimRefMax until reaching this temperature [C] + real(kind=kind_noahmp) :: CarbonAssimRefMax ! reference maximum CO2 assimilation rate [g co2/m2/s] + real(kind=kind_noahmp) :: LightExtCoeff ! light extinction coefficient + real(kind=kind_noahmp) :: LightUseEfficiency ! initial light use efficiency + real(kind=kind_noahmp) :: CarbonAssimReducFac ! CO2 assimilation reduction factor(0-1) (caused by non-modeling part,e.g.pest,weeds) + real(kind=kind_noahmp) :: StemAreaIndexMin ! minimum stem area index [m2/m2] + real(kind=kind_noahmp) :: WoodAllocFac ! present wood allocation factor + real(kind=kind_noahmp) :: WaterStressCoeff ! water stress coeficient + real(kind=kind_noahmp) :: LeafAreaIndexMin ! minimum leaf area index [m2/m2] + real(kind=kind_noahmp) :: TurnoverCoeffRootVeg ! root turnover coefficient [1/s] for generic vegetation + real(kind=kind_noahmp) :: WoodRespCoeff ! wood respiration coeficient [1/s] + + real(kind=kind_noahmp), allocatable, dimension(:) :: LeafDeathTempCoeffCrop ! coeficient for leaf temperature stress death [1/s] for crop + real(kind=kind_noahmp), allocatable, dimension(:) :: LeafDeathWaterCoeffCrop ! coeficient for leaf water stress death [1/s] for crop + real(kind=kind_noahmp), allocatable, dimension(:) :: CarbohydrLeafToGrain ! fraction of carbohydrate flux transallocate from leaf to grain + real(kind=kind_noahmp), allocatable, dimension(:) :: CarbohydrStemToGrain ! fraction of carbohydrate flux transallocate from stem to grain + real(kind=kind_noahmp), allocatable, dimension(:) :: CarbohydrRootToGrain ! fraction of carbohydrate flux transallocate from root to grain + real(kind=kind_noahmp), allocatable, dimension(:) :: CarbohydrFracToLeaf ! fraction of carbohydrate flux to leaf for crop + real(kind=kind_noahmp), allocatable, dimension(:) :: CarbohydrFracToStem ! fraction of carbohydrate flux to stem for crop + real(kind=kind_noahmp), allocatable, dimension(:) :: CarbohydrFracToRoot ! fraction of carbohydrate flux to root for crop + real(kind=kind_noahmp), allocatable, dimension(:) :: CarbohydrFracToGrain ! fraction of carbohydrate flux to grain for crop + real(kind=kind_noahmp), allocatable, dimension(:) :: TurnoverCoeffLeafCrop ! leaf turnover coefficient [1/s] for crop + real(kind=kind_noahmp), allocatable, dimension(:) :: TurnoverCoeffStemCrop ! stem turnover coefficient [1/s] for crop + real(kind=kind_noahmp), allocatable, dimension(:) :: TurnoverCoeffRootCrop ! root tunrover coefficient [1/s] for crop + + end type parameter_type + + +!=== define biochem type that includes 3 subtypes (flux,state,parameter) + type, public :: biochem_type + + type(flux_type) :: flux + type(state_type) :: state + type(parameter_type) :: param + + end type biochem_type + +end module BiochemVarType diff --git a/src/core_atmosphere/physics/physics_noahmp/src/CanopyHydrologyMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/CanopyHydrologyMod.F90 new file mode 100644 index 0000000000..24fab3b4be --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/CanopyHydrologyMod.F90 @@ -0,0 +1,141 @@ +module CanopyHydrologyMod + +!!! Canopy Hydrology processes for intercepted rain and snow water +!!! Canopy liquid water evaporation and dew; canopy ice water sublimation and frost + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine CanopyHydrology(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: CANWATER +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! -------------------------------------------------------------------- + associate( & + MainTimeStep => noahmp%config%domain%MainTimeStep ,& ! in, noahmp main time step [s] + HeatLatentCanopy => noahmp%energy%flux%HeatLatentCanopy ,& ! in, canopy latent heat flux [W/m2] (+ to atm) + HeatLatentTransp => noahmp%energy%flux%HeatLatentTransp ,& ! in, latent heat flux from transpiration [W/m2] (+ to atm) + LeafAreaIndEff => noahmp%energy%state%LeafAreaIndEff ,& ! in, leaf area index, after burying by snow + StemAreaIndEff => noahmp%energy%state%StemAreaIndEff ,& ! in, stem area index, after burying by snow + FlagFrozenCanopy => noahmp%energy%state%FlagFrozenCanopy ,& ! in, used to define latent heat pathway + VegFrac => noahmp%energy%state%VegFrac ,& ! in, greeness vegetation fraction + SnowfallDensity => noahmp%water%state%SnowfallDensity ,& ! in, bulk density of snowfall [kg/m3] + CanopyLiqHoldCap => noahmp%water%param%CanopyLiqHoldCap ,& ! in, maximum intercepted liquid water per unit veg area index [mm] + CanopyLiqWater => noahmp%water%state%CanopyLiqWater ,& ! inout, intercepted canopy liquid water [mm] + CanopyIce => noahmp%water%state%CanopyIce ,& ! inout, intercepted canopy ice [mm] + TemperatureCanopy => noahmp%energy%state%TemperatureCanopy ,& ! inout, vegetation temperature [K] + CanopyTotalWater => noahmp%water%state%CanopyTotalWater ,& ! out, total canopy intercepted water [mm] + CanopyWetFrac => noahmp%water%state%CanopyWetFrac ,& ! out, wetted or snowed fraction of the canopy + CanopyIceMax => noahmp%water%state%CanopyIceMax ,& ! out, canopy capacity for snow interception [mm] + CanopyLiqWaterMax => noahmp%water%state%CanopyLiqWaterMax ,& ! out, canopy capacity for rain interception [mm] + EvapCanopyNet => noahmp%water%flux%EvapCanopyNet ,& ! out, evaporation of intercepted total water [mm/s] + Transpiration => noahmp%water%flux%Transpiration ,& ! out, transpiration rate [mm/s] + EvapCanopyLiq => noahmp%water%flux%EvapCanopyLiq ,& ! out, canopy liquid water evaporation rate [mm/s] + DewCanopyLiq => noahmp%water%flux%DewCanopyLiq ,& ! out, canopy liquid water dew rate [mm/s] + FrostCanopyIce => noahmp%water%flux%FrostCanopyIce ,& ! out, canopy ice frost rate [mm/s] + SublimCanopyIce => noahmp%water%flux%SublimCanopyIce ,& ! out, canopy ice sublimation rate [mm/s] + MeltCanopyIce => noahmp%water%flux%MeltCanopyIce ,& ! out, canopy ice melting rate [mm/s] + FreezeCanopyLiq => noahmp%water%flux%FreezeCanopyLiq & ! out, canopy water freezing rate [mm/s] + ) +! -------------------------------------------------------------------- + + ! initialization for out-only variables + EvapCanopyNet = 0.0 + Transpiration = 0.0 + EvapCanopyLiq = 0.0 + DewCanopyLiq = 0.0 + FrostCanopyIce = 0.0 + SublimCanopyIce = 0.0 + MeltCanopyIce = 0.0 + FreezeCanopyLiq = 0.0 + CanopyLiqWaterMax = 0.0 + CanopyIceMax = 0.0 + CanopyWetFrac = 0.0 + CanopyTotalWater = 0.0 + + ! canopy liquid water + ! maximum canopy intercepted water + CanopyLiqWaterMax = VegFrac * CanopyLiqHoldCap * (LeafAreaIndEff + StemAreaIndEff) + + ! canopy evaporation, transpiration, and dew + if ( FlagFrozenCanopy .eqv. .false. ) then ! Barlage: change to FlagFrozenCanopy + Transpiration = max( HeatLatentTransp/ConstLatHeatEvap, 0.0 ) + EvapCanopyLiq = max( HeatLatentCanopy/ConstLatHeatEvap, 0.0 ) + DewCanopyLiq = abs( min( HeatLatentCanopy/ConstLatHeatEvap, 0.0 ) ) + SublimCanopyIce = 0.0 + FrostCanopyIce = 0.0 + else + Transpiration = max( HeatLatentTransp/ConstLatHeatSublim, 0.0 ) + EvapCanopyLiq = 0.0 + DewCanopyLiq = 0.0 + SublimCanopyIce = max( HeatLatentCanopy/ConstLatHeatSublim, 0.0 ) + FrostCanopyIce = abs( min( HeatLatentCanopy/ConstLatHeatSublim, 0.0 ) ) + endif + + ! canopy water balance. for convenience allow dew to bring CanopyLiqWater above + ! maxh2o or else would have to re-adjust drip + EvapCanopyLiq = min( CanopyLiqWater/MainTimeStep, EvapCanopyLiq ) + CanopyLiqWater = max( 0.0, CanopyLiqWater+(DewCanopyLiq-EvapCanopyLiq)*MainTimeStep ) + if ( CanopyLiqWater <= 1.0e-06 ) CanopyLiqWater = 0.0 + + ! canopy ice + ! maximum canopy intercepted ice + CanopyIceMax = VegFrac * 6.6 * (0.27 + 46.0/SnowfallDensity) * (LeafAreaIndEff + StemAreaIndEff) + + ! canopy sublimation and frost + SublimCanopyIce = min( CanopyIce/MainTimeStep, SublimCanopyIce ) + CanopyIce = max( 0.0, CanopyIce+(FrostCanopyIce-SublimCanopyIce)*MainTimeStep ) + if ( CanopyIce <= 1.0e-6 ) CanopyIce = 0.0 + + ! wetted fraction of canopy + if ( (CanopyIce > 0.0) .and. (CanopyIce >= CanopyLiqWater) ) then + CanopyWetFrac = max(0.0,CanopyIce) / max(CanopyIceMax,1.0e-06) + else + CanopyWetFrac = max(0.0,CanopyLiqWater) / max(CanopyLiqWaterMax,1.0e-06) + endif + CanopyWetFrac = min(CanopyWetFrac, 1.0) ** 0.667 + CanopyTotalWater = CanopyLiqWater + CanopyIce + + ! phase change + ! canopy ice melting + if ( (CanopyIce > 1.0e-6) .and. (TemperatureCanopy > ConstFreezePoint) ) then + MeltCanopyIce = min( CanopyIce/MainTimeStep, (TemperatureCanopy-ConstFreezePoint) * ConstHeatCapacIce * & + CanopyIce / ConstDensityIce / (MainTimeStep*ConstLatHeatFusion) ) + CanopyIce = max( 0.0, CanopyIce - MeltCanopyIce*MainTimeStep ) + CanopyLiqWater = max( 0.0, CanopyTotalWater - CanopyIce ) + TemperatureCanopy = CanopyWetFrac*ConstFreezePoint + (1.0 - CanopyWetFrac)*TemperatureCanopy + endif + + ! canopy water refreeezing + if ( (CanopyLiqWater > 1.0e-6) .and. (TemperatureCanopy < ConstFreezePoint) ) then + FreezeCanopyLiq = min( CanopyLiqWater/MainTimeStep, (ConstFreezePoint-TemperatureCanopy) * ConstHeatCapacWater * & + CanopyLiqWater / ConstDensityWater / (MainTimeStep*ConstLatHeatFusion) ) + CanopyLiqWater = max( 0.0, CanopyLiqWater - FreezeCanopyLiq*MainTimeStep ) + CanopyIce = max( 0.0, CanopyTotalWater - CanopyLiqWater ) + TemperatureCanopy = CanopyWetFrac*ConstFreezePoint + (1.0 - CanopyWetFrac)*TemperatureCanopy + endif + + ! update total canopy water + CanopyTotalWater = CanopyLiqWater + CanopyIce + + ! total canopy net evaporation + EvapCanopyNet = EvapCanopyLiq + SublimCanopyIce - DewCanopyLiq - FrostCanopyIce + + end associate + + end subroutine CanopyHydrology + +end module CanopyHydrologyMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/CanopyRadiationTwoStreamMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/CanopyRadiationTwoStreamMod.F90 new file mode 100644 index 0000000000..cbafc5c115 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/CanopyRadiationTwoStreamMod.F90 @@ -0,0 +1,263 @@ +module CanopyRadiationTwoStreamMod + +!!! Compute canopy radiative transfer using two-stream approximation of Dickinson (1983) Adv Geophysics +!!! Calculate fluxes absorbed by vegetation, reflected by vegetation, and transmitted through vegetation +!!! for unit incoming direct or diffuse flux given an underlying ground with known albedo. +!!! Reference for the modified two-stream scheme Niu and Yang (2004), JGR + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine CanopyRadiationTwoStream(noahmp, IndSwBnd, IndSwDif) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: TWOSTREAM +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + integer , intent(in ) :: IndSwBnd ! solar radiation band index + integer , intent(in ) :: IndSwDif ! 0=unit incoming direct; 1=unit incoming diffuse + +! local variables + real(kind=kind_noahmp) :: ScatCoeffCan ! total scattering coefficient for canopy + real(kind=kind_noahmp) :: ScatCoeffLeaf ! scattering coefficient for leaves not covered by snow + real(kind=kind_noahmp) :: UpscatCoeffCanDif ! upscatter parameter for diffuse radiation + real(kind=kind_noahmp) :: UpscatCoeffLeafDif ! upscatter parameter for diffuse radiation for leaves + real(kind=kind_noahmp) :: UpscatCoeffCanDir ! upscatter parameter for direct radiation + real(kind=kind_noahmp) :: UpscatCoeffLeafDir ! upscatter parameter for direct radiation for leaves + real(kind=kind_noahmp) :: OpticDepthDir ! optical depth of direct beam per unit leaf area + real(kind=kind_noahmp) :: OpticDepthDif ! average diffuse optical depth per unit leaf area + real(kind=kind_noahmp) :: CosSolarZenithAngleTmp ! cosine of solar zenith angle (0.001~1.0) + real(kind=kind_noahmp) :: SingleScatAlb ! single scattering albedo + real(kind=kind_noahmp) :: LeafOrientIndex ! leaf orientation index (-0.4~0.6) + real(kind=kind_noahmp) :: RadSwTransDir ! transmitted direct solar radiation below canopy + real(kind=kind_noahmp) :: RadSwTransDif ! transmitted diffuse solar radiation below canopy + real(kind=kind_noahmp) :: RadSwReflTot ! total reflected flux by canopy and ground + real(kind=kind_noahmp) :: VegDensity ! vegetation density + real(kind=kind_noahmp) :: RadSwReflCan ! reflected flux by canopy + real(kind=kind_noahmp) :: RadSwReflGrd ! reflected flux by ground + real(kind=kind_noahmp) :: CrownDepth ! crown depth [m] + real(kind=kind_noahmp) :: CrownRadiusVert ! vertical crown radius [m] + real(kind=kind_noahmp) :: SolarAngleTmp ! solar angle conversion from SZA + real(kind=kind_noahmp) :: FoliageDensity ! foliage volume density (m-1) + real(kind=kind_noahmp) :: VegAreaIndTmp ! temporary effective VAI + real(kind=kind_noahmp) :: Tmp0,Tmp1,Tmp2,Tmp3,Tmp4 ! temporary vars + real(kind=kind_noahmp) :: Tmp5,Tmp6,Tmp7,Tmp8,Tmp9 ! temporary vars + real(kind=kind_noahmp) :: P1,P2,P3,P4,S1,S2,U1,U2,U3 ! temporary vars + real(kind=kind_noahmp) :: B,C,D,D1,D2,F,H,H1,H2,H3 ! temporary vars + real(kind=kind_noahmp) :: H4,H5,H6,H7,H8,H9,H10 ! temporary vars + real(kind=kind_noahmp) :: Phi1,Phi2,Sigma ! temporary vars + +! -------------------------------------------------------------------- + associate( & + OptCanopyRadiationTransfer => noahmp%config%nmlist%OptCanopyRadiationTransfer ,& ! in, options for canopy radiation transfer + CosSolarZenithAngle => noahmp%config%domain%CosSolarZenithAngle ,& ! in, cosine solar zenith angle + CanopyWetFrac => noahmp%water%state%CanopyWetFrac ,& ! in, wetted or snowed fraction of the canopy + TreeCrownRadius => noahmp%energy%param%TreeCrownRadius ,& ! in, tree crown radius [m] + HeightCanopyTop => noahmp%energy%param%HeightCanopyTop ,& ! in, top of canopy [m] + HeightCanopyBot => noahmp%energy%param%HeightCanopyBot ,& ! in, bottom of canopy [m] + TreeDensity => noahmp%energy%param%TreeDensity ,& ! in, tree density [no. of trunks per m2] + CanopyOrientIndex => noahmp%energy%param%CanopyOrientIndex ,& ! in, leaf/stem orientation index + ScatterCoeffSnow => noahmp%energy%param%ScatterCoeffSnow ,& ! in, Scattering coefficient for snow + UpscatterCoeffSnowDir => noahmp%energy%param%UpscatterCoeffSnowDir ,& ! in, Upscattering parameters for snow for direct radiation + UpscatterCoeffSnowDif => noahmp%energy%param%UpscatterCoeffSnowDif ,& ! in, Upscattering parameters for snow for diffuse radiation + VegAreaIndEff => noahmp%energy%state%VegAreaIndEff ,& ! in, one-sided leaf+stem area index [m2/m2] + TemperatureCanopy => noahmp%energy%state%TemperatureCanopy ,& ! in, vegetation temperature [K] + AlbedoGrdDir => noahmp%energy%state%AlbedoGrdDir ,& ! in, ground albedo (direct beam: vis, nir) + AlbedoGrdDif => noahmp%energy%state%AlbedoGrdDif ,& ! in, ground albedo (diffuse: vis, nir) + ReflectanceVeg => noahmp%energy%state%ReflectanceVeg ,& ! in, leaf/stem reflectance weighted by LAI and SAI fraction + TransmittanceVeg => noahmp%energy%state%TransmittanceVeg ,& ! in, leaf/stem transmittance weighted by LAI and SAI fraction + VegFrac => noahmp%energy%state%VegFrac ,& ! in, greeness vegetation fraction + AlbedoSfcDir => noahmp%energy%state%AlbedoSfcDir ,& ! out, surface albedo (direct) + AlbedoSfcDif => noahmp%energy%state%AlbedoSfcDif ,& ! out, surface albedo (diffuse) + VegAreaProjDir => noahmp%energy%state%VegAreaProjDir ,& ! out, projected leaf+stem area in solar direction + GapBtwCanopy => noahmp%energy%state%GapBtwCanopy ,& ! out, between canopy gap fraction for beam + GapInCanopy => noahmp%energy%state%GapInCanopy ,& ! out, within canopy gap fraction for beam + GapCanopyDif => noahmp%energy%state%GapCanopyDif ,& ! out, gap fraction for diffue light + GapCanopyDir => noahmp%energy%state%GapCanopyDir ,& ! out, total gap fraction for beam (<=1-VegFrac) + RadSwAbsVegDir => noahmp%energy%flux%RadSwAbsVegDir ,& ! out, flux abs by veg (per unit direct flux) + RadSwAbsVegDif => noahmp%energy%flux%RadSwAbsVegDif ,& ! out, flux abs by veg (per unit diffuse flux) + RadSwDirTranGrdDir => noahmp%energy%flux%RadSwDirTranGrdDir ,& ! out, downward direct flux below veg (per unit dir flux) + RadSwDirTranGrdDif => noahmp%energy%flux%RadSwDirTranGrdDif ,& ! out, downward direct flux below veg per unit dif flux (=0) + RadSwDifTranGrdDir => noahmp%energy%flux%RadSwDifTranGrdDir ,& ! out, downward diffuse flux below veg (per unit dir flux) + RadSwDifTranGrdDif => noahmp%energy%flux%RadSwDifTranGrdDif ,& ! out, downward diffuse flux below veg (per unit dif flux) + RadSwReflVegDir => noahmp%energy%flux%RadSwReflVegDir ,& ! out, flux reflected by veg layer (per unit direct flux) + RadSwReflVegDif => noahmp%energy%flux%RadSwReflVegDif ,& ! out, flux reflected by veg layer (per unit diffuse flux) + RadSwReflGrdDir => noahmp%energy%flux%RadSwReflGrdDir ,& ! out, flux reflected by ground (per unit direct flux) + RadSwReflGrdDif => noahmp%energy%flux%RadSwReflGrdDif & ! out, flux reflected by ground (per unit diffuse flux) + ) +! ---------------------------------------------------------------------- + + ! compute within and between gaps + if ( VegAreaIndEff == 0.0 ) then + GapCanopyDir = 1.0 + GapCanopyDif = 1.0 + else + if ( OptCanopyRadiationTransfer == 1 ) then + VegDensity = -log(max(1.0-VegFrac, 0.01)) / (ConstPI*TreeCrownRadius**2) + CrownDepth = HeightCanopyTop - HeightCanopyBot + CrownRadiusVert = 0.5 * CrownDepth + SolarAngleTmp = atan(CrownRadiusVert / TreeCrownRadius * tan(acos(max(0.01, CosSolarZenithAngle)))) + !GapBtwCanopy = exp(TreeDensity * ConstPI * TreeCrownRadius**2 / cos(SolarAngleTmp)) + GapBtwCanopy = exp(-VegDensity * ConstPI * TreeCrownRadius**2 / cos(SolarAngleTmp)) + FoliageDensity = VegAreaIndEff / (1.33*ConstPI*TreeCrownRadius**3.0 * (CrownRadiusVert/TreeCrownRadius)*VegDensity) + VegAreaIndTmp = CrownDepth * FoliageDensity + GapInCanopy = (1.0 - GapBtwCanopy) * exp(-0.5*VegAreaIndTmp/CosSolarZenithAngle) + GapCanopyDir = min( 1.0-VegFrac, GapBtwCanopy+GapInCanopy ) + GapCanopyDif = 0.05 + endif + if ( OptCanopyRadiationTransfer == 2 ) then + GapCanopyDir = 0.0 + GapCanopyDif = 0.0 + endif + if ( OptCanopyRadiationTransfer == 3 ) then + GapCanopyDir = 1.0 - VegFrac + GapCanopyDif = 1.0 - VegFrac + endif + endif + + ! calculate two-stream parameters ScatCoeffCan, UpscatCoeffCanDir, UpscatCoeffCanDif, OpticDepthDif, VegAreaProjDir, OpticDepthDir. + ! ScatCoeffCan, UpscatCoeffCanDir, UpscatCoeffCanDif are adjusted for snow. values for ScatCoeffCan*UpscatCoeffCanDir + ! and ScatCoeffCan*UpscatCoeffCanDif are calculated and then divided by the new ScatCoeffCan + ! because the product ScatCoeffCan*UpscatCoeffCanDif, ScatCoeffCan*UpscatCoeffCanDir is used in solution. + ! also, the transmittances and reflectances are linear + ! weights of leaf and stem values. + + CosSolarZenithAngleTmp = max( 0.001, CosSolarZenithAngle ) + LeafOrientIndex = min( max(CanopyOrientIndex, -0.4), 0.6 ) + if ( abs(LeafOrientIndex) <= 0.01 ) LeafOrientIndex = 0.01 + Phi1 = 0.5 - 0.633 * LeafOrientIndex - 0.330 * LeafOrientIndex * LeafOrientIndex + Phi2 = 0.877 * (1.0 - 2.0 * Phi1) + VegAreaProjDir = Phi1 + Phi2 * CosSolarZenithAngleTmp + OpticDepthDir = VegAreaProjDir / CosSolarZenithAngleTmp + OpticDepthDif = (1.0 - Phi1/Phi2 * log( (Phi1+Phi2) / Phi1 )) / Phi2 + ScatCoeffLeaf = ReflectanceVeg(IndSwBnd) + TransmittanceVeg(IndSwBnd) + Tmp0 = VegAreaProjDir + Phi2 * CosSolarZenithAngleTmp + Tmp1 = Phi1 * CosSolarZenithAngleTmp + SingleScatAlb = 0.5 * ScatCoeffLeaf * VegAreaProjDir / Tmp0 * (1.0 - Tmp1/Tmp0 * log((Tmp1+Tmp0)/Tmp1) ) + UpscatCoeffLeafDir = (1.0 + OpticDepthDif * OpticDepthDir) / & + (ScatCoeffLeaf * OpticDepthDif * OpticDepthDir) * SingleScatAlb + UpscatCoeffLeafDif = 0.5 * (ReflectanceVeg(IndSwBnd) + TransmittanceVeg(IndSwBnd) + & + (ReflectanceVeg(IndSwBnd)-TransmittanceVeg(IndSwBnd))*((1.0+LeafOrientIndex)/2.0)**2)/ScatCoeffLeaf + + ! adjust omega, betad, and betai for intercepted snow + if ( TemperatureCanopy > ConstFreezePoint ) then ! no snow on leaf + Tmp0 = ScatCoeffLeaf + Tmp1 = UpscatCoeffLeafDir + Tmp2 = UpscatCoeffLeafDif + else + Tmp0 = (1.0 - CanopyWetFrac) * ScatCoeffLeaf + CanopyWetFrac * ScatterCoeffSnow(IndSwBnd) + Tmp1 = ((1.0 - CanopyWetFrac) * ScatCoeffLeaf * UpscatCoeffLeafDir + & + CanopyWetFrac * ScatterCoeffSnow(IndSwBnd) * UpscatterCoeffSnowDir ) / Tmp0 ! direct + Tmp2 = ((1.0 - CanopyWetFrac) * ScatCoeffLeaf * UpscatCoeffLeafDif + & + CanopyWetFrac * ScatterCoeffSnow(IndSwBnd) * UpscatterCoeffSnowDif ) / Tmp0 ! diffuse + endif + ScatCoeffCan = Tmp0 + UpscatCoeffCanDir = Tmp1 + UpscatCoeffCanDif = Tmp2 + + ! absorbed, reflected, transmitted fluxes per unit incoming radiation + B = 1.0 - ScatCoeffCan + ScatCoeffCan * UpscatCoeffCanDif + C = ScatCoeffCan * UpscatCoeffCanDif + Tmp0 = OpticDepthDif * OpticDepthDir + D = Tmp0 * ScatCoeffCan * UpscatCoeffCanDir + F = Tmp0 * ScatCoeffCan * (1.0 - UpscatCoeffCanDir) + Tmp1 = B * B - C * C + H = sqrt(Tmp1) / OpticDepthDif + Sigma = Tmp0 * Tmp0 - Tmp1 + if ( abs(Sigma) < 1.0e-6 ) Sigma = sign(1.0e-6, Sigma) + P1 = B + OpticDepthDif * H + P2 = B - OpticDepthDif * H + P3 = B + Tmp0 + P4 = B - Tmp0 + S1 = exp( -H * VegAreaIndEff ) + S2 = exp( -OpticDepthDir * VegAreaIndEff ) + if ( IndSwDif == 0 ) then ! direct + U1 = B - C / AlbedoGrdDir(IndSwBnd) + U2 = B - C * AlbedoGrdDir(IndSwBnd) + U3 = F + C * AlbedoGrdDir(IndSwBnd) + else ! diffuse + U1 = B - C / AlbedoGrdDif(IndSwBnd) + U2 = B - C * AlbedoGrdDif(IndSwBnd) + U3 = F + C * AlbedoGrdDif(IndSwBnd) + endif + Tmp2 = U1 - OpticDepthDif * H + Tmp3 = U1 + OpticDepthDif * H + D1 = P1 * Tmp2 / S1 - P2 * Tmp3 * S1 + Tmp4 = U2 + OpticDepthDif * H + Tmp5 = U2 - OpticDepthDif * H + D2 = Tmp4 / S1 - Tmp5 * S1 + H1 = -D * P4 - C * F + Tmp6 = D - H1 * P3 / Sigma + Tmp7 = ( D - C - H1 / Sigma * (U1+Tmp0) ) * S2 + H2 = ( Tmp6 * Tmp2 / S1 - P2 * Tmp7 ) / D1 + H3 = - ( Tmp6 * Tmp3 * S1 - P1 * Tmp7 ) / D1 + H4 = -F * P3 - C * D + Tmp8 = H4 / Sigma + Tmp9 = ( U3 - Tmp8 * (U2-Tmp0) ) * S2 + H5 = - ( Tmp8 * Tmp4 / S1 + Tmp9 ) / D2 + H6 = ( Tmp8 * Tmp5 * S1 + Tmp9 ) / D2 + H7 = (C * Tmp2) / (D1 * S1) + H8 = (-C * Tmp3 * S1) / D1 + H9 = Tmp4 / (D2 * S1) + H10 = (-Tmp5 * S1) / D2 + + ! downward direct and diffuse fluxes below vegetation Niu and Yang (2004), JGR. + if ( IndSwDif == 0 ) then ! direct + RadSwTransDir = S2 * (1.0 - GapCanopyDir) + GapCanopyDir + RadSwTransDif = (H4 * S2 / Sigma + H5 * S1 + H6 / S1) * (1.0 - GapCanopyDir) + else ! diffuse + RadSwTransDir = 0.0 + RadSwTransDif = (H9 * S1 + H10 / S1) * (1.0 - GapCanopyDif) + GapCanopyDif + endif + if ( IndSwDif == 0 ) then ! direct + RadSwDirTranGrdDir(IndSwBnd) = RadSwTransDir + RadSwDifTranGrdDir(IndSwBnd) = RadSwTransDif + else ! diffuse + RadSwDirTranGrdDif(IndSwBnd) = RadSwTransDir + RadSwDifTranGrdDif(IndSwBnd) = RadSwTransDif + endif + + ! flux reflected by the surface (veg. and ground) + if ( IndSwDif == 0 ) then ! direct + RadSwReflTot = (H1 / Sigma + H2 + H3) * (1.0 - GapCanopyDir) + AlbedoGrdDir(IndSwBnd) * GapCanopyDir + RadSwReflCan = (H1 / Sigma + H2 + H3) * (1.0 - GapCanopyDir) + RadSwReflGrd = AlbedoGrdDir(IndSwBnd) * GapCanopyDir + else ! diffuse + RadSwReflTot = (H7 + H8) * (1.0 - GapCanopyDif) + AlbedoGrdDif(IndSwBnd) * GapCanopyDif + RadSwReflCan = (H7 + H8) * (1.0 - GapCanopyDif) + AlbedoGrdDif(IndSwBnd) * GapCanopyDif + RadSwReflGrd = 0 + endif + if ( IndSwDif == 0 ) then ! direct + AlbedoSfcDir(IndSwBnd) = RadSwReflTot + RadSwReflVegDir(IndSwBnd) = RadSwReflCan + RadSwReflGrdDir(IndSwBnd) = RadSwReflGrd + else ! diffuse + AlbedoSfcDif(IndSwBnd) = RadSwReflTot + RadSwReflVegDif(IndSwBnd) = RadSwReflCan + RadSwReflGrdDif(IndSwBnd) = RadSwReflGrd + endif + + ! flux absorbed by vegetation + if ( IndSwDif == 0 ) then ! direct + RadSwAbsVegDir(IndSwBnd) = 1.0 - AlbedoSfcDir(IndSwBnd) - (1.0 - AlbedoGrdDir(IndSwBnd))*RadSwDirTranGrdDir(IndSwBnd) - & + (1.0 - AlbedoGrdDif(IndSwBnd))*RadSwDifTranGrdDir(IndSwBnd) + else ! diffuse + RadSwAbsVegDif(IndSwBnd) = 1.0 - AlbedoSfcDif(IndSwBnd) - (1.0 - AlbedoGrdDir(IndSwBnd))*RadSwDirTranGrdDif(IndSwBnd) - & + (1.0 - AlbedoGrdDif(IndSwBnd))*RadSwDifTranGrdDif(IndSwBnd) + endif + + end associate + + end subroutine CanopyRadiationTwoStream + +end module CanopyRadiationTwoStreamMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/CanopyWaterInterceptMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/CanopyWaterInterceptMod.F90 new file mode 100644 index 0000000000..274d0c2604 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/CanopyWaterInterceptMod.F90 @@ -0,0 +1,155 @@ +module CanopyWaterInterceptMod + +!!! Canopy water processes for snow and rain interception +!!! Subsequent hydrological process for intercepted water is done in CanopyHydrologyMod.F90 + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine CanopyWaterIntercept(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: PRECIP_HEAT +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! The water and heat portions of PRECIP_HEAT are separated in refactored code +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + real(kind=kind_noahmp) :: IceDripFacTemp ! temperature factor for unloading rate + real(kind=kind_noahmp) :: IceDripFacWind ! wind factor for unloading rate + real(kind=kind_noahmp) :: CanopySnowDrip ! canopy snow/ice unloading + +! -------------------------------------------------------------------- + associate( & + SurfaceType => noahmp%config%domain%SurfaceType ,& ! in, surface type 1-soil; 2-lake + MainTimeStep => noahmp%config%domain%MainTimeStep ,& ! in, noahmp main time step [s] + WindEastwardRefHeight => noahmp%forcing%WindEastwardRefHeight ,& ! in, wind speed [m/s] in eastward direction at reference height + WindNorthwardRefHeight => noahmp%forcing%WindNorthwardRefHeight ,& ! in, wind speed [m/s] in northward direction at reference height + LeafAreaIndEff => noahmp%energy%state%LeafAreaIndEff ,& ! in, leaf area index, after burying by snow + StemAreaIndEff => noahmp%energy%state%StemAreaIndEff ,& ! in, stem area index, after burying by snow + VegFrac => noahmp%energy%state%VegFrac ,& ! in, greeness vegetation fraction + TemperatureCanopy => noahmp%energy%state%TemperatureCanopy ,& ! in, vegetation temperature [K] + TemperatureGrd => noahmp%energy%state%TemperatureGrd ,& ! in, ground temperature [K] + CanopyLiqHoldCap => noahmp%water%param%CanopyLiqHoldCap ,& ! in, maximum intercepted liquid water per unit veg area index [mm] + RainfallRefHeight => noahmp%water%flux%RainfallRefHeight ,& ! in, total liquid rainfall [mm/s] before interception + SnowfallRefHeight => noahmp%water%flux%SnowfallRefHeight ,& ! in, total snowfall [mm/s] before interception + SnowfallDensity => noahmp%water%state%SnowfallDensity ,& ! in, bulk density of snowfall [kg/m3] + PrecipAreaFrac => noahmp%water%state%PrecipAreaFrac ,& ! in, fraction of the gridcell that receives precipitation + CanopyLiqWater => noahmp%water%state%CanopyLiqWater ,& ! inout, intercepted canopy liquid water [mm] + CanopyIce => noahmp%water%state%CanopyIce ,& ! inout, intercepted canopy ice [mm] + CanopyWetFrac => noahmp%water%state%CanopyWetFrac ,& ! out, wetted or snowed fraction of the canopy + CanopyTotalWater => noahmp%water%state%CanopyTotalWater ,& ! out, total canopy intercepted water [mm] + CanopyIceMax => noahmp%water%state%CanopyIceMax ,& ! out, canopy capacity for snow interception [mm] + CanopyLiqWaterMax => noahmp%water%state%CanopyLiqWaterMax ,& ! out, canopy capacity for rain interception [mm] + InterceptCanopyRain => noahmp%water%flux%InterceptCanopyRain ,& ! out, interception rate for rain [mm/s] + DripCanopyRain => noahmp%water%flux%DripCanopyRain ,& ! out, drip rate for intercepted rain [mm/s] + ThroughfallRain => noahmp%water%flux%ThroughfallRain ,& ! out, throughfall for rain [mm/s] + InterceptCanopySnow => noahmp%water%flux%InterceptCanopySnow ,& ! out, interception (loading) rate for snowfall [mm/s] + DripCanopySnow => noahmp%water%flux%DripCanopySnow ,& ! out, drip (unloading) rate for intercepted snow [mm/s] + ThroughfallSnow => noahmp%water%flux%ThroughfallSnow ,& ! out, throughfall of snowfall [mm/s] + RainfallGround => noahmp%water%flux%RainfallGround ,& ! out, rainfall at ground surface [mm/s] + SnowfallGround => noahmp%water%flux%SnowfallGround ,& ! out, snowfall at ground surface [mm/s] + SnowDepthIncr => noahmp%water%flux%SnowDepthIncr & ! out, snow depth increasing rate [m/s] due to snowfall + ) +! ---------------------------------------------------------------------- + + ! initialization + InterceptCanopyRain = 0.0 + DripCanopyRain = 0.0 + ThroughfallRain = 0.0 + InterceptCanopySnow = 0.0 + DripCanopySnow = 0.0 + ThroughfallSnow = 0.0 + RainfallGround = 0.0 + SnowfallGround = 0.0 + SnowDepthIncr = 0.0 + CanopySnowDrip = 0.0 + IceDripFacTemp = 0.0 + IceDripFacWind = 0.0 + + ! ----------------------- canopy liquid water ------------------------------ + ! maximum canopy water + CanopyLiqWaterMax = VegFrac * CanopyLiqHoldCap * (LeafAreaIndEff + StemAreaIndEff) + + ! average rain interception and throughfall + if ( (LeafAreaIndEff+StemAreaIndEff) > 0.0 ) then + InterceptCanopyRain = VegFrac * RainfallRefHeight * PrecipAreaFrac ! max interception capability + InterceptCanopyRain = min( InterceptCanopyRain, (CanopyLiqWaterMax-CanopyLiqWater)/MainTimeStep * & + (1.0-exp(-RainfallRefHeight*MainTimeStep/CanopyLiqWaterMax)) ) + InterceptCanopyRain = max( InterceptCanopyRain, 0.0 ) + DripCanopyRain = VegFrac * RainfallRefHeight - InterceptCanopyRain + ThroughfallRain = (1.0 - VegFrac) * RainfallRefHeight + CanopyLiqWater = max( 0.0, CanopyLiqWater + InterceptCanopyRain*MainTimeStep ) + else + InterceptCanopyRain = 0.0 + DripCanopyRain = 0.0 + ThroughfallRain = RainfallRefHeight + if ( CanopyLiqWater > 0.0 ) then ! canopy gets buried by rain + DripCanopyRain = DripCanopyRain + CanopyLiqWater / MainTimeStep + CanopyLiqWater = 0.0 + endif + endif + + ! ----------------------- canopy ice ------------------------------ + ! maximum canopy ice + CanopyIceMax = VegFrac * 6.6 * (0.27 + 46.0/SnowfallDensity) * (LeafAreaIndEff + StemAreaIndEff) + + ! average snow interception and throughfall + if ( (LeafAreaIndEff+StemAreaIndEff) > 0.0 ) then + InterceptCanopySnow = VegFrac * SnowfallRefHeight * PrecipAreaFrac + InterceptCanopySnow = min( InterceptCanopySnow, (CanopyIceMax-CanopyIce)/MainTimeStep * & + (1.0-exp(-SnowfallRefHeight*MainTimeStep/CanopyIceMax)) ) + InterceptCanopySnow = max( InterceptCanopySnow, 0.0 ) + IceDripFacTemp = max( 0.0, (TemperatureCanopy - 270.15) / 1.87e5 ) + IceDripFacWind = sqrt(WindEastwardRefHeight**2.0 + WindNorthwardRefHeight**2.0) / 1.56e5 + ! MB: changed below to reflect the rain assumption that all precip gets intercepted + CanopySnowDrip = max( 0.0, CanopyIce ) * (IceDripFacWind + IceDripFacTemp) + CanopySnowDrip = min( CanopyIce/MainTimeStep + InterceptCanopySnow, CanopySnowDrip) ! add constraint to keep water balance + DripCanopySnow = (VegFrac * SnowfallRefHeight - InterceptCanopySnow) + CanopySnowDrip + ThroughfallSnow = (1.0 - VegFrac) * SnowfallRefHeight + CanopyIce = max( 0.0, CanopyIce + (InterceptCanopySnow-CanopySnowDrip)*MainTimeStep ) + else + InterceptCanopySnow = 0.0 + DripCanopySnow = 0.0 + ThroughfallSnow = SnowfallRefHeight + if ( CanopyIce > 0.0 ) then ! canopy gets buried by snow + DripCanopySnow = DripCanopySnow + CanopyIce / MainTimeStep + CanopyIce = 0.0 + endif + endif + + ! wetted fraction of canopy + if ( CanopyIce > 0.0 ) then + CanopyWetFrac = max( 0.0, CanopyIce ) / max( CanopyIceMax, 1.0e-06 ) + else + CanopyWetFrac = max( 0.0, CanopyLiqWater ) / max( CanopyLiqWaterMax, 1.0e-06 ) + endif + CanopyWetFrac = min( CanopyWetFrac, 1.0 ) ** 0.667 + + ! total canopy water + CanopyTotalWater = CanopyLiqWater + CanopyIce + + ! rain or snow on the ground + RainfallGround = DripCanopyRain + ThroughfallRain + SnowfallGround = DripCanopySnow + ThroughfallSnow + SnowDepthIncr = SnowfallGround / SnowfallDensity + if ( (SurfaceType == 2) .and. (TemperatureGrd > ConstFreezePoint) ) then + SnowfallGround = 0.0 + SnowDepthIncr = 0.0 + endif + + end associate + + end subroutine CanopyWaterIntercept + +end module CanopyWaterInterceptMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/CarbonFluxCropMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/CarbonFluxCropMod.F90 new file mode 100644 index 0000000000..59f6ff10a2 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/CarbonFluxCropMod.F90 @@ -0,0 +1,268 @@ +module CarbonFluxCropMod + +!!! Main Carbon assimilation for crops +!!! based on RE Dickinson et al.(1998), modifed by Guo-Yue Niu, 2004 +!!! Modified by Xing Liu, 2014 + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine CarbonFluxCrop(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: CO2FLUX_CROP +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + real(kind=kind_noahmp) :: DeathCoeffTemp ! temperature stress death coefficient + real(kind=kind_noahmp) :: DeathCoeffWater ! water stress death coefficient + real(kind=kind_noahmp) :: NetPriProdLeafAdd ! leaf assimil after resp. losses removed [gCH2O/m2/s] + real(kind=kind_noahmp) :: NetPriProdStemAdd ! stem assimil after resp. losses removed [gCH2O/m2/s] + !real(kind=kind_noahmp) :: RespTmp, Temp0 ! temperary vars for function below + !RespTmp(Temp0) = exp(0.08 * (Temp0 - 298.16)) ! Respiration as a function of temperature + +!------------------------------------------------------------------------ + associate( & + MainTimeStep => noahmp%config%domain%MainTimeStep ,& ! in, main noahmp timestep [s] + WaterStressCoeff => noahmp%biochem%param%WaterStressCoeff ,& ! in, water stress coeficient + LeafAreaIndexMin => noahmp%biochem%param%LeafAreaIndexMin ,& ! in, minimum leaf area index [m2/m2] + StemAreaIndexMin => noahmp%biochem%param%StemAreaIndexMin ,& ! in, minimum stem area index [m2/m2] + NitrogenConcFoliageMax => noahmp%biochem%param%NitrogenConcFoliageMax ,& ! in, foliage nitrogen concentration when f(n)=1 [%] + RespMaintQ10 => noahmp%biochem%param%RespMaintQ10 ,& ! in, change in maintenance respiration for each 10C temp. change + RespMaintLeaf25C => noahmp%biochem%param%RespMaintLeaf25C ,& ! in, leaf maintenance respiration at 25C [umol CO2/m2/s] + RespMaintRoot25C => noahmp%biochem%param%RespMaintRoot25C ,& ! in, root maintenance respiration at 25C [umol CO2/kgCH2O/s] + RespMaintStem25C => noahmp%biochem%param%RespMaintStem25C ,& ! in, stem maintenance respiration at 25C [umol CO2/kgCH2O/s] + RespMaintGrain25C => noahmp%biochem%param%RespMaintGrain25C ,& ! in, grain maintenance respiration at 25C [umol CO2/kgCH2O/s] + GrowthRespFrac => noahmp%biochem%param%GrowthRespFrac ,& ! in, fraction of growth respiration + CarbohydrFracToLeaf => noahmp%biochem%param%CarbohydrFracToLeaf ,& ! in, fraction of carbohydrate flux to leaf + CarbohydrFracToStem => noahmp%biochem%param%CarbohydrFracToStem ,& ! in, fraction of carbohydrate flux to stem + CarbohydrFracToRoot => noahmp%biochem%param%CarbohydrFracToRoot ,& ! in, fraction of carbohydrate flux to root + CarbohydrFracToGrain => noahmp%biochem%param%CarbohydrFracToGrain ,& ! in, fraction of carbohydrate flux to grain + TurnoverCoeffLeafCrop => noahmp%biochem%param%TurnoverCoeffLeafCrop ,& ! in, leaf turnover coefficient [1/s] for crop + TurnoverCoeffRootCrop => noahmp%biochem%param%TurnoverCoeffRootCrop ,& ! in, root tunrover coefficient [1/s] for crop + TurnoverCoeffStemCrop => noahmp%biochem%param%TurnoverCoeffStemCrop ,& ! in, stem turnover coefficient [1/s] for crop + TemperaureLeafFreeze => noahmp%biochem%param%TemperaureLeafFreeze ,& ! in, characteristic temperature for leaf freezing [K] + LeafDeathWaterCoeffCrop => noahmp%biochem%param%LeafDeathWaterCoeffCrop ,& ! in, coeficient for water leaf stress death [1/s] for crop + LeafDeathTempCoeffCrop => noahmp%biochem%param%LeafDeathTempCoeffCrop ,& ! in, coeficient for temperature leaf stress death [1/s] for crop + CarbohydrLeafToGrain => noahmp%biochem%param%CarbohydrLeafToGrain ,& ! in, fraction of carbohydrate translocation from leaf to grain + CarbohydrStemToGrain => noahmp%biochem%param%CarbohydrStemToGrain ,& ! in, fraction of carbohydrate translocation from stem to grain + CarbohydrRootToGrain => noahmp%biochem%param%CarbohydrRootToGrain ,& ! in, fraction of carbohydrate translocation from root to grain + MicroRespCoeff => noahmp%biochem%param%MicroRespCoeff ,& ! in, microbial respiration parameter [umol CO2/kgC/s] + LeafAreaPerBiomass => noahmp%biochem%param%LeafAreaPerBiomass ,& ! in, leaf area per living leaf biomass [m2/g] + SoilWaterRootZone => noahmp%water%state%SoilWaterRootZone ,& ! in, root zone soil water + SoilWaterStress => noahmp%water%state%SoilWaterStress ,& ! in, water stress coeficient (1.0 for wilting) + PhotosynTotal => noahmp%biochem%flux%PhotosynTotal ,& ! in, total leaf photosynthesis [umol CO2/m2/s] + NitrogenConcFoliage => noahmp%biochem%state%NitrogenConcFoliage ,& ! in, foliage nitrogen concentration [%] + IndexPlanting => noahmp%biochem%state%IndexPlanting ,& ! in, Planting index + PlantGrowStage => noahmp%biochem%state%PlantGrowStage ,& ! in, plant growing stage + TemperatureSoilSnow => noahmp%energy%state%TemperatureSoilSnow ,& ! in, snow and soil layer temperature [K] + TemperatureCanopy => noahmp%energy%state%TemperatureCanopy ,& ! in, vegetation temperature [K] + LeafAreaIndex => noahmp%energy%state%LeafAreaIndex ,& ! inout, leaf area index + StemAreaIndex => noahmp%energy%state%StemAreaIndex ,& ! inout, stem area index + LeafMass => noahmp%biochem%state%LeafMass ,& ! inout, leaf mass [gCH2O/m2] + RootMass => noahmp%biochem%state%RootMass ,& ! inout, mass of fine roots [gCH2O/m2] + StemMass => noahmp%biochem%state%StemMass ,& ! inout, stem mass [gCH2O/m2] + CarbonMassDeepSoil => noahmp%biochem%state%CarbonMassDeepSoil ,& ! inout, stable carbon in deep soil [gC/m2] + CarbonMassShallowSoil => noahmp%biochem%state%CarbonMassShallowSoil ,& ! inout, short-lived carbon in shallow soil [gC/m2] + GrainMass => noahmp%biochem%state%GrainMass ,& ! inout, mass of grain [gCH2O/m2] + RespFacNitrogenFoliage => noahmp%biochem%state%RespFacNitrogenFoliage ,& ! out, foliage nitrogen adjustemt to respiration (<= 1) + MicroRespFactorSoilWater => noahmp%biochem%state%MicroRespFactorSoilWater ,& ! out, soil water factor for microbial respiration + MicroRespFactorSoilTemp => noahmp%biochem%state%MicroRespFactorSoilTemp ,& ! out, soil temperature factor for microbial respiration + LeafMassMin => noahmp%biochem%state%LeafMassMin ,& ! out, minimum leaf mass [gCH2O/m2] + StemMassMin => noahmp%biochem%state%StemMassMin ,& ! out, minimum stem mass [gCH2O/m2] + StemAreaPerMass => noahmp%biochem%state%StemAreaPerMass ,& ! out, stem area per unit mass [m2/g] + RespFacTemperature => noahmp%biochem%state%RespFacTemperature ,& ! out, temperature factor + CarbonMassSoilTot => noahmp%biochem%state%CarbonMassSoilTot ,& ! out, total soil carbon [gC/m2] + CarbonMassLiveTot => noahmp%biochem%state%CarbonMassLiveTot ,& ! out, total living carbon [gC/m2] + CarbonAssim => noahmp%biochem%flux%CarbonAssim ,& ! out, carbon assimilated rate [gC/m2/s] + CarbohydrAssim => noahmp%biochem%flux%CarbohydrAssim ,& ! out, carbohydrate assimilated rate [gCH2O/m2/s] + TurnoverLeaf => noahmp%biochem%flux%TurnoverLeaf ,& ! out, leaf turnover rate [gCH2O/m2/s] + TurnoverStem => noahmp%biochem%flux%TurnoverStem ,& ! out, stem turnover rate [gCH2O/m2/s] + TurnoverRoot => noahmp%biochem%flux%TurnoverRoot ,& ! out, root carbon loss rate by turnover [gCH2O/m2/s] + ConvLeafToGrain => noahmp%biochem%flux%ConvLeafToGrain ,& ! out, leaf to grain conversion [gCH2O/m2] + ConvRootToGrain => noahmp%biochem%flux%ConvRootToGrain ,& ! out, root to grain conversion [gCH2O/m2] + ConvStemToGrain => noahmp%biochem%flux%ConvStemToGrain ,& ! out, stem to grain conversion [gCH2O/m2] + RespirationPlantTot => noahmp%biochem%flux%RespirationPlantTot ,& ! out, total plant respiration [gC/m2/s C] + CarbonToAtmos => noahmp%biochem%flux%CarbonToAtmos ,& ! out, carbon flux to atmosphere [gC/m2/s] + GrossPriProduction => noahmp%biochem%flux%GrossPriProduction ,& ! out, gross primary production [gC/m2/s] + NetPriProductionTot => noahmp%biochem%flux%NetPriProductionTot ,& ! out, total net primary productivity [gC/m2/s] + NetPriProductionLeaf => noahmp%biochem%flux%NetPriProductionLeaf ,& ! out, leaf net primary productivity [gCH2O/m2/s] + NetPriProductionRoot => noahmp%biochem%flux%NetPriProductionRoot ,& ! out, root net primary productivity [gCH2O/m2/s] + NetPriProductionStem => noahmp%biochem%flux%NetPriProductionStem ,& ! out, stem net primary productivity [gCH2O/m2/s] + NetPriProductionGrain => noahmp%biochem%flux%NetPriProductionGrain ,& ! out, grain net primary productivity [gCH2O/m2/s] + NetEcoExchange => noahmp%biochem%flux%NetEcoExchange ,& ! out, net ecosystem exchange [gCO2/m2/s] + GrowthRespGrain => noahmp%biochem%flux%GrowthRespGrain ,& ! out, growth respiration rate for grain [gCH2O/m2/s] + GrowthRespLeaf => noahmp%biochem%flux%GrowthRespLeaf ,& ! out, growth respiration rate for leaf [gCH2O/m2/s] + GrowthRespRoot => noahmp%biochem%flux%GrowthRespRoot ,& ! out, growth respiration rate for root [gCH2O/m2/s] + GrowthRespStem => noahmp%biochem%flux%GrowthRespStem ,& ! out, growth respiration rate for stem [gCH2O/m2/s] + RespirationSoilOrg => noahmp%biochem%flux%RespirationSoilOrg ,& ! out, soil organic respiration rate [gC/m2/s] + LeafMassMaxChg => noahmp%biochem%flux%LeafMassMaxChg ,& ! out, maximum leaf mass available to change [gCH2O/m2/s] + StemMassMaxChg => noahmp%biochem%flux%StemMassMaxChg ,& ! out, maximum steam mass available to change [gCH2O/m2/s] + RespirationLeaf => noahmp%biochem%flux%RespirationLeaf ,& ! out, leaf respiration rate [umol CO2/m2/s] + RespirationStem => noahmp%biochem%flux%RespirationStem ,& ! out, stem respiration rate [gCH2O/m2/s] + RespirationLeafMaint => noahmp%biochem%flux%RespirationLeafMaint ,& ! out, leaf maintenance respiration rate [gCH2O/m2/s] + RespirationRoot => noahmp%biochem%flux%RespirationRoot ,& ! out, fine root respiration rate [gCH2O/m2/s] + RespirationSoil => noahmp%biochem%flux%RespirationSoil ,& ! out, soil respiration rate [gCH2O/m2/s] + RespirationGrain => noahmp%biochem%flux%RespirationGrain ,& ! out, grain respiration rate [gCH2O/m2/s] + DeathLeaf => noahmp%biochem%flux%DeathLeaf ,& ! out, death rate of leaf mass [gCH2O/m2/s] + CarbonDecayToStable => noahmp%biochem%flux%CarbonDecayToStable & ! out, decay rate of fast carbon to slow carbon [gCH2O/m2/s] + ) +!---------------------------------------------------------------------- + + ! initialization + StemAreaPerMass = 3.0 * 0.001 ! m2/kg -->m2/g + LeafMassMin = LeafAreaIndexMin / 0.035 + StemMassMin = StemAreaIndexMin / StemAreaPerMass + + !!! carbon assimilation starts + ! 1 mole -> 12 g carbon or 44 g CO2 or 30 g CH20 + CarbonAssim = PhotosynTotal * 12.0e-6 !*IndexPlanting !umol co2 /m2/ s -> g/m2/s C + CarbohydrAssim = PhotosynTotal * 30.0e-6 !*IndexPlanting !umol co2 /m2/ s -> g/m2/s CH2O + + ! mainteinance respiration + RespFacNitrogenFoliage = min(NitrogenConcFoliage / max(1.0e-06, NitrogenConcFoliageMax), 1.0) + RespFacTemperature = RespMaintQ10**((TemperatureCanopy - 298.16) / 10.0) + RespirationLeaf = RespMaintLeaf25C * RespFacTemperature * RespFacNitrogenFoliage * & + LeafAreaIndex * (1.0 - SoilWaterStress) ! umolCO2/m2/s + RespirationLeafMaint = min((LeafMass - LeafMassMin) / MainTimeStep, RespirationLeaf*30.0e-6) ! gCH2O/m2/s + RespirationRoot = RespMaintRoot25C * (RootMass * 1.0e-3) * RespFacTemperature * 30.0e-6 ! gCH2O/m2/s + RespirationStem = RespMaintStem25C * (StemMass * 1.0e-3) * RespFacTemperature * 30.0e-6 ! gCH2O/m2/s + RespirationGrain = RespMaintGrain25C * (GrainMass * 1.0e-3) * RespFacTemperature * 30.0e-6 ! gCH2O/m2/s + + ! calculate growth respiration for leaf, root and grain + GrowthRespLeaf = max(0.0, GrowthRespFrac * (CarbohydrFracToLeaf(PlantGrowStage)*CarbohydrAssim - RespirationLeafMaint)) ! gCH2O/m2/s + GrowthRespStem = max(0.0, GrowthRespFrac * (CarbohydrFracToStem(PlantGrowStage)*CarbohydrAssim - RespirationStem)) ! gCH2O/m2/s + GrowthRespRoot = max(0.0, GrowthRespFrac * (CarbohydrFracToRoot(PlantGrowStage)*CarbohydrAssim - RespirationRoot)) ! gCH2O/m2/s + GrowthRespGrain = max(0.0, GrowthRespFrac * (CarbohydrFracToGrain(PlantGrowStage)*CarbohydrAssim - RespirationGrain)) ! gCH2O/m2/s + + ! leaf turnover, stem turnover, root turnover and leaf death caused by soil water and soil temperature stress + TurnoverLeaf = TurnoverCoeffLeafCrop(PlantGrowStage) * 1.0e-6 * LeafMass ! gCH2O/m2/s + TurnoverRoot = TurnoverCoeffRootCrop(PlantGrowStage) * 1.0e-6 * RootMass ! gCH2O/m2/s + TurnoverStem = TurnoverCoeffStemCrop(PlantGrowStage) * 1.0e-6 * StemMass ! gCH2O/m2/s + DeathCoeffTemp = exp(-0.3 * max(0.0, TemperatureCanopy-TemperaureLeafFreeze)) * (LeafMass/120.0) + DeathCoeffWater = exp((SoilWaterStress - 1.0) * WaterStressCoeff) + DeathLeaf = LeafMass * 1.0e-6 * (LeafDeathWaterCoeffCrop(PlantGrowStage) * DeathCoeffWater + & + LeafDeathTempCoeffCrop(PlantGrowStage) * DeathCoeffTemp) ! gCH2O/m2/s + + ! Allocation of CarbohydrAssim to leaf, stem, root and grain at each growth stage + !NetPriProdLeafAdd = max(0.0, CarbohydrFracToLeaf(PlantGrowStage)*CarbohydrAssim - GrowthRespLeaf - RespirationLeafMaint) ! gCH2O/m2/s + NetPriProdLeafAdd = CarbohydrFracToLeaf(PlantGrowStage)*CarbohydrAssim - GrowthRespLeaf - RespirationLeafMaint ! gCH2O/m2/s + !NetPriProdStemAdd = max(0.0, CarbohydrFracToStem(PlantGrowStage)*CarbohydrAssim - GrowthRespStem - RespirationStem) ! gCH2O/m2/s + NetPriProdStemAdd = CarbohydrFracToStem(PlantGrowStage)*CarbohydrAssim - GrowthRespStem - RespirationStem ! gCH2O/m2/s + + ! avoid reducing leaf mass below its minimum value but conserve mass + LeafMassMaxChg = (LeafMass - LeafMassMin) / MainTimeStep ! gCH2O/m2/s + StemMassMaxChg = (StemMass - StemMassMin) / MainTimeStep ! gCH2O/m2/s + TurnoverLeaf = min(TurnoverLeaf, LeafMassMaxChg+NetPriProdLeafAdd) ! gCH2O/m2/s + TurnoverStem = min(TurnoverStem, StemMassMaxChg+NetPriProdStemAdd) ! gCH2O/m2/s + DeathLeaf = min(DeathLeaf, LeafMassMaxChg+NetPriProdLeafAdd-TurnoverLeaf) ! gCH2O/m2/s + + ! net primary productivities + !NetPriProductionLeaf = max(NetPriProdLeafAdd, -LeafMassMaxChg) ! gCH2O/m2/s + NetPriProductionLeaf = NetPriProdLeafAdd ! gCH2O/m2/s + !NetPriProductionStem = max(NetPriProdStemAdd, -StemMassMaxChg) ! gCH2O/m2/s + NetPriProductionStem = NetPriProdStemAdd ! gCH2O/m2/s + NetPriProductionRoot = CarbohydrFracToRoot(PlantGrowStage) * CarbohydrAssim - RespirationRoot - GrowthRespRoot ! gCH2O/m2/s + NetPriProductionGrain = CarbohydrFracToGrain(PlantGrowStage) * CarbohydrAssim - RespirationGrain - GrowthRespGrain ! gCH2O/m2/s + + ! masses of plant components + LeafMass = LeafMass + (NetPriProductionLeaf - TurnoverLeaf - DeathLeaf) * MainTimeStep ! gCH2O/m2 + StemMass = StemMass + (NetPriProductionStem - TurnoverStem) * MainTimeStep ! gCH2O/m2 + RootMass = RootMass + (NetPriProductionRoot - TurnoverRoot) * MainTimeStep ! gCH2O/m2 + GrainMass = GrainMass + NetPriProductionGrain * MainTimeStep ! gCH2O/m2 + GrossPriProduction = CarbohydrAssim * 0.4 ! gC/m2/s 0.4=12/30, CH20 to C + + ! carbon convert to grain ! Zhe Zhang 2020-07-13 + ConvLeafToGrain = 0.0 + ConvStemToGrain = 0.0 + ConvRootToGrain = 0.0 + ConvLeafToGrain = LeafMass * (CarbohydrLeafToGrain(PlantGrowStage) * MainTimeStep / 3600.0) ! gCH2O/m2 + ConvStemToGrain = StemMass * (CarbohydrStemToGrain(PlantGrowStage) * MainTimeStep / 3600.0) ! gCH2O/m2 + ConvRootToGrain = RootMass * (CarbohydrRootToGrain(PlantGrowStage) * MainTimeStep / 3600.0) ! gCH2O/m2 + LeafMass = LeafMass - ConvLeafToGrain ! gCH2O/m2 + StemMass = StemMass - ConvStemToGrain ! gCH2O/m2 + RootMass = RootMass - ConvRootToGrain ! gCH2O/m2 + GrainMass = GrainMass + ConvStemToGrain + ConvRootToGrain + ConvLeafToGrain ! gCH2O/m2 + !if ( PlantGrowStage==6 ) then + ! ConvStemToGrain = StemMass * (0.00005 * MainTimeStep / 3600.0) ! gCH2O/m2 + ! StemMass = StemMass - ConvStemToGrain ! gCH2O/m2 + ! ConvRootToGrain = RootMass * (0.0005 * MainTimeStep / 3600.0) ! gCH2O/m2 + ! RootMass = RootMass - ConvRootToGrain ! gCH2O/m2 + ! GrainMass = GrainMass + ConvStemToGrain + ConvRootToGrain ! gCH2O/m2 + !endif + + if ( RootMass < 0.0 ) then + TurnoverRoot = NetPriProductionRoot + RootMass = 0.0 + endif + if ( GrainMass < 0.0 ) then + GrainMass = 0.0 + endif + + ! soil carbon budgets + !if ( (PlantGrowStage == 1) .or. (PlantGrowStage == 2) .or. (PlantGrowStage == 8) ) then + ! CarbonMassShallowSoil = 1000 + !else + CarbonMassShallowSoil = CarbonMassShallowSoil + & + (TurnoverRoot+TurnoverLeaf+TurnoverStem+DeathLeaf) * MainTimeStep * 0.4 ! 0.4: gCH2O/m2 -> gC/m2 + !endif + MicroRespFactorSoilTemp = 2.0**((TemperatureSoilSnow(1) - 283.16) / 10.0) + MicroRespFactorSoilWater = SoilWaterRootZone / (0.20 + SoilWaterRootZone) * 0.23 / (0.23 + SoilWaterRootZone) + RespirationSoil = MicroRespFactorSoilWater * MicroRespFactorSoilTemp * & + MicroRespCoeff * max(0.0, CarbonMassShallowSoil*1.0e-3) * 30.0e-6 ! gCH2O/m2/s + CarbonDecayToStable = 0.1 * RespirationSoil ! gCH2O/m2/s + CarbonMassShallowSoil = CarbonMassShallowSoil - (RespirationSoil + CarbonDecayToStable) * MainTimeStep * 0.4 ! 0.4: gCH2O/m2 -> gC/m2 + CarbonMassDeepSoil = CarbonMassDeepSoil + CarbonDecayToStable * MainTimeStep * 0.4 ! 0.4: gCH2O/m2 -> gC/m2 + + ! total carbon flux + CarbonToAtmos = - CarbonAssim + (RespirationLeafMaint + RespirationRoot + RespirationStem + RespirationGrain + & + 0.9*RespirationSoil + GrowthRespLeaf + GrowthRespRoot + GrowthRespStem + GrowthRespGrain) * 0.4 ! gC/m2/s 0.4=12/30, CH20 to C + + ! for outputs + NetPriProductionTot = (NetPriProductionLeaf + NetPriProductionStem + & + NetPriProductionRoot + NetPriProductionGrain) * 0.4 ! gC/m2/s 0.4=12/30, CH20 to C + RespirationPlantTot = (RespirationRoot + RespirationGrain + RespirationLeafMaint + RespirationStem + & + GrowthRespLeaf + GrowthRespRoot + GrowthRespGrain + GrowthRespStem) * 0.4 ! gC/m2/s 0.4=12/30, CH20 to C + RespirationSoilOrg = 0.9 * RespirationSoil * 0.4 ! gC/m2/s 0.4=12/30, CH20 to C + NetEcoExchange = (RespirationPlantTot + RespirationSoilOrg - GrossPriProduction) * 44.0 / 12.0 ! gCO2/m2/s + CarbonMassSoilTot = CarbonMassShallowSoil + CarbonMassDeepSoil ! gC/m2 + CarbonMassLiveTot = (LeafMass + RootMass + StemMass + GrainMass) * 0.4 ! gC/m2 0.4=12/30, CH20 to C + + ! leaf area index and stem area index + LeafAreaIndex = max(LeafMass*LeafAreaPerBiomass, LeafAreaIndexMin) + StemAreaIndex = max(StemMass*StemAreaPerMass, StemAreaIndexMin) + + ! After harversting + !if ( PlantGrowStage == 8 ) then + ! LeafMass = 0.62 + ! StemMass = 0.0 + ! GrainMass = 0.0 + !endif + + !if ( (PlantGrowStage == 1) .or. (PlantGrowStage == 2) .or. (PlantGrowStage == 8) ) then + if ( (PlantGrowStage == 8) .and. & + ((GrainMass > 0) .or. (LeafMass > 0) .or. (StemMass > 0) .or. (RootMass > 0)) ) then + LeafAreaIndex = 0.05 + StemAreaIndex = 0.05 + LeafMass = LeafMassMin + StemMass = StemMassMin + RootMass = 0.0 + GrainMass = 0.0 + endif + + end associate + + end subroutine CarbonFluxCrop + +end module CarbonFluxCropMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/CarbonFluxNatureVegMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/CarbonFluxNatureVegMod.F90 new file mode 100644 index 0000000000..38dc8b0793 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/CarbonFluxNatureVegMod.F90 @@ -0,0 +1,248 @@ +module CarbonFluxNatureVegMod + +!!! Main Carbon assimilation for natural/generic vegetation +!!! based on RE Dickinson et al.(1998), modifed by Guo-Yue Niu, 2004 + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine CarbonFluxNatureVeg(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: CO2FLUX +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variables + real(kind=kind_noahmp) :: DeathCoeffTemp ! temperature stress death coefficient + real(kind=kind_noahmp) :: DeathCoeffWater ! water stress death coefficient + real(kind=kind_noahmp) :: NetPriProdLeafAdd ! leaf assimil after resp. losses removed [gC/m2/s] + real(kind=kind_noahmp) :: NetPriProdStemAdd ! stem assimil after resp. losses removed [gC/m2/s] + real(kind=kind_noahmp) :: RespTmp, Temp0 ! temperary vars for function below + RespTmp(Temp0) = exp(0.08 * (Temp0 - 298.16)) ! Respiration as a function of temperature + +!------------------------------------------------------------------------ + associate( & + VegType => noahmp%config%domain%VegType ,& ! in, vegetation type + MainTimeStep => noahmp%config%domain%MainTimeStep ,& ! in, main noahmp timestep [s] + IndexEBLForest => noahmp%config%domain%IndexEBLForest ,& ! in, flag for Evergreen Broadleaf Forest + WoodToRootRatio => noahmp%biochem%param%WoodToRootRatio ,& ! in, wood to root ratio + TurnoverCoeffLeafVeg => noahmp%biochem%param%TurnoverCoeffLeafVeg ,& ! in, leaf turnover coefficient [1/s] for generic vegetation + TemperaureLeafFreeze => noahmp%biochem%param%TemperaureLeafFreeze ,& ! in, characteristic temperature for leaf freezing [K] + LeafDeathWaterCoeffVeg => noahmp%biochem%param%LeafDeathWaterCoeffVeg ,& ! in, coeficient for leaf water stress death [1/s] for generic veg + LeafDeathTempCoeffVeg => noahmp%biochem%param%LeafDeathTempCoeffVeg ,& ! in, coeficient for leaf temp. stress death [1/s] for generic veg + GrowthRespFrac => noahmp%biochem%param%GrowthRespFrac ,& ! in, fraction of growth respiration + TemperatureMinPhotosyn => noahmp%biochem%param%TemperatureMinPhotosyn ,& ! in, minimum temperature for photosynthesis [K] + MicroRespCoeff => noahmp%biochem%param%MicroRespCoeff ,& ! in, microbial respiration parameter [umol CO2/kgC/s] + NitrogenConcFoliageMax => noahmp%biochem%param%NitrogenConcFoliageMax ,& ! in, foliage nitrogen concentration when f(n)=1 (%) + RespMaintQ10 => noahmp%biochem%param%RespMaintQ10 ,& ! in, q10 for maintenance respiration + RespMaintLeaf25C => noahmp%biochem%param%RespMaintLeaf25C ,& ! in, leaf maintenance respiration at 25c [umol CO2/m2/s] + RespMaintRoot25C => noahmp%biochem%param%RespMaintRoot25C ,& ! in, root maintenance respiration at 25c [umol CO2/kgC/s] + RespMaintStem25C => noahmp%biochem%param%RespMaintStem25C ,& ! in, stem maintenance respiration at 25c [umol CO2/kgC/s] + WoodPoolIndex => noahmp%biochem%param%WoodPoolIndex ,& ! in, wood pool index (0~1) depending on woody or not + TurnoverCoeffRootVeg => noahmp%biochem%param%TurnoverCoeffRootVeg ,& ! in, root turnover coefficient [1/s] for generic vegetation + WoodRespCoeff => noahmp%biochem%param%WoodRespCoeff ,& ! in, wood respiration coeficient [1/s] + WoodAllocFac => noahmp%biochem%param%WoodAllocFac ,& ! in, parameter for present wood allocation + WaterStressCoeff => noahmp%biochem%param%WaterStressCoeff ,& ! in, water stress coeficient + LeafAreaIndexMin => noahmp%biochem%param%LeafAreaIndexMin ,& ! in, minimum leaf area index [m2/m2] + StemAreaIndexMin => noahmp%biochem%param%StemAreaIndexMin ,& ! in, minimum stem area index [m2/m2] + IndexGrowSeason => noahmp%biochem%state%IndexGrowSeason ,& ! in, growing season index (0=off, 1=on) + NitrogenConcFoliage => noahmp%biochem%state%NitrogenConcFoliage ,& ! in, foliage nitrogen concentration [%] + LeafAreaPerMass => noahmp%biochem%state%LeafAreaPerMass ,& ! in, leaf area per unit mass [m2/g] + PhotosynTotal => noahmp%biochem%flux%PhotosynTotal ,& ! in, total leaf photosynthesis [umolCO2/m2/s] + SoilWaterRootZone => noahmp%water%state%SoilWaterRootZone ,& ! in, root zone soil water + SoilWaterStress => noahmp%water%state%SoilWaterStress ,& ! in, water stress coeficient (1.0 for wilting) + TemperatureSoilSnow => noahmp%energy%state%TemperatureSoilSnow ,& ! in, snow and soil layer temperature [K] + TemperatureCanopy => noahmp%energy%state%TemperatureCanopy ,& ! in, vegetation temperature [K] + LeafAreaIndex => noahmp%energy%state%LeafAreaIndex ,& ! inout, leaf area index + StemAreaIndex => noahmp%energy%state%StemAreaIndex ,& ! inout, stem area index + LeafMass => noahmp%biochem%state%LeafMass ,& ! inout, leaf mass [gC/m2] + RootMass => noahmp%biochem%state%RootMass ,& ! inout, mass of fine roots [gC/m2] + StemMass => noahmp%biochem%state%StemMass ,& ! inout, stem mass [gC/m2] + WoodMass => noahmp%biochem%state%WoodMass ,& ! inout, mass of wood (incl. woody roots) [gC/m2] + CarbonMassDeepSoil => noahmp%biochem%state%CarbonMassDeepSoil ,& ! inout, stable carbon in deep soil [gC/m2] + CarbonMassShallowSoil => noahmp%biochem%state%CarbonMassShallowSoil ,& ! inout, short-lived carbon in shallow soil [gC/m2] + CarbonMassSoilTot => noahmp%biochem%state%CarbonMassSoilTot ,& ! out, total soil carbon [gC/m2] + CarbonMassLiveTot => noahmp%biochem%state%CarbonMassLiveTot ,& ! out, total living carbon ([gC/m2] + LeafMassMin => noahmp%biochem%state%LeafMassMin ,& ! out, minimum leaf mass [gC/m2] + CarbonFracToLeaf => noahmp%biochem%state%CarbonFracToLeaf ,& ! out, fraction of carbon allocated to leaves + WoodCarbonFrac => noahmp%biochem%state%WoodCarbonFrac ,& ! out, calculated wood to root ratio + CarbonFracToWoodRoot => noahmp%biochem%state%CarbonFracToWoodRoot ,& ! out, fraction of carbon to root and wood + CarbonFracToRoot => noahmp%biochem%state%CarbonFracToRoot ,& ! out, fraction of carbon flux to roots + CarbonFracToWood => noahmp%biochem%state%CarbonFracToWood ,& ! out, fraction of carbon flux to wood + CarbonFracToStem => noahmp%biochem%state%CarbonFracToStem ,& ! out, fraction of carbon flux to stem + MicroRespFactorSoilWater => noahmp%biochem%state%MicroRespFactorSoilWater ,& ! out, soil water factor for microbial respiration + MicroRespFactorSoilTemp => noahmp%biochem%state%MicroRespFactorSoilTemp ,& ! out, soil temperature factor for microbial respiration + RespFacNitrogenFoliage => noahmp%biochem%state%RespFacNitrogenFoliage ,& ! out, foliage nitrogen adjustemt to respiration (<= 1) + RespFacTemperature => noahmp%biochem%state%RespFacTemperature ,& ! out, temperature factor + RespReductionFac => noahmp%biochem%state%RespReductionFac ,& ! out, respiration reduction factor (<= 1) + StemMassMin => noahmp%biochem%state%StemMassMin ,& ! out, minimum stem mass [gC/m2] + StemAreaPerMass => noahmp%biochem%state%StemAreaPerMass ,& ! out, stem area per unit mass [m2/g] + CarbonAssim => noahmp%biochem%flux%CarbonAssim ,& ! out, carbon assimilated rate [gC/m2/s] + GrossPriProduction => noahmp%biochem%flux%GrossPriProduction ,& ! out, gross primary production [gC/m2/s] + NetPriProductionTot => noahmp%biochem%flux%NetPriProductionTot ,& ! out, total net primary productivity [gC/m2/s] + NetEcoExchange => noahmp%biochem%flux%NetEcoExchange ,& ! out, net ecosystem exchange [gCO2/m2/s] + RespirationPlantTot => noahmp%biochem%flux%RespirationPlantTot ,& ! out, total plant respiration [gC/m2/s] + RespirationSoilOrg => noahmp%biochem%flux%RespirationSoilOrg ,& ! out, soil organic respiration [gC/m2/s] + CarbonToAtmos => noahmp%biochem%flux%CarbonToAtmos ,& ! out, carbon flux to atmosphere [gC/m2/s] + NetPriProductionLeaf => noahmp%biochem%flux%NetPriProductionLeaf ,& ! out, leaf net primary productivity [gC/m2/s] + NetPriProductionRoot => noahmp%biochem%flux%NetPriProductionRoot ,& ! out, root net primary productivity [gC/m2/s] + NetPriProductionWood => noahmp%biochem%flux%NetPriProductionWood ,& ! out, wood net primary productivity [gC/m2/s] + NetPriProductionStem => noahmp%biochem%flux%NetPriProductionStem ,& ! out, stem net primary productivity [gC/m2/s] + GrowthRespLeaf => noahmp%biochem%flux%GrowthRespLeaf ,& ! out, growth respiration rate for leaf [gC/m2/s] + GrowthRespRoot => noahmp%biochem%flux%GrowthRespRoot ,& ! out, growth respiration rate for root [gC/m2/s] + GrowthRespWood => noahmp%biochem%flux%GrowthRespWood ,& ! out, growth respiration rate for wood [gC/m2/s] + GrowthRespStem => noahmp%biochem%flux%GrowthRespStem ,& ! out, growth respiration rate for stem [gC/m2/s] + LeafMassMaxChg => noahmp%biochem%flux%LeafMassMaxChg ,& ! out, maximum leaf mass available to change [gC/m2/s] + CarbonDecayToStable => noahmp%biochem%flux%CarbonDecayToStable ,& ! out, decay rate of fast carbon to slow carbon [gC/m2/s] + RespirationLeaf => noahmp%biochem%flux%RespirationLeaf ,& ! out, leaf respiration rate [umol CO2/m2/s] + RespirationStem => noahmp%biochem%flux%RespirationStem ,& ! out, stem respiration rate [gC/m2/s] + RespirationWood => noahmp%biochem%flux%RespirationWood ,& ! out, wood respiration rate [gC/m2/s] + RespirationLeafMaint => noahmp%biochem%flux%RespirationLeafMaint ,& ! out, leaf maintenance respiration rate [gC/m2/s] + RespirationRoot => noahmp%biochem%flux%RespirationRoot ,& ! out, fine root respiration rate [gC/m2/s] + RespirationSoil => noahmp%biochem%flux%RespirationSoil ,& ! out, soil respiration rate [gC/m2/s] + DeathLeaf => noahmp%biochem%flux%DeathLeaf ,& ! out, death rate of leaf mass [gC/m2/s] + DeathStem => noahmp%biochem%flux%DeathStem ,& ! out, death rate of stem mass [gC/m2/s] + TurnoverLeaf => noahmp%biochem%flux%TurnoverLeaf ,& ! out, leaf turnover rate [gC/m2/s] + TurnoverStem => noahmp%biochem%flux%TurnoverStem ,& ! out, stem turnover rate [gC/m2/s] + TurnoverWood => noahmp%biochem%flux%TurnoverWood ,& ! out, wood turnover rate [gC/m2/s] + TurnoverRoot => noahmp%biochem%flux%TurnoverRoot ,& ! out, root turnover rate [gC/m2/s] + StemMassMaxChg => noahmp%biochem%flux%StemMassMaxChg & ! out, maximum steam mass available to change [gC/m2/s] + ) +!----------------------------------------------------------------------- + + ! initialization + StemAreaPerMass = 3.0 * 0.001 ! m2/kg -->m2/g + LeafMassMin = LeafAreaIndexMin / LeafAreaPerMass ! gC/m2 + StemMassMin = StemAreaIndexMin / StemAreaPerMass ! gC/m2 + + ! respiration + if ( IndexGrowSeason == 0.0 ) then + RespReductionFac = 0.5 + else + RespReductionFac = 1.0 + endif + RespFacNitrogenFoliage = min(NitrogenConcFoliage / max(1.0e-06,NitrogenConcFoliageMax), 1.0) + RespFacTemperature = RespMaintQ10**((TemperatureCanopy - 298.16) / 10.0) + RespirationLeaf = RespMaintLeaf25C * RespFacTemperature * RespFacNitrogenFoliage * & + LeafAreaIndex * RespReductionFac * (1.0 - SoilWaterStress) ! umol CO2/m2/s + RespirationLeafMaint = min((LeafMass-LeafMassMin)/MainTimeStep, RespirationLeaf*12.0e-6) ! gC/m2/s + RespirationRoot = RespMaintRoot25C * (RootMass*1.0e-3) * RespFacTemperature * RespReductionFac * 12.0e-6 ! gC/m2/s + RespirationStem = RespMaintStem25C * ((StemMass-StemMassMin) * 1.0e-3) * & + RespFacTemperature * RespReductionFac * 12.0e-6 ! gC/m2/s + RespirationWood = WoodRespCoeff * RespTmp(TemperatureCanopy) * WoodMass * WoodPoolIndex ! gC/m2/s + + !!! carbon assimilation start + ! 1 mole -> 12 g carbon or 44 g CO2; 1 umol -> 12.e-6 g carbon; + CarbonAssim = PhotosynTotal * 12.0e-6 ! umol CO2/m2/s -> gC/m2/s + + ! fraction of carbon into leaf versus nonleaf + CarbonFracToLeaf = exp(0.01 * (1.0 - exp(0.75*LeafAreaIndex)) * LeafAreaIndex) + if ( VegType == IndexEBLForest ) CarbonFracToLeaf = exp(0.01 * (1.0 - exp(0.50*LeafAreaIndex)) * LeafAreaIndex) + CarbonFracToWoodRoot = 1.0 - CarbonFracToLeaf + CarbonFracToStem = LeafAreaIndex / 10.0 * CarbonFracToLeaf + CarbonFracToLeaf = CarbonFracToLeaf - CarbonFracToStem + + ! fraction of carbon into wood versus root + if ( WoodMass > 1.0e-6 ) then + WoodCarbonFrac = (1.0 - exp(-WoodAllocFac * (WoodToRootRatio*RootMass/WoodMass)) / WoodAllocFac) * WoodPoolIndex + else + WoodCarbonFrac = WoodPoolIndex + endif + CarbonFracToRoot = CarbonFracToWoodRoot * (1.0 - WoodCarbonFrac) + CarbonFracToWood = CarbonFracToWoodRoot * WoodCarbonFrac + + ! leaf and root turnover per time step + TurnoverLeaf = TurnoverCoeffLeafVeg * 5.0e-7 * LeafMass ! gC/m2/s + TurnoverStem = TurnoverCoeffLeafVeg * 5.0e-7 * StemMass ! gC/m2/s + TurnoverRoot = TurnoverCoeffRootVeg * RootMass ! gC/m2/s + TurnoverWood = 9.5e-10 * WoodMass ! gC/m2/s + + ! seasonal leaf die rate dependent on temp and water stress + ! water stress is set to 1 at permanent wilting point + DeathCoeffTemp = exp(-0.3 * max(0.0, TemperatureCanopy-TemperaureLeafFreeze)) * (LeafMass / 120.0) + DeathCoeffWater = exp((SoilWaterStress - 1.0) * WaterStressCoeff) + DeathLeaf = LeafMass * 1.0e-6 * (LeafDeathWaterCoeffVeg * DeathCoeffWater + LeafDeathTempCoeffVeg * DeathCoeffTemp) ! gC/m2/s + DeathStem = StemMass * 1.0e-6 * (LeafDeathWaterCoeffVeg * DeathCoeffWater + LeafDeathTempCoeffVeg * DeathCoeffTemp) ! gC/m2/s + + ! calculate growth respiration for leaf, root and wood + GrowthRespLeaf = max(0.0, GrowthRespFrac * (CarbonFracToLeaf*CarbonAssim - RespirationLeafMaint)) ! gC/m2/s + GrowthRespStem = max(0.0, GrowthRespFrac * (CarbonFracToStem*CarbonAssim - RespirationStem)) ! gC/m2/s + GrowthRespRoot = max(0.0, GrowthRespFrac * (CarbonFracToRoot*CarbonAssim - RespirationRoot)) ! gC/m2/s + GrowthRespWood = max(0.0, GrowthRespFrac * (CarbonFracToWood*CarbonAssim - RespirationWood)) ! gC/m2/s + + ! Impose lower T limit for photosynthesis + NetPriProdLeafAdd = max(0.0, CarbonFracToLeaf*CarbonAssim - GrowthRespLeaf - RespirationLeafMaint) ! gC/m2/s + NetPriProdStemAdd = max(0.0, CarbonFracToStem*CarbonAssim - GrowthRespStem - RespirationStem) ! gC/m2/s + !NetPriProdLeafAdd = CarbonFracToLeaf*CarbonAssim - GrowthRespLeaf - RespirationLeafMaint ! MB: test Kjetil + !NetPriProdStemAdd = CarbonFracToStem*CarbonAssim - GrowthRespStem - RespirationStem ! MB: test Kjetil + if ( TemperatureCanopy < TemperatureMinPhotosyn ) NetPriProdLeafAdd = 0.0 + if ( TemperatureCanopy < TemperatureMinPhotosyn ) NetPriProdStemAdd = 0.0 + + ! update leaf, root, and wood carbon + ! avoid reducing leaf mass below its minimum value but conserve mass + LeafMassMaxChg = (LeafMass - LeafMassMin) / MainTimeStep ! gC/m2/s + StemMassMaxChg = (StemMass - StemMassMin) / MainTimeStep ! gC/m2/s + DeathLeaf = min(DeathLeaf, LeafMassMaxChg+NetPriProdLeafAdd-TurnoverLeaf) ! gC/m2/s + DeathStem = min(DeathStem, StemMassMaxChg+NetPriProdStemAdd-TurnoverStem) ! gC/m2/s + + ! net primary productivities + NetPriProductionLeaf = max(NetPriProdLeafAdd, -LeafMassMaxChg) ! gC/m2/s + NetPriProductionStem = max(NetPriProdStemAdd, -StemMassMaxChg) ! gC/m2/s + NetPriProductionRoot = CarbonFracToRoot * CarbonAssim - RespirationRoot - GrowthRespRoot ! gC/m2/s + NetPriProductionWood = CarbonFracToWood * CarbonAssim - RespirationWood - GrowthRespWood ! gC/m2/s + + ! masses of plant components + LeafMass = LeafMass + (NetPriProductionLeaf - TurnoverLeaf - DeathLeaf) * MainTimeStep ! gC/m2 + StemMass = StemMass + (NetPriProductionStem - TurnoverStem - DeathStem) * MainTimeStep ! gC/m2 + RootMass = RootMass + (NetPriProductionRoot - TurnoverRoot) * MainTimeStep ! gC/m2 + if ( RootMass < 0.0 ) then + TurnoverRoot = NetPriProductionRoot + RootMass = 0.0 + endif + WoodMass = (WoodMass + (NetPriProductionWood - TurnoverWood) * MainTimeStep ) * WoodPoolIndex ! gC/m2 + + ! soil carbon budgets + CarbonMassShallowSoil = CarbonMassShallowSoil + & + (TurnoverRoot+TurnoverLeaf+TurnoverStem+TurnoverWood+DeathLeaf+DeathStem) * MainTimeStep ! gC/m2, MB: add DeathStem v3.7 + MicroRespFactorSoilTemp = 2.0**( (TemperatureSoilSnow(1) - 283.16) / 10.0 ) + MicroRespFactorSoilWater = SoilWaterRootZone / (0.20 + SoilWaterRootZone) * 0.23 / (0.23 + SoilWaterRootZone) + RespirationSoil = MicroRespFactorSoilWater * MicroRespFactorSoilTemp * & + MicroRespCoeff * max(0.0, CarbonMassShallowSoil*1.0e-3) * 12.0e-6 ! gC/m2/s + CarbonDecayToStable = 0.1 * RespirationSoil ! gC/m2/s + CarbonMassShallowSoil = CarbonMassShallowSoil - (RespirationSoil + CarbonDecayToStable) * MainTimeStep ! gC/m2 + CarbonMassDeepSoil = CarbonMassDeepSoil + CarbonDecayToStable * MainTimeStep ! gC/m2 + + ! total carbon flux ! MB: add RespirationStem,GrowthRespStem,0.9*RespirationSoil v3.7 + CarbonToAtmos = - CarbonAssim + RespirationLeafMaint + RespirationRoot + RespirationWood + RespirationStem + & + 0.9*RespirationSoil + GrowthRespLeaf + GrowthRespRoot + GrowthRespWood + GrowthRespStem ! gC/m2/s + + ! for outputs ! MB: add RespirationStem, GrowthRespStem in RespirationPlantTot v3.7 + GrossPriProduction = CarbonAssim ! gC/m2/s + NetPriProductionTot = NetPriProductionLeaf + NetPriProductionWood + NetPriProductionRoot + NetPriProductionStem ! gC/m2/s + RespirationPlantTot = RespirationRoot + RespirationWood + RespirationLeafMaint + RespirationStem + & + GrowthRespLeaf + GrowthRespRoot + GrowthRespWood + GrowthRespStem ! gC/m2/s + RespirationSoilOrg = 0.9 * RespirationSoil ! gC/m2/s MB: add 0.9* v3.7 + NetEcoExchange = (RespirationPlantTot + RespirationSoilOrg - GrossPriProduction) * 44.0 / 12.0 ! gCO2/m2/s + CarbonMassSoilTot = CarbonMassShallowSoil + CarbonMassDeepSoil ! gC/m2 + CarbonMassLiveTot = LeafMass + RootMass + StemMass + WoodMass ! gC/m2 MB: add StemMass v3.7 + + ! leaf area index and stem area index + LeafAreaIndex = max(LeafMass*LeafAreaPerMass, LeafAreaIndexMin) + StemAreaIndex = max(StemMass*StemAreaPerMass, StemAreaIndexMin) + + end associate + + end subroutine CarbonFluxNatureVeg + +end module CarbonFluxNatureVegMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/ConfigVarInitMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/ConfigVarInitMod.F90 new file mode 100644 index 0000000000..5c8af537b0 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/ConfigVarInitMod.F90 @@ -0,0 +1,89 @@ +module ConfigVarInitMod + +!!! Initialize column (1-D) Noah-MP configuration variables +!!! Configuration variables should be first defined in ConfigVarType.F90 + +! ------------------------ Code history ------------------------------------ +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! -------------------------------------------------------------------------- + + use Machine + use NoahmpVarType + + implicit none + +contains + +!=== initialize with default values + subroutine ConfigVarInitDefault(noahmp) + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + + ! config namelist variable + noahmp%config%nmlist%OptDynamicVeg = undefined_int + noahmp%config%nmlist%OptRainSnowPartition = undefined_int + noahmp%config%nmlist%OptSoilWaterTranspiration = undefined_int + noahmp%config%nmlist%OptGroundResistanceEvap = undefined_int + noahmp%config%nmlist%OptSurfaceDrag = undefined_int + noahmp%config%nmlist%OptStomataResistance = undefined_int + noahmp%config%nmlist%OptSnowAlbedo = undefined_int + noahmp%config%nmlist%OptCanopyRadiationTransfer = undefined_int + noahmp%config%nmlist%OptSnowSoilTempTime = undefined_int + noahmp%config%nmlist%OptSnowThermConduct = undefined_int + noahmp%config%nmlist%OptSoilTemperatureBottom = undefined_int + noahmp%config%nmlist%OptSoilSupercoolWater = undefined_int + noahmp%config%nmlist%OptRunoffSurface = undefined_int + noahmp%config%nmlist%OptRunoffSubsurface = undefined_int + noahmp%config%nmlist%OptSoilPermeabilityFrozen = undefined_int + noahmp%config%nmlist%OptDynVicInfiltration = undefined_int + noahmp%config%nmlist%OptTileDrainage = undefined_int + noahmp%config%nmlist%OptIrrigation = undefined_int + noahmp%config%nmlist%OptIrrigationMethod = undefined_int + noahmp%config%nmlist%OptCropModel = undefined_int + noahmp%config%nmlist%OptSoilProperty = undefined_int + noahmp%config%nmlist%OptPedotransfer = undefined_int + noahmp%config%nmlist%OptGlacierTreatment = undefined_int + + ! config domain variable + noahmp%config%domain%LandUseDataName = "MODIFIED_IGBP_MODIS_NOAH" + noahmp%config%domain%FlagUrban = .false. + noahmp%config%domain%FlagCropland = .false. + noahmp%config%domain%FlagDynamicCrop = .false. + noahmp%config%domain%FlagDynamicVeg = .false. + noahmp%config%domain%FlagSoilProcess = .false. + noahmp%config%domain%NumSoilTimeStep = undefined_int + noahmp%config%domain%NumSnowLayerMax = undefined_int + noahmp%config%domain%NumSnowLayerNeg = undefined_int + noahmp%config%domain%NumSoilLayer = undefined_int + noahmp%config%domain%GridIndexI = undefined_int + noahmp%config%domain%GridIndexJ = undefined_int + noahmp%config%domain%VegType = undefined_int + noahmp%config%domain%CropType = undefined_int + noahmp%config%domain%SurfaceType = undefined_int + noahmp%config%domain%NumSwRadBand = undefined_int + noahmp%config%domain%SoilColor = undefined_int + noahmp%config%domain%IndicatorIceSfc = undefined_int + noahmp%config%domain%NumCropGrowStage = undefined_int + noahmp%config%domain%IndexWaterPoint = undefined_int + noahmp%config%domain%IndexBarrenPoint = undefined_int + noahmp%config%domain%IndexIcePoint = undefined_int + noahmp%config%domain%IndexCropPoint = undefined_int + noahmp%config%domain%IndexEBLForest = undefined_int + noahmp%config%domain%NumDayInYear = undefined_int + noahmp%config%domain%RunoffSlopeType = undefined_int + noahmp%config%domain%MainTimeStep = undefined_real + noahmp%config%domain%SoilTimeStep = undefined_real + noahmp%config%domain%GridSize = undefined_real + noahmp%config%domain%DayJulianInYear = undefined_real + noahmp%config%domain%CosSolarZenithAngle = undefined_real + noahmp%config%domain%RefHeightAboveSfc = undefined_real + noahmp%config%domain%ThicknessAtmosBotLayer = undefined_real + noahmp%config%domain%Latitude = undefined_real + noahmp%config%domain%DepthSoilTempBottom = undefined_real + + end subroutine ConfigVarInitDefault + +end module ConfigVarInitMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/ConfigVarType.F90 b/src/core_atmosphere/physics/physics_noahmp/src/ConfigVarType.F90 new file mode 100644 index 0000000000..dc7979f3cb --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/ConfigVarType.F90 @@ -0,0 +1,183 @@ +module ConfigVarType + +!!! Define column (1-D) Noah-MP configuration variables +!!! Configuration variable initialization is done in ConfigVarInitMod.F90 + +! ------------------------ Code history ----------------------------------- +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + use Machine + + implicit none + save + private + +!=== define "namelist" sub-type of config (config%nmlist%variable) + type :: namelist_type + + integer :: OptDynamicVeg ! options for dynamic vegetation + ! 1 -> off (use table LeafAreaIndex; use VegFrac = VegFracGreen from input) + ! 2 -> on (together with OptStomataResistance = 1) + ! 3 -> off (use table LeafAreaIndex; calculate VegFrac) + ! 4 -> off (use table LeafAreaIndex; use maximum vegetation fraction) (default) + ! 5 -> on (use maximum vegetation fraction) + ! 6 -> on (use VegFrac = VegFracGreen from input) + ! 7 -> off (use input LeafAreaIndex; use VegFrac = VegFracGreen from input) + ! 8 -> off (use input LeafAreaIndex; calculate VegFrac) + ! 9 -> off (use input LeafAreaIndex; use maximum vegetation fraction) + integer :: OptRainSnowPartition ! options for partitioning precipitation into rainfall & snowfall + ! 1 -> Jordan (1991) scheme (default) + ! 2 -> BATS: when TemperatureAirRefHeight < freezing point+2.2 + ! 3 -> TemperatureAirRefHeight < freezing point + ! 4 -> Use WRF microphysics output + ! 5 -> Use wetbulb temperature (Wang et al., 2019) + integer :: OptSoilWaterTranspiration ! options for soil moisture factor for stomatal resistance & evapotranspiration + ! 1 -> Noah (soil moisture) (default) + ! 2 -> CLM (matric potential) + ! 3 -> SSiB (matric potential) + integer :: OptGroundResistanceEvap ! options for ground resistent to evaporation/sublimation + ! 1 -> Sakaguchi and Zeng, 2009 (default) + ! 2 -> Sellers (1992) + ! 3 -> adjusted Sellers to decrease ResistanceGrdEvap for wet soil + ! 4 -> option 1 for non-snow; rsurf = rsurf_snow for snow (set in table) + integer :: OptSurfaceDrag ! options for surface layer drag/exchange coefficient + ! 1 -> Monin-Obukhov (M-O) Similarity Theory (MOST) (default) + ! 2 -> original Noah (Chen et al. 1997) + integer :: OptStomataResistance ! options for canopy stomatal resistance + ! 1 -> Ball-Berry scheme (default) + ! 2 -> Jarvis scheme + integer :: OptSnowAlbedo ! options for ground snow surface albedo + ! 1 -> BATS snow albedo scheme (default) + ! 2 -> CLASS snow albedo scheme + integer :: OptCanopyRadiationTransfer ! options for canopy radiation transfer + ! 1 -> modified two-stream (gap=F(solar angle,3D structure, etc)<1-VegFrac) + ! 2 -> two-stream applied to grid-cell (gap = 0) + ! 3 -> two-stream applied to vegetated fraction (gap=1-VegFrac) (default) + integer :: OptSnowSoilTempTime ! options for snow/soil temperature time scheme (only layer 1) + ! 1 -> semi-implicit; flux top boundary condition (default) + ! 2 -> full implicit (original Noah); temperature top boundary condition + ! 3 -> same as 1, but snow cover for skin temperature calculation (generally improves snow) + integer :: OptSnowThermConduct ! options for snow thermal conductivity + ! 1 -> Stieglitz(yen,1965) scheme (default) + ! 2 -> Anderson, 1976 scheme + ! 3 -> constant + ! 4 -> Verseghy (1991) scheme + ! 5 -> Douvill(Yen, 1981) scheme + integer :: OptSoilTemperatureBottom ! options for lower boundary condition of soil temperature + ! 1 -> zero heat flux from bottom (DepthSoilTempBottom & TemperatureSoilBottom not used) + ! 2 -> TemperatureSoilBottom at DepthSoilTempBottom (8m) read from a file (original Noah) (default) + integer :: OptSoilSupercoolWater ! options for soil supercooled liquid water + ! 1 -> no iteration (Niu and Yang, 2006 JHM) (default) + ! 2 -> Koren's iteration (Koren et al., 1999 JGR) + integer :: OptRunoffSurface ! options for surface runoff + ! 1 -> TOPMODEL with groundwater + ! 2 -> TOPMODEL with an equilibrium water table + ! 3 -> original surface and subsurface runoff (free drainage) (default) + ! 4 -> BATS surface and subsurface runoff (free drainage) + ! 5 -> Miguez-Macho&Fan groundwater scheme + ! 6 -> Variable Infiltration Capacity Model surface runoff scheme + ! 7 -> Xinanjiang Infiltration and surface runoff scheme + ! 8 -> Dynamic VIC surface runoff scheme + integer :: OptRunoffSubsurface ! options for drainage & subsurface runoff + ! 1~8: similar to runoff option, separated from original NoahMP runoff option + ! currently tested & recommended the same option# as surface runoff (default) + integer :: OptSoilPermeabilityFrozen ! options for frozen soil permeability + ! 1 -> linear effects, more permeable (default) + ! 2 -> nonlinear effects, less permeable + integer :: OptDynVicInfiltration ! options for infiltration in dynamic VIC runoff scheme + ! 1 -> Philip scheme (default) + ! 2 -> Green-Ampt scheme + ! 3 -> Smith-Parlange scheme + integer :: OptTileDrainage ! options for tile drainage + ! currently only tested & calibrated to work with runoff option=3 + ! 0 -> No tile drainage (default) + ! 1 -> on (simple scheme) + ! 2 -> on (Hooghoudt's scheme) + integer :: OptIrrigation ! options for irrigation + ! 0 -> No irrigation (default) + ! 1 -> Irrigation ON + ! 2 -> irrigation trigger based on crop season Planting and harvesting dates + ! 3 -> irrigation trigger based on LeafAreaIndex threshold + integer :: OptIrrigationMethod ! options for irrigation method + ! only works when OptIrrigation > 0 + ! 0 -> method based on geo_em fractions (default) + ! 1 -> sprinkler method + ! 2 -> micro/drip irrigation + ! 3 -> surface flooding + integer :: OptCropModel ! options for crop model + ! 0 -> No crop model (default) + ! 1 -> Liu, et al. 2016 crop scheme + integer :: OptSoilProperty ! options for defining soil properties + ! 1 -> use input dominant soil texture (default) + ! 2 -> use input soil texture that varies with depth + ! 3 -> use soil composition (sand, clay, orgm) and pedotransfer function + ! 4 -> use input soil properties + integer :: OptPedotransfer ! options for pedotransfer functions + ! only works when OptSoilProperty = 3 + ! 1 -> Saxton and Rawls (2006) scheme (default) + integer :: OptGlacierTreatment ! options for glacier treatment + ! 1 -> include phase change of ice (default) + ! 2 -> ice treatment more like original Noah + + end type namelist_type + + +!=== define "domain" sub-type of config (config%domain%variable) + type :: domain_type + + character(len=256) :: LandUseDataName ! landuse dataset name (USGS or MODIFIED_IGBP_MODIS_NOAH) + logical :: FlagUrban ! flag for urban grid + logical :: FlagCropland ! flag to identify croplands + logical :: FlagDynamicCrop ! flag to activate dynamic crop model + logical :: FlagDynamicVeg ! flag to activate dynamic vegetation scheme + logical :: FlagSoilProcess ! flag to determine if calculating soil processes + integer :: GridIndexI ! model grid index in x-direction + integer :: GridIndexJ ! model grid index in y-direction + integer :: VegType ! vegetation type + integer :: CropType ! crop type + integer :: NumSoilLayer ! number of soil layers + integer :: NumSnowLayerMax ! maximum number of snow layers + integer :: NumSnowLayerNeg ! actual number of snow layers (negative) + integer :: SurfaceType ! surface type (1=soil; 2=lake) + integer :: NumSwRadBand ! number of shortwave radiation bands + integer :: SoilColor ! soil color type for albedo + integer :: IndicatorIceSfc ! indicator for ice surface/point (1=sea ice, 0=non-ice, -1=land ice) + integer :: IndexWaterPoint ! land type index for water point + integer :: IndexBarrenPoint ! land type index for barren land point + integer :: IndexIcePoint ! land type index for ice point + integer :: IndexCropPoint ! land type index for cropland point + integer :: IndexEBLForest ! land type index for evergreen broadleaf (EBL) Forest + integer :: NumCropGrowStage ! number of crop growth stages + integer :: NumDayInYear ! Number of days in the particular year + integer :: RunoffSlopeType ! underground runoff slope term type + integer :: NumSoilTimeStep ! number of timesteps to calculate soil processes + real(kind=kind_noahmp) :: MainTimeStep ! noahmp main timestep [sec] + real(kind=kind_noahmp) :: SoilTimeStep ! soil timestep [sec] + real(kind=kind_noahmp) :: GridSize ! noahmp model grid spacing [m] + real(kind=kind_noahmp) :: DayJulianInYear ! julian day of the year + real(kind=kind_noahmp) :: CosSolarZenithAngle ! cosine solar zenith angle + real(kind=kind_noahmp) :: RefHeightAboveSfc ! reference height [m] above surface zero plane (including vegetation) + real(kind=kind_noahmp) :: ThicknessAtmosBotLayer ! thickness of atmospheric bottom layers [m] + real(kind=kind_noahmp) :: Latitude ! latitude [degree] + real(kind=kind_noahmp) :: DepthSoilTempBottom ! depth [m, negative] from soil surface for lower boundary soil temperature forcing + + integer , allocatable, dimension(:) :: SoilType ! soil type for each soil layer + real(kind=kind_noahmp), allocatable, dimension(:) :: DepthSoilLayer ! depth [m] of layer-bottom from soil surface + real(kind=kind_noahmp), allocatable, dimension(:) :: ThicknessSnowSoilLayer ! snow and soil layer thickness [m] + real(kind=kind_noahmp), allocatable, dimension(:) :: DepthSnowSoilLayer ! snow and soil layer-bottom depth [m] + real(kind=kind_noahmp), allocatable, dimension(:) :: ThicknessSoilLayer ! soil layer thickness [m] + + end type domain_type + + +!=== define config type that includes namelist & domain subtypes + type, public :: config_type + + type(namelist_type) :: nmlist + type(domain_type) :: domain + + end type config_type + +end module ConfigVarType diff --git a/src/core_atmosphere/physics/physics_noahmp/src/ConstantDefineMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/ConstantDefineMod.F90 new file mode 100644 index 0000000000..4fa3e98745 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/ConstantDefineMod.F90 @@ -0,0 +1,40 @@ +module ConstantDefineMod + +!!! Define Noah-MP constant variable values + +! ------------------------ Code history ----------------------------------- +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + use Machine + + implicit none + save + private + + ! define specific physical constants + real(kind=kind_noahmp), public, parameter :: ConstGravityAcc = 9.80616 ! acceleration due to gravity [m/s2] + real(kind=kind_noahmp), public, parameter :: ConstStefanBoltzmann = 5.67e-08 ! Stefan-Boltzmann constant [W/m2/K4] + real(kind=kind_noahmp), public, parameter :: ConstVonKarman = 0.40 ! von Karman constant + real(kind=kind_noahmp), public, parameter :: ConstFreezePoint = 273.16 ! freezing/melting temperature point [K] + real(kind=kind_noahmp), public, parameter :: ConstLatHeatSublim = 2.8440e06 ! latent heat of sublimation [J/kg] + real(kind=kind_noahmp), public, parameter :: ConstLatHeatEvap = 2.5104e06 ! latent heat of vaporization [J/kg] + real(kind=kind_noahmp), public, parameter :: ConstLatHeatFusion = 0.3336e06 ! latent heat of fusion of water [J/kg] + real(kind=kind_noahmp), public, parameter :: ConstHeatCapacWater = 4.188e06 ! specific heat capacity of water [J/m3/K] + real(kind=kind_noahmp), public, parameter :: ConstHeatCapacIce = 2.094e06 ! specific heat capacity of ice [J/m3/K] + real(kind=kind_noahmp), public, parameter :: ConstHeatCapacAir = 1004.64 ! specific heat capacity of dry air [J/kg/K] + real(kind=kind_noahmp), public, parameter :: ConstThermConductWater = 0.57 ! thermal conductivity of water [W/m/K] + real(kind=kind_noahmp), public, parameter :: ConstThermConductIce = 2.2 ! thermal conductivity of ice [W/m/K] + real(kind=kind_noahmp), public, parameter :: ConstThermConductAir = 0.023 ! thermal conductivity of air [W/m/K] + real(kind=kind_noahmp), public, parameter :: ConstThermConductQuartz = 7.7 ! thermal conductivity for quartz [W/m/K] + real(kind=kind_noahmp), public, parameter :: ConstThermConductSoilOth = 2.0 ! thermal conductivity for other soil components [W/m/K] + real(kind=kind_noahmp), public, parameter :: ConstGasDryAir = 287.04 ! gas constant for dry air [J/kg/K] + real(kind=kind_noahmp), public, parameter :: ConstGasWaterVapor = 461.269 ! gas constant for water vapor [J/kg/K] + real(kind=kind_noahmp), public, parameter :: ConstDensityWater = 1000.0 ! density of water [kg/m3] + real(kind=kind_noahmp), public, parameter :: ConstDensityIce = 917.0 ! density of ice [kg/m3] + real(kind=kind_noahmp), public, parameter :: ConstPI = 3.14159265 ! pi value + real(kind=kind_noahmp), public, parameter :: ConstDensityGraupel = 500.0 ! graupel bulk density [kg/m3] + real(kind=kind_noahmp), public, parameter :: ConstDensityHail = 917.0 ! hail bulk density [kg/m3] + +end module ConstantDefineMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/CropGrowDegreeDayMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/CropGrowDegreeDayMod.F90 new file mode 100644 index 0000000000..cbad4158ee --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/CropGrowDegreeDayMod.F90 @@ -0,0 +1,107 @@ +module CropGrowDegreeDayMod + +!!! Compute crop growing degree days + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine CropGrowDegreeDay(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: GROWING_GDD +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variables + real(kind=kind_noahmp) :: GrowDegDayCnt ! gap bewtween GrowDegreeDay and GrowDegreeDay8 + real(kind=kind_noahmp) :: TemperatureDiff ! temperature difference for growing degree days calculation + real(kind=kind_noahmp) :: TemperatureAirC ! air temperature degC + +!------------------------------------------------------------------------ + associate( & + MainTimeStep => noahmp%config%domain%MainTimeStep ,& ! in, main noahmp timestep [s] + DayJulianInYear => noahmp%config%domain%DayJulianInYear ,& ! in, Julian day of year + TemperatureAir2m => noahmp%energy%state%TemperatureAir2m ,& ! in, 2-m air temperature [K] + DatePlanting => noahmp%biochem%param%DatePlanting ,& ! in, Planting day (day of year) + DateHarvest => noahmp%biochem%param%DateHarvest ,& ! in, Harvest date (day of year) + TempBaseGrowDegDay => noahmp%biochem%param%TempBaseGrowDegDay ,& ! in, Base temperature for grow degree day accumulation [C] + TempMaxGrowDegDay => noahmp%biochem%param%TempMaxGrowDegDay ,& ! in, Max temperature for grow degree day accumulation [C] + GrowDegDayEmerg => noahmp%biochem%param%GrowDegDayEmerg ,& ! in, grow degree day from seeding to emergence + GrowDegDayInitVeg => noahmp%biochem%param%GrowDegDayInitVeg ,& ! in, grow degree day from seeding to initial vegetative + GrowDegDayPostVeg => noahmp%biochem%param%GrowDegDayPostVeg ,& ! in, grow degree day from seeding to post vegetative + GrowDegDayInitReprod => noahmp%biochem%param%GrowDegDayInitReprod ,& ! in, grow degree day from seeding to intial reproductive + GrowDegDayMature => noahmp%biochem%param%GrowDegDayMature ,& ! in, grow degree day from seeding to physical maturity + GrowDegreeDay => noahmp%biochem%state%GrowDegreeDay ,& ! inout, crop growing degree days + IndexPlanting => noahmp%biochem%state%IndexPlanting ,& ! out, Planting index index (0=off, 1=on) + IndexHarvest => noahmp%biochem%state%IndexHarvest ,& ! out, Havest index (0=on,1=off) + PlantGrowStage => noahmp%biochem%state%PlantGrowStage & ! out, Plant growth stage (1=S1,2=S2,3=S3) + ) +!------------------------------------------------------------------------ + + ! initialize + TemperatureAirC = TemperatureAir2m - 273.15 + + ! Planting and Havest index + IndexPlanting = 1 ! planting on + IndexHarvest = 1 ! harvest off + + ! turn on/off the planting + if ( DayJulianInYear < DatePlanting ) IndexPlanting = 0 ! planting off + + ! turn on/off the harvesting + if ( DayJulianInYear >= DateHarvest ) IndexHarvest = 0 ! harvest on + + ! Calculate the growing degree days + if ( TemperatureAirC < TempBaseGrowDegDay ) then + TemperatureDiff = 0.0 + elseif ( TemperatureAirC >= TempMaxGrowDegDay ) then + TemperatureDiff = TempMaxGrowDegDay - TempBaseGrowDegDay + else + TemperatureDiff = TemperatureAirC - TempBaseGrowDegDay + endif + GrowDegreeDay = (GrowDegreeDay + TemperatureDiff * MainTimeStep / 86400.0) * IndexPlanting * IndexHarvest + GrowDegDayCnt = GrowDegreeDay + + ! Decide corn growth stage, based on Hybrid-Maize + ! PlantGrowStage = 1 : Before planting + ! PlantGrowStage = 2 : from tassel initiation to silking + ! PlantGrowStage = 3 : from silking to effective grain filling + ! PlantGrowStage = 4 : from effective grain filling to pysiological maturity + ! PlantGrowStage = 5 : GrowDegDayMax=1389 + ! PlantGrowStage = 6 : + ! PlantGrowStage = 7 : + ! PlantGrowStage = 8 : + ! GrowDegDayMax = 1389 + ! GrowDegDayMax = 1555 + ! GrowDegDayTmp = 0.41 * GrowDegDayMax + 145.4 + 150 ! from hybrid-maize + ! GrowDegDayEmerg = ((GrowDegDayTmp - 96) / 38.9 - 4) * 21 + ! GrowDegDayEmerg = 0.77 * GrowDegDayTmp + ! GrowDegDayPostVeg = GrowDegDayTmp + 170 + ! GrowDegDayPostVeg = 170 + + ! compute plant growth stage + PlantGrowStage = 1 ! MB: set PlantGrowStage = 1 (for initialization during growing season when no GDD) + if ( GrowDegDayCnt > 0.0 ) PlantGrowStage = 2 + if ( GrowDegDayCnt >= GrowDegDayEmerg ) PlantGrowStage = 3 + if ( GrowDegDayCnt >= GrowDegDayInitVeg ) PlantGrowStage = 4 + if ( GrowDegDayCnt >= GrowDegDayPostVeg ) PlantGrowStage = 5 + if ( GrowDegDayCnt >= GrowDegDayInitReprod ) PlantGrowStage = 6 + if ( GrowDegDayCnt >= GrowDegDayMature ) PlantGrowStage = 7 + if ( DayJulianInYear >= DateHarvest ) PlantGrowStage = 8 + if ( DayJulianInYear < DatePlanting ) PlantGrowStage = 1 + + end associate + + end subroutine CropGrowDegreeDay + +end module CropGrowDegreeDayMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/CropPhotosynthesisMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/CropPhotosynthesisMod.F90 new file mode 100644 index 0000000000..1a7ff70748 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/CropPhotosynthesisMod.F90 @@ -0,0 +1,109 @@ +module CropPhotosynthesisMod + +!!! Compute crop photosynthesis + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine CropPhotosynthesis(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: PSN_CROP +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + real(kind=kind_noahmp) :: PhotosynRad ! photosynthetically active radiation (w/m2) 1 W m-2 = 0.0864 MJ m-2 day-1 + real(kind=kind_noahmp) :: Co2AssimMax ! Maximum CO2 assimulation rate g CO2/m2/s + real(kind=kind_noahmp) :: Co2AssimTot ! CO2 Assimilation g CO2/m2/s + real(kind=kind_noahmp) :: TemperatureAirC ! air temperature degC + real(kind=kind_noahmp) :: L1 ! Three Gaussian method + real(kind=kind_noahmp) :: L2 ! Three Gaussian method + real(kind=kind_noahmp) :: L3 ! Three Gaussian method + real(kind=kind_noahmp) :: I1 ! Three Gaussian method + real(kind=kind_noahmp) :: I2 ! Three Gaussian method + real(kind=kind_noahmp) :: I3 ! Three Gaussian method + real(kind=kind_noahmp) :: A1 ! Three Gaussian method + real(kind=kind_noahmp) :: A2 ! Three Gaussian method + real(kind=kind_noahmp) :: A3 ! Three Gaussian method + +!------------------------------------------------------------------------ + associate( & + RadSwDownRefHeight => noahmp%forcing%RadSwDownRefHeight ,& ! in, downward shortwave radiation [W/m2] at reference height + TemperatureAir2m => noahmp%energy%state%TemperatureAir2m ,& ! in, 2-m air temperature [K] + LeafAreaIndex => noahmp%energy%state%LeafAreaIndex ,& ! in, leaf area index, unadjusted for burying by snow + PhotosynRadFrac => noahmp%biochem%param%PhotosynRadFrac ,& ! in, Fraction of incoming radiation to photosynthetically active radiation + TempMinCarbonAssim => noahmp%biochem%param%TempMinCarbonAssim ,& ! in, Minimum temperature for CO2 assimilation [C] + TempMaxCarbonAssim => noahmp%biochem%param%TempMaxCarbonAssim ,& ! in, CO2 assim. linearly increasing until reaching this temperature [C] + TempMaxCarbonAssimMax => noahmp%biochem%param%TempMaxCarbonAssimMax ,& ! in, CO2 assim. remain at CarbonAssimRefMax until reaching this temperature [C] + CarbonAssimRefMax => noahmp%biochem%param%CarbonAssimRefMax ,& ! in, reference maximum CO2 assimilation rate + LightExtCoeff => noahmp%biochem%param%LightExtCoeff ,& ! in, light extinction coefficient + LightUseEfficiency => noahmp%biochem%param%LightUseEfficiency ,& ! in, initial light use efficiency + CarbonAssimReducFac => noahmp%biochem%param%CarbonAssimReducFac ,& ! in, CO2 assimulation reduction factor(0-1) (caused by e.g.pest,weeds) + PhotosynCrop => noahmp%biochem%flux%PhotosynCrop & ! out, crop photosynthesis [umol co2/m2/s] + ) +!------------------------------------------------------------------------ + + ! initialize + TemperatureAirC = TemperatureAir2m - 273.15 + PhotosynRad = PhotosynRadFrac * RadSwDownRefHeight * 0.0036 !w to MJ m-2 + + ! compute Maximum CO2 assimulation rate g/co2/s + if ( TemperatureAirC < TempMinCarbonAssim ) then + Co2AssimMax = 1.0e-10 + elseif ( (TemperatureAirC >= TempMinCarbonAssim) .and. (TemperatureAirC < TempMaxCarbonAssim) ) then + Co2AssimMax = (TemperatureAirC - TempMinCarbonAssim) * CarbonAssimRefMax / (TempMaxCarbonAssim - TempMinCarbonAssim) + elseif ( (TemperatureAirC >= TempMaxCarbonAssim) .and. (TemperatureAirC < TempMaxCarbonAssimMax) ) then + Co2AssimMax = CarbonAssimRefMax + else + Co2AssimMax = CarbonAssimRefMax - 0.2 * (TemperatureAir2m - TempMaxCarbonAssimMax) + endif + Co2AssimMax = max(Co2AssimMax, 0.01) + + ! compute coefficients + if ( LeafAreaIndex <= 0.05 ) then + L1 = 0.1127 * 0.05 ! use initial LeafAreaIndex(0.05), avoid error + L2 = 0.5 * 0.05 + L3 = 0.8873 * 0.05 + else + L1 = 0.1127 * LeafAreaIndex + L2 = 0.5 * LeafAreaIndex + L3 = 0.8873 * LeafAreaIndex + endif + + I1 = LightExtCoeff * PhotosynRad * exp(-LightExtCoeff * L1) + I2 = LightExtCoeff * PhotosynRad * exp(-LightExtCoeff * L2) + I3 = LightExtCoeff * PhotosynRad * exp(-LightExtCoeff * L3) + I1 = max(I1, 1.0e-10) + I2 = max(I2, 1.0e-10) + I3 = max(I3, 1.0e-10) + A1 = Co2AssimMax * (1 - exp(-LightUseEfficiency * I1 / Co2AssimMax)) + A2 = Co2AssimMax * (1 - exp(-LightUseEfficiency * I2 / Co2AssimMax)) * 1.6 + A3 = Co2AssimMax * (1 - exp(-LightUseEfficiency * I3 / Co2AssimMax)) + + ! compute photosynthesis rate + if ( LeafAreaIndex <= 0.05 ) then + Co2AssimTot = (A1 + A2 + A3) / 3.6 * 0.05 + elseif ( (LeafAreaIndex > 0.05) .and. (LeafAreaIndex <= 4.0) ) then + Co2AssimTot = (A1 + A2 + A3) / 3.6 * LeafAreaIndex + else + Co2AssimTot = (A1 + A2 + A3) / 3.6 * 4 + endif + Co2AssimTot = Co2AssimTot * CarbonAssimReducFac ! Attainable + PhotosynCrop = 6.313 * Co2AssimTot ! (1/44) * 1000000)/3600 = 6.313 + + end associate + + end subroutine CropPhotosynthesis + +end module CropPhotosynthesisMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/EnergyMainGlacierMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/EnergyMainGlacierMod.F90 new file mode 100644 index 0000000000..3fc0bf0717 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/EnergyMainGlacierMod.F90 @@ -0,0 +1,173 @@ +module EnergyMainGlacierMod + +!!! Main energy module for glacier points including all energy relevant processes +!!! snow thermal property -> radiation -> ground heat flux -> snow temperature solver -> snow/ice phase change + + use Machine + use NoahmpVarType + use ConstantDefineMod + use SnowCoverGlacierMod, only : SnowCoverGlacier + use GroundRoughnessPropertyGlacierMod, only : GroundRoughnessPropertyGlacier + use GroundThermalPropertyGlacierMod, only : GroundThermalPropertyGlacier + use SurfaceAlbedoGlacierMod, only : SurfaceAlbedoGlacier + use SurfaceRadiationGlacierMod, only : SurfaceRadiationGlacier + use SurfaceEmissivityGlacierMod, only : SurfaceEmissivityGlacier + use ResistanceGroundEvaporationGlacierMod, only : ResistanceGroundEvaporationGlacier + use PsychrometricVariableGlacierMod, only : PsychrometricVariableGlacier + use SurfaceEnergyFluxGlacierMod, only : SurfaceEnergyFluxGlacier + use GlacierTemperatureMainMod, only : GlacierTemperatureMain + use GlacierPhaseChangeMod, only : GlacierPhaseChange + + implicit none + +contains + + subroutine EnergyMainGlacier(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: ENERGY_GLACIER +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + +! -------------------------------------------------------------------- + associate( & + RadLwDownRefHeight => noahmp%forcing%RadLwDownRefHeight ,& ! in, downward longwave radiation [W/m2] at reference height + RadSwDownRefHeight => noahmp%forcing%RadSwDownRefHeight ,& ! in, downward shortwave radiation [W/m2] at reference height + OptSnowSoilTempTime => noahmp%config%nmlist%OptSnowSoilTempTime ,& ! in, options for snow/soil temperature time scheme + HeatPrecipAdvBareGrd => noahmp%energy%flux%HeatPrecipAdvBareGrd ,& ! in, precipitation advected heat - bare ground net [W/m2] + TemperatureSfc => noahmp%energy%state%TemperatureSfc ,& ! inout, surface temperature [K] + TemperatureGrd => noahmp%energy%state%TemperatureGrd ,& ! inout, ground temperature [K] + SpecHumiditySfc => noahmp%energy%state%SpecHumiditySfc ,& ! inout, specific humidity at bare surface + SpecHumiditySfcMean => noahmp%energy%state%SpecHumiditySfcMean ,& ! inout, specific humidity at surface grid mean + ExchCoeffMomSfc => noahmp%energy%state%ExchCoeffMomSfc ,& ! inout, exchange coefficient [m/s] for momentum, surface, grid mean + ExchCoeffShSfc => noahmp%energy%state%ExchCoeffShSfc ,& ! inout, exchange coefficient [m/s] for heat, surface, grid mean + SnowDepth => noahmp%water%state%SnowDepth ,& ! inout, snow depth [m] + RoughLenMomSfcToAtm => noahmp%energy%state%RoughLenMomSfcToAtm ,& ! out, roughness length, momentum, surface, sent to coupled model + WindStressEwSfc => noahmp%energy%state%WindStressEwSfc ,& ! out, wind stress: east-west [N/m2] grid mean + WindStressNsSfc => noahmp%energy%state%WindStressNsSfc ,& ! out, wind stress: north-south [N/m2] grid mean + TemperatureRadSfc => noahmp%energy%state%TemperatureRadSfc ,& ! out, radiative temperature [K] + TemperatureAir2m => noahmp%energy%state%TemperatureAir2m ,& ! out, grid mean 2-m air temperature [K] + TemperatureAir2mBare => noahmp%energy%state%TemperatureAir2mBare ,& ! out, 2 m height air temperature [K] bare ground + EmissivitySfc => noahmp%energy%state%EmissivitySfc ,& ! out, surface emissivity + RoughLenMomGrd => noahmp%energy%state%RoughLenMomGrd ,& ! out, roughness length, momentum, ground [m] + WindStressEwBare => noahmp%energy%state%WindStressEwBare ,& ! out, wind stress: east-west [N/m2] bare ground + WindStressNsBare => noahmp%energy%state%WindStressNsBare ,& ! out, wind stress: north-south [N/m2] bare ground + SpecHumidity2mBare => noahmp%energy%state%SpecHumidity2mBare ,& ! out, bare ground 2-m water vapor mixing ratio + SpecHumidity2m => noahmp%energy%state%SpecHumidity2m ,& ! out, grid mean 2-m water vapor mixing ratio + TemperatureGrdBare => noahmp%energy%state%TemperatureGrdBare ,& ! out, bare ground temperature [K] + ExchCoeffMomBare => noahmp%energy%state%ExchCoeffMomBare ,& ! out, exchange coeff [m/s] for momentum, above ZeroPlaneDisp, bare ground + ExchCoeffShBare => noahmp%energy%state%ExchCoeffShBare ,& ! out, exchange coeff [m/s] for heat, above ZeroPlaneDisp, bare ground + AlbedoSfc => noahmp%energy%state%AlbedoSfc ,& ! out, total shortwave surface albedo + RadSwReflSfc => noahmp%energy%flux%RadSwReflSfc ,& ! out, total reflected solar radiation [W/m2] + RadLwNetSfc => noahmp%energy%flux%RadLwNetSfc ,& ! out, total net longwave rad [W/m2] (+ to atm) + HeatSensibleSfc => noahmp%energy%flux%HeatSensibleSfc ,& ! out, total sensible heat [W/m2] (+ to atm) + HeatLatentGrd => noahmp%energy%flux%HeatLatentGrd ,& ! out, total ground latent heat [W/m2] (+ to atm) + HeatGroundTot => noahmp%energy%flux%HeatGroundTot ,& ! out, total ground heat flux [W/m2] (+ to soil/snow) + HeatPrecipAdvSfc => noahmp%energy%flux%HeatPrecipAdvSfc ,& ! out, precipitation advected heat - total [W/m2] + RadLwEmitSfc => noahmp%energy%flux%RadLwEmitSfc ,& ! out, emitted outgoing IR [W/m2] + RadLwNetBareGrd => noahmp%energy%flux%RadLwNetBareGrd ,& ! out, net longwave rad [W/m2] bare ground (+ to atm) + HeatSensibleBareGrd => noahmp%energy%flux%HeatSensibleBareGrd ,& ! out, sensible heat flux [W/m2] bare ground (+ to atm) + HeatLatentBareGrd => noahmp%energy%flux%HeatLatentBareGrd ,& ! out, latent heat flux [W/m2] bare ground (+ to atm) + HeatGroundBareGrd => noahmp%energy%flux%HeatGroundBareGrd & ! out, bare ground heat flux [W/m2] (+ to soil/snow) + ) +! ---------------------------------------------------------------------- + + ! glaicer snow cover fraction + call SnowCoverGlacier(noahmp) + + ! ground and surface roughness length and reference height + call GroundRoughnessPropertyGlacier(noahmp) + + ! Thermal properties of snow and glacier ice + call GroundThermalPropertyGlacier(noahmp) + + ! Glacier surface shortwave abeldo + call SurfaceAlbedoGlacier(noahmp) + + ! Glacier surface shortwave radiation + call SurfaceRadiationGlacier(noahmp) + + ! longwave emissivity for glacier surface + call SurfaceEmissivityGlacier(noahmp) + + ! glacier surface resistance for ground evaporation/sublimation + call ResistanceGroundEvaporationGlacier(noahmp) + + ! set psychrometric variable/constant + call PsychrometricVariableGlacier(noahmp) + + ! temperatures and energy fluxes of glacier ground + TemperatureGrdBare = TemperatureGrd + ExchCoeffMomBare = ExchCoeffMomSfc + ExchCoeffShBare = ExchCoeffShSfc + call SurfaceEnergyFluxGlacier(noahmp) + + ! assign glacier bare ground quantity to grid-level quantity + ! Energy balance at glacier (bare) ground: + ! RadSwAbsGrd + HeatPrecipAdvBareGrd = RadLwNetBareGrd + HeatSensibleBareGrd + HeatLatentBareGrd + HeatGroundBareGrd + WindStressEwSfc = WindStressEwBare + WindStressNsSfc = WindStressNsBare + RadLwNetSfc = RadLwNetBareGrd + HeatSensibleSfc = HeatSensibleBareGrd + HeatLatentGrd = HeatLatentBareGrd + HeatGroundTot = HeatGroundBareGrd + TemperatureGrd = TemperatureGrdBare + TemperatureAir2m = TemperatureAir2mBare + HeatPrecipAdvSfc = HeatPrecipAdvBareGrd + TemperatureSfc = TemperatureGrd + ExchCoeffMomSfc = ExchCoeffMomBare + ExchCoeffShSfc = ExchCoeffShBare + SpecHumiditySfcMean = SpecHumiditySfc + SpecHumidity2m = SpecHumidity2mBare + RoughLenMomSfcToAtm = RoughLenMomGrd + + ! emitted longwave radiation and physical check + RadLwEmitSfc = RadLwDownRefHeight + RadLwNetSfc + if ( RadLwEmitSfc <= 0.0 ) then + write(*,*) "emitted longwave <0; skin T may be wrong due to inconsistent" + write(*,*) "RadLwDownRefHeight = ", RadLwDownRefHeight, "RadLwNetSfc = ", RadLwNetSfc, "SnowDepth = ", SnowDepth + stop "Error: Longwave radiation budget problem in NoahMP LSM" + endif + + ! radiative temperature: subtract from the emitted IR the + ! reflected portion of the incoming longwave radiation, so just + ! considering the IR originating/emitted in the ground system. + ! Old TemperatureRadSfc calculation not taking into account Emissivity: + ! TemperatureRadSfc = (RadLwEmitSfc/ConstStefanBoltzmann)**0.25 + TemperatureRadSfc = ((RadLwEmitSfc - (1.0 - EmissivitySfc)*RadLwDownRefHeight) / & + (EmissivitySfc * ConstStefanBoltzmann)) ** 0.25 + + ! compute snow and glacier ice temperature + call GlacierTemperatureMain(noahmp) + + ! adjusting suface temperature based on snow condition + if ( OptSnowSoilTempTime == 2 ) then + if ( (SnowDepth > 0.05) .and. (TemperatureGrd > ConstFreezePoint) ) then + TemperatureGrdBare = ConstFreezePoint + TemperatureGrd = TemperatureGrdBare + TemperatureSfc = TemperatureGrdBare + endif + endif + + ! Phase change and Energy released or consumed by snow & glacier ice + call GlacierPhaseChange(noahmp) + + ! update total surface albedo + if ( RadSwDownRefHeight > 0.0 ) then + AlbedoSfc = RadSwReflSfc / RadSwDownRefHeight + else + AlbedoSfc = undefined_real + endif + + end associate + + end subroutine EnergyMainGlacier + +end module EnergyMainGlacierMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/EnergyMainMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/EnergyMainMod.F90 new file mode 100644 index 0000000000..0bd1df9ff2 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/EnergyMainMod.F90 @@ -0,0 +1,350 @@ +module EnergyMainMod + +!!! Main energy module including all energy relevant processes +!!! soil/snow thermal property -> radiation -> ground/vegtation heat flux -> snow/soil temperature solver -> soil/snow phase change +! +! -------------------------------------------------------------------------------------------------- +! NoahMP uses different approaches to deal with subgrid features of radiation transfer and turbulent +! transfer. It uses 'tile' approach to compute turbulent fluxes, while it uses two-stream approx. +! to compute radiation transfer. Tile approach, assemblying vegetation canopies together, +! may expose too much ground surfaces (either covered by snow or grass) to solar radiation. The +! modified two-stream assumes vegetation covers fully the gridcell but with gaps between tree crowns. +! -------------------------------------------------------------------------------------------------- +! turbulence transfer : 'tile' approach to compute energy fluxes in vegetated fraction and +! bare fraction separately and then sum them up weighted by fraction +! -------------------------------------- +! / O O O O O O O O / / +! / | | | | | | | | / / +! / O O O O O O O O / / +! / | | |tile1| | | | / tile2 / +! / O O O O O O O O / bare / +! / | | | vegetated | | / / +! / O O O O O O O O / / +! / | | | | | | | | / / +! -------------------------------------- +! -------------------------------------------------------------------------------------------------- +! radiation transfer : modified two-stream (Yang and Friedl, 2003, JGR; Niu ang Yang, 2004, JGR) +! -------------------------------------- two-stream treats leaves as +! / O O O O O O O O / cloud over the entire grid-cell, +! / | | | | | | | | / while the modified two-stream +! / O O O O O O O O / aggregates cloudy leaves into +! / | | | | | | | | / tree crowns with gaps (as shown in +! / O O O O O O O O / the left figure). We assume these +! / | | | | | | | | / tree crowns are evenly distributed +! / O O O O O O O O / within the gridcell with 100% veg +! / | | | | | | | | / fraction, but with gaps. The 'tile' +! -------------------------------------- approach overlaps too much shadows. +! -------------------------------------------------------------------------------------------------- + + use Machine + use NoahmpVarType + use ConstantDefineMod + use SnowCoverGroundNiu07Mod, only : SnowCoverGroundNiu07 + use GroundRoughnessPropertyMod, only : GroundRoughnessProperty + use GroundThermalPropertyMod, only : GroundThermalProperty + use SurfaceAlbedoMod, only : SurfaceAlbedo + use SurfaceRadiationMod, only : SurfaceRadiation + use SurfaceEmissivityMod, only : SurfaceEmissivity + use SoilWaterTranspirationMod, only : SoilWaterTranspiration + use ResistanceGroundEvaporationMod, only : ResistanceGroundEvaporation + use PsychrometricVariableMod, only : PsychrometricVariable + use SurfaceEnergyFluxVegetatedMod, only : SurfaceEnergyFluxVegetated + use SurfaceEnergyFluxBareGroundMod, only : SurfaceEnergyFluxBareGround + use SoilSnowTemperatureMainMod, only : SoilSnowTemperatureMain + use SoilSnowWaterPhaseChangeMod, only : SoilSnowWaterPhaseChange + + implicit none + +contains + + subroutine EnergyMain(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: ENERGY +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + logical :: FlagVegSfc ! flag: true if vegetated surface + +! -------------------------------------------------------------------- + associate( & + PressureAirRefHeight => noahmp%forcing%PressureAirRefHeight ,& ! in, air pressure [Pa] at reference height + RadLwDownRefHeight => noahmp%forcing%RadLwDownRefHeight ,& ! in, downward longwave radiation [W/m2] at reference height + RadSwDownRefHeight => noahmp%forcing%RadSwDownRefHeight ,& ! in, downward shortwave radiation [W/m2] at reference height + OptSnowSoilTempTime => noahmp%config%nmlist%OptSnowSoilTempTime ,& ! in, options for snow/soil temperature time scheme + FlagCropland => noahmp%config%domain%FlagCropland ,& ! in, flag to identify croplands + FlagSoilProcess => noahmp%config%domain%FlagSoilProcess ,& ! in, flag to determine if calculating soil processes + NumSoilTimeStep => noahmp%config%domain%NumSoilTimeStep ,& ! in, number of time step for calculating soil processes + SoilTimeStep => noahmp%config%domain%SoilTimeStep ,& ! in, soil process timestep [s] + IrriFracThreshold => noahmp%water%param%IrriFracThreshold ,& ! in, irrigation fraction parameter + IrrigationFracGrid => noahmp%water%state%IrrigationFracGrid ,& ! in, total input irrigation fraction + LeafAreaIndEff => noahmp%energy%state%LeafAreaIndEff ,& ! in, leaf area index, after burying by snow + StemAreaIndEff => noahmp%energy%state%StemAreaIndEff ,& ! in, stem area index, after burying by snow + VegFrac => noahmp%energy%state%VegFrac ,& ! in, greeness vegetation fraction + HeatLatentIrriEvap => noahmp%energy%flux%HeatLatentIrriEvap ,& ! in, latent heating due to sprinkler evaporation [W/m2] + HeatPrecipAdvCanopy => noahmp%energy%flux%HeatPrecipAdvCanopy ,& ! in, precipitation advected heat - vegetation net [W/m2] + HeatPrecipAdvVegGrd => noahmp%energy%flux%HeatPrecipAdvVegGrd ,& ! in, precipitation advected heat - under canopy net [W/m2] + HeatPrecipAdvBareGrd => noahmp%energy%flux%HeatPrecipAdvBareGrd ,& ! in, precipitation advected heat - bare ground net [W/m2] + TemperatureSfc => noahmp%energy%state%TemperatureSfc ,& ! inout, surface temperature [K] + TemperatureGrd => noahmp%energy%state%TemperatureGrd ,& ! inout, ground temperature [K] + TemperatureCanopy => noahmp%energy%state%TemperatureCanopy ,& ! inout, vegetation temperature [K] + SpecHumiditySfc => noahmp%energy%state%SpecHumiditySfc ,& ! inout, specific humidity [kg/kg] at bare/veg/urban surface + SpecHumiditySfcMean => noahmp%energy%state%SpecHumiditySfcMean ,& ! inout, specific humidity [kg/kg] at surface grid mean + PressureVaporCanAir => noahmp%energy%state%PressureVaporCanAir ,& ! inout, canopy air vapor pressure [Pa] + ExchCoeffMomSfc => noahmp%energy%state%ExchCoeffMomSfc ,& ! inout, exchange coefficient [m/s] for momentum, surface, grid mean + ExchCoeffShSfc => noahmp%energy%state%ExchCoeffShSfc ,& ! inout, exchange coefficient [m/s] for heat, surface, grid mean + HeatGroundTotAcc => noahmp%energy%flux%HeatGroundTotAcc ,& ! inout, accumulated total ground heat flux per soil timestep [W/m2 * dt_soil/dt_main] + SnowDepth => noahmp%water%state%SnowDepth ,& ! inout, snow depth [m] + RoughLenMomSfcToAtm => noahmp%energy%state%RoughLenMomSfcToAtm ,& ! out, roughness length, momentum, surface, sent to coupled model + WindStressEwSfc => noahmp%energy%state%WindStressEwSfc ,& ! out, wind stress: east-west [N/m2] grid mean + WindStressNsSfc => noahmp%energy%state%WindStressNsSfc ,& ! out, wind stress: north-south [N/m2] grid mean + TemperatureRadSfc => noahmp%energy%state%TemperatureRadSfc ,& ! out, surface radiative temperature [K] + TemperatureAir2m => noahmp%energy%state%TemperatureAir2m ,& ! out, grid mean 2-m air temperature [K] + ResistanceStomataSunlit => noahmp%energy%state%ResistanceStomataSunlit ,& ! out, sunlit leaf stomatal resistance [s/m] + ResistanceStomataShade => noahmp%energy%state%ResistanceStomataShade ,& ! out, shaded leaf stomatal resistance [s/m] + TemperatureAir2mVeg => noahmp%energy%state%TemperatureAir2mVeg ,& ! out, 2 m height air temperature [K], vegetated + TemperatureAir2mBare => noahmp%energy%state%TemperatureAir2mBare ,& ! out, 2 m height air temperature [K] bare ground + LeafAreaIndSunlit => noahmp%energy%state%LeafAreaIndSunlit ,& ! out, sunlit leaf area index, one-sided [m2/m2] + LeafAreaIndShade => noahmp%energy%state%LeafAreaIndShade ,& ! out, shaded leaf area index, one-sided [m2/m2] + EmissivitySfc => noahmp%energy%state%EmissivitySfc ,& ! out, surface emissivity + VegAreaIndEff => noahmp%energy%state%VegAreaIndEff ,& ! out, one-sided leaf+stem area index [m2/m2] + RoughLenMomSfc => noahmp%energy%state%RoughLenMomSfc ,& ! out, roughness length [m], momentum, surface + RoughLenMomGrd => noahmp%energy%state%RoughLenMomGrd ,& ! out, roughness length [m], momentum, ground + WindStressEwVeg => noahmp%energy%state%WindStressEwVeg ,& ! out, wind stress: east-west [N/m2] above canopy + WindStressNsVeg => noahmp%energy%state%WindStressNsVeg ,& ! out, wind stress: north-south [N/m2] above canopy + WindStressEwBare => noahmp%energy%state%WindStressEwBare ,& ! out, wind stress: east-west [N/m2] bare ground + WindStressNsBare => noahmp%energy%state%WindStressNsBare ,& ! out, wind stress: north-south [N/m2] bare ground + SpecHumidity2mVeg => noahmp%energy%state%SpecHumidity2mVeg ,& ! out, water vapor mixing ratio at 2m vegetated + SpecHumidity2mBare => noahmp%energy%state%SpecHumidity2mBare ,& ! out, bare ground 2-m water vapor mixing ratio + SpecHumidity2m => noahmp%energy%state%SpecHumidity2m ,& ! out, grid mean 2-m water vapor mixing ratio + TemperatureGrdVeg => noahmp%energy%state%TemperatureGrdVeg ,& ! out, vegetated ground (below-canopy) temperature [K] + TemperatureGrdBare => noahmp%energy%state%TemperatureGrdBare ,& ! out, bare ground temperature [K] + ExchCoeffMomAbvCan => noahmp%energy%state%ExchCoeffMomAbvCan ,& ! out, exchange coeff [m/s] for momentum, above ZeroPlaneDisp, vegetated + ExchCoeffMomBare => noahmp%energy%state%ExchCoeffMomBare ,& ! out, exchange coeff [m/s] for momentum, above ZeroPlaneDisp, bare ground + ExchCoeffShAbvCan => noahmp%energy%state%ExchCoeffShAbvCan ,& ! out, exchange coeff [m/s] for heat, above ZeroPlaneDisp, vegetated + ExchCoeffShBare => noahmp%energy%state%ExchCoeffShBare ,& ! out, exchange coeff [m/s] for heat, above ZeroPlaneDisp, bare ground + ExchCoeffShLeaf => noahmp%energy%state%ExchCoeffShLeaf ,& ! out, leaf sensible heat exchange coeff [m/s], leaf to canopy air + ExchCoeffShUndCan => noahmp%energy%state%ExchCoeffShUndCan ,& ! out, under canopy sensible heat exchange coefficient [m/s] + ExchCoeffSh2mVeg => noahmp%energy%state%ExchCoeffSh2mVeg ,& ! out, 2m sensible heat exchange coefficient [m/s] vegetated + AlbedoSfc => noahmp%energy%state%AlbedoSfc ,& ! out, total shortwave surface albedo + RadSwReflSfc => noahmp%energy%flux%RadSwReflSfc ,& ! out, total reflected solar radiation [W/m2] + RadLwNetSfc => noahmp%energy%flux%RadLwNetSfc ,& ! out, total net longwave rad [W/m2] (+ to atm) + HeatSensibleSfc => noahmp%energy%flux%HeatSensibleSfc ,& ! out, total sensible heat [W/m2] (+ to atm) + HeatLatentGrd => noahmp%energy%flux%HeatLatentGrd ,& ! out, total ground latent heat [W/m2] (+ to atm) + HeatLatentCanopy => noahmp%energy%flux%HeatLatentCanopy ,& ! out, canopy latent heat flux [W/m2] (+ to atm) + HeatLatentTransp => noahmp%energy%flux%HeatLatentTransp ,& ! out, latent heat flux from transpiration [W/m2] (+ to atm) + RadPhotoActAbsCan => noahmp%energy%flux%RadPhotoActAbsCan ,& ! out, total photosyn. active energy [W/m2) absorbed by canopy + RadPhotoActAbsSunlit => noahmp%energy%flux%RadPhotoActAbsSunlit ,& ! out, average absorbed par for sunlit leaves [W/m2] + RadPhotoActAbsShade => noahmp%energy%flux%RadPhotoActAbsShade ,& ! out, average absorbed par for shaded leaves [W/m2] + HeatGroundTot => noahmp%energy%flux%HeatGroundTot ,& ! out, total ground heat flux [W/m2] (+ to soil/snow) + HeatPrecipAdvSfc => noahmp%energy%flux%HeatPrecipAdvSfc ,& ! out, precipitation advected heat - total [W/m2] + RadLwEmitSfc => noahmp%energy%flux%RadLwEmitSfc ,& ! out, emitted outgoing IR [W/m2] + RadLwNetCanopy => noahmp%energy%flux%RadLwNetCanopy ,& ! out, canopy net longwave radiation [W/m2] (+ to atm) + RadLwNetVegGrd => noahmp%energy%flux%RadLwNetVegGrd ,& ! out, ground net longwave radiation [W/m2] (+ to atm) + RadLwNetBareGrd => noahmp%energy%flux%RadLwNetBareGrd ,& ! out, net longwave rad [W/m2] bare ground (+ to atm) + HeatSensibleCanopy => noahmp%energy%flux%HeatSensibleCanopy ,& ! out, canopy sensible heat flux [W/m2] (+ to atm) + HeatSensibleVegGrd => noahmp%energy%flux%HeatSensibleVegGrd ,& ! out, vegetated ground sensible heat flux [W/m2] (+ to atm) + HeatSensibleBareGrd => noahmp%energy%flux%HeatSensibleBareGrd ,& ! out, sensible heat flux [W/m2] bare ground (+ to atm) + HeatLatentVegGrd => noahmp%energy%flux%HeatLatentVegGrd ,& ! out, ground evaporation heat flux [W/m2] (+ to atm) + HeatLatentBareGrd => noahmp%energy%flux%HeatLatentBareGrd ,& ! out, latent heat flux [W/m2] bare ground (+ to atm) + HeatLatentCanEvap => noahmp%energy%flux%HeatLatentCanEvap ,& ! out, canopy evaporation heat flux [W/m2] (+ to atm) + HeatLatentCanTransp => noahmp%energy%flux%HeatLatentCanTransp ,& ! out, canopy transpiration heat flux [W/m2] (+ to atm) + HeatGroundVegGrd => noahmp%energy%flux%HeatGroundVegGrd ,& ! out, vegetated ground heat [W/m2] (+ to soil/snow) + HeatGroundBareGrd => noahmp%energy%flux%HeatGroundBareGrd ,& ! out, bare ground heat flux [W/m2] (+ to soil/snow) + HeatCanStorageChg => noahmp%energy%flux%HeatCanStorageChg ,& ! out, canopy heat storage change [W/m2] + HeatFromSoilBot => noahmp%energy%flux%HeatFromSoilBot ,& ! out, energy influx from soil bottom [J/m2] during soil timestep + HeatGroundTotMean => noahmp%energy%flux%HeatGroundTotMean ,& ! out, mean ground heat flux during soil timestep [W/m2] + PhotosynTotal => noahmp%biochem%flux%PhotosynTotal ,& ! out, total leaf photosynthesis [umol co2 /m2 /s] + PhotosynLeafSunlit => noahmp%biochem%flux%PhotosynLeafSunlit ,& ! out, sunlit leaf photosynthesis [umol co2 /m2 /s] + PhotosynLeafShade => noahmp%biochem%flux%PhotosynLeafShade & ! out, shaded leaf photosynthesis [umol co2 /m2 /s] + ) +! ---------------------------------------------------------------------- + + ! initialization + WindStressEwVeg = 0.0 + WindStressNsVeg = 0.0 + RadLwNetCanopy = 0.0 + HeatSensibleCanopy = 0.0 + RadLwNetVegGrd = 0.0 + HeatSensibleVegGrd = 0.0 + HeatLatentVegGrd = 0.0 + HeatLatentCanEvap = 0.0 + HeatLatentCanTransp = 0.0 + HeatGroundVegGrd = 0.0 + PhotosynLeafSunlit = 0.0 + PhotosynLeafShade = 0.0 + TemperatureAir2mVeg = 0.0 + SpecHumidity2mVeg = 0.0 + ExchCoeffShAbvCan = 0.0 + ExchCoeffShLeaf = 0.0 + ExchCoeffShUndCan = 0.0 + ExchCoeffSh2mVeg = 0.0 + HeatPrecipAdvSfc = 0.0 + HeatCanStorageChg = 0.0 + + ! vegetated or non-vegetated + VegAreaIndEff = LeafAreaIndEff + StemAreaIndEff + FlagVegSfc = .false. + if ( VegAreaIndEff > 0.0 ) FlagVegSfc = .true. + + ! ground snow cover fraction [Niu and Yang, 2007, JGR] + call SnowCoverGroundNiu07(noahmp) + + ! ground and surface roughness length and reference height + call GroundRoughnessProperty(noahmp, FlagVegSfc) + + ! Thermal properties of soil, snow, lake, and frozen soil + call GroundThermalProperty(noahmp) + + ! Surface shortwave albedo: ground and canopy radiative transfer + call SurfaceAlbedo(noahmp) + + ! Surface shortwave radiation: absorbed & reflected by the ground and canopy + call SurfaceRadiation(noahmp) + + ! longwave emissivity for vegetation, ground, total net surface + call SurfaceEmissivity(noahmp) + + ! soil water transpiration factor controlling stomatal resistance and evapotranspiration + call SoilWaterTranspiration(noahmp) + + ! soil surface resistance for ground evaporation/sublimation + call ResistanceGroundEvaporation(noahmp) + + ! set psychrometric variable/constant + call PsychrometricVariable(noahmp) + + ! temperatures and energy fluxes of canopy and below-canopy ground + if ( (FlagVegSfc .eqv. .true.) .and. (VegFrac > 0) ) then ! vegetated portion of the grid + TemperatureGrdVeg = TemperatureGrd + ExchCoeffMomAbvCan = ExchCoeffMomSfc + ExchCoeffShAbvCan = ExchCoeffShSfc + call SurfaceEnergyFluxVegetated(noahmp) + endif + + ! temperatures and energy fluxes of bare ground + TemperatureGrdBare = TemperatureGrd + ExchCoeffMomBare = ExchCoeffMomSfc + ExchCoeffShBare = ExchCoeffShSfc + call SurfaceEnergyFluxBareGround(noahmp) + + ! compute grid mean quantities by weighting vegetated and bare portions + ! Energy balance at vege canopy: + ! RadSwAbsVeg = (RadLwNetCanopy + HeatSensibleCanopy + HeatLatentCanEvap + HeatLatentCanTransp) * VegFrac at VegFrac + ! Energy balance at vege ground: + ! RadSwAbsGrd * VegFrac = (RadLwNetVegGrd + HeatSensibleVegGrd + HeatLatentVegGrd + HeatGroundVegGrd) * VegFrac at VegFrac + ! Energy balance at bare ground: + ! RadSwAbsGrd * (1-VegFrac) = (RadLwNetBareGrd + HeatSensibleBareGrd + HeatLatentBareGrd + HeatGroundBareGrd) * (1-VegFrac) at 1-VegFrac + if ( (FlagVegSfc .eqv. .true.) .and. (VegFrac > 0) ) then + WindStressEwSfc = VegFrac * WindStressEwVeg + (1.0 - VegFrac) * WindStressEwBare + WindStressNsSfc = VegFrac * WindStressNsVeg + (1.0 - VegFrac) * WindStressNsBare + RadLwNetSfc = VegFrac * RadLwNetVegGrd + (1.0 - VegFrac) * RadLwNetBareGrd + RadLwNetCanopy + HeatSensibleSfc = VegFrac * HeatSensibleVegGrd + (1.0 - VegFrac) * HeatSensibleBareGrd + HeatSensibleCanopy + HeatLatentGrd = VegFrac * HeatLatentVegGrd + (1.0 - VegFrac) * HeatLatentBareGrd + HeatGroundTot = VegFrac * HeatGroundVegGrd + (1.0 - VegFrac) * HeatGroundBareGrd + HeatLatentCanopy = HeatLatentCanEvap + HeatLatentTransp = HeatLatentCanTransp + HeatPrecipAdvSfc = VegFrac * HeatPrecipAdvVegGrd + (1.0 - VegFrac) * HeatPrecipAdvBareGrd + HeatPrecipAdvCanopy + TemperatureGrd = VegFrac * TemperatureGrdVeg + (1.0 - VegFrac) * TemperatureGrdBare + TemperatureAir2m = VegFrac * TemperatureAir2mVeg + (1.0 - VegFrac) * TemperatureAir2mBare + TemperatureSfc = VegFrac * TemperatureCanopy + (1.0 - VegFrac) * TemperatureGrdBare + ExchCoeffMomSfc = VegFrac * ExchCoeffMomAbvCan + (1.0 - VegFrac) * ExchCoeffMomBare ! better way to average? + ExchCoeffShSfc = VegFrac * ExchCoeffShAbvCan + (1.0 - VegFrac) * ExchCoeffShBare + SpecHumidity2m = VegFrac * SpecHumidity2mVeg + (1.0 - VegFrac) * SpecHumidity2mBare + SpecHumiditySfcMean = VegFrac * (PressureVaporCanAir * 0.622 / & + (PressureAirRefHeight - 0.378*PressureVaporCanAir)) + (1.0 - VegFrac) * SpecHumiditySfc + RoughLenMomSfcToAtm = RoughLenMomSfc + else + WindStressEwSfc = WindStressEwBare + WindStressNsSfc = WindStressNsBare + RadLwNetSfc = RadLwNetBareGrd + HeatSensibleSfc = HeatSensibleBareGrd + HeatLatentGrd = HeatLatentBareGrd + HeatGroundTot = HeatGroundBareGrd + TemperatureGrd = TemperatureGrdBare + TemperatureAir2m = TemperatureAir2mBare + HeatLatentCanopy = 0.0 + HeatLatentTransp = 0.0 + HeatPrecipAdvSfc = HeatPrecipAdvBareGrd + TemperatureSfc = TemperatureGrd + ExchCoeffMomSfc = ExchCoeffMomBare + ExchCoeffShSfc = ExchCoeffShBare + SpecHumiditySfcMean = SpecHumiditySfc + SpecHumidity2m = SpecHumidity2mBare + ResistanceStomataSunlit = 0.0 + ResistanceStomataShade = 0.0 + TemperatureGrdVeg = TemperatureGrdBare + ExchCoeffShAbvCan = ExchCoeffShBare + RoughLenMomSfcToAtm = RoughLenMomGrd + endif + + ! emitted longwave radiation and physical check + RadLwEmitSfc = RadLwDownRefHeight + RadLwNetSfc + if ( RadLwEmitSfc <= 0.0 ) then + write(*,*) "emitted longwave <0; skin T may be wrong due to inconsistent" + write(*,*) "input of VegFracGreen with LeafAreaIndex" + write(*,*) "VegFrac = ", VegFrac, "VegAreaIndEff = ", VegAreaIndEff, & + "TemperatureCanopy = ", TemperatureCanopy, "TemperatureGrd = ", TemperatureGrd + write(*,*) "RadLwDownRefHeight = ", RadLwDownRefHeight, "RadLwNetSfc = ", RadLwNetSfc, "SnowDepth = ", SnowDepth + stop "Error: Longwave radiation budget problem in NoahMP LSM" + endif + + ! radiative temperature: subtract from the emitted IR the + ! reflected portion of the incoming longwave radiation, so just + ! considering the IR originating/emitted in the canopy/ground system. + ! Old TemperatureRadSfc calculation not taking into account Emissivity: + ! TemperatureRadSfc = (RadLwEmitSfc/ConstStefanBoltzmann)**0.25 + TemperatureRadSfc = ((RadLwEmitSfc - (1.0-EmissivitySfc)*RadLwDownRefHeight) / (EmissivitySfc*ConstStefanBoltzmann))**0.25 + + ! other photosynthesis related quantities for biochem process + RadPhotoActAbsCan = RadPhotoActAbsSunlit * LeafAreaIndSunlit + RadPhotoActAbsShade * LeafAreaIndShade + PhotosynTotal = PhotosynLeafSunlit * LeafAreaIndSunlit + PhotosynLeafShade * LeafAreaIndShade + + ! compute snow and soil layer temperature at soil timestep + HeatFromSoilBot = 0.0 + HeatGroundTotAcc = HeatGroundTotAcc + HeatGroundTot + if ( FlagSoilProcess .eqv. .true. ) then + HeatGroundTotMean = HeatGroundTotAcc / NumSoilTimeStep + call SoilSnowTemperatureMain(noahmp) + endif ! FlagSoilProcess + + ! adjusting suface temperature based on snow condition + if ( OptSnowSoilTempTime == 2 ) then + if ( (SnowDepth > 0.05) .and. (TemperatureGrd > ConstFreezePoint) ) then + TemperatureGrdVeg = ConstFreezePoint + TemperatureGrdBare = ConstFreezePoint + if ( (FlagVegSfc .eqv. .true.) .and. (VegFrac > 0) ) then + TemperatureGrd = VegFrac * TemperatureGrdVeg + (1.0 - VegFrac) * TemperatureGrdBare + TemperatureSfc = VegFrac * TemperatureCanopy + (1.0 - VegFrac) * TemperatureGrdBare + else + TemperatureGrd = TemperatureGrdBare + TemperatureSfc = TemperatureGrdBare + endif + endif + endif + + ! Phase change and Energy released or consumed by snow & frozen soil + call SoilSnowWaterPhaseChange(noahmp) + + ! update sensible heat flux due to sprinkler irrigation evaporation + if ( (FlagCropland .eqv. .true.) .and. (IrrigationFracGrid >= IrriFracThreshold) ) & + HeatSensibleSfc = HeatSensibleSfc - HeatLatentIrriEvap + + ! update total surface albedo + if ( RadSwDownRefHeight > 0.0 ) then + AlbedoSfc = RadSwReflSfc / RadSwDownRefHeight + else + AlbedoSfc = undefined_real + endif + + end associate + + end subroutine EnergyMain + +end module EnergyMainMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/EnergyVarInitMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/EnergyVarInitMod.F90 new file mode 100644 index 0000000000..16484712b1 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/EnergyVarInitMod.F90 @@ -0,0 +1,398 @@ +module EnergyVarInitMod + +!!! Initialize column (1-D) Noah-MP energy variables +!!! Energy variables should be first defined in EnergyVarType.F90 + +! ------------------------ Code history ----------------------------------- +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + use Machine + use NoahmpVarType + + implicit none + +contains + +!=== initialize with default values + subroutine EnergyVarInitDefault(noahmp) + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + + associate( & + NumSnowLayerMax => noahmp%config%domain%NumSnowLayerMax ,& + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& + NumSwRadBand => noahmp%config%domain%NumSwRadBand & + ) + + ! energy state variables + noahmp%energy%state%FlagFrozenCanopy = .false. + noahmp%energy%state%FlagFrozenGround = .false. + noahmp%energy%state%LeafAreaIndEff = undefined_real + noahmp%energy%state%StemAreaIndEff = undefined_real + noahmp%energy%state%LeafAreaIndex = undefined_real + noahmp%energy%state%StemAreaIndex = undefined_real + noahmp%energy%state%VegAreaIndEff = undefined_real + noahmp%energy%state%VegFrac = undefined_real + noahmp%energy%state%PressureVaporRefHeight = undefined_real + noahmp%energy%state%SnowAgeFac = undefined_real + noahmp%energy%state%SnowAgeNondim = undefined_real + noahmp%energy%state%AlbedoSnowPrev = undefined_real + noahmp%energy%state%VegAreaProjDir = undefined_real + noahmp%energy%state%GapBtwCanopy = undefined_real + noahmp%energy%state%GapInCanopy = undefined_real + noahmp%energy%state%GapCanopyDif = undefined_real + noahmp%energy%state%GapCanopyDir = undefined_real + noahmp%energy%state%CanopySunlitFrac = undefined_real + noahmp%energy%state%CanopyShadeFrac = undefined_real + noahmp%energy%state%LeafAreaIndSunlit = undefined_real + noahmp%energy%state%LeafAreaIndShade = undefined_real + noahmp%energy%state%VapPresSatCanopy = undefined_real + noahmp%energy%state%VapPresSatGrdVeg = undefined_real + noahmp%energy%state%VapPresSatGrdBare = undefined_real + noahmp%energy%state%VapPresSatCanTempD = undefined_real + noahmp%energy%state%VapPresSatGrdVegTempD = undefined_real + noahmp%energy%state%VapPresSatGrdBareTempD = undefined_real + noahmp%energy%state%PressureVaporCanAir = undefined_real + noahmp%energy%state%PressureAtmosCO2 = undefined_real + noahmp%energy%state%PressureAtmosO2 = undefined_real + noahmp%energy%state%ResistanceStomataSunlit = undefined_real + noahmp%energy%state%ResistanceStomataShade = undefined_real + noahmp%energy%state%DensityAirRefHeight = undefined_real + noahmp%energy%state%TemperatureCanopyAir = undefined_real + noahmp%energy%state%ZeroPlaneDispSfc = undefined_real + noahmp%energy%state%ZeroPlaneDispGrd = undefined_real + noahmp%energy%state%RoughLenMomGrd = undefined_real + noahmp%energy%state%RoughLenMomSfc = undefined_real + noahmp%energy%state%CanopyHeight = undefined_real + noahmp%energy%state%WindSpdCanopyTop = undefined_real + noahmp%energy%state%RoughLenShCanopy = undefined_real + noahmp%energy%state%RoughLenShVegGrd = undefined_real + noahmp%energy%state%RoughLenShBareGrd = undefined_real + noahmp%energy%state%FrictionVelVeg = undefined_real + noahmp%energy%state%FrictionVelBare = undefined_real + noahmp%energy%state%WindExtCoeffCanopy = undefined_real + noahmp%energy%state%MoStabParaUndCan = undefined_real + noahmp%energy%state%MoStabParaAbvCan = undefined_real + noahmp%energy%state%MoStabParaBare = undefined_real + noahmp%energy%state%MoStabParaVeg2m = undefined_real + noahmp%energy%state%MoStabParaBare2m = undefined_real + noahmp%energy%state%MoLengthUndCan = undefined_real + noahmp%energy%state%MoLengthAbvCan = undefined_real + noahmp%energy%state%MoLengthBare = undefined_real + noahmp%energy%state%MoStabCorrShUndCan = undefined_real + noahmp%energy%state%MoStabCorrMomAbvCan = undefined_real + noahmp%energy%state%MoStabCorrShAbvCan = undefined_real + noahmp%energy%state%MoStabCorrMomVeg2m = undefined_real + noahmp%energy%state%MoStabCorrShVeg2m = undefined_real + noahmp%energy%state%MoStabCorrShBare = undefined_real + noahmp%energy%state%MoStabCorrMomBare = undefined_real + noahmp%energy%state%MoStabCorrMomBare2m = undefined_real + noahmp%energy%state%MoStabCorrShBare2m = undefined_real + noahmp%energy%state%ExchCoeffMomSfc = undefined_real + noahmp%energy%state%ExchCoeffMomAbvCan = undefined_real + noahmp%energy%state%ExchCoeffMomBare = undefined_real + noahmp%energy%state%ExchCoeffShSfc = undefined_real + noahmp%energy%state%ExchCoeffShBare = undefined_real + noahmp%energy%state%ExchCoeffShAbvCan = undefined_real + noahmp%energy%state%ExchCoeffShLeaf = undefined_real + noahmp%energy%state%ExchCoeffShUndCan = undefined_real + noahmp%energy%state%ExchCoeffSh2mVegMo = undefined_real + noahmp%energy%state%ExchCoeffSh2mBareMo = undefined_real + noahmp%energy%state%ExchCoeffSh2mVeg = undefined_real + noahmp%energy%state%ExchCoeffSh2mBare = undefined_real + noahmp%energy%state%ExchCoeffLhAbvCan = undefined_real + noahmp%energy%state%ExchCoeffLhTransp = undefined_real + noahmp%energy%state%ExchCoeffLhEvap = undefined_real + noahmp%energy%state%ExchCoeffLhUndCan = undefined_real + noahmp%energy%state%ResistanceMomUndCan = undefined_real + noahmp%energy%state%ResistanceShUndCan = undefined_real + noahmp%energy%state%ResistanceLhUndCan = undefined_real + noahmp%energy%state%ResistanceMomAbvCan = undefined_real + noahmp%energy%state%ResistanceShAbvCan = undefined_real + noahmp%energy%state%ResistanceLhAbvCan = undefined_real + noahmp%energy%state%ResistanceMomBareGrd = undefined_real + noahmp%energy%state%ResistanceShBareGrd = undefined_real + noahmp%energy%state%ResistanceLhBareGrd = undefined_real + noahmp%energy%state%ResistanceLeafBoundary = undefined_real + noahmp%energy%state%TemperaturePotRefHeight = undefined_real + noahmp%energy%state%WindSpdRefHeight = undefined_real + noahmp%energy%state%FrictionVelVertVeg = undefined_real + noahmp%energy%state%FrictionVelVertBare = undefined_real + noahmp%energy%state%EmissivityVeg = undefined_real + noahmp%energy%state%EmissivityGrd = undefined_real + noahmp%energy%state%ResistanceGrdEvap = undefined_real + noahmp%energy%state%PsychConstCanopy = undefined_real + noahmp%energy%state%LatHeatVapCanopy = undefined_real + noahmp%energy%state%PsychConstGrd = undefined_real + noahmp%energy%state%LatHeatVapGrd = undefined_real + noahmp%energy%state%RelHumidityGrd = undefined_real + noahmp%energy%state%SpecHumiditySfcMean = undefined_real + noahmp%energy%state%SpecHumiditySfc = undefined_real + noahmp%energy%state%SpecHumidity2mVeg = undefined_real + noahmp%energy%state%SpecHumidity2mBare = undefined_real + noahmp%energy%state%SpecHumidity2m = undefined_real + noahmp%energy%state%TemperatureSfc = undefined_real + noahmp%energy%state%TemperatureGrd = undefined_real + noahmp%energy%state%TemperatureCanopy = undefined_real + noahmp%energy%state%TemperatureGrdVeg = undefined_real + noahmp%energy%state%TemperatureGrdBare = undefined_real + noahmp%energy%state%TemperatureRootZone = undefined_real + noahmp%energy%state%WindStressEwVeg = undefined_real + noahmp%energy%state%WindStressNsVeg = undefined_real + noahmp%energy%state%WindStressEwBare = undefined_real + noahmp%energy%state%WindStressNsBare = undefined_real + noahmp%energy%state%WindStressEwSfc = undefined_real + noahmp%energy%state%WindStressNsSfc = undefined_real + noahmp%energy%state%TemperatureAir2mVeg = undefined_real + noahmp%energy%state%TemperatureAir2mBare = undefined_real + noahmp%energy%state%TemperatureAir2m = undefined_real + noahmp%energy%state%CanopyFracSnowBury = undefined_real + noahmp%energy%state%DepthSoilTempBotToSno = undefined_real + noahmp%energy%state%RoughLenMomSfcToAtm = undefined_real + noahmp%energy%state%TemperatureRadSfc = undefined_real + noahmp%energy%state%EmissivitySfc = undefined_real + noahmp%energy%state%AlbedoSfc = undefined_real + noahmp%energy%state%EnergyBalanceError = undefined_real + noahmp%energy%state%RadSwBalanceError = undefined_real + noahmp%energy%state%RefHeightAboveGrd = undefined_real + + if ( .not. allocated(noahmp%energy%state%TemperatureSoilSnow) ) & + allocate( noahmp%energy%state%TemperatureSoilSnow(-NumSnowLayerMax+1:NumSoilLayer) ) + if ( .not. allocated(noahmp%energy%state%ThermConductSoilSnow) ) & + allocate( noahmp%energy%state%ThermConductSoilSnow(-NumSnowLayerMax+1:NumSoilLayer) ) + if ( .not. allocated(noahmp%energy%state%HeatCapacSoilSnow) ) & + allocate( noahmp%energy%state%HeatCapacSoilSnow(-NumSnowLayerMax+1:NumSoilLayer) ) + if ( .not. allocated(noahmp%energy%state%PhaseChgFacSoilSnow) ) & + allocate( noahmp%energy%state%PhaseChgFacSoilSnow(-NumSnowLayerMax+1:NumSoilLayer) ) + if ( .not. allocated(noahmp%energy%state%HeatCapacVolSnow) ) & + allocate( noahmp%energy%state%HeatCapacVolSnow(-NumSnowLayerMax+1:0) ) + if ( .not. allocated(noahmp%energy%state%ThermConductSnow) ) & + allocate( noahmp%energy%state%ThermConductSnow(-NumSnowLayerMax+1:0) ) + if ( .not. allocated(noahmp%energy%state%HeatCapacVolSoil) ) & + allocate( noahmp%energy%state%HeatCapacVolSoil(1:NumSoilLayer) ) + if ( .not. allocated(noahmp%energy%state%ThermConductSoil) ) & + allocate( noahmp%energy%state%ThermConductSoil(1:NumSoilLayer) ) + if ( .not. allocated(noahmp%energy%state%HeatCapacGlaIce) ) & + allocate( noahmp%energy%state%HeatCapacGlaIce(1:NumSoilLayer) ) + if ( .not. allocated(noahmp%energy%state%ThermConductGlaIce) ) & + allocate( noahmp%energy%state%ThermConductGlaIce(1:NumSoilLayer) ) + if ( .not. allocated(noahmp%energy%state%AlbedoSnowDir) ) & + allocate( noahmp%energy%state%AlbedoSnowDir(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%state%AlbedoSnowDif) ) & + allocate( noahmp%energy%state%AlbedoSnowDif(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%state%AlbedoSoilDir) ) & + allocate( noahmp%energy%state%AlbedoSoilDir(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%state%AlbedoSoilDif) ) & + allocate( noahmp%energy%state%AlbedoSoilDif(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%state%AlbedoGrdDir) ) & + allocate( noahmp%energy%state%AlbedoGrdDir(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%state%AlbedoGrdDif) ) & + allocate( noahmp%energy%state%AlbedoGrdDif(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%state%ReflectanceVeg) ) & + allocate( noahmp%energy%state%ReflectanceVeg(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%state%TransmittanceVeg) ) & + allocate( noahmp%energy%state%TransmittanceVeg(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%state%AlbedoSfcDir) ) & + allocate( noahmp%energy%state%AlbedoSfcDir(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%state%AlbedoSfcDif) ) & + allocate( noahmp%energy%state%AlbedoSfcDif(1:NumSwRadBand) ) + + noahmp%energy%state%TemperatureSoilSnow (:) = undefined_real + noahmp%energy%state%ThermConductSoilSnow(:) = undefined_real + noahmp%energy%state%HeatCapacSoilSnow (:) = undefined_real + noahmp%energy%state%PhaseChgFacSoilSnow (:) = undefined_real + noahmp%energy%state%HeatCapacVolSnow (:) = undefined_real + noahmp%energy%state%ThermConductSnow (:) = undefined_real + noahmp%energy%state%HeatCapacVolSoil (:) = undefined_real + noahmp%energy%state%ThermConductSoil (:) = undefined_real + noahmp%energy%state%HeatCapacGlaIce (:) = undefined_real + noahmp%energy%state%ThermConductGlaIce (:) = undefined_real + noahmp%energy%state%AlbedoSnowDir (:) = undefined_real + noahmp%energy%state%AlbedoSnowDif (:) = undefined_real + noahmp%energy%state%AlbedoSoilDir (:) = undefined_real + noahmp%energy%state%AlbedoSoilDif (:) = undefined_real + noahmp%energy%state%AlbedoGrdDir (:) = undefined_real + noahmp%energy%state%AlbedoGrdDif (:) = undefined_real + noahmp%energy%state%ReflectanceVeg (:) = undefined_real + noahmp%energy%state%TransmittanceVeg (:) = undefined_real + noahmp%energy%state%AlbedoSfcDir (:) = undefined_real + noahmp%energy%state%AlbedoSfcDif (:) = undefined_real + + ! energy flux variables + noahmp%energy%flux%HeatLatentCanopy = undefined_real + noahmp%energy%flux%HeatLatentTransp = undefined_real + noahmp%energy%flux%HeatLatentGrd = undefined_real + noahmp%energy%flux%HeatPrecipAdvCanopy = undefined_real + noahmp%energy%flux%HeatPrecipAdvVegGrd = undefined_real + noahmp%energy%flux%HeatPrecipAdvBareGrd = undefined_real + noahmp%energy%flux%HeatPrecipAdvSfc = undefined_real + noahmp%energy%flux%RadPhotoActAbsSunlit = undefined_real + noahmp%energy%flux%RadPhotoActAbsShade = undefined_real + noahmp%energy%flux%RadSwAbsVeg = undefined_real + noahmp%energy%flux%RadSwAbsGrd = undefined_real + noahmp%energy%flux%RadSwAbsSfc = undefined_real + noahmp%energy%flux%RadSwReflSfc = undefined_real + noahmp%energy%flux%RadSwReflVeg = undefined_real + noahmp%energy%flux%RadSwReflGrd = undefined_real + noahmp%energy%flux%RadLwNetCanopy = undefined_real + noahmp%energy%flux%HeatSensibleCanopy = undefined_real + noahmp%energy%flux%HeatLatentCanEvap = undefined_real + noahmp%energy%flux%RadLwNetVegGrd = undefined_real + noahmp%energy%flux%HeatSensibleVegGrd = undefined_real + noahmp%energy%flux%HeatLatentVegGrd = undefined_real + noahmp%energy%flux%HeatLatentCanTransp = undefined_real + noahmp%energy%flux%HeatGroundVegGrd = undefined_real + noahmp%energy%flux%RadLwNetBareGrd = undefined_real + noahmp%energy%flux%HeatSensibleBareGrd = undefined_real + noahmp%energy%flux%HeatLatentBareGrd = undefined_real + noahmp%energy%flux%HeatGroundBareGrd = undefined_real + noahmp%energy%flux%HeatGroundTot = undefined_real + noahmp%energy%flux%HeatFromSoilBot = undefined_real + noahmp%energy%flux%RadLwNetSfc = undefined_real + noahmp%energy%flux%HeatSensibleSfc = undefined_real + noahmp%energy%flux%RadPhotoActAbsCan = undefined_real + noahmp%energy%flux%RadLwEmitSfc = undefined_real + noahmp%energy%flux%HeatCanStorageChg = undefined_real + noahmp%energy%flux%HeatGroundTotAcc = undefined_real + noahmp%energy%flux%HeatGroundTotMean = undefined_real + noahmp%energy%flux%HeatLatentIrriEvap = 0.0 + + if ( .not. allocated(noahmp%energy%flux%RadSwAbsVegDir) ) & + allocate( noahmp%energy%flux%RadSwAbsVegDir(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%flux%RadSwAbsVegDif) ) & + allocate( noahmp%energy%flux%RadSwAbsVegDif(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%flux%RadSwDirTranGrdDir) ) & + allocate( noahmp%energy%flux%RadSwDirTranGrdDir(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%flux%RadSwDirTranGrdDif) ) & + allocate( noahmp%energy%flux%RadSwDirTranGrdDif(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%flux%RadSwDifTranGrdDir) ) & + allocate( noahmp%energy%flux%RadSwDifTranGrdDir(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%flux%RadSwDifTranGrdDif) ) & + allocate( noahmp%energy%flux%RadSwDifTranGrdDif(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%flux%RadSwReflVegDir) ) & + allocate( noahmp%energy%flux%RadSwReflVegDir(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%flux%RadSwReflVegDif) ) & + allocate( noahmp%energy%flux%RadSwReflVegDif(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%flux%RadSwReflGrdDir) ) & + allocate( noahmp%energy%flux%RadSwReflGrdDir(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%flux%RadSwReflGrdDif) ) & + allocate( noahmp%energy%flux%RadSwReflGrdDif(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%flux%RadSwDownDir) ) & + allocate( noahmp%energy%flux%RadSwDownDir(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%flux%RadSwDownDif) ) & + allocate( noahmp%energy%flux%RadSwDownDif(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%flux%RadSwPenetrateGrd) ) & + allocate( noahmp%energy%flux%RadSwPenetrateGrd(-NumSnowLayerMax+1:NumSoilLayer) ) + + noahmp%energy%flux%RadSwAbsVegDir (:) = undefined_real + noahmp%energy%flux%RadSwAbsVegDif (:) = undefined_real + noahmp%energy%flux%RadSwDirTranGrdDir(:) = undefined_real + noahmp%energy%flux%RadSwDirTranGrdDif(:) = undefined_real + noahmp%energy%flux%RadSwDifTranGrdDir(:) = undefined_real + noahmp%energy%flux%RadSwDifTranGrdDif(:) = undefined_real + noahmp%energy%flux%RadSwReflVegDir (:) = undefined_real + noahmp%energy%flux%RadSwReflVegDif (:) = undefined_real + noahmp%energy%flux%RadSwReflGrdDir (:) = undefined_real + noahmp%energy%flux%RadSwReflGrdDif (:) = undefined_real + noahmp%energy%flux%RadSwDownDir (:) = undefined_real + noahmp%energy%flux%RadSwDownDif (:) = undefined_real + noahmp%energy%flux%RadSwPenetrateGrd (:) = undefined_real + + ! energy parameter variables + noahmp%energy%param%TreeCrownRadius = undefined_real + noahmp%energy%param%HeightCanopyTop = undefined_real + noahmp%energy%param%HeightCanopyBot = undefined_real + noahmp%energy%param%RoughLenMomVeg = undefined_real + noahmp%energy%param%TreeDensity = undefined_real + noahmp%energy%param%CanopyOrientIndex = undefined_real + noahmp%energy%param%UpscatterCoeffSnowDir = undefined_real + noahmp%energy%param%UpscatterCoeffSnowDif = undefined_real + noahmp%energy%param%SoilHeatCapacity = undefined_real + noahmp%energy%param%SnowAgeFacBats = undefined_real + noahmp%energy%param%SnowGrowVapFacBats = undefined_real + noahmp%energy%param%SnowSootFacBats = undefined_real + noahmp%energy%param%SnowGrowFrzFacBats = undefined_real + noahmp%energy%param%SolarZenithAdjBats = undefined_real + noahmp%energy%param%FreshSnoAlbVisBats = undefined_real + noahmp%energy%param%FreshSnoAlbNirBats = undefined_real + noahmp%energy%param%SnoAgeFacDifVisBats = undefined_real + noahmp%energy%param%SnoAgeFacDifNirBats = undefined_real + noahmp%energy%param%SzaFacDirVisBats = undefined_real + noahmp%energy%param%SzaFacDirNirBats = undefined_real + noahmp%energy%param%SnowAlbRefClass = undefined_real + noahmp%energy%param%SnowAgeFacClass = undefined_real + noahmp%energy%param%SnowAlbFreshClass = undefined_real + noahmp%energy%param%ConductanceLeafMin = undefined_real + noahmp%energy%param%Co2MmConst25C = undefined_real + noahmp%energy%param%O2MmConst25C = undefined_real + noahmp%energy%param%Co2MmConstQ10 = undefined_real + noahmp%energy%param%O2MmConstQ10 = undefined_real + noahmp%energy%param%RadiationStressFac = undefined_real + noahmp%energy%param%ResistanceStomataMin = undefined_real + noahmp%energy%param%ResistanceStomataMax = undefined_real + noahmp%energy%param%AirTempOptimTransp = undefined_real + noahmp%energy%param%VaporPresDeficitFac = undefined_real + noahmp%energy%param%LeafDimLength = undefined_real + noahmp%energy%param%ZilitinkevichCoeff = undefined_real + noahmp%energy%param%EmissivitySnow = undefined_real + noahmp%energy%param%CanopyWindExtFac = undefined_real + noahmp%energy%param%RoughLenMomSnow = undefined_real + noahmp%energy%param%RoughLenMomSoil = undefined_real + noahmp%energy%param%RoughLenMomLake = undefined_real + noahmp%energy%param%EmissivityIceSfc = undefined_real + noahmp%energy%param%ResistanceSoilExp = undefined_real + noahmp%energy%param%ResistanceSnowSfc = undefined_real + noahmp%energy%param%VegFracAnnMax = undefined_real + noahmp%energy%param%VegFracGreen = undefined_real + noahmp%energy%param%HeatCapacCanFac = undefined_real + + if ( .not. allocated(noahmp%energy%param%LeafAreaIndexMon) ) & + allocate( noahmp%energy%param%LeafAreaIndexMon(1:12) ) + if ( .not. allocated(noahmp%energy%param%StemAreaIndexMon) ) & + allocate( noahmp%energy%param%StemAreaIndexMon(1:12) ) + if ( .not. allocated(noahmp%energy%param%SoilQuartzFrac) ) & + allocate( noahmp%energy%param%SoilQuartzFrac(1:NumSoilLayer) ) + if ( .not. allocated(noahmp%energy%param%AlbedoSoilSat) ) & + allocate( noahmp%energy%param%AlbedoSoilSat(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%param%AlbedoSoilDry) ) & + allocate( noahmp%energy%param%AlbedoSoilDry(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%param%AlbedoLakeFrz) ) & + allocate( noahmp%energy%param%AlbedoLakeFrz(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%param%ScatterCoeffSnow) ) & + allocate( noahmp%energy%param%ScatterCoeffSnow(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%param%ReflectanceLeaf) ) & + allocate( noahmp%energy%param%ReflectanceLeaf(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%param%ReflectanceStem) ) & + allocate( noahmp%energy%param%ReflectanceStem(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%param%TransmittanceLeaf) ) & + allocate( noahmp%energy%param%TransmittanceLeaf(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%param%TransmittanceStem) ) & + allocate( noahmp%energy%param%TransmittanceStem(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%param%EmissivitySoilLake) ) & + allocate( noahmp%energy%param%EmissivitySoilLake(1:2) ) + if ( .not. allocated(noahmp%energy%param%AlbedoLandIce) ) & + allocate( noahmp%energy%param%AlbedoLandIce(1:NumSwRadBand) ) + + noahmp%energy%param%LeafAreaIndexMon (:) = undefined_real + noahmp%energy%param%StemAreaIndexMon (:) = undefined_real + noahmp%energy%param%SoilQuartzFrac (:) = undefined_real + noahmp%energy%param%AlbedoSoilSat (:) = undefined_real + noahmp%energy%param%AlbedoSoilDry (:) = undefined_real + noahmp%energy%param%AlbedoLakeFrz (:) = undefined_real + noahmp%energy%param%ScatterCoeffSnow (:) = undefined_real + noahmp%energy%param%ReflectanceLeaf (:) = undefined_real + noahmp%energy%param%ReflectanceStem (:) = undefined_real + noahmp%energy%param%TransmittanceLeaf (:) = undefined_real + noahmp%energy%param%TransmittanceStem (:) = undefined_real + noahmp%energy%param%EmissivitySoilLake(:) = undefined_real + noahmp%energy%param%AlbedoLandIce (:) = undefined_real + + end associate + + end subroutine EnergyVarInitDefault + +end module EnergyVarInitMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/EnergyVarType.F90 b/src/core_atmosphere/physics/physics_noahmp/src/EnergyVarType.F90 new file mode 100644 index 0000000000..0805d30344 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/EnergyVarType.F90 @@ -0,0 +1,309 @@ +module EnergyVarType + +!!! Define column (1-D) Noah-MP Energy variables +!!! Energy variable initialization is done in EnergyVarInitMod.F90 + +! ------------------------ Code history ----------------------------------- +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + use Machine + + implicit none + save + private + +!=== define "flux" sub-type of energy (energy%flux%variable) + type :: flux_type + + real(kind=kind_noahmp) :: HeatLatentCanopy ! canopy latent heat flux [W/m2] (+ to atm) + real(kind=kind_noahmp) :: HeatLatentTransp ! latent heat flux from transpiration [W/m2] (+ to atm) + real(kind=kind_noahmp) :: HeatLatentGrd ! total ground latent heat [W/m2] (+ to atm) + real(kind=kind_noahmp) :: HeatLatentIrriEvap ! latent heating due to sprinkler irrigation evaporation [W/m2] + real(kind=kind_noahmp) :: HeatPrecipAdvCanopy ! precipitation advected heat - canopy net [W/m2] + real(kind=kind_noahmp) :: HeatPrecipAdvVegGrd ! precipitation advected heat - vegetated ground net [W/m2] + real(kind=kind_noahmp) :: HeatPrecipAdvBareGrd ! precipitation advected heat - bare ground net [W/m2] + real(kind=kind_noahmp) :: HeatPrecipAdvSfc ! precipitation advected heat - total [W/m2] + real(kind=kind_noahmp) :: HeatSensibleCanopy ! canopy sensible heat flux [W/m2] (+ to atm) + real(kind=kind_noahmp) :: HeatLatentCanEvap ! canopy evaporation heat flux [W/m2] (+ to atm) + real(kind=kind_noahmp) :: HeatSensibleVegGrd ! vegetated ground sensible heat flux [W/m2] (+ to atm) + real(kind=kind_noahmp) :: HeatSensibleSfc ! total sensible heat [W/m2] (+ to atm) + real(kind=kind_noahmp) :: HeatLatentVegGrd ! vegetated ground latent heat flux [W/m2] (+ to atm) + real(kind=kind_noahmp) :: HeatLatentCanTransp ! canopy transpiration latent heat flux [W/m2] (+ to atm) + real(kind=kind_noahmp) :: HeatGroundVegGrd ! vegetated ground heat flux [W/m2] (+ to soil/snow) + real(kind=kind_noahmp) :: HeatSensibleBareGrd ! bare ground sensible heat flux [W/m2] (+ to atm) + real(kind=kind_noahmp) :: HeatLatentBareGrd ! bare ground latent heat flux [W/m2] (+ to atm) + real(kind=kind_noahmp) :: HeatGroundBareGrd ! bare ground heat flux [W/m2] (+ to soil/snow) + real(kind=kind_noahmp) :: HeatGroundTot ! total ground heat flux [W/m2] (+ to soil/snow) + real(kind=kind_noahmp) :: HeatGroundTotMean ! total ground heat flux [W/m2] averaged over soil timestep + real(kind=kind_noahmp) :: HeatFromSoilBot ! energy influx from soil bottom [W/m2] + real(kind=kind_noahmp) :: HeatCanStorageChg ! canopy heat storage change [W/m2] + real(kind=kind_noahmp) :: HeatGroundTotAcc ! accumulated total ground heat flux per soil timestep [W/m2 * dt_soil/dt_main] (+ to soil/snow) + real(kind=kind_noahmp) :: RadPhotoActAbsSunlit ! absorbed photosyn. active radiation for sunlit leaves [W/m2] + real(kind=kind_noahmp) :: RadPhotoActAbsShade ! absorbed photosyn. active radiation for shaded leaves [W/m2] + real(kind=kind_noahmp) :: RadSwAbsVeg ! solar radiation absorbed by vegetation [W/m2] + real(kind=kind_noahmp) :: RadSwAbsGrd ! solar radiation absorbed by ground [W/m2] + real(kind=kind_noahmp) :: RadSwAbsSfc ! total absorbed solar radiation [W/m2] + real(kind=kind_noahmp) :: RadSwReflSfc ! total reflected solar radiation [W/m2] + real(kind=kind_noahmp) :: RadSwReflVeg ! reflected solar radiation by vegetation [W/m2] + real(kind=kind_noahmp) :: RadSwReflGrd ! reflected solar radiation by ground [W/m2] + real(kind=kind_noahmp) :: RadLwNetCanopy ! canopy net longwave radiation [W/m2] (+ to atm) + real(kind=kind_noahmp) :: RadLwNetSfc ! total net longwave radiation [W/m2] (+ to atm) + real(kind=kind_noahmp) :: RadPhotoActAbsCan ! total photosyn. active energy [W/m2] absorbed by canopy + real(kind=kind_noahmp) :: RadLwEmitSfc ! emitted outgoing longwave radiation [W/m2] + real(kind=kind_noahmp) :: RadLwNetVegGrd ! vegetated ground net longwave radiation [W/m2] (+ to atm) + real(kind=kind_noahmp) :: RadLwNetBareGrd ! bare ground net longwave rad [W/m2] (+ to atm) + + real(kind=kind_noahmp), allocatable, dimension(:) :: RadSwAbsVegDir ! solar flux absorbed by veg per unit direct flux + real(kind=kind_noahmp), allocatable, dimension(:) :: RadSwAbsVegDif ! solar flux absorbed by veg per unit diffuse flux + real(kind=kind_noahmp), allocatable, dimension(:) :: RadSwDirTranGrdDir ! transmitted direct flux below veg per unit direct flux + real(kind=kind_noahmp), allocatable, dimension(:) :: RadSwDirTranGrdDif ! transmitted direct flux below veg per unit diffuse flux + real(kind=kind_noahmp), allocatable, dimension(:) :: RadSwDifTranGrdDir ! transmitted diffuse flux below veg per unit direct flux + real(kind=kind_noahmp), allocatable, dimension(:) :: RadSwDifTranGrdDif ! transmitted diffuse flux below veg per unit diffuse flux + real(kind=kind_noahmp), allocatable, dimension(:) :: RadSwReflVegDir ! solar flux reflected by veg layer per unit direct flux + real(kind=kind_noahmp), allocatable, dimension(:) :: RadSwReflVegDif ! solar flux reflected by veg layer per unit diffuse flux + real(kind=kind_noahmp), allocatable, dimension(:) :: RadSwReflGrdDir ! solar flux reflected by ground per unit direct flux + real(kind=kind_noahmp), allocatable, dimension(:) :: RadSwReflGrdDif ! solar flux reflected by ground per unit diffuse flux + real(kind=kind_noahmp), allocatable, dimension(:) :: RadSwDownDir ! incoming direct solar radiation [W/m2] + real(kind=kind_noahmp), allocatable, dimension(:) :: RadSwDownDif ! incoming diffuse solar radiation [W/m2] + real(kind=kind_noahmp), allocatable, dimension(:) :: RadSwPenetrateGrd ! light penetrating through soil/snow water [W/m2] + + end type flux_type + + +!=== define "state" sub-type of energy (energy%state%variable) + type :: state_type + + logical :: FlagFrozenCanopy ! frozen canopy flag used to define latent heat pathway + logical :: FlagFrozenGround ! frozen ground flag used to define latent heat pathway + real(kind=kind_noahmp) :: LeafAreaIndEff ! effective leaf area index, after burying by snow + real(kind=kind_noahmp) :: StemAreaIndEff ! effective stem area index, after burying by snow + real(kind=kind_noahmp) :: LeafAreaIndex ! leaf area index + real(kind=kind_noahmp) :: StemAreaIndex ! stem area index + real(kind=kind_noahmp) :: VegAreaIndEff ! one-sided leaf+stem area index [m2/m2], after burying by snow + real(kind=kind_noahmp) :: VegFrac ! greeness vegetation fraction + real(kind=kind_noahmp) :: TemperatureGrd ! ground temperature [K] + real(kind=kind_noahmp) :: TemperatureCanopy ! vegetation/canopy temperature [K] + real(kind=kind_noahmp) :: TemperatureSfc ! surface temperature [K] + real(kind=kind_noahmp) :: TemperatureRootZone ! root-zone averaged temperature [K] + real(kind=kind_noahmp) :: PressureVaporRefHeight ! vapor pressure air [Pa] + real(kind=kind_noahmp) :: SnowAgeFac ! snow age factor + real(kind=kind_noahmp) :: SnowAgeNondim ! non-dimensional snow age + real(kind=kind_noahmp) :: AlbedoSnowPrev ! snow albedo at last time step + real(kind=kind_noahmp) :: VegAreaProjDir ! projected leaf+stem area in solar direction + real(kind=kind_noahmp) :: GapBtwCanopy ! between canopy gap fraction for beam + real(kind=kind_noahmp) :: GapInCanopy ! within canopy gap fraction for beam + real(kind=kind_noahmp) :: GapCanopyDif ! gap fraction for diffue light + real(kind=kind_noahmp) :: GapCanopyDir ! total gap fraction for beam (<=1-shafac) + real(kind=kind_noahmp) :: CanopySunlitFrac ! sunlit fraction of canopy + real(kind=kind_noahmp) :: CanopyShadeFrac ! shaded fraction of canopy + real(kind=kind_noahmp) :: LeafAreaIndSunlit ! sunlit leaf area + real(kind=kind_noahmp) :: LeafAreaIndShade ! shaded leaf area + real(kind=kind_noahmp) :: VapPresSatCanopy ! canopy saturation vapor pressure at veg temperature [Pa] + real(kind=kind_noahmp) :: VapPresSatGrdVeg ! below-canopy saturation vapor pressure at ground temperature [Pa] + real(kind=kind_noahmp) :: VapPresSatGrdBare ! bare ground saturation vapor pressure at ground temperature [Pa] + real(kind=kind_noahmp) :: VapPresSatCanTempD ! canopy saturation vapor pressure derivative with temperature at veg temp. [Pa/K] + real(kind=kind_noahmp) :: VapPresSatGrdVegTempD ! below-canopy saturation vapor pressure derivative with temperature at ground temp. [Pa/K] + real(kind=kind_noahmp) :: VapPresSatGrdBareTempD ! bare ground saturation vapor pressure derivative with temperature at ground temp. [Pa/K] + real(kind=kind_noahmp) :: PressureVaporCanAir ! canopy air vapor pressure [Pa] + real(kind=kind_noahmp) :: PressureAtmosCO2 ! atmospheric co2 partial pressure [Pa] + real(kind=kind_noahmp) :: PressureAtmosO2 ! atmospheric o2 partial pressure [Pa] + real(kind=kind_noahmp) :: ResistanceStomataSunlit ! sunlit leaf stomatal resistance [s/m] + real(kind=kind_noahmp) :: ResistanceStomataShade ! shaded leaf stomatal resistance [s/m] + real(kind=kind_noahmp) :: DensityAirRefHeight ! density air [kg/m3] at reference height + real(kind=kind_noahmp) :: TemperatureCanopyAir ! canopy air temperature [K] + real(kind=kind_noahmp) :: ZeroPlaneDispSfc ! surface zero plane displacement [m] + real(kind=kind_noahmp) :: ZeroPlaneDispGrd ! ground zero plane displacement [m] + real(kind=kind_noahmp) :: RoughLenMomGrd ! roughness length, momentum, ground [m] + real(kind=kind_noahmp) :: RoughLenMomSfc ! roughness length, momentum, surface [m] + real(kind=kind_noahmp) :: RoughLenShCanopy ! roughness length, sensible heat, canopy [m] + real(kind=kind_noahmp) :: RoughLenShVegGrd ! roughness length, sensible heat, ground, below canopy [m] + real(kind=kind_noahmp) :: RoughLenShBareGrd ! roughness length, sensible heat, bare ground [m] + real(kind=kind_noahmp) :: CanopyHeight ! canopy height [m] + real(kind=kind_noahmp) :: WindSpdCanopyTop ! wind speed at top of canopy [m/s] + real(kind=kind_noahmp) :: FrictionVelVeg ! friction velocity [m/s], vegetated + real(kind=kind_noahmp) :: FrictionVelBare ! friction velocity [m/s], bare ground + real(kind=kind_noahmp) :: WindExtCoeffCanopy ! canopy wind extinction coefficient + real(kind=kind_noahmp) :: MoStabParaUndCan ! M-O stability parameter ground, below canopy + real(kind=kind_noahmp) :: MoStabParaAbvCan ! M-O stability parameter (z/L), above ZeroPlaneDisp, vegetated + real(kind=kind_noahmp) :: MoStabParaBare ! M-O stability parameter (z/L), above ZeroPlaneDisp, bare ground + real(kind=kind_noahmp) :: MoStabParaVeg2m ! M-O stability parameter (2/L), 2m, vegetated + real(kind=kind_noahmp) :: MoStabParaBare2m ! M-O stability parameter (2/L), 2m, bare ground + real(kind=kind_noahmp) :: MoLengthUndCan ! M-O length [m], ground, below canopy + real(kind=kind_noahmp) :: MoLengthAbvCan ! M-O length [m], above ZeroPlaneDisp, vegetated + real(kind=kind_noahmp) :: MoLengthBare ! M-O length [m], above ZeroPlaneDisp, bare ground + real(kind=kind_noahmp) :: MoStabCorrShUndCan ! M-O stability correction ground, below canopy + real(kind=kind_noahmp) :: MoStabCorrMomAbvCan ! M-O momentum stability correction, above ZeroPlaneDisp, vegetated + real(kind=kind_noahmp) :: MoStabCorrShAbvCan ! M-O sensible heat stability correction, above ZeroPlaneDisp, vegetated + real(kind=kind_noahmp) :: MoStabCorrMomVeg2m ! M-O momentum stability correction, 2m, vegetated + real(kind=kind_noahmp) :: MoStabCorrShVeg2m ! M-O sensible heat stability correction, 2m, vegetated + real(kind=kind_noahmp) :: MoStabCorrShBare ! M-O sensible heat stability correction, above ZeroPlaneDisp, bare ground + real(kind=kind_noahmp) :: MoStabCorrMomBare ! M-O momentum stability correction, above ZeroPlaneDisp, bare ground + real(kind=kind_noahmp) :: MoStabCorrMomBare2m ! M-O momentum stability correction, 2m, bare ground + real(kind=kind_noahmp) :: MoStabCorrShBare2m ! M-O sensible heat stability correction, 2m, bare ground + real(kind=kind_noahmp) :: ExchCoeffMomSfc ! exchange coefficient [m/s] for momentum, surface, grid mean + real(kind=kind_noahmp) :: ExchCoeffMomAbvCan ! exchange coefficient [m/s] for momentum, above ZeroPlaneDisp, vegetated + real(kind=kind_noahmp) :: ExchCoeffMomBare ! exchange coefficient [m/s] for momentum, above ZeroPlaneDisp, bare ground + real(kind=kind_noahmp) :: ExchCoeffShSfc ! exchange coefficient [m/s] for sensible heat, surface, grid mean + real(kind=kind_noahmp) :: ExchCoeffShAbvCan ! exchange coefficient [m/s] for sensible heat, above ZeroPlaneDisp, vegetated + real(kind=kind_noahmp) :: ExchCoeffShBare ! exchange coefficient [m/s] for sensible heat, above ZeroPlaneDisp, bare ground + real(kind=kind_noahmp) :: ExchCoeffSh2mVegMo ! exchange coefficient [m/s] for sensible heat, 2m, vegetated (M-O) + real(kind=kind_noahmp) :: ExchCoeffSh2mBareMo ! exchange coefficient [m/s] for sensible heat, 2m, bare ground (M-O) + real(kind=kind_noahmp) :: ExchCoeffSh2mVeg ! exchange coefficient [m/s] for sensible heat, 2m, vegetated (diagnostic) + real(kind=kind_noahmp) :: ExchCoeffLhAbvCan ! exchange coefficient [m/s] for latent heat, canopy air to ref height + real(kind=kind_noahmp) :: ExchCoeffLhTransp ! exchange coefficient [m/s] for transpiration, leaf to canopy air + real(kind=kind_noahmp) :: ExchCoeffLhEvap ! exchange coefficient [m/s] for leaf evaporation, leaf to canopy air + real(kind=kind_noahmp) :: ExchCoeffLhUndCan ! exchange coefficient [m/s] for latent heat, ground to canopy air + real(kind=kind_noahmp) :: ResistanceMomUndCan ! aerodynamic resistance [s/m] for momentum, ground, below canopy + real(kind=kind_noahmp) :: ResistanceShUndCan ! aerodynamic resistance [s/m] for sensible heat, ground, below canopy + real(kind=kind_noahmp) :: ResistanceLhUndCan ! aerodynamic resistance [s/m] for water vapor, ground, below canopy + real(kind=kind_noahmp) :: ResistanceMomAbvCan ! aerodynamic resistance [s/m] for momentum, above canopy + real(kind=kind_noahmp) :: ResistanceShAbvCan ! aerodynamic resistance [s/m] for sensible heat, above canopy + real(kind=kind_noahmp) :: ResistanceLhAbvCan ! aerodynamic resistance [s/m] for water vapor, above canopy + real(kind=kind_noahmp) :: ResistanceMomBareGrd ! aerodynamic resistance [s/m] for momentum, bare ground + real(kind=kind_noahmp) :: ResistanceShBareGrd ! aerodynamic resistance [s/m] for sensible heat, bare ground + real(kind=kind_noahmp) :: ResistanceLhBareGrd ! aerodynamic resistance [s/m] for water vapor, bare ground + real(kind=kind_noahmp) :: ResistanceLeafBoundary ! bulk leaf boundary layer resistance [s/m] + real(kind=kind_noahmp) :: TemperaturePotRefHeight ! potential temp at reference height [K] + real(kind=kind_noahmp) :: WindSpdRefHeight ! wind speed [m/s] at reference height + real(kind=kind_noahmp) :: FrictionVelVertVeg ! friction velocity in vertical direction [m/s], vegetated (only for Chen97) + real(kind=kind_noahmp) :: FrictionVelVertBare ! friction velocity in vertical direction [m/s], bare ground (only for Chen97) + real(kind=kind_noahmp) :: EmissivityVeg ! vegetation emissivity + real(kind=kind_noahmp) :: EmissivityGrd ! ground emissivity + real(kind=kind_noahmp) :: ResistanceGrdEvap ! ground surface resistance [s/m] to evaporation/sublimation + real(kind=kind_noahmp) :: PsychConstCanopy ! psychrometric constant [Pa/K], canopy + real(kind=kind_noahmp) :: LatHeatVapCanopy ! latent heat of vaporization/subli [J/kg], canopy + real(kind=kind_noahmp) :: PsychConstGrd ! psychrometric constant [Pa/K], ground + real(kind=kind_noahmp) :: LatHeatVapGrd ! latent heat of vaporization/subli [J/kg], ground + real(kind=kind_noahmp) :: RelHumidityGrd ! raltive humidity in surface soil/snow air space (-) + real(kind=kind_noahmp) :: SpecHumiditySfc ! specific humidity at surface (bare or vegetated or urban) + real(kind=kind_noahmp) :: SpecHumiditySfcMean ! specific humidity at surface grid mean + real(kind=kind_noahmp) :: SpecHumidity2mVeg ! specific humidity at 2m vegetated + real(kind=kind_noahmp) :: SpecHumidity2mBare ! specific humidity at 2m bare ground + real(kind=kind_noahmp) :: SpecHumidity2m ! specific humidity at 2m grid mean + real(kind=kind_noahmp) :: TemperatureGrdVeg ! vegetated ground (below-canopy) temperature [K] + real(kind=kind_noahmp) :: TemperatureGrdBare ! bare ground temperature [K] + real(kind=kind_noahmp) :: WindStressEwVeg ! wind stress [N/m2]: east-west above canopy + real(kind=kind_noahmp) :: WindStressNsVeg ! wind stress [N/m2]: north-south above canopy + real(kind=kind_noahmp) :: WindStressEwBare ! wind stress [N/m2]: east-west bare ground + real(kind=kind_noahmp) :: WindStressNsBare ! wind stress [N/m2]: north-south bare ground + real(kind=kind_noahmp) :: WindStressEwSfc ! wind stress [N/m2]: east-west grid mean + real(kind=kind_noahmp) :: WindStressNsSfc ! wind stress [N/m2]: north-south grid mean + real(kind=kind_noahmp) :: TemperatureAir2mVeg ! 2 m height air temperature [K], vegetated + real(kind=kind_noahmp) :: TemperatureAir2mBare ! 2 m height air temperature [K], bare ground + real(kind=kind_noahmp) :: TemperatureAir2m ! 2 m height air temperature [K], grid mean + real(kind=kind_noahmp) :: ExchCoeffShLeaf ! leaf sensible heat exchange coefficient [m/s] + real(kind=kind_noahmp) :: ExchCoeffShUndCan ! under canopy sensible heat exchange coefficient [m/s] + real(kind=kind_noahmp) :: ExchCoeffSh2mBare ! bare ground 2-m sensible heat exchange coefficient [m/s] (diagnostic) + real(kind=kind_noahmp) :: RefHeightAboveGrd ! reference height [m] above ground + real(kind=kind_noahmp) :: CanopyFracSnowBury ! fraction of canopy buried by snow + real(kind=kind_noahmp) :: DepthSoilTempBotToSno ! depth of soil temperature lower boundary condition from snow surface [m] + real(kind=kind_noahmp) :: RoughLenMomSfcToAtm ! roughness length, momentum, surface, sent to coupled atmos model + real(kind=kind_noahmp) :: TemperatureRadSfc ! radiative temperature [K] + real(kind=kind_noahmp) :: EmissivitySfc ! surface emissivity + real(kind=kind_noahmp) :: AlbedoSfc ! total surface albedo + real(kind=kind_noahmp) :: EnergyBalanceError ! error in surface energy balance [W/m2] + real(kind=kind_noahmp) :: RadSwBalanceError ! error in shortwave radiation balance [W/m2] + + real(kind=kind_noahmp), allocatable, dimension(:) :: TemperatureSoilSnow ! snow and soil layer temperature [K] + real(kind=kind_noahmp), allocatable, dimension(:) :: HeatCapacVolSnow ! snow layer volumetric specific heat capacity [J/m3/K] + real(kind=kind_noahmp), allocatable, dimension(:) :: ThermConductSnow ! snow layer thermal conductivity [W/m/K] + real(kind=kind_noahmp), allocatable, dimension(:) :: HeatCapacVolSoil ! soil layer volumetric specific heat capacity [J/m3/K] + real(kind=kind_noahmp), allocatable, dimension(:) :: ThermConductSoil ! soil layer thermal conductivity [W/m/K] + real(kind=kind_noahmp), allocatable, dimension(:) :: HeatCapacGlaIce ! glacier ice layer volumetric specific heat [J/m3/K] + real(kind=kind_noahmp), allocatable, dimension(:) :: ThermConductGlaIce ! glacier ice thermal conductivity [W/m/K] + real(kind=kind_noahmp), allocatable, dimension(:) :: ThermConductSoilSnow ! thermal conductivity for all soil and snow layers [W/m/K] + real(kind=kind_noahmp), allocatable, dimension(:) :: HeatCapacSoilSnow ! heat capacity for all snow and soil layers [J/m3/K] + real(kind=kind_noahmp), allocatable, dimension(:) :: PhaseChgFacSoilSnow ! energy factor for soil and snow phase change + real(kind=kind_noahmp), allocatable, dimension(:) :: AlbedoSnowDir ! snow albedo for direct(1=vis, 2=nir) + real(kind=kind_noahmp), allocatable, dimension(:) :: AlbedoSnowDif ! snow albedo for diffuse(1=vis, 2=nir) + real(kind=kind_noahmp), allocatable, dimension(:) :: AlbedoSoilDir ! soil albedo (direct) + real(kind=kind_noahmp), allocatable, dimension(:) :: AlbedoSoilDif ! soil albedo (diffuse) + real(kind=kind_noahmp), allocatable, dimension(:) :: AlbedoGrdDir ! ground albedo (direct beam: vis, nir) + real(kind=kind_noahmp), allocatable, dimension(:) :: AlbedoGrdDif ! ground albedo (diffuse: vis, nir) + real(kind=kind_noahmp), allocatable, dimension(:) :: ReflectanceVeg ! leaf/stem reflectance weighted by LeafAreaIndex and StemAreaIndex + real(kind=kind_noahmp), allocatable, dimension(:) :: TransmittanceVeg ! leaf/stem transmittance weighted by LeafAreaIndex and StemAreaIndex + real(kind=kind_noahmp), allocatable, dimension(:) :: AlbedoSfcDir ! surface albedo (direct) + real(kind=kind_noahmp), allocatable, dimension(:) :: AlbedoSfcDif ! surface albedo (diffuse) + + end type state_type + + +!=== define "parameter" sub-type of energy (energy%param%variable) + type :: parameter_type + + real(kind=kind_noahmp) :: TreeCrownRadius ! tree crown radius [m] + real(kind=kind_noahmp) :: HeightCanopyTop ! height of canopy top [m] + real(kind=kind_noahmp) :: HeightCanopyBot ! height of canopy bottom [m] + real(kind=kind_noahmp) :: RoughLenMomVeg ! momentum roughness length [m] vegetated + real(kind=kind_noahmp) :: TreeDensity ! tree density [no. of trunks per m2] + real(kind=kind_noahmp) :: CanopyOrientIndex ! leaf/stem orientation index + real(kind=kind_noahmp) :: UpscatterCoeffSnowDir ! Upscattering parameters for snow for direct radiation + real(kind=kind_noahmp) :: UpscatterCoeffSnowDif ! Upscattering parameters for snow for diffuse radiation + real(kind=kind_noahmp) :: SoilHeatCapacity ! volumetric soil heat capacity [j/m3/K] + real(kind=kind_noahmp) :: SnowAgeFacBats ! snow aging parameter for BATS snow albedo + real(kind=kind_noahmp) :: SnowGrowVapFacBats ! vapor diffusion snow growth factor for BATS snow albedo + real(kind=kind_noahmp) :: SnowSootFacBats ! dirt and soot effect factor for BATS snow albedo + real(kind=kind_noahmp) :: SnowGrowFrzFacBats ! extra snow growth factor near freezing for BATS snow albedo + real(kind=kind_noahmp) :: SolarZenithAdjBats ! zenith angle snow albedo adjustment + real(kind=kind_noahmp) :: FreshSnoAlbVisBats ! new snow visible albedo for BATS + real(kind=kind_noahmp) :: FreshSnoAlbNirBats ! new snow NIR albedo for BATS + real(kind=kind_noahmp) :: SnoAgeFacDifVisBats ! age factor for diffuse visible snow albedo for BATS + real(kind=kind_noahmp) :: SnoAgeFacDifNirBats ! age factor for diffuse NIR snow albedo for BATS + real(kind=kind_noahmp) :: SzaFacDirVisBats ! cosz factor for direct visible snow albedo for BATS + real(kind=kind_noahmp) :: SzaFacDirNirBats ! cosz factor for direct NIR snow albedo for BATS + real(kind=kind_noahmp) :: SnowAlbRefClass ! reference snow albedo in CLASS scheme + real(kind=kind_noahmp) :: SnowAgeFacClass ! snow aging e-folding time [s] in CLASS albedo scheme + real(kind=kind_noahmp) :: SnowAlbFreshClass ! fresh snow albedo in CLASS albedo scheme + real(kind=kind_noahmp) :: ConductanceLeafMin ! minimum leaf conductance [umol/m2/s] + real(kind=kind_noahmp) :: Co2MmConst25C ! co2 michaelis-menten constant at 25c [Pa] + real(kind=kind_noahmp) :: O2MmConst25C ! o2 michaelis-menten constant at 25c [Pa] + real(kind=kind_noahmp) :: Co2MmConstQ10 ! change in co2 Michaelis-Menten constant for every 10-deg C temperature change + real(kind=kind_noahmp) :: O2MmConstQ10 ! change in o2 michaelis-menten constant for every 10-deg C temperature change + real(kind=kind_noahmp) :: RadiationStressFac ! Parameter used in radiation stress function in Jarvis scheme + real(kind=kind_noahmp) :: ResistanceStomataMin ! Minimum stomatal resistance [s/m] in Jarvis scheme + real(kind=kind_noahmp) :: ResistanceStomataMax ! Maximal stomatal resistance [s/m] in Jarvis scheme + real(kind=kind_noahmp) :: AirTempOptimTransp ! Optimum transpiration air temperature [K] in Jarvis scheme + real(kind=kind_noahmp) :: VaporPresDeficitFac ! Parameter used in vapor pressure deficit function in Jarvis scheme + real(kind=kind_noahmp) :: LeafDimLength ! characteristic leaf dimension [m] + real(kind=kind_noahmp) :: ZilitinkevichCoeff ! Zilitinkevich coefficient for heat exchange coefficient calculation + real(kind=kind_noahmp) :: EmissivitySnow ! snow emissivity + real(kind=kind_noahmp) :: CanopyWindExtFac ! empirical canopy wind extinction parameter + real(kind=kind_noahmp) :: RoughLenMomSnow ! snow surface roughness length [m] + real(kind=kind_noahmp) :: RoughLenMomSoil ! Bare-soil roughness length [m] + real(kind=kind_noahmp) :: RoughLenMomLake ! lake surface roughness length [m] + real(kind=kind_noahmp) :: EmissivityIceSfc ! ice surface emissivity + real(kind=kind_noahmp) :: ResistanceSoilExp ! exponent in the shape parameter for soil resistance option 1 + real(kind=kind_noahmp) :: ResistanceSnowSfc ! surface resistance for snow [s/m] + real(kind=kind_noahmp) :: VegFracGreen ! green vegetation fraction + real(kind=kind_noahmp) :: VegFracAnnMax ! annual maximum vegetation fraction + real(kind=kind_noahmp) :: HeatCapacCanFac ! canopy biomass heat capacity parameter [m] + + real(kind=kind_noahmp), allocatable, dimension(:) :: LeafAreaIndexMon ! monthly leaf area index, one-sided + real(kind=kind_noahmp), allocatable, dimension(:) :: StemAreaIndexMon ! monthly stem area index, one-sided + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilQuartzFrac ! soil quartz content + real(kind=kind_noahmp), allocatable, dimension(:) :: AlbedoSoilSat ! saturated soil albedos: 1=vis, 2=nir + real(kind=kind_noahmp), allocatable, dimension(:) :: AlbedoSoilDry ! dry soil albedos: 1=vis, 2=nir + real(kind=kind_noahmp), allocatable, dimension(:) :: AlbedoLakeFrz ! albedo frozen lakes: 1=vis, 2=nir + real(kind=kind_noahmp), allocatable, dimension(:) :: ScatterCoeffSnow ! Scattering coefficient for snow + real(kind=kind_noahmp), allocatable, dimension(:) :: ReflectanceLeaf ! leaf reflectance: 1=vis, 2=nir + real(kind=kind_noahmp), allocatable, dimension(:) :: ReflectanceStem ! stem reflectance: 1=vis, 2=nir + real(kind=kind_noahmp), allocatable, dimension(:) :: TransmittanceLeaf ! leaf transmittance: 1=vis, 2=nir + real(kind=kind_noahmp), allocatable, dimension(:) :: TransmittanceStem ! stem transmittance: 1=vis, 2=nir + real(kind=kind_noahmp), allocatable, dimension(:) :: EmissivitySoilLake ! emissivity soil surface: 1=soil, 2=lake + real(kind=kind_noahmp), allocatable, dimension(:) :: AlbedoLandIce ! land/glacier ice albedo: 1=vis, 2=nir + + end type parameter_type + + +!=== define energy type that includes 3 subtypes (flux,state,parameter) + type, public :: energy_type + + type(flux_type) :: flux + type(state_type) :: state + type(parameter_type) :: param + + end type energy_type + +end module EnergyVarType diff --git a/src/core_atmosphere/physics/physics_noahmp/src/ForcingVarInitMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/ForcingVarInitMod.F90 new file mode 100644 index 0000000000..b69c589e0a --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/ForcingVarInitMod.F90 @@ -0,0 +1,43 @@ +module ForcingVarInitMod + +!!! Initialize column (1-D) Noah-MP forcing variables +!!! Forcing variables should be first defined in ForcingVarType.F90 + +! ------------------------ Code history ----------------------------------- +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + use Machine + use NoahmpVarType + + implicit none + +contains + +!=== initialize with default values + subroutine ForcingVarInitDefault(noahmp) + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + + noahmp%forcing%SpecHumidityRefHeight = undefined_real + noahmp%forcing%TemperatureAirRefHeight = undefined_real + noahmp%forcing%WindEastwardRefHeight = undefined_real + noahmp%forcing%WindNorthwardRefHeight = undefined_real + noahmp%forcing%RadLwDownRefHeight = undefined_real + noahmp%forcing%RadSwDownRefHeight = undefined_real + noahmp%forcing%PrecipConvRefHeight = undefined_real + noahmp%forcing%PrecipNonConvRefHeight = undefined_real + noahmp%forcing%PrecipShConvRefHeight = undefined_real + noahmp%forcing%PrecipSnowRefHeight = undefined_real + noahmp%forcing%PrecipGraupelRefHeight = undefined_real + noahmp%forcing%PrecipHailRefHeight = undefined_real + noahmp%forcing%PressureAirSurface = undefined_real + noahmp%forcing%PressureAirRefHeight = undefined_real + noahmp%forcing%TemperatureSoilBottom = undefined_real + + end subroutine ForcingVarInitDefault + +end module ForcingVarInitMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/ForcingVarType.F90 b/src/core_atmosphere/physics/physics_noahmp/src/ForcingVarType.F90 new file mode 100644 index 0000000000..a88aa316b1 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/ForcingVarType.F90 @@ -0,0 +1,37 @@ +module ForcingVarType + +!!! Define column (1-D) Noah-MP forcing variables +!!! Forcing variable initialization is done in ForcingVarInitMod.F90 + +! ------------------------ Code history ----------------------------------- +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + use Machine + + implicit none + save + private + + type, public :: forcing_type + + real(kind=kind_noahmp) :: SpecHumidityRefHeight ! Specific humidity [kg water vapor / kg moist air] forcing at reference height + real(kind=kind_noahmp) :: TemperatureAirRefHeight ! Air temperature [K] forcing at reference height + real(kind=kind_noahmp) :: WindEastwardRefHeight ! wind speed [m/s] in eastward dir at reference height + real(kind=kind_noahmp) :: WindNorthwardRefHeight ! wind speed [m/s] in northward dir at reference height + real(kind=kind_noahmp) :: RadSwDownRefHeight ! downward shortwave radiation [W/m2] at reference height + real(kind=kind_noahmp) :: RadLwDownRefHeight ! downward longwave radiation [W/m2] at reference height + real(kind=kind_noahmp) :: PressureAirRefHeight ! air pressure [Pa] at reference height + real(kind=kind_noahmp) :: PressureAirSurface ! air pressure [Pa] at surface-atmosphere interface (lowest atmos model boundary) + real(kind=kind_noahmp) :: PrecipConvRefHeight ! convective precipitation rate [mm/s] at reference height + real(kind=kind_noahmp) :: PrecipNonConvRefHeight ! non-convective precipitation rate [mm/s] at reference height + real(kind=kind_noahmp) :: PrecipShConvRefHeight ! shallow convective precipitation rate [mm/s] at reference height + real(kind=kind_noahmp) :: PrecipSnowRefHeight ! snowfall rate [mm/s] at reference height + real(kind=kind_noahmp) :: PrecipGraupelRefHeight ! graupel rate [mm/s] at reference height + real(kind=kind_noahmp) :: PrecipHailRefHeight ! hail rate [mm/s] at reference height + real(kind=kind_noahmp) :: TemperatureSoilBottom ! bottom boundary condition for soil temperature [K] + + end type forcing_type + +end module ForcingVarType diff --git a/src/core_atmosphere/physics/physics_noahmp/src/GeneralInitGlacierMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/GeneralInitGlacierMod.F90 new file mode 100644 index 0000000000..278c8eeda8 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/GeneralInitGlacierMod.F90 @@ -0,0 +1,50 @@ +module GeneralInitGlacierMod + +!!! General initialization for glacier variables + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine GeneralInitGlacier(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: None (embedded in NOAHMP_GLACIER) +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: LoopInd ! loop index + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg ,& ! in, actual number of snow layers (negative) + DepthSnowSoilLayer => noahmp%config%domain%DepthSnowSoilLayer ,& ! in, depth of snow/soil layer-bottom [m] + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer & ! out, thickness of snow/soil layers [m] + ) +! ---------------------------------------------------------------------- + + ! initialize snow/soil layer thickness + do LoopInd = NumSnowLayerNeg+1, NumSoilLayer + if ( LoopInd == (NumSnowLayerNeg+1) ) then + ThicknessSnowSoilLayer(LoopInd) = - DepthSnowSoilLayer(LoopInd) + else + ThicknessSnowSoilLayer(LoopInd) = DepthSnowSoilLayer(LoopInd-1) - DepthSnowSoilLayer(LoopInd) + endif + enddo + + end associate + + end subroutine GeneralInitGlacier + +end module GeneralInitGlacierMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/GeneralInitMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/GeneralInitMod.F90 new file mode 100644 index 0000000000..551e0176d9 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/GeneralInitMod.F90 @@ -0,0 +1,61 @@ +module GeneralInitMod + +!!! General initialization for variables + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine GeneralInit(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: None (embedded in NOAHMP_SFLX) +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: LoopInd ! loop index + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + DepthSoilLayer => noahmp%config%domain%DepthSoilLayer ,& ! in, depth [m] of layer-bottom from soil surface + NumSoilLayerRoot => noahmp%water%param%NumSoilLayerRoot ,& ! in, number of soil layers with root present + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg ,& ! in, actual number of snow layers (negative) + DepthSnowSoilLayer => noahmp%config%domain%DepthSnowSoilLayer ,& ! in, depth of snow/soil layer-bottom [m] + TemperatureSoilSnow => noahmp%energy%state%TemperatureSoilSnow ,& ! in, snow and soil layer temperature [K] + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! out, thickness of snow/soil layers [m] + TemperatureRootZone => noahmp%energy%state%TemperatureRootZone & ! out, root-zone averaged temperature [K] + ) +! ---------------------------------------------------------------------- + + ! initialize snow/soil layer thickness + do LoopInd = NumSnowLayerNeg+1, NumSoilLayer + if ( LoopInd == NumSnowLayerNeg+1 ) then + ThicknessSnowSoilLayer(LoopInd) = - DepthSnowSoilLayer(LoopInd) + else + ThicknessSnowSoilLayer(LoopInd) = DepthSnowSoilLayer(LoopInd-1) - DepthSnowSoilLayer(LoopInd) + endif + enddo + + ! initialize root-zone soil temperature + TemperatureRootZone = 0.0 + do LoopInd = 1, NumSoilLayerRoot + TemperatureRootZone = TemperatureRootZone + & + TemperatureSoilSnow(LoopInd) * ThicknessSnowSoilLayer(LoopInd) / (-DepthSoilLayer(NumSoilLayerRoot)) + enddo + + end associate + + end subroutine GeneralInit + +end module GeneralInitMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/GlacierIceThermalPropertyMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/GlacierIceThermalPropertyMod.F90 new file mode 100644 index 0000000000..27f9ca14ba --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/GlacierIceThermalPropertyMod.F90 @@ -0,0 +1,51 @@ +module GlacierIceThermalPropertyMod + +!!! Compute glacier ice thermal conductivity based on Noah scheme + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine GlacierIceThermalProperty(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: none (embedded in ENERGY_GLACIER) +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: LoopInd1, LoopInd2 ! loop index + real(kind=kind_noahmp) :: DepthIceLayerMid ! mid-point ice layer depth + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! in, thickness of snow/soil layers [m] + HeatCapacGlaIce => noahmp%energy%state%HeatCapacGlaIce ,& ! out, glacier ice layer volumetric specific heat [J/m3/K] + ThermConductGlaIce => noahmp%energy%state%ThermConductGlaIce & ! out, glacier ice layer thermal conductivity [W/m/K] + ) +! ---------------------------------------------------------------------- + + do LoopInd1 = 1, NumSoilLayer + DepthIceLayerMid = 0.5 * ThicknessSnowSoilLayer(LoopInd1) + do LoopInd2 = 1, LoopInd1-1 + DepthIceLayerMid = DepthIceLayerMid + ThicknessSnowSoilLayer(LoopInd2) + enddo + HeatCapacGlaIce(LoopInd1) = 1.0e6 * (0.8194 + 0.1309 * DepthIceLayerMid) + ThermConductGlaIce(LoopInd1) = 0.32333 + (0.10073 * DepthIceLayerMid) + enddo + + end associate + + end subroutine GlacierIceThermalProperty + +end module GlacierIceThermalPropertyMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/GlacierPhaseChangeMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/GlacierPhaseChangeMod.F90 new file mode 100644 index 0000000000..3ce21f71c4 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/GlacierPhaseChangeMod.F90 @@ -0,0 +1,440 @@ +module GlacierPhaseChangeMod + +!!! Compute the phase change (melting/freezing) of snow and glacier ice + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine GlacierPhaseChange(noahmp) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: PHASECHANGE_GLACIER +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + +! in & out variables + type(noahmp_type) , intent(inout) :: noahmp + +! local variable + integer :: LoopInd1, LoopInd2 ! loop index + real(kind=kind_noahmp) :: SnowWaterPrev ! old/previous snow water equivalent [kg/m2] + real(kind=kind_noahmp) :: SnowWaterRatio ! ratio of previous vs updated snow water equivalent + real(kind=kind_noahmp) :: HeatLhTotPhsChg ! total latent heat of phase change + real(kind=kind_noahmp), allocatable, dimension(:) :: EnergyRes ! energy residual [W/m2] + real(kind=kind_noahmp), allocatable, dimension(:) :: GlacierPhaseChg ! melting or freezing glacier water [kg/m2] + real(kind=kind_noahmp), allocatable, dimension(:) :: MassWatTotInit ! initial total water (ice + liq) mass + real(kind=kind_noahmp), allocatable, dimension(:) :: MassWatIceInit ! initial ice content + real(kind=kind_noahmp), allocatable, dimension(:) :: MassWatLiqInit ! initial liquid content + real(kind=kind_noahmp), allocatable, dimension(:) :: MassWatIceTmp ! soil/snow ice mass [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: MassWatLiqTmp ! soil/snow liquid water mass [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: EnergyResLeft ! energy residual or loss after melting/freezing + +! -------------------------------------------------------------------- + associate( & + OptGlacierTreatment => noahmp%config%nmlist%OptGlacierTreatment ,& ! in, options for glacier treatment + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + NumSnowLayerMax => noahmp%config%domain%NumSnowLayerMax ,& ! in, maximum number of snow layers + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg ,& ! in, actual number of snow layers (negative) + MainTimeStep => noahmp%config%domain%MainTimeStep ,& ! in, main noahmp timestep [s] + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! in, thickness of snow/soil layers [m] + PhaseChgFacSoilSnow => noahmp%energy%state%PhaseChgFacSoilSnow ,& ! in, energy factor for soil & snow phase change + TemperatureSoilSnow => noahmp%energy%state%TemperatureSoilSnow ,& ! inout, snow and soil layer temperature [K] + SoilLiqWater => noahmp%water%state%SoilLiqWater ,& ! inout, soil water content [m3/m3] + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! inout, total soil moisture [m3/m3] + SnowIce => noahmp%water%state%SnowIce ,& ! inout, snow layer ice [mm] + SnowLiqWater => noahmp%water%state%SnowLiqWater ,& ! inout, snow layer liquid water [mm] + SnowDepth => noahmp%water%state%SnowDepth ,& ! inout, snow depth [m] + SnowWaterEquiv => noahmp%water%state%SnowWaterEquiv ,& ! inout, snow water equivalent [mm] + IndexPhaseChange => noahmp%water%state%IndexPhaseChange ,& ! out, phase change index [0-none;1-melt;2-refreeze] + MeltGroundSnow => noahmp%water%flux%MeltGroundSnow ,& ! out, ground snowmelt rate [mm/s] + PondSfcThinSnwMelt => noahmp%water%state%PondSfcThinSnwMelt & ! out, surface ponding [mm] from snowmelt when thin snow has no layer + ) +! ---------------------------------------------------------------------- + + !--- Initialization + if (.not. allocated(EnergyRes) ) allocate(EnergyRes (-NumSnowLayerMax+1:NumSoilLayer)) + if (.not. allocated(GlacierPhaseChg)) allocate(GlacierPhaseChg(-NumSnowLayerMax+1:NumSoilLayer)) + if (.not. allocated(MassWatTotInit) ) allocate(MassWatTotInit (-NumSnowLayerMax+1:NumSoilLayer)) + if (.not. allocated(MassWatIceInit) ) allocate(MassWatIceInit (-NumSnowLayerMax+1:NumSoilLayer)) + if (.not. allocated(MassWatLiqInit) ) allocate(MassWatLiqInit (-NumSnowLayerMax+1:NumSoilLayer)) + if (.not. allocated(MassWatIceTmp) ) allocate(MassWatIceTmp (-NumSnowLayerMax+1:NumSoilLayer)) + if (.not. allocated(MassWatLiqTmp) ) allocate(MassWatLiqTmp (-NumSnowLayerMax+1:NumSoilLayer)) + if (.not. allocated(EnergyResLeft) ) allocate(EnergyResLeft (-NumSnowLayerMax+1:NumSoilLayer)) + EnergyRes = 0.0 + GlacierPhaseChg = 0.0 + MassWatTotInit = 0.0 + MassWatIceInit = 0.0 + MassWatLiqInit = 0.0 + MassWatIceTmp = 0.0 + MassWatLiqTmp = 0.0 + EnergyResLeft = 0.0 + MeltGroundSnow = 0.0 + PondSfcThinSnwMelt = 0.0 + HeatLhTotPhsChg = 0.0 + + !--- treat snowpack over glacier ice first + + ! snow layer water mass + do LoopInd1 = NumSnowLayerNeg+1, 0 + MassWatIceTmp(LoopInd1) = SnowIce(LoopInd1) + MassWatLiqTmp(LoopInd1) = SnowLiqWater(LoopInd1) + enddo + + ! other required variables + do LoopInd1 = NumSnowLayerNeg+1, 0 + IndexPhaseChange(LoopInd1) = 0 + EnergyRes (LoopInd1) = 0.0 + GlacierPhaseChg (LoopInd1) = 0.0 + EnergyResLeft (LoopInd1) = 0.0 + MassWatIceInit (LoopInd1) = MassWatIceTmp(LoopInd1) + MassWatLiqInit (LoopInd1) = MassWatLiqTmp(LoopInd1) + MassWatTotInit (LoopInd1) = MassWatIceTmp(LoopInd1) + MassWatLiqTmp(LoopInd1) + enddo + + ! determine melting or freezing state + do LoopInd1 = NumSnowLayerNeg+1, 0 + if ( (MassWatIceTmp(LoopInd1) > 0.0) .and. (TemperatureSoilSnow(LoopInd1) >= ConstFreezePoint) ) then + IndexPhaseChange(LoopInd1) = 1 ! melting + endif + if ( (MassWatLiqTmp(LoopInd1) > 0.0) .and. (TemperatureSoilSnow(LoopInd1) < ConstFreezePoint) ) then + IndexPhaseChange(LoopInd1) = 2 ! freezing + endif + enddo + + ! Calculate the energy surplus and loss for melting and freezing + do LoopInd1 = NumSnowLayerNeg+1, 0 + if ( IndexPhaseChange(LoopInd1) > 0 ) then + EnergyRes(LoopInd1) = (TemperatureSoilSnow(LoopInd1) - ConstFreezePoint) / PhaseChgFacSoilSnow(LoopInd1) + TemperatureSoilSnow(LoopInd1) = ConstFreezePoint + endif + if ( (IndexPhaseChange(LoopInd1) == 1) .and. (EnergyRes(LoopInd1) < 0.0) ) then + EnergyRes(LoopInd1) = 0.0 + IndexPhaseChange(LoopInd1) = 0 + endif + if ( (IndexPhaseChange(LoopInd1) == 2) .and. (EnergyRes(LoopInd1) > 0.0) ) then + EnergyRes(LoopInd1) = 0.0 + IndexPhaseChange(LoopInd1) = 0 + endif + GlacierPhaseChg(LoopInd1) = EnergyRes(LoopInd1) * MainTimeStep / ConstLatHeatFusion + enddo + + ! The rate of melting for snow without a layer, needs more work. + if ( OptGlacierTreatment == 2 ) then + if ( (NumSnowLayerNeg == 0) .and. (SnowWaterEquiv > 0.0) .and. (TemperatureSoilSnow(1) > ConstFreezePoint) ) then + EnergyRes(1) = (TemperatureSoilSnow(1) - ConstFreezePoint) / PhaseChgFacSoilSnow(1) ! available heat + TemperatureSoilSnow(1) = ConstFreezePoint ! set T to freezing + GlacierPhaseChg(1) = EnergyRes(1) * MainTimeStep / ConstLatHeatFusion ! total snow melt possible + SnowWaterPrev = SnowWaterEquiv + SnowWaterEquiv = max(0.0, SnowWaterPrev-GlacierPhaseChg(1)) ! snow remaining + SnowWaterRatio = SnowWaterEquiv / SnowWaterPrev ! fraction melted + SnowDepth = max(0.0, SnowWaterRatio*SnowDepth) ! new snow height + SnowDepth = min(max(SnowDepth,SnowWaterEquiv/500.0), SnowWaterEquiv/50.0) ! limit to a reasonable snow density + EnergyResLeft(1) = EnergyRes(1) - ConstLatHeatFusion * (SnowWaterPrev - SnowWaterEquiv) / MainTimeStep ! excess heat + if ( EnergyResLeft(1) > 0.0 ) then + GlacierPhaseChg(1) = EnergyResLeft(1) * MainTimeStep / ConstLatHeatFusion + TemperatureSoilSnow(1) = TemperatureSoilSnow(1) + PhaseChgFacSoilSnow(1) * EnergyResLeft(1) ! re-heat ice + else + GlacierPhaseChg(1) = 0.0 + EnergyRes(1) = 0.0 + endif + MeltGroundSnow = max(0.0, SnowWaterPrev-SnowWaterEquiv) / MainTimeStep ! melted snow rate + HeatLhTotPhsChg = ConstLatHeatFusion * MeltGroundSnow ! melted snow energy + PondSfcThinSnwMelt = SnowWaterPrev - SnowWaterEquiv ! melt water + endif + endif ! OptGlacierTreatment==2 + + ! The rate of melting and freezing for multi-layer snow + do LoopInd1 = NumSnowLayerNeg+1, 0 + if ( (IndexPhaseChange(LoopInd1) > 0) .and. (abs(EnergyRes(LoopInd1)) > 0.0) ) then + EnergyResLeft(LoopInd1) = 0.0 + if ( GlacierPhaseChg(LoopInd1) > 0.0 ) then + MassWatIceTmp(LoopInd1) = max(0.0, MassWatIceInit(LoopInd1)-GlacierPhaseChg(LoopInd1)) + EnergyResLeft(LoopInd1) = EnergyRes(LoopInd1) - ConstLatHeatFusion * & + (MassWatIceInit(LoopInd1) - MassWatIceTmp(LoopInd1)) / MainTimeStep + elseif ( GlacierPhaseChg(LoopInd1) < 0.0 ) then + MassWatIceTmp(LoopInd1) = min(MassWatTotInit(LoopInd1), MassWatIceInit(LoopInd1)-GlacierPhaseChg(LoopInd1)) + EnergyResLeft(LoopInd1) = EnergyRes(LoopInd1) - ConstLatHeatFusion * & + (MassWatIceInit(LoopInd1) - MassWatIceTmp(LoopInd1)) / MainTimeStep + endif + MassWatLiqTmp(LoopInd1) = max(0.0, MassWatTotInit(LoopInd1)-MassWatIceTmp(LoopInd1)) ! update liquid water mass + + ! update snow temperature and energy surplus/loss + if ( abs(EnergyResLeft(LoopInd1)) > 0.0 ) then + TemperatureSoilSnow(LoopInd1) = TemperatureSoilSnow(LoopInd1) + & + PhaseChgFacSoilSnow(LoopInd1) * EnergyResLeft(LoopInd1) + if ( (MassWatLiqTmp(LoopInd1)*MassWatIceTmp(LoopInd1)) > 0.0 ) & + TemperatureSoilSnow(LoopInd1) = ConstFreezePoint + endif + HeatLhTotPhsChg = HeatLhTotPhsChg + & + ConstLatHeatFusion * (MassWatIceInit(LoopInd1) - MassWatIceTmp(LoopInd1)) / MainTimeStep + + ! snow melting rate + MeltGroundSnow = MeltGroundSnow + max(0.0, (MassWatIceInit(LoopInd1)-MassWatIceTmp(LoopInd1))) / MainTimeStep + endif + enddo + + !---- glacier ice layer treatment + + if ( OptGlacierTreatment == 1 ) then + + ! ice layer water mass + do LoopInd1 = 1, NumSoilLayer + MassWatLiqTmp(LoopInd1) = SoilLiqWater(LoopInd1) * ThicknessSnowSoilLayer(LoopInd1) * 1000.0 + MassWatIceTmp(LoopInd1) = (SoilMoisture(LoopInd1) - SoilLiqWater(LoopInd1)) * ThicknessSnowSoilLayer(LoopInd1) * 1000.0 + enddo + + ! other required variables + do LoopInd1 = 1, NumSoilLayer + IndexPhaseChange(LoopInd1) = 0 + EnergyRes(LoopInd1) = 0.0 + GlacierPhaseChg(LoopInd1) = 0.0 + EnergyResLeft(LoopInd1) = 0.0 + MassWatIceInit(LoopInd1) = MassWatIceTmp(LoopInd1) + MassWatLiqInit(LoopInd1) = MassWatLiqTmp(LoopInd1) + MassWatTotInit(LoopInd1) = MassWatIceTmp(LoopInd1) + MassWatLiqTmp(LoopInd1) + enddo + + ! determine melting or freezing state + do LoopInd1 = 1, NumSoilLayer + if ( (MassWatIceTmp(LoopInd1) > 0.0) .and. (TemperatureSoilSnow(LoopInd1) >= ConstFreezePoint) ) then + IndexPhaseChange(LoopInd1) = 1 ! melting + endif + if ( (MassWatLiqTmp(LoopInd1) > 0.0) .and. (TemperatureSoilSnow(LoopInd1) < ConstFreezePoint) ) then + IndexPhaseChange(LoopInd1) = 2 ! freezing + endif + ! If snow exists, but its thickness is not enough to create a layer + if ( (NumSnowLayerNeg == 0) .and. (SnowWaterEquiv > 0.0) .and. (LoopInd1 == 1) ) then + if ( TemperatureSoilSnow(LoopInd1) >= ConstFreezePoint ) then + IndexPhaseChange(LoopInd1) = 1 + endif + endif + enddo + + ! Calculate the energy surplus and loss for melting and freezing + do LoopInd1 = 1, NumSoilLayer + if ( IndexPhaseChange(LoopInd1) > 0 ) then + EnergyRes(LoopInd1) = (TemperatureSoilSnow(LoopInd1) - ConstFreezePoint) / PhaseChgFacSoilSnow(LoopInd1) + TemperatureSoilSnow(LoopInd1) = ConstFreezePoint + endif + if ( (IndexPhaseChange(LoopInd1) == 1) .and. (EnergyRes(LoopInd1) < 0.0) ) then + EnergyRes(LoopInd1) = 0.0 + IndexPhaseChange(LoopInd1) = 0 + endif + if ( (IndexPhaseChange(LoopInd1) == 2) .and. (EnergyRes(LoopInd1) > 0.0) ) then + EnergyRes(LoopInd1) = 0.0 + IndexPhaseChange(LoopInd1) = 0 + endif + GlacierPhaseChg(LoopInd1) = EnergyRes(LoopInd1) * MainTimeStep / ConstLatHeatFusion + enddo + + ! The rate of melting for snow without a layer, needs more work. + if ( (NumSnowLayerNeg == 0) .and. (SnowWaterEquiv > 0.0) .and. (GlacierPhaseChg(1) > 0.0) ) then + SnowWaterPrev = SnowWaterEquiv + SnowWaterEquiv = max(0.0, SnowWaterPrev-GlacierPhaseChg(1)) + SnowWaterRatio = SnowWaterEquiv / SnowWaterPrev + SnowDepth = max(0.0, SnowWaterRatio*SnowDepth) + SnowDepth = min(max(SnowDepth,SnowWaterEquiv/500.0), SnowWaterEquiv/50.0) ! limit to a reasonable snow density + EnergyResLeft(1) = EnergyRes(1) - ConstLatHeatFusion * (SnowWaterPrev - SnowWaterEquiv) / MainTimeStep + if ( EnergyResLeft(1) > 0.0 ) then + GlacierPhaseChg(1) = EnergyResLeft(1) * MainTimeStep / ConstLatHeatFusion + EnergyRes(1) = EnergyResLeft(1) + IndexPhaseChange(1) = 1 + else + GlacierPhaseChg(1) = 0.0 + EnergyRes(1) = 0.0 + IndexPhaseChange(1) = 0 + endif + MeltGroundSnow = max(0.0, (SnowWaterPrev-SnowWaterEquiv)) / MainTimeStep + HeatLhTotPhsChg = ConstLatHeatFusion * MeltGroundSnow + PondSfcThinSnwMelt = SnowWaterPrev - SnowWaterEquiv + endif + + ! The rate of melting and freezing for glacier ice + do LoopInd1 = 1, NumSoilLayer + if ( (IndexPhaseChange(LoopInd1) > 0) .and. (abs(EnergyRes(LoopInd1)) > 0.0) ) then + EnergyResLeft(LoopInd1) = 0.0 + if ( GlacierPhaseChg(LoopInd1) > 0.0 ) then + MassWatIceTmp(LoopInd1) = max(0.0, MassWatIceInit(LoopInd1)-GlacierPhaseChg(LoopInd1)) + EnergyResLeft(LoopInd1) = EnergyRes(LoopInd1) - ConstLatHeatFusion * & + (MassWatIceInit(LoopInd1) - MassWatIceTmp(LoopInd1)) / MainTimeStep + elseif ( GlacierPhaseChg(LoopInd1) < 0.0 ) then + MassWatIceTmp(LoopInd1) = min(MassWatTotInit(LoopInd1), MassWatIceInit(LoopInd1)-GlacierPhaseChg(LoopInd1)) + EnergyResLeft(LoopInd1) = EnergyRes(LoopInd1) - ConstLatHeatFusion * & + (MassWatIceInit(LoopInd1) - MassWatIceTmp(LoopInd1)) / MainTimeStep + endif + MassWatLiqTmp(LoopInd1) = max(0.0, MassWatTotInit(LoopInd1)-MassWatIceTmp(LoopInd1)) ! update liquid water mass + + ! update ice temperature and energy surplus/loss + if ( abs(EnergyResLeft(LoopInd1)) > 0.0 ) then + TemperatureSoilSnow(LoopInd1) = TemperatureSoilSnow(LoopInd1) + & + PhaseChgFacSoilSnow(LoopInd1) * EnergyResLeft(LoopInd1) + endif + HeatLhTotPhsChg = HeatLhTotPhsChg + & + ConstLatHeatFusion * (MassWatIceInit(LoopInd1) - MassWatIceTmp(LoopInd1)) / MainTimeStep + endif + enddo + EnergyResLeft = 0.0 + GlacierPhaseChg = 0.0 + + !--- Deal with residuals in ice/soil + + ! first remove excess heat by reducing layer temperature + if ( any(TemperatureSoilSnow(1:NumSoilLayer) > ConstFreezePoint) .and. & + any(TemperatureSoilSnow(1:NumSoilLayer) < ConstFreezePoint) ) then + do LoopInd1 = 1, NumSoilLayer + if ( TemperatureSoilSnow(LoopInd1) > ConstFreezePoint ) then + EnergyResLeft(LoopInd1) = (TemperatureSoilSnow(LoopInd1) - ConstFreezePoint) / PhaseChgFacSoilSnow(LoopInd1) + do LoopInd2 = 1, NumSoilLayer + if ( (LoopInd1 /= LoopInd2) .and. (TemperatureSoilSnow(LoopInd2) < ConstFreezePoint) .and. & + (EnergyResLeft(LoopInd1) > 0.1) ) then + EnergyResLeft(LoopInd2) = (TemperatureSoilSnow(LoopInd2) - ConstFreezePoint) / & + PhaseChgFacSoilSnow(LoopInd2) + if ( abs(EnergyResLeft(LoopInd2)) > EnergyResLeft(LoopInd1) ) then ! LAYER ABSORBS ALL + EnergyResLeft(LoopInd2) = EnergyResLeft(LoopInd2) + EnergyResLeft(LoopInd1) + TemperatureSoilSnow(LoopInd2) = ConstFreezePoint + & + EnergyResLeft(LoopInd2) * PhaseChgFacSoilSnow(LoopInd2) + EnergyResLeft(LoopInd1) = 0.0 + else + EnergyResLeft(LoopInd1) = EnergyResLeft(LoopInd1) + EnergyResLeft(LoopInd2) + EnergyResLeft(LoopInd2) = 0.0 + TemperatureSoilSnow(LoopInd2) = ConstFreezePoint + endif + endif + enddo + TemperatureSoilSnow(LoopInd1) = ConstFreezePoint + EnergyResLeft(LoopInd1) * PhaseChgFacSoilSnow(LoopInd1) + endif + enddo + endif + + ! now remove excess cold by increasing temperture (may not be necessary with above loop) + if ( any(TemperatureSoilSnow(1:NumSoilLayer) > ConstFreezePoint) .and. & + any(TemperatureSoilSnow(1:NumSoilLayer) < ConstFreezePoint) ) then + do LoopInd1 = 1, NumSoilLayer + if ( TemperatureSoilSnow(LoopInd1) < ConstFreezePoint ) then + EnergyResLeft(LoopInd1) = (TemperatureSoilSnow(LoopInd1) - ConstFreezePoint) / PhaseChgFacSoilSnow(LoopInd1) + do LoopInd2 = 1, NumSoilLayer + if ( (LoopInd1 /= LoopInd2) .and. (TemperatureSoilSnow(LoopInd2) > ConstFreezePoint) .and. & + (EnergyResLeft(LoopInd1) < -0.1) ) then + EnergyResLeft(LoopInd2) = (TemperatureSoilSnow(LoopInd2) - ConstFreezePoint) / & + PhaseChgFacSoilSnow(LoopInd2) + if ( EnergyResLeft(LoopInd2) > abs(EnergyResLeft(LoopInd1)) ) then ! LAYER ABSORBS ALL + EnergyResLeft(LoopInd2) = EnergyResLeft(LoopInd2) + EnergyResLeft(LoopInd1) + TemperatureSoilSnow(LoopInd2) = ConstFreezePoint + & + EnergyResLeft(LoopInd2) * PhaseChgFacSoilSnow(LoopInd2) + EnergyResLeft(LoopInd1) = 0.0 + else + EnergyResLeft(LoopInd1) = EnergyResLeft(LoopInd1) + EnergyResLeft(LoopInd2) + EnergyResLeft(LoopInd2) = 0.0 + TemperatureSoilSnow(LoopInd2) = ConstFreezePoint + endif + endif + enddo + TemperatureSoilSnow(LoopInd1) = ConstFreezePoint + EnergyResLeft(LoopInd1) * PhaseChgFacSoilSnow(LoopInd1) + endif + enddo + endif + + ! now remove excess heat by melting ice + if ( any(TemperatureSoilSnow(1:NumSoilLayer) > ConstFreezePoint) .and. & + any(MassWatIceTmp(1:NumSoilLayer) > 0.0) ) then + do LoopInd1 = 1, NumSoilLayer + if ( TemperatureSoilSnow(LoopInd1) > ConstFreezePoint ) then + EnergyResLeft(LoopInd1) = (TemperatureSoilSnow(LoopInd1) - ConstFreezePoint) / PhaseChgFacSoilSnow(LoopInd1) + GlacierPhaseChg(LoopInd1) = EnergyResLeft(LoopInd1) * MainTimeStep / ConstLatHeatFusion + do LoopInd2 = 1, NumSoilLayer + if ( (LoopInd1 /= LoopInd2) .and. (MassWatIceTmp(LoopInd2) > 0.0) .and. & + (GlacierPhaseChg(LoopInd1) > 0.1) ) then + if ( MassWatIceTmp(LoopInd2) > GlacierPhaseChg(LoopInd1) ) then ! LAYER ABSORBS ALL + MassWatIceTmp(LoopInd2) = MassWatIceTmp(LoopInd2) - GlacierPhaseChg(LoopInd1) + HeatLhTotPhsChg = HeatLhTotPhsChg + & + ConstLatHeatFusion * GlacierPhaseChg(LoopInd1)/MainTimeStep + TemperatureSoilSnow(LoopInd2) = ConstFreezePoint + GlacierPhaseChg(LoopInd1) = 0.0 + else + GlacierPhaseChg(LoopInd1) = GlacierPhaseChg(LoopInd1) - MassWatIceTmp(LoopInd2) + HeatLhTotPhsChg = HeatLhTotPhsChg + & + ConstLatHeatFusion * MassWatIceTmp(LoopInd2) / MainTimeStep + MassWatIceTmp(LoopInd2) = 0.0 + TemperatureSoilSnow(LoopInd2) = ConstFreezePoint + endif + MassWatLiqTmp(LoopInd2) = max(0.0, MassWatTotInit(LoopInd2)-MassWatIceTmp(LoopInd2)) + endif + enddo + EnergyResLeft(LoopInd1) = GlacierPhaseChg(LoopInd1) * ConstLatHeatFusion / MainTimeStep + TemperatureSoilSnow(LoopInd1) = ConstFreezePoint + EnergyResLeft(LoopInd1) * PhaseChgFacSoilSnow(LoopInd1) + endif + enddo + endif + + ! snow remove excess cold by refreezing liquid (may not be necessary with above loop) + if ( any(TemperatureSoilSnow(1:NumSoilLayer) < ConstFreezePoint) .and. & + any(MassWatLiqTmp(1:NumSoilLayer) > 0.0) ) then + do LoopInd1 = 1, NumSoilLayer + if ( TemperatureSoilSnow(LoopInd1) < ConstFreezePoint ) then + EnergyResLeft(LoopInd1) = (TemperatureSoilSnow(LoopInd1) - ConstFreezePoint) / PhaseChgFacSoilSnow(LoopInd1) + GlacierPhaseChg(LoopInd1) = EnergyResLeft(LoopInd1) * MainTimeStep / ConstLatHeatFusion + do LoopInd2 = 1, NumSoilLayer + if ( (LoopInd1 /= LoopInd2) .and. (MassWatLiqTmp(LoopInd2) > 0.0) .and. & + (GlacierPhaseChg(LoopInd1) < -0.1) ) then + if ( MassWatLiqTmp(LoopInd2) > abs(GlacierPhaseChg(LoopInd1)) ) then ! LAYER ABSORBS ALL + MassWatIceTmp(LoopInd2) = MassWatIceTmp(LoopInd2) - GlacierPhaseChg(LoopInd1) + HeatLhTotPhsChg = HeatLhTotPhsChg + & + ConstLatHeatFusion * GlacierPhaseChg(LoopInd1) / MainTimeStep + TemperatureSoilSnow(LoopInd2) = ConstFreezePoint + GlacierPhaseChg(LoopInd1) = 0.0 + else + GlacierPhaseChg(LoopInd1) = GlacierPhaseChg(LoopInd1) + MassWatLiqTmp(LoopInd2) + HeatLhTotPhsChg = HeatLhTotPhsChg - & + ConstLatHeatFusion * MassWatLiqTmp(LoopInd2) / MainTimeStep + MassWatIceTmp(LoopInd2) = MassWatTotInit(LoopInd2) + TemperatureSoilSnow(LoopInd2) = ConstFreezePoint + endif + MassWatLiqTmp(LoopInd2) = max(0.0, MassWatTotInit(LoopInd2)-MassWatIceTmp(LoopInd2)) + endif + enddo + EnergyResLeft(LoopInd1) = GlacierPhaseChg(LoopInd1) * ConstLatHeatFusion / MainTimeStep + TemperatureSoilSnow(LoopInd1) = ConstFreezePoint + EnergyResLeft(LoopInd1) * PhaseChgFacSoilSnow(LoopInd1) + endif + enddo + endif + + endif ! OptGlacierTreatment==1 + + !--- update snow and soil ice and liquid content + do LoopInd1 = NumSnowLayerNeg+1, 0 ! snow + SnowLiqWater(LoopInd1) = MassWatLiqTmp(LoopInd1) + SnowIce(LoopInd1) = MassWatIceTmp(LoopInd1) + enddo + do LoopInd1 = 1, NumSoilLayer ! glacier ice + if ( OptGlacierTreatment == 1 ) then + SoilLiqWater(LoopInd1) = MassWatLiqTmp(LoopInd1) / (1000.0 * ThicknessSnowSoilLayer(LoopInd1)) + SoilLiqWater(LoopInd1) = max(0.0, min(1.0,SoilLiqWater(LoopInd1))) + elseif ( OptGlacierTreatment == 2 ) then + SoilLiqWater(LoopInd1) = 0.0 ! ice, assume all frozen forever + endif + SoilMoisture(LoopInd1) = 1.0 + enddo + + ! deallocate local arrays to avoid memory leaks + deallocate(EnergyRes ) + deallocate(GlacierPhaseChg) + deallocate(MassWatTotInit ) + deallocate(MassWatIceInit ) + deallocate(MassWatLiqInit ) + deallocate(MassWatIceTmp ) + deallocate(MassWatLiqTmp ) + deallocate(EnergyResLeft ) + + end associate + + end subroutine GlacierPhaseChange + +end module GlacierPhaseChangeMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/GlacierTemperatureMainMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/GlacierTemperatureMainMod.F90 new file mode 100644 index 0000000000..8093807748 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/GlacierTemperatureMainMod.F90 @@ -0,0 +1,80 @@ +module GlacierTemperatureMainMod + +!!! Main module to compute snow (if exists) and glacier ice temperature. +!!! Note that snow temperatures during melting season may exceed melting +!!! point but later in GlacierPhaseChange subroutine the snow +!!! temperatures are reset to melting point for melting snow. + + use Machine + use NoahmpVarType + use ConstantDefineMod + use GlacierTemperatureSolverMod, only : GlacierTemperatureSolver + use GlacierThermalDiffusionMod, only : GlacierThermalDiffusion + + implicit none + +contains + + subroutine GlacierTemperatureMain(noahmp) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: TSNOSOI_GLACIER +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + +! in & out variables + type(noahmp_type) , intent(inout) :: noahmp + +! local variable + real(kind=kind_noahmp), allocatable, dimension(:) :: MatRight ! right-hand side term of the matrix + real(kind=kind_noahmp), allocatable, dimension(:) :: MatLeft1 ! left-hand side term of the matrix + real(kind=kind_noahmp), allocatable, dimension(:) :: MatLeft2 ! left-hand side term of the matrix + real(kind=kind_noahmp), allocatable, dimension(:) :: MatLeft3 ! left-hand side term of the matrix + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of glacier/soil layers + NumSnowLayerMax => noahmp%config%domain%NumSnowLayerMax ,& ! in, maximum number of snow layers + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg ,& ! in, actual number of snow layers (negative) + MainTimeStep => noahmp%config%domain%MainTimeStep ,& ! in, main noahmp timestep [s] + DepthSoilTempBottom => noahmp%config%domain%DepthSoilTempBottom ,& ! in, depth [m] from glacier surface for lower soil temperature boundary + SnowDepth => noahmp%water%state%SnowDepth ,& ! in, snow depth [m] + DepthSoilTempBotToSno => noahmp%energy%state%DepthSoilTempBotToSno ,& ! out, depth of lower boundary condition [m] from snow surface + RadSwPenetrateGrd => noahmp%energy%flux%RadSwPenetrateGrd & ! out, light penetrating through snow/ice [W/m2] + ) +! ---------------------------------------------------------------------- + + ! initialization + if (.not. allocated(MatRight)) allocate(MatRight(-NumSnowLayerMax+1:NumSoilLayer)) + if (.not. allocated(MatLeft1)) allocate(MatLeft1(-NumSnowLayerMax+1:NumSoilLayer)) + if (.not. allocated(MatLeft2)) allocate(MatLeft2(-NumSnowLayerMax+1:NumSoilLayer)) + if (.not. allocated(MatLeft3)) allocate(MatLeft3(-NumSnowLayerMax+1:NumSoilLayer)) + MatRight(:) = 0.0 + MatLeft1(:) = 0.0 + MatLeft2(:) = 0.0 + MatLeft3(:) = 0.0 + + ! compute solar penetration through water, needs more work + RadSwPenetrateGrd(NumSnowLayerNeg+1:NumSoilLayer) = 0.0 + + ! adjust DepthSoilTempBottom from glacier ice surface to DepthSoilTempBotToSno from snow surface + DepthSoilTempBotToSno = DepthSoilTempBottom - SnowDepth + + ! compute soil temperatures + call GlacierThermalDiffusion(noahmp, MatLeft1, MatLeft2, MatLeft3, MatRight) + call GlacierTemperatureSolver(noahmp, MainTimeStep, MatLeft1, MatLeft2, MatLeft3, MatRight) + + ! deallocate local arrays to avoid memory leaks + deallocate(MatRight) + deallocate(MatLeft1) + deallocate(MatLeft2) + deallocate(MatLeft3) + + end associate + + end subroutine GlacierTemperatureMain + +end module GlacierTemperatureMainMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/GlacierTemperatureSolverMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/GlacierTemperatureSolverMod.F90 new file mode 100644 index 0000000000..e94beb5f55 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/GlacierTemperatureSolverMod.F90 @@ -0,0 +1,84 @@ +module GlacierTemperatureSolverMod + +!!! Compute Glacier and snow layer temperature using tri-diagonal matrix solution +!!! Dependent on the output from GlacierThermalDiffusion module + + use Machine + use NoahmpVarType + use ConstantDefineMod + use MatrixSolverTriDiagonalMod, only : MatrixSolverTriDiagonal + + implicit none + +contains + + subroutine GlacierTemperatureSolver(noahmp, TimeStep, MatLeft1, MatLeft2, MatLeft3, MatRight) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: HSTEP_GLACIER +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + +! in & out variables + type(noahmp_type) , intent(inout) :: noahmp + real(kind=kind_noahmp), intent(in) :: TimeStep ! timestep (may not be the same as model timestep) + real(kind=kind_noahmp), allocatable, dimension(:), intent(inout) :: MatRight ! right-hand side term of the matrix + real(kind=kind_noahmp), allocatable, dimension(:), intent(inout) :: MatLeft1 ! left-hand side term of the matrix + real(kind=kind_noahmp), allocatable, dimension(:), intent(inout) :: MatLeft2 ! left-hand side term of the matrix + real(kind=kind_noahmp), allocatable, dimension(:), intent(inout) :: MatLeft3 ! left-hand side term of the matrix + +! local variable + integer :: LoopInd ! layer loop index + real(kind=kind_noahmp), allocatable, dimension(:) :: MatRightTmp ! temporary MatRight matrix coefficient + real(kind=kind_noahmp), allocatable, dimension(:) :: MatLeft3Tmp ! temporary MatLeft3 matrix coefficient + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of glacier/soil layers + NumSnowLayerMax => noahmp%config%domain%NumSnowLayerMax ,& ! in, maximum number of snow layers + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg ,& ! in, actual number of snow layers (negative) + TemperatureSoilSnow => noahmp%energy%state%TemperatureSoilSnow & ! inout, snow and glacier layer temperature [K] + ) +! ---------------------------------------------------------------------- + + ! initialization + if (.not. allocated(MatRightTmp)) allocate(MatRightTmp(-NumSnowLayerMax+1:NumSoilLayer)) + if (.not. allocated(MatLeft3Tmp)) allocate(MatLeft3Tmp(-NumSnowLayerMax+1:NumSoilLayer)) + MatRightTmp = 0.0 + MatLeft3Tmp = 0.0 + + ! update tri-diagonal matrix elements + do LoopInd = NumSnowLayerNeg+1, NumSoilLayer + MatRight(LoopInd) = MatRight(LoopInd) * TimeStep + MatLeft1(LoopInd) = MatLeft1(LoopInd) * TimeStep + MatLeft2(LoopInd) = 1.0 + MatLeft2(LoopInd) * TimeStep + MatLeft3(LoopInd) = MatLeft3(LoopInd) * TimeStep + enddo + + ! copy values for input variables before call to rosr12 + do LoopInd = NumSnowLayerNeg+1, NumSoilLayer + MatRightTmp(LoopInd) = MatRight(LoopInd) + MatLeft3Tmp(LoopInd) = MatLeft3(LoopInd) + enddo + + ! solve the tri-diagonal matrix equation + call MatrixSolverTriDiagonal(MatLeft3,MatLeft1,MatLeft2,MatLeft3Tmp,MatRightTmp,MatRight,& + NumSnowLayerNeg+1,NumSoilLayer,NumSnowLayerMax) + + ! update snow & glacier temperature + do LoopInd = NumSnowLayerNeg+1, NumSoilLayer + TemperatureSoilSnow(LoopInd) = TemperatureSoilSnow(LoopInd) + MatLeft3(LoopInd) + enddo + + ! deallocate local arrays to avoid memory leaks + deallocate(MatRightTmp) + deallocate(MatLeft3Tmp) + + end associate + + end subroutine GlacierTemperatureSolver + +end module GlacierTemperatureSolverMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/GlacierThermalDiffusionMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/GlacierThermalDiffusionMod.F90 new file mode 100644 index 0000000000..0eb8e66cc0 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/GlacierThermalDiffusionMod.F90 @@ -0,0 +1,141 @@ +module GlacierThermalDiffusionMod + +!!! Solve glacier ice and snow layer thermal diffusion +!!! Calculate the right hand side of the time tendency term of the glacier +!!! and snow thermal diffusion equation. Currently snow and glacier ice layers +!!! are coupled in solving the equations. Also compute/prepare the matrix +!!! coefficients for the tri-diagonal matrix of the implicit time scheme. + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine GlacierThermalDiffusion(noahmp, MatLeft1, MatLeft2, MatLeft3, MatRight) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: HRT_GLACIER +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + +! in & out variables + type(noahmp_type) , intent(inout) :: noahmp + real(kind=kind_noahmp), allocatable, dimension(:), intent(inout) :: MatRight ! right-hand side term of the matrix + real(kind=kind_noahmp), allocatable, dimension(:), intent(inout) :: MatLeft1 ! left-hand side term of the matrix + real(kind=kind_noahmp), allocatable, dimension(:), intent(inout) :: MatLeft2 ! left-hand side term of the matrix + real(kind=kind_noahmp), allocatable, dimension(:), intent(inout) :: MatLeft3 ! left-hand side term of the matrix + +! local variable + integer :: LoopInd ! loop index + real(kind=kind_noahmp) :: DepthSnowSoilTmp ! temporary snow/soil layer depth [m] + real(kind=kind_noahmp), allocatable, dimension(:) :: DepthSnowSoilInv ! inverse of snow/soil layer depth [1/m] + real(kind=kind_noahmp), allocatable, dimension(:) :: HeatCapacPerArea ! Heat capacity of soil/snow per area [J/m2/K] + real(kind=kind_noahmp), allocatable, dimension(:) :: TempGradDepth ! temperature gradient (derivative) with soil/snow depth [K/m] + real(kind=kind_noahmp), allocatable, dimension(:) :: EnergyExcess ! energy flux excess in soil/snow [W/m2] + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + NumSnowLayerMax => noahmp%config%domain%NumSnowLayerMax ,& ! in, maximum number of snow layers + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg ,& ! in, actual number of snow layers (negative) + DepthSnowSoilLayer => noahmp%config%domain%DepthSnowSoilLayer ,& ! in, depth of snow/soil layer-bottom [m] + OptSoilTemperatureBottom => noahmp%config%nmlist%OptSoilTemperatureBottom ,& ! in, options for lower boundary condition of soil temperature + OptSnowSoilTempTime => noahmp%config%nmlist%OptSnowSoilTempTime ,& ! in, options for snow/soil temperature time scheme + TemperatureSoilBottom => noahmp%forcing%TemperatureSoilBottom ,& ! in, bottom boundary soil temperature [K] + DepthSoilTempBotToSno => noahmp%energy%state%DepthSoilTempBotToSno ,& ! in, depth of lower boundary condition [m] from snow surface + TemperatureSoilSnow => noahmp%energy%state%TemperatureSoilSnow ,& ! in, snow and soil layer temperature [K] + ThermConductSoilSnow => noahmp%energy%state%ThermConductSoilSnow ,& ! in, thermal conductivity [W/m/K] for all soil & snow + HeatCapacSoilSnow => noahmp%energy%state%HeatCapacSoilSnow ,& ! in, heat capacity [J/m3/K] for all soil & snow + HeatGroundTot => noahmp%energy%flux%HeatGroundTot ,& ! in, total ground heat flux [W/m2] (+ to soil/snow) + RadSwPenetrateGrd => noahmp%energy%flux%RadSwPenetrateGrd ,& ! in, light penetrating through soil/snow water [W/m2] + HeatFromSoilBot => noahmp%energy%flux%HeatFromSoilBot & ! out, energy influx from soil bottom [W/m2] + ) +! ---------------------------------------------------------------------- + + ! initialization + if (.not. allocated(DepthSnowSoilInv)) allocate(DepthSnowSoilInv(-NumSnowLayerMax+1:NumSoilLayer)) + if (.not. allocated(HeatCapacPerArea)) allocate(HeatCapacPerArea(-NumSnowLayerMax+1:NumSoilLayer)) + if (.not. allocated(TempGradDepth) ) allocate(TempGradDepth (-NumSnowLayerMax+1:NumSoilLayer)) + if (.not. allocated(EnergyExcess) ) allocate(EnergyExcess (-NumSnowLayerMax+1:NumSoilLayer)) + MatRight(:) = 0.0 + MatLeft1(:) = 0.0 + MatLeft2(:) = 0.0 + MatLeft3(:) = 0.0 + DepthSnowSoilInv(:) = 0.0 + HeatCapacPerArea(:) = 0.0 + TempGradDepth(:) = 0.0 + EnergyExcess(:) = 0.0 + + ! compute gradient and flux of glacier/snow thermal diffusion + do LoopInd = NumSnowLayerNeg+1, NumSoilLayer + if ( LoopInd == (NumSnowLayerNeg+1) ) then + HeatCapacPerArea(LoopInd) = - DepthSnowSoilLayer(LoopInd) * HeatCapacSoilSnow(LoopInd) + DepthSnowSoilTmp = - DepthSnowSoilLayer(LoopInd+1) + DepthSnowSoilInv(LoopInd) = 2.0 / DepthSnowSoilTmp + TempGradDepth(LoopInd) = 2.0 * (TemperatureSoilSnow(LoopInd) - TemperatureSoilSnow(LoopInd+1)) / DepthSnowSoilTmp + EnergyExcess(LoopInd) = ThermConductSoilSnow(LoopInd) * TempGradDepth(LoopInd) - & + HeatGroundTot - RadSwPenetrateGrd(LoopInd) + elseif ( LoopInd < NumSoilLayer ) then + HeatCapacPerArea(LoopInd) = (DepthSnowSoilLayer(LoopInd-1) - DepthSnowSoilLayer(LoopInd)) * HeatCapacSoilSnow(LoopInd) + DepthSnowSoilTmp = DepthSnowSoilLayer(LoopInd-1) - DepthSnowSoilLayer(LoopInd+1) + DepthSnowSoilInv(LoopInd) = 2.0 / DepthSnowSoilTmp + TempGradDepth(LoopInd) = 2.0 * (TemperatureSoilSnow(LoopInd) - TemperatureSoilSnow(LoopInd+1)) / DepthSnowSoilTmp + EnergyExcess(LoopInd) = (ThermConductSoilSnow(LoopInd)*TempGradDepth(LoopInd) - & + ThermConductSoilSnow(LoopInd-1)*TempGradDepth(LoopInd-1) ) - RadSwPenetrateGrd(LoopInd) + elseif ( LoopInd == NumSoilLayer ) then + HeatCapacPerArea(LoopInd) = (DepthSnowSoilLayer(LoopInd-1) - DepthSnowSoilLayer(LoopInd)) * HeatCapacSoilSnow(LoopInd) + DepthSnowSoilTmp = DepthSnowSoilLayer(LoopInd-1) - DepthSnowSoilLayer(LoopInd) + if ( OptSoilTemperatureBottom == 1 ) then + HeatFromSoilBot = 0.0 + endif + if ( OptSoilTemperatureBottom == 2 ) then + TempGradDepth(LoopInd) = (TemperatureSoilSnow(LoopInd) - TemperatureSoilBottom) / & + (0.5 * (DepthSnowSoilLayer(LoopInd-1)+DepthSnowSoilLayer(LoopInd)) - DepthSoilTempBotToSno) + HeatFromSoilBot = -ThermConductSoilSnow(LoopInd) * TempGradDepth(LoopInd) + endif + EnergyExcess(LoopInd) = (-HeatFromSoilBot - ThermConductSoilSnow(LoopInd-1)*TempGradDepth(LoopInd-1)) - & + RadSwPenetrateGrd(LoopInd) + endif + enddo + + ! prepare the matrix coefficients for the tri-diagonal matrix + do LoopInd = NumSnowLayerNeg+1, NumSoilLayer + if ( LoopInd == (NumSnowLayerNeg+1) ) then + MatLeft1(LoopInd) = 0.0 + MatLeft3(LoopInd) = - ThermConductSoilSnow(LoopInd) * DepthSnowSoilInv(LoopInd) / HeatCapacPerArea(LoopInd) + if ( (OptSnowSoilTempTime == 1) .or. (OptSnowSoilTempTime == 3) ) then + MatLeft2(LoopInd) = - MatLeft3(LoopInd) + endif + if ( OptSnowSoilTempTime == 2 ) then + MatLeft2(LoopInd) = - MatLeft3(LoopInd) + ThermConductSoilSnow(LoopInd) / & + (0.5*DepthSnowSoilLayer(LoopInd)*DepthSnowSoilLayer(LoopInd)*HeatCapacSoilSnow(LoopInd)) + endif + elseif ( LoopInd < NumSoilLayer ) then + MatLeft1(LoopInd) = - ThermConductSoilSnow(LoopInd-1) * DepthSnowSoilInv(LoopInd-1) / HeatCapacPerArea(LoopInd) + MatLeft3(LoopInd) = - ThermConductSoilSnow(LoopInd ) * DepthSnowSoilInv(LoopInd ) / HeatCapacPerArea(LoopInd) + MatLeft2(LoopInd) = - (MatLeft1(LoopInd) + MatLeft3 (LoopInd)) + elseif ( LoopInd == NumSoilLayer ) then + MatLeft1(LoopInd) = - ThermConductSoilSnow(LoopInd-1) * DepthSnowSoilInv(LoopInd-1) / HeatCapacPerArea(LoopInd) + MatLeft3(LoopInd) = 0.0 + MatLeft2(LoopInd) = - (MatLeft1(LoopInd) + MatLeft3(LoopInd)) + endif + MatRight(LoopInd) = EnergyExcess(LoopInd) / (-HeatCapacPerArea(LoopInd)) + enddo + + ! deallocate local arrays to avoid memory leaks + deallocate(DepthSnowSoilInv) + deallocate(HeatCapacPerArea) + deallocate(TempGradDepth ) + deallocate(EnergyExcess ) + + end associate + + end subroutine GlacierThermalDiffusion + +end module GlacierThermalDiffusionMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/GroundAlbedoGlacierMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/GroundAlbedoGlacierMod.F90 new file mode 100644 index 0000000000..5e876a59b2 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/GroundAlbedoGlacierMod.F90 @@ -0,0 +1,51 @@ +module GroundAlbedoGlacierMod + +!!! Compute glacier ground albedo based on snow and ice albedo + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine GroundAlbedoGlacier(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: RADIATION_GLACIER +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: IndSwBnd ! solar radiation band index + +! -------------------------------------------------------------------- + associate( & + NumSwRadBand => noahmp%config%domain%NumSwRadBand ,& ! in, number of solar radiation wave bands + SnowCoverFrac => noahmp%water%state%SnowCoverFrac ,& ! in, snow cover fraction + AlbedoLandIce => noahmp%energy%param%AlbedoLandIce ,& ! in, albedo land ice: 1=vis, 2=nir + AlbedoSnowDir => noahmp%energy%state%AlbedoSnowDir ,& ! in, snow albedo for direct(1=vis, 2=nir) + AlbedoSnowDif => noahmp%energy%state%AlbedoSnowDif ,& ! in, snow albedo for diffuse(1=vis, 2=nir) + AlbedoGrdDir => noahmp%energy%state%AlbedoGrdDir ,& ! out, ground albedo (direct beam: vis, nir) + AlbedoGrdDif => noahmp%energy%state%AlbedoGrdDif & ! out, ground albedo (diffuse: vis, nir) + ) +! ---------------------------------------------------------------------- + + do IndSwBnd = 1, NumSwRadBand + + AlbedoGrdDir(IndSwBnd) = AlbedoLandIce(IndSwBnd)*(1.0-SnowCoverFrac) + AlbedoSnowDir(IndSwBnd)*SnowCoverFrac + AlbedoGrdDif(IndSwBnd) = AlbedoLandIce(IndSwBnd)*(1.0-SnowCoverFrac) + AlbedoSnowDif(IndSwBnd)*SnowCoverFrac + + enddo + + end associate + + end subroutine GroundAlbedoGlacier + +end module GroundAlbedoGlacierMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/GroundAlbedoMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/GroundAlbedoMod.F90 new file mode 100644 index 0000000000..6ca4b10566 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/GroundAlbedoMod.F90 @@ -0,0 +1,73 @@ +module GroundAlbedoMod + +!!! Compute ground albedo based on soil and snow albedo + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine GroundAlbedo(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: GROUNDALB +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: IndSwBnd ! solar radiation band index + real(kind=kind_noahmp) :: AlbedoSoilAdjWet ! soil water correction factor for soil albedo + +! -------------------------------------------------------------------- + associate( & + NumSwRadBand => noahmp%config%domain%NumSwRadBand ,& ! in, number of solar radiation wave bands + SurfaceType => noahmp%config%domain%SurfaceType ,& ! in, surface type 1-soil; 2-lake + CosSolarZenithAngle => noahmp%config%domain%CosSolarZenithAngle ,& ! in, cosine solar zenith angle + SnowCoverFrac => noahmp%water%state%SnowCoverFrac ,& ! in, snow cover fraction + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! in, total soil moisture [m3/m3] + AlbedoSoilSat => noahmp%energy%param%AlbedoSoilSat ,& ! in, saturated soil albedos: 1=vis, 2=nir + AlbedoSoilDry => noahmp%energy%param%AlbedoSoilDry ,& ! in, dry soil albedos: 1=vis, 2=nir + AlbedoLakeFrz => noahmp%energy%param%AlbedoLakeFrz ,& ! in, albedo frozen lakes: 1=vis, 2=nir + TemperatureGrd => noahmp%energy%state%TemperatureGrd ,& ! in, ground temperature [K] + AlbedoSnowDir => noahmp%energy%state%AlbedoSnowDir ,& ! in, snow albedo for direct(1=vis, 2=nir) + AlbedoSnowDif => noahmp%energy%state%AlbedoSnowDif ,& ! in, snow albedo for diffuse(1=vis, 2=nir) + AlbedoSoilDir => noahmp%energy%state%AlbedoSoilDir ,& ! out, soil albedo (direct) + AlbedoSoilDif => noahmp%energy%state%AlbedoSoilDif ,& ! out, soil albedo (diffuse) + AlbedoGrdDir => noahmp%energy%state%AlbedoGrdDir ,& ! out, ground albedo (direct beam: vis, nir) + AlbedoGrdDif => noahmp%energy%state%AlbedoGrdDif & ! out, ground albedo (diffuse: vis, nir) + ) +! ---------------------------------------------------------------------- + + do IndSwBnd = 1, NumSwRadBand + + AlbedoSoilAdjWet = max(0.11-0.40*SoilMoisture(1), 0.0) + + if ( SurfaceType == 1 ) then ! soil + AlbedoSoilDir(IndSwBnd) = min(AlbedoSoilSat(IndSwBnd)+AlbedoSoilAdjWet, AlbedoSoilDry(IndSwBnd)) + AlbedoSoilDif(IndSwBnd) = AlbedoSoilDir(IndSwBnd) + elseif ( TemperatureGrd > ConstFreezePoint ) then ! unfrozen lake, wetland + AlbedoSoilDir(IndSwBnd) = 0.06 / (max(0.01, CosSolarZenithAngle)**1.7+0.15) + AlbedoSoilDif(IndSwBnd) = 0.06 + else ! frozen lake, wetland + AlbedoSoilDir(IndSwBnd) = AlbedoLakeFrz(IndSwBnd) + AlbedoSoilDif(IndSwBnd) = AlbedoSoilDir(IndSwBnd) + endif + + AlbedoGrdDir(IndSwBnd) = AlbedoSoilDir(IndSwBnd)*(1.0-SnowCoverFrac) + AlbedoSnowDir(IndSwBnd)*SnowCoverFrac + AlbedoGrdDif(IndSwBnd) = AlbedoSoilDif(IndSwBnd)*(1.0-SnowCoverFrac) + AlbedoSnowDif(IndSwBnd)*SnowCoverFrac + + enddo + + end associate + + end subroutine GroundAlbedo + +end module GroundAlbedoMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/GroundRoughnessPropertyGlacierMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/GroundRoughnessPropertyGlacierMod.F90 new file mode 100644 index 0000000000..785ac62ade --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/GroundRoughnessPropertyGlacierMod.F90 @@ -0,0 +1,54 @@ +module GroundRoughnessPropertyGlacierMod + +!!! Compute glacier ground roughness length, displacement height, and surface reference height + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine GroundRoughnessPropertyGlacier(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: None (embedded in ENERGY_GLACIER subroutine) +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + +! in & out variables + type(noahmp_type), intent(inout) :: noahmp + +! -------------------------------------------------------------------- + associate( & + RefHeightAboveSfc => noahmp%config%domain%RefHeightAboveSfc ,& ! in, reference height [m] above surface zero plane + SnowDepth => noahmp%water%state%SnowDepth ,& ! in, snow depth [m] + RoughLenMomSnow => noahmp%energy%param%RoughLenMomSnow ,& ! in, snow surface roughness length [m] + RoughLenMomSfc => noahmp%energy%state%RoughLenMomSfc ,& ! out, roughness length [m], momentum, surface + RoughLenMomGrd => noahmp%energy%state%RoughLenMomGrd ,& ! out, roughness length [m], momentum, ground + ZeroPlaneDispSfc => noahmp%energy%state%ZeroPlaneDispSfc ,& ! out, surface zero plane displacement [m] + ZeroPlaneDispGrd => noahmp%energy%state%ZeroPlaneDispGrd ,& ! out, ground zero plane displacement [m] + RefHeightAboveGrd => noahmp%energy%state%RefHeightAboveGrd & ! out, reference height [m] above ground + ) +! ---------------------------------------------------------------------- + + ! ground roughness length + RoughLenMomGrd = RoughLenMomSnow + RoughLenMomSfc = RoughLenMomGrd + + ! surface roughness length and displacement height + ZeroPlaneDispGrd = SnowDepth + ZeroPlaneDispSfc = ZeroPlaneDispGrd + + ! reference height above ground + RefHeightAboveGrd = ZeroPlaneDispSfc + RefHeightAboveSfc + + end associate + + end subroutine GroundRoughnessPropertyGlacier + +end module GroundRoughnessPropertyGlacierMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/GroundRoughnessPropertyMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/GroundRoughnessPropertyMod.F90 new file mode 100644 index 0000000000..9394131883 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/GroundRoughnessPropertyMod.F90 @@ -0,0 +1,86 @@ +module GroundRoughnessPropertyMod + +!!! Compute ground roughness length, displacement height, and surface reference height + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine GroundRoughnessProperty(noahmp, FlagVegSfc) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: None (embedded in ENERGY subroutine) +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + +! in & out variables + type(noahmp_type), intent(inout) :: noahmp + logical , intent(in ) :: FlagVegSfc ! flag: true if vegetated surface + +! -------------------------------------------------------------------- + associate( & + SurfaceType => noahmp%config%domain%SurfaceType ,& ! in, surface type 1-soil; 2-lake + RefHeightAboveSfc => noahmp%config%domain%RefHeightAboveSfc ,& ! in, reference height [m] above surface zero plane + FlagUrban => noahmp%config%domain%FlagUrban ,& ! in, logical flag for urban grid + SnowCoverFrac => noahmp%water%state%SnowCoverFrac ,& ! in, snow cover fraction + SnowDepth => noahmp%water%state%SnowDepth ,& ! in, snow depth [m] + HeightCanopyTop => noahmp%energy%param%HeightCanopyTop ,& ! in, top of canopy [m] + RoughLenMomVeg => noahmp%energy%param%RoughLenMomVeg ,& ! in, momentum roughness length vegetated [m] + RoughLenMomSnow => noahmp%energy%param%RoughLenMomSnow ,& ! in, snow surface roughness length [m] + RoughLenMomSoil => noahmp%energy%param%RoughLenMomSoil ,& ! in, bare-soil roughness length [m] + RoughLenMomLake => noahmp%energy%param%RoughLenMomLake ,& ! in, lake surface roughness length [m] + TemperatureGrd => noahmp%energy%state%TemperatureGrd ,& ! in, ground temperature [K] + RoughLenMomSfc => noahmp%energy%state%RoughLenMomSfc ,& ! out, roughness length [m], momentum, surface + RoughLenMomGrd => noahmp%energy%state%RoughLenMomGrd ,& ! out, roughness length [m], momentum, ground + ZeroPlaneDispSfc => noahmp%energy%state%ZeroPlaneDispSfc ,& ! out, surface zero plane displacement [m] + ZeroPlaneDispGrd => noahmp%energy%state%ZeroPlaneDispGrd ,& ! out, ground zero plane displacement [m] + RefHeightAboveGrd => noahmp%energy%state%RefHeightAboveGrd & ! out, reference height [m] above ground + ) +! ---------------------------------------------------------------------- + + ! ground roughness length + if ( SurfaceType == 2 ) then ! Lake + if ( TemperatureGrd <= ConstFreezePoint ) then + RoughLenMomGrd = RoughLenMomLake * (1.0-SnowCoverFrac) + SnowCoverFrac * RoughLenMomSnow + else + RoughLenMomGrd = RoughLenMomLake + endif + else ! soil + RoughLenMomGrd = RoughLenMomSoil * (1.0-SnowCoverFrac) + SnowCoverFrac * RoughLenMomSnow + endif + + ! surface roughness length and displacement height + ZeroPlaneDispGrd = SnowDepth + if ( FlagVegSfc .eqv. .true. ) then + RoughLenMomSfc = RoughLenMomVeg + ZeroPlaneDispSfc = 0.65 * HeightCanopyTop + if ( SnowDepth > ZeroPlaneDispSfc ) ZeroPlaneDispSfc = SnowDepth + else + RoughLenMomSfc = RoughLenMomGrd + ZeroPlaneDispSfc = ZeroPlaneDispGrd + endif + + ! special case for urban + if ( FlagUrban .eqv. .true. ) then + RoughLenMomGrd = RoughLenMomVeg + ZeroPlaneDispGrd = 0.65 * HeightCanopyTop + RoughLenMomSfc = RoughLenMomGrd + ZeroPlaneDispSfc = ZeroPlaneDispGrd + endif + + ! reference height above ground + RefHeightAboveGrd = max(ZeroPlaneDispSfc, HeightCanopyTop) + RefHeightAboveSfc + if ( ZeroPlaneDispGrd >= RefHeightAboveGrd ) RefHeightAboveGrd = ZeroPlaneDispGrd + RefHeightAboveSfc + + end associate + + end subroutine GroundRoughnessProperty + +end module GroundRoughnessPropertyMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/GroundThermalPropertyGlacierMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/GroundThermalPropertyGlacierMod.F90 new file mode 100644 index 0000000000..62268d9714 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/GroundThermalPropertyGlacierMod.F90 @@ -0,0 +1,84 @@ +module GroundThermalPropertyGlacierMod + +!!! Compute snow and glacier ice thermal conductivity and heat capacity + + use Machine + use NoahmpVarType + use ConstantDefineMod + use SnowThermalPropertyMod, only : SnowThermalProperty + use GlacierIceThermalPropertyMod, only : GlacierIceThermalProperty + + implicit none + +contains + + subroutine GroundThermalPropertyGlacier(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: THERMOPROP_GLACIER +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: LoopInd ! loop index + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + MainTimeStep => noahmp%config%domain%MainTimeStep ,& ! in, main noahmp timestep [s] + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! in, thickness of snow/soil layers [m] + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg ,& ! in, actual number of snow layers (negative) + SnowDepth => noahmp%water%state%SnowDepth ,& ! in, snow depth [m] + ThermConductSoilSnow => noahmp%energy%state%ThermConductSoilSnow ,& ! out, thermal conductivity [W/m/K] for all soil & snow + HeatCapacSoilSnow => noahmp%energy%state%HeatCapacSoilSnow ,& ! out, heat capacity [J/m3/K] for all soil & snow + PhaseChgFacSoilSnow => noahmp%energy%state%PhaseChgFacSoilSnow ,& ! out, energy factor for soil & snow phase change + HeatCapacVolSnow => noahmp%energy%state%HeatCapacVolSnow ,& ! out, snow layer volumetric specific heat [J/m3/K] + ThermConductSnow => noahmp%energy%state%ThermConductSnow ,& ! out, snow layer thermal conductivity [W/m/K] + HeatCapacGlaIce => noahmp%energy%state%HeatCapacGlaIce ,& ! out, glacier ice layer volumetric specific heat [J/m3/K] + ThermConductGlaIce => noahmp%energy%state%ThermConductGlaIce & ! out, glacier ice layer thermal conductivity [W/m/K] + ) +! ---------------------------------------------------------------------- + + ! initialize + HeatCapacSoilSnow = 0.0 + ThermConductSoilSnow = 0.0 + + ! compute snow thermal conductivity and heat capacity + call SnowThermalProperty(noahmp) + do LoopInd = NumSnowLayerNeg+1, 0 + ThermConductSoilSnow(LoopInd) = ThermConductSnow(LoopInd) + HeatCapacSoilSnow(LoopInd) = HeatCapacVolSnow(LoopInd) + enddo + + ! compute glacier ice thermal properties (using Noah glacial ice approximations) + call GlacierIceThermalProperty(noahmp) + do LoopInd = 1, NumSoilLayer + ThermConductSoilSnow(LoopInd) = ThermConductGlaIce(LoopInd) + HeatCapacSoilSnow(LoopInd) = HeatCapacGlaIce(LoopInd) + enddo + + ! combine a temporary variable used for melting/freezing of snow and glacier ice + do LoopInd = NumSnowLayerNeg+1, NumSoilLayer + PhaseChgFacSoilSnow(LoopInd) = MainTimeStep / (HeatCapacSoilSnow(LoopInd)*ThicknessSnowSoilLayer(LoopInd)) + enddo + + ! snow/glacier ice interface + if ( NumSnowLayerNeg == 0 ) then + ThermConductSoilSnow(1) = (ThermConductSoilSnow(1)*ThicknessSnowSoilLayer(1) + 0.35*SnowDepth) / & + (SnowDepth + ThicknessSnowSoilLayer(1)) + else + ThermConductSoilSnow(1) = (ThermConductSoilSnow(1)*ThicknessSnowSoilLayer(1) + & + ThermConductSoilSnow(0)*ThicknessSnowSoilLayer(0)) / & + (ThicknessSnowSoilLayer(0) + ThicknessSnowSoilLayer(1)) + endif + + end associate + + end subroutine GroundThermalPropertyGlacier + +end module GroundThermalPropertyGlacierMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/GroundThermalPropertyMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/GroundThermalPropertyMod.F90 new file mode 100644 index 0000000000..a8b28ed51a --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/GroundThermalPropertyMod.F90 @@ -0,0 +1,111 @@ +module GroundThermalPropertyMod + +!!! Compute snow and soil thermal conductivity and heat capacity + + use Machine + use NoahmpVarType + use ConstantDefineMod + use SnowThermalPropertyMod, only : SnowThermalProperty + use SoilThermalPropertyMod, only : SoilThermalProperty + + implicit none + +contains + + subroutine GroundThermalProperty(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: THERMOPROP +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: LoopInd ! loop index + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + SurfaceType => noahmp%config%domain%SurfaceType ,& ! in, surface type 1-soil; 2-lake + MainTimeStep => noahmp%config%domain%MainTimeStep ,& ! in, main noahmp timestep [s] + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! in, thickness of snow/soil layers [m] + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg ,& ! in, actual number of snow layers (negative) + FlagUrban => noahmp%config%domain%FlagUrban ,& ! in, logical flag for urban grid + SnowDepth => noahmp%water%state%SnowDepth ,& ! in, snow depth [m] + TemperatureSoilSnow => noahmp%energy%state%TemperatureSoilSnow ,& ! in, snow and soil layer temperature [K] + ThermConductSoilSnow => noahmp%energy%state%ThermConductSoilSnow ,& ! out, thermal conductivity [W/m/K] for all soil & snow + HeatCapacSoilSnow => noahmp%energy%state%HeatCapacSoilSnow ,& ! out, heat capacity [J/m3/K] for all soil & snow + PhaseChgFacSoilSnow => noahmp%energy%state%PhaseChgFacSoilSnow ,& ! out, energy factor for soil & snow phase change + HeatCapacVolSnow => noahmp%energy%state%HeatCapacVolSnow ,& ! out, snow layer volumetric specific heat [J/m3/K] + ThermConductSnow => noahmp%energy%state%ThermConductSnow ,& ! out, snow layer thermal conductivity [W/m/K] + HeatCapacVolSoil => noahmp%energy%state%HeatCapacVolSoil ,& ! out, soil layer volumetric specific heat [J/m3/K] + ThermConductSoil => noahmp%energy%state%ThermConductSoil & ! out, soil layer thermal conductivity [W/m/K] + ) +! ---------------------------------------------------------------------- + + ! initialize + HeatCapacSoilSnow = 0.0 + ThermConductSoilSnow = 0.0 + + ! compute snow thermal conductivity and heat capacity + call SnowThermalProperty(noahmp) + do LoopInd = NumSnowLayerNeg+1, 0 + ThermConductSoilSnow(LoopInd) = ThermConductSnow(LoopInd) + HeatCapacSoilSnow(LoopInd) = HeatCapacVolSnow(LoopInd) + enddo + + ! compute soil thermal properties + call SoilThermalProperty(noahmp) + do LoopInd = 1, NumSoilLayer + ThermConductSoilSnow(LoopInd) = ThermConductSoil(LoopInd) + HeatCapacSoilSnow(LoopInd) = HeatCapacVolSoil(LoopInd) + enddo + if ( FlagUrban .eqv. .true. ) then + do LoopInd = 1, NumSoilLayer + ThermConductSoilSnow(LoopInd) = 3.24 + enddo + endif + + ! heat flux reduction effect from the overlying green canopy, adapted from + ! section 2.1.2 of Peters-Lidard et al. (1997, JGR, VOL 102(D4)). + ! not in use because of the separation of the canopy layer from the ground. + ! but this may represent the effects of leaf litter (Niu comments) + ! ThermConductSoilSnow(1) = ThermConductSoilSnow(1) * EXP (SBETA * VegFracGreen) + + ! compute lake thermal properties (no consideration of turbulent mixing for this version) + if ( SurfaceType == 2 ) then + do LoopInd = 1, NumSoilLayer + if ( TemperatureSoilSnow(LoopInd) > ConstFreezePoint) then + HeatCapacSoilSnow(LoopInd) = ConstHeatCapacWater + ThermConductSoilSnow(LoopInd) = ConstThermConductWater !+ KEDDY * ConstHeatCapacWater + else + HeatCapacSoilSnow(LoopInd) = ConstHeatCapacIce + ThermConductSoilSnow(LoopInd) = ConstThermConductIce + endif + enddo + endif + + ! combine a temporary variable used for melting/freezing of snow and frozen soil + do LoopInd = NumSnowLayerNeg+1, NumSoilLayer + PhaseChgFacSoilSnow(LoopInd) = MainTimeStep / (HeatCapacSoilSnow(LoopInd) * ThicknessSnowSoilLayer(LoopInd)) + enddo + + ! snow/soil interface + if ( NumSnowLayerNeg == 0 ) then + ThermConductSoilSnow(1) = (ThermConductSoilSnow(1)*ThicknessSnowSoilLayer(1) + 0.35*SnowDepth) / & + (SnowDepth + ThicknessSnowSoilLayer(1)) + else + ThermConductSoilSnow(1) = (ThermConductSoilSnow(1)*ThicknessSnowSoilLayer(1) + & + ThermConductSoilSnow(0)*ThicknessSnowSoilLayer(0)) / & + (ThicknessSnowSoilLayer(0) + ThicknessSnowSoilLayer(1)) + endif + + end associate + + end subroutine GroundThermalProperty + +end module GroundThermalPropertyMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/GroundWaterMmfMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/GroundWaterMmfMod.F90 new file mode 100644 index 0000000000..da9ef7c9cb --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/GroundWaterMmfMod.F90 @@ -0,0 +1,691 @@ +module GroundWaterMmfMod + +!!! Module to calculate lateral groundwater flow and the flux between groundwater and rivers +!!! plus the routine to update soil moisture and water table due to those two fluxes +!!! according to the Miguez-Macho & Fan groundwater scheme (Miguez-Macho et al., JGR 2007). +!!! Module written by Gonzalo Miguez-Macho , U. de Santiago de Compostela, Galicia, Spain +!!! November 2012 + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: module_sf_groundwater.F +! Original code: Miguez-Macho&Fan (Miguez-Macho et al 2007, Fan et al 2007) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! Note: this MMF scheme needs further refactoring +! ------------------------------------------------------------------------- + + use NoahmpIOVarType + use NoahmpVarType + use Machine + + implicit none + +contains + + subroutine WTABLE_mmf_noahmp (NoahmpIO ,NSOIL ,XLAND ,XICE ,XICE_THRESHOLD,& + ISICE ,ISLTYP ,SMOISEQ ,DZS ,WTDDT ,& !in + FDEPTH ,AREA ,TOPO ,ISURBAN ,IVGTYP ,& !in + RIVERCOND ,RIVERBED ,EQWTD ,PEXP ,& !in + SMOIS ,SH2OXY ,SMCWTD ,WTD , QLAT, QRF ,& !inout + DEEPRECH ,QSPRING ,QSLAT ,QRFS ,QSPRINGS ,RECH ,& !inout + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + +! ---------------------------------------------------------------------- +! USE NOAHMP_TABLES, ONLY: BEXP_TABLE, DKSAT_TABLE, SMCMAX_TABLE,PSISAT_TABLE, SMCWLT_TABLE +! ---------------------------------------------------------------------- + IMPLICIT NONE +! ---------------------------------------------------------------------- +! IN only + + type(NoahmpIO_type), intent(in) :: NoahmpIO + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & + & ims,ime, jms,jme, kms,kme, & + & its,ite, jts,jte, kts,kte + REAL, INTENT(IN) :: WTDDT + REAL, INTENT(IN) :: XICE_THRESHOLD + INTEGER, INTENT(IN ) :: ISICE + REAL, DIMENSION( ims:ime, jms:jme ) , & + & INTENT(IN ) :: XLAND, & + XICE + INTEGER, DIMENSION( ims:ime, jms:jme ) , & + INTENT(IN ) :: ISLTYP, & + IVGTYP + INTEGER, INTENT(IN) :: nsoil + INTEGER, INTENT(IN) :: ISURBAN + REAL, DIMENSION( ims:ime , 1:nsoil, jms:jme ), & + & INTENT(IN) :: SMOISEQ + REAL, DIMENSION(1:nsoil), INTENT(IN) :: DZS + REAL, DIMENSION( ims:ime, jms:jme ) , & + & INTENT(IN) :: FDEPTH, & + AREA, & + TOPO, & + EQWTD, & + PEXP, & + RIVERBED, & + RIVERCOND + +! IN and OUT + + REAL, DIMENSION( ims:ime , 1:nsoil, jms:jme ), & + & INTENT(INOUT) :: SMOIS, & + & SH2OXY + + + REAL, DIMENSION( ims:ime, jms:jme ) , & + & INTENT(INOUT) :: WTD, & + SMCWTD, & + DEEPRECH, & + QSLAT, & + QRFS, & + QSPRINGS, & + RECH + +!OUT + + REAL, DIMENSION( ims:ime, jms:jme ) , & + & INTENT(OUT) :: QRF, & !groundwater - river water flux + QSPRING !water springing at the surface from groundwater convergence in the column + +!LOCAL + + INTEGER :: I,J,K + REAL, DIMENSION( 0:NSOIL) :: ZSOIL !depth of soil layer-bottom [m] + REAL, DIMENSION( 1:NSOIL) :: SMCEQ !equilibrium soil water content [m3/m3] + REAL, DIMENSION( 1:NSOIL) :: SMC,SH2O + REAL :: DELTAT,RCOND,TOTWATER,PSI & + ,WFLUXDEEP,WCNDDEEP,DDZ,SMCWTDMID & + ,WPLUS,WMINUS + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: QLAT + INTEGER, DIMENSION( ims:ime, jms:jme ) :: LANDMASK !-1 for water (ice or no ice) and glacial areas, 1 for land where the LSM does its soil moisture calculations. + + REAL :: BEXP,DKSAT,PSISAT,SMCMAX,SMCWLT + + DELTAT = WTDDT * 60. !timestep in seconds for this calculation + + ZSOIL(0) = 0. + ZSOIL(1) = -DZS(1) + DO K = 2, NSOIL + ZSOIL(K) = -DZS(K) + ZSOIL(K-1) + END DO + + WHERE(XLAND-1.5.LT.0..AND.XICE.LT. XICE_THRESHOLD.AND.IVGTYP.NE.ISICE) + LANDMASK=1 + ELSEWHERE + LANDMASK=-1 + ENDWHERE + +!Calculate lateral flow + + QLAT = 0. + CALL LATERALFLOW(NoahmpIO, ISLTYP,WTD,QLAT,FDEPTH,TOPO,LANDMASK,DELTAT,AREA & + ,ids,ide,jds,jde,kds,kde & + ,ims,ime,jms,jme,kms,kme & + ,its,ite,jts,jte,kts,kte ) + + +!compute flux from grounwater to rivers in the cell + + DO J=jts,jte + DO I=its,ite + IF(LANDMASK(I,J).GT.0)THEN + IF(WTD(I,J) .GT. RIVERBED(I,J) .AND. EQWTD(I,J) .GT. RIVERBED(I,J)) THEN + RCOND = RIVERCOND(I,J) * EXP(PEXP(I,J)*(WTD(I,J)-EQWTD(I,J))) + ELSE + RCOND = RIVERCOND(I,J) + ENDIF + QRF(I,J) = RCOND * (WTD(I,J)-RIVERBED(I,J)) * DELTAT/AREA(I,J) +!for now, dont allow it to go from river to groundwater + QRF(I,J) = MAX(QRF(I,J),0.) + ELSE + QRF(I,J) = 0. + ENDIF + ENDDO + ENDDO + + DO J=jts,jte + DO I=its,ite + IF(LANDMASK(I,J).GT.0)THEN + + BEXP = NoahmpIO%BEXP_TABLE (ISLTYP(I,J)) + DKSAT = NoahmpIO%DKSAT_TABLE (ISLTYP(I,J)) + PSISAT = -1.0*NoahmpIO%PSISAT_TABLE (ISLTYP(I,J)) + SMCMAX = NoahmpIO%SMCMAX_TABLE (ISLTYP(I,J)) + SMCWLT = NoahmpIO%SMCWLT_TABLE (ISLTYP(I,J)) + + IF(IVGTYP(I,J)==NoahmpIO%ISURBAN)THEN + SMCMAX = 0.45 + SMCWLT = 0.40 + ENDIF + +!for deep water table calculate recharge + IF(WTD(I,J) < ZSOIL(NSOIL)-DZS(NSOIL))THEN +!assume all liquid if the wtd is deep + DDZ = ZSOIL(NSOIL)-WTD(I,J) + SMCWTDMID = 0.5 * (SMCWTD(I,J) + SMCMAX ) + PSI = PSISAT * ( SMCMAX / SMCWTD(I,J) ) ** BEXP + WCNDDEEP = DKSAT * ( SMCWTDMID / SMCMAX ) ** (2.0*BEXP + 3.0) + WFLUXDEEP = - DELTAT * WCNDDEEP * ( (PSISAT-PSI) / DDZ - 1.) +!update deep soil moisture + SMCWTD(I,J) = SMCWTD(I,J) + (DEEPRECH(I,J) - WFLUXDEEP) / DDZ + WPLUS = MAX((SMCWTD(I,J)-SMCMAX), 0.0) * DDZ + WMINUS = MAX((1.E-4-SMCWTD(I,J)), 0.0) * DDZ + SMCWTD(I,J) = MAX( MIN(SMCWTD(I,J),SMCMAX) , 1.E-4) + WFLUXDEEP = WFLUXDEEP + WPLUS - WMINUS + DEEPRECH(I,J) = WFLUXDEEP + ENDIF + + +!Total water flux to or from groundwater in the cell + TOTWATER = QLAT(I,J) - QRF(I,J) + DEEPRECH(I,J) + + SMC(1:NSOIL) = SMOIS(I,1:NSOIL,J) + SH2O(1:NSOIL) = SH2OXY(I,1:NSOIL,J) + SMCEQ(1:NSOIL) = SMOISEQ(I,1:NSOIL,J) + +!Update the water table depth and soil moisture + CALL UPDATEWTD ( NSOIL, DZS , ZSOIL, SMCEQ, SMCMAX, SMCWLT, PSISAT, BEXP ,I , J , &!in + TOTWATER, WTD(I,J), SMC, SH2O, SMCWTD(I,J) , &!inout + QSPRING(I,J) ) !out + +!now update soil moisture + SMOIS(I,1:NSOIL,J) = SMC(1:NSOIL) + SH2OXY(I,1:NSOIL,J) = SH2O(1:NSOIL) + + ENDIF + ENDDO + ENDDO + +!accumulate fluxes for output + + DO J=jts,jte + DO I=its,ite + IF(LANDMASK(I,J).GT.0)THEN + QSLAT(I,J) = QSLAT(I,J) + QLAT(I,J)*1.E3 + QRFS(I,J) = QRFS(I,J) + QRF(I,J)*1.E3 + QSPRINGS(I,J) = QSPRINGS(I,J) + QSPRING(I,J)*1.E3 + RECH(I,J) = RECH(I,J) + DEEPRECH(I,J)*1.E3 +!zero out DEEPRECH + DEEPRECH(I,J) =0. + ENDIF + ENDDO + ENDDO + + end subroutine WTABLE_mmf_noahmp + + +! ================================================================================================== +! ---------------------------------------------------------------------- + subroutine LATERALFLOW (NoahmpIO, ISLTYP,WTD,QLAT,FDEPTH,TOPO,LANDMASK,DELTAT,AREA & + ,ids,ide,jds,jde,kds,kde & + ,ims,ime,jms,jme,kms,kme & + ,its,ite,jts,jte,kts,kte ) +! ---------------------------------------------------------------------- +! USE NOAHMP_TABLES, ONLY : DKSAT_TABLE + +#ifdef MPP_LAND + ! MPP_LAND only for HRLDAS Noah-MP/WRF-Hydro - Prasanth Valayamkunnath (06/10/2022) + use module_mpp_land, only: mpp_land_com_real, mpp_land_com_integer, global_nx, global_ny, my_id +#endif +! ---------------------------------------------------------------------- + IMPLICIT NONE +! ---------------------------------------------------------------------- +! input + + type(NoahmpIO_type), intent(in) :: NoahmpIO + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & + & ims,ime, jms,jme, kms,kme, & + & its,ite, jts,jte, kts,kte + REAL , INTENT(IN) :: DELTAT + INTEGER, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: ISLTYP, LANDMASK + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: FDEPTH,WTD,TOPO,AREA + +!output + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(OUT) :: QLAT + +!local + INTEGER :: I, J, itsh, iteh, jtsh, jteh, nx, ny + REAL :: Q, KLAT + +#ifdef MPP_LAND + ! halo'ed arrays + REAL, DIMENSION(ims-1:ime+1, jms-1:jme+1) :: KCELL, HEAD + integer, dimension(ims-1:ime+1, jms-1:jme+1) :: landmask_h + real, dimension(ims-1:ime+1, jms-1:jme+1) :: area_h, qlat_h +#else + REAL, DIMENSION(ims:ime, jms:jme) :: KCELL, HEAD +#endif + + REAL, DIMENSION(19) :: KLATFACTOR + DATA KLATFACTOR /2.,3.,4.,10.,10.,12.,14.,20.,24.,28.,40.,48.,2.,0.,10.,0.,20.,2.,2./ + + REAL, PARAMETER :: PI = 3.14159265 + REAL, PARAMETER :: FANGLE = 0.22754493 ! = 0.5*sqrt(0.5*tan(pi/8)) + +#ifdef MPP_LAND +! create halo'ed local copies of tile vars + landmask_h(ims:ime, jms:jme) = landmask + area_h(ims:ime, jms:jme) = area + + nx = ((ime-ims) + 1) + 2 ! include halos + ny = ((jme-jms) + 1) + 2 ! include halos + + !copy neighbor's values for landmask and area + call mpp_land_com_integer(landmask_h, nx, ny, 99) + call mpp_land_com_real(area_h, nx, ny, 99) + + itsh=max(its,1) + iteh=min(ite,global_nx) + jtsh=max(jts,1) + jteh=min(jte,global_ny) +#else + itsh=max(its-1,ids) + iteh=min(ite+1,ide-1) + jtsh=max(jts-1,jds) + jteh=min(jte+1,jde-1) +#endif + + DO J=jtsh,jteh + DO I=itsh,iteh + IF(FDEPTH(I,J).GT.0.)THEN + KLAT = NoahmpIO%DKSAT_TABLE(ISLTYP(I,J)) * KLATFACTOR(ISLTYP(I,J)) + IF(WTD(I,J) < -1.5)THEN + KCELL(I,J) = FDEPTH(I,J) * KLAT * EXP( (WTD(I,J) + 1.5) / FDEPTH(I,J) ) + ELSE + KCELL(I,J) = KLAT * ( WTD(I,J) + 1.5 + FDEPTH(I,J) ) + ENDIF + ELSE + KCELL(i,J) = 0. + ENDIF + + HEAD(I,J) = TOPO(I,J) + WTD(I,J) + ENDDO + ENDDO + +#ifdef MPP_LAND +! update neighbors with kcell/head/calculation + call mpp_land_com_real(KCELL, nx, ny, 99) + call mpp_land_com_real(HEAD, nx, ny, 99) + + itsh=max(its,2) + iteh=min(ite,global_nx-1) + jtsh=max(jts,2) + jteh=min(jte,global_ny-1) + + qlat_h = 0. +#else + itsh=max(its,ids+1) + iteh=min(ite,ide-2) + jtsh=max(jts,jds+1) + jteh=min(jte,jde-2) +#endif + + DO J=jtsh,jteh + DO I=itsh,iteh +#ifdef MPP_LAND + IF( landmask_h(I,J).GT.0 )THEN +#else + IF( LANDMASK(I,J).GT.0 )THEN +#endif + Q=0. + + Q = Q + (KCELL(I-1,J+1)+KCELL(I,J)) & + * (HEAD(I-1,J+1)-HEAD(I,J))/SQRT(2.) + + Q = Q + (KCELL(I-1,J)+KCELL(I,J)) & + * (HEAD(I-1,J)-HEAD(I,J)) + + Q = Q + (KCELL(I-1,J-1)+KCELL(I,J)) & + * (HEAD(I-1,J-1)-HEAD(I,J))/SQRT(2.) + + Q = Q + (KCELL(I,J+1)+KCELL(I,J)) & + * (HEAD(I,J+1)-HEAD(I,J)) + + Q = Q + (KCELL(I,J-1)+KCELL(I,J)) & + * (HEAD(I,J-1)-HEAD(I,J)) + + Q = Q + (KCELL(I+1,J+1)+KCELL(I,J)) & + * (HEAD(I+1,J+1)-HEAD(I,J))/SQRT(2.) + + Q = Q + (KCELL(I+1,J)+KCELL(I,J)) & + * (HEAD(I+1,J)-HEAD(I,J)) + + Q = Q + (KCELL(I+1,J-1)+KCELL(I,J)) & + * (HEAD(I+1,J-1)-HEAD(I,J))/SQRT(2.) + + ! Here, Q is in m3/s. To convert to m, divide it by area of the grid cell. +#ifdef MPP_LAND + qlat_h(I, J) = (FANGLE * Q * DELTAT / area_h(I, J)) +#else + QLAT(I,J) = FANGLE* Q * DELTAT / AREA(I,J) +#endif + ENDIF + ENDDO + ENDDO + +#ifdef MPP_LAND +! merge (sum) of all neighbor's edge Q's + call mpp_land_com_real(qlat_h, nx, ny, 1) + qlat = qlat_h(ims:ime, jms:jme) +#endif + + end subroutine LATERALFLOW + + +! ================================================================================================== +! ---------------------------------------------------------------------- + subroutine UPDATEWTD (NSOIL, DZS, ZSOIL ,SMCEQ ,& !in + SMCMAX, SMCWLT, PSISAT, BEXP ,ILOC ,JLOC ,& !in + TOTWATER, WTD ,SMC, SH2O ,SMCWTD ,& !inout + QSPRING ) !out +! ---------------------------------------------------------------------- + IMPLICIT NONE +! ---------------------------------------------------------------------- +! input + INTEGER, INTENT(IN) :: NSOIL !no. of soil layers + INTEGER, INTENT(IN) :: ILOC, JLOC + REAL, INTENT(IN) :: SMCMAX + REAL, INTENT(IN) :: SMCWLT + REAL, INTENT(IN) :: PSISAT + REAL, INTENT(IN) :: BEXP + REAL, DIMENSION( 0:NSOIL), INTENT(IN) :: ZSOIL !depth of soil layer-bottom [m] + REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: SMCEQ !equilibrium soil water content [m3/m3] + REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: DZS ! soil layer thickness [m] +! input-output + REAL , INTENT(INOUT) :: TOTWATER + REAL , INTENT(INOUT) :: WTD + REAL , INTENT(INOUT) :: SMCWTD + REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SMC + REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SH2O +! output + REAL , INTENT(OUT) :: QSPRING +!local + INTEGER :: K + INTEGER :: K1 + INTEGER :: IWTD + INTEGER :: KWTD + REAL :: MAXWATUP, MAXWATDW ,WTDOLD + REAL :: WGPMID + REAL :: SYIELDDW + REAL :: DZUP + REAL :: SMCEQDEEP + REAL, DIMENSION( 1:NSOIL) :: SICE +! ------------------------------------------------------------- + + + + QSPRING=0. + + SICE = SMC - SH2O + +iwtd=1 + +!case 1: totwater > 0 (water table going up): +IF(totwater.gt.0.)then + + + if(wtd.ge.zsoil(nsoil))then + + do k=nsoil-1,1,-1 + if(wtd.lt.zsoil(k))exit + enddo + iwtd=k + kwtd=iwtd+1 + +!max water that fits in the layer + maxwatup=dzs(kwtd)*(smcmax-smc(kwtd)) + + if(totwater.le.maxwatup)then + smc(kwtd) = smc(kwtd) + totwater / dzs(kwtd) + smc(kwtd) = min(smc(kwtd),smcmax) + if(smc(kwtd).gt.smceq(kwtd))wtd = min ( ( smc(kwtd)*dzs(kwtd) & + - smceq(kwtd)*zsoil(iwtd) + smcmax*zsoil(kwtd) ) / & + ( smcmax-smceq(kwtd) ) , zsoil(iwtd) ) + totwater=0. + else !water enough to saturate the layer + smc(kwtd) = smcmax + totwater=totwater-maxwatup + k1=iwtd + do k=k1,0,-1 + wtd = zsoil(k) + iwtd=k-1 + if(k.eq.0)exit + maxwatup=dzs(k)*(smcmax-smc(k)) + if(totwater.le.maxwatup)then + smc(k) = smc(k) + totwater / dzs(k) + smc(k) = min(smc(k),smcmax) + if(smc(k).gt.smceq(k))wtd = min ( ( smc(k)*dzs(k) & + - smceq(k)*zsoil(iwtd) + smcmax*zsoil(k) ) / & + ( smcmax-smceq(k) ) , zsoil(iwtd) ) + totwater=0. + exit + else + smc(k) = smcmax + totwater=totwater-maxwatup + endif + + enddo + + endif + + elseif(wtd.ge.zsoil(nsoil)-dzs(nsoil))then ! wtd below bottom of soil model + + !gmmequilibrium soil moisture content + smceqdeep = smcmax * ( psisat / & + (psisat - dzs(nsoil)) ) ** (1./bexp) +! smceqdeep = max(smceqdeep,smcwlt) + smceqdeep = max(smceqdeep,1.E-4) + + maxwatup=(smcmax-smcwtd)*dzs(nsoil) + + if(totwater.le.maxwatup)then + smcwtd = smcwtd + totwater / dzs(nsoil) + smcwtd = min(smcwtd,smcmax) + if(smcwtd.gt.smceqdeep)wtd = min( ( smcwtd*dzs(nsoil) & + - smceqdeep*zsoil(nsoil) + smcmax*(zsoil(nsoil)-dzs(nsoil)) ) / & + ( smcmax-smceqdeep ) , zsoil(nsoil) ) + totwater=0. + else + smcwtd=smcmax + totwater=totwater-maxwatup + do k=nsoil,0,-1 + wtd=zsoil(k) + iwtd=k-1 + if(k.eq.0)exit + maxwatup=dzs(k)*(smcmax-smc(k)) + if(totwater.le.maxwatup)then + smc(k) = min(smc(k) + totwater / dzs(k),smcmax) + if(smc(k).gt.smceq(k))wtd = min ( ( smc(k)*dzs(k) & + - smceq(k)*zsoil(iwtd) + smcmax*zsoil(k) ) / & + ( smcmax-smceq(k) ) , zsoil(iwtd) ) + totwater=0. + exit + else + smc(k) = smcmax + totwater=totwater-maxwatup + endif + enddo + endif + +!deep water table + else + + maxwatup=(smcmax-smcwtd)*(zsoil(nsoil)-dzs(nsoil)-wtd) + if(totwater.le.maxwatup)then + wtd = wtd + totwater/(smcmax-smcwtd) + totwater=0. + else + totwater=totwater-maxwatup + wtd=zsoil(nsoil)-dzs(nsoil) + maxwatup=(smcmax-smcwtd)*dzs(nsoil) + if(totwater.le.maxwatup)then + + !gmmequilibrium soil moisture content + smceqdeep = smcmax * ( psisat / & + (psisat - dzs(nsoil)) ) ** (1./bexp) +! smceqdeep = max(smceqdeep,smcwlt) + smceqdeep = max(smceqdeep,1.E-4) + + smcwtd = smcwtd + totwater / dzs(nsoil) + smcwtd = min(smcwtd,smcmax) + wtd = ( smcwtd*dzs(nsoil) & + - smceqdeep*zsoil(nsoil) + smcmax*(zsoil(nsoil)-dzs(nsoil)) ) / & + ( smcmax-smceqdeep ) + totwater=0. + else + smcwtd=smcmax + totwater=totwater-maxwatup + do k=nsoil,0,-1 + wtd=zsoil(k) + iwtd=k-1 + if(k.eq.0)exit + maxwatup=dzs(k)*(smcmax-smc(k)) + + if(totwater.le.maxwatup)then + smc(k) = smc(k) + totwater / dzs(k) + smc(k) = min(smc(k),smcmax) + if(smc(k).gt.smceq(k))wtd = ( smc(k)*dzs(k) & + - smceq(k)*zsoil(iwtd) + smcmax*zsoil(k) ) / & + ( smcmax-smceq(k) ) + totwater=0. + exit + else + smc(k) = smcmax + totwater=totwater-maxwatup + endif + enddo + endif + endif + endif + +!water springing at the surface + qspring=totwater + +!case 2: totwater < 0 (water table going down): +ELSEIF(totwater.lt.0.)then + + + if(wtd.ge.zsoil(nsoil))then !wtd in the resolved layers + + do k=nsoil-1,1,-1 + if(wtd.lt.zsoil(k))exit + enddo + iwtd=k + + k1=iwtd+1 + do kwtd=k1,nsoil + +!max water that the layer can yield + maxwatdw=dzs(kwtd)*(smc(kwtd)-max(smceq(kwtd),sice(kwtd))) + + if(-totwater.le.maxwatdw)then + smc(kwtd) = smc(kwtd) + totwater / dzs(kwtd) + if(smc(kwtd).gt.smceq(kwtd))then + wtd = ( smc(kwtd)*dzs(kwtd) & + - smceq(kwtd)*zsoil(iwtd) + smcmax*zsoil(kwtd) ) / & + ( smcmax-smceq(kwtd) ) + else + wtd=zsoil(kwtd) + iwtd=iwtd+1 + endif + totwater=0. + exit + else + wtd = zsoil(kwtd) + iwtd=iwtd+1 + if(maxwatdw.ge.0.)then + smc(kwtd) = smc(kwtd) + maxwatdw / dzs(kwtd) + totwater = totwater + maxwatdw + endif + endif + + enddo + + if(iwtd.eq.nsoil.and.totwater.lt.0.)then + !gmmequilibrium soil moisture content + smceqdeep = smcmax * ( psisat / & + (psisat - dzs(nsoil)) ) ** (1./bexp) +! smceqdeep = max(smceqdeep,smcwlt) + smceqdeep = max(smceqdeep,1.E-4) + + maxwatdw=dzs(nsoil)*(smcwtd-smceqdeep) + + if(-totwater.le.maxwatdw)then + + smcwtd = smcwtd + totwater / dzs(nsoil) + wtd = max( ( smcwtd*dzs(nsoil) & + - smceqdeep*zsoil(nsoil) + smcmax*(zsoil(nsoil)-dzs(nsoil)) ) / & + ( smcmax-smceqdeep ) , zsoil(nsoil)-dzs(nsoil) ) + + else + + wtd=zsoil(nsoil)-dzs(nsoil) + smcwtd = smcwtd + totwater / dzs(nsoil) +!and now even further down + dzup=(smceqdeep-smcwtd)*dzs(nsoil)/(smcmax-smceqdeep) + wtd=wtd-dzup + smcwtd=smceqdeep + + endif + + endif + + + + elseif(wtd.ge.zsoil(nsoil)-dzs(nsoil))then + +!if wtd was already below the bottom of the resolved soil crust + !gmmequilibrium soil moisture content + smceqdeep = smcmax * ( psisat / & + (psisat - dzs(nsoil)) ) ** (1./bexp) +! smceqdeep = max(smceqdeep,smcwlt) + smceqdeep = max(smceqdeep,1.E-4) + + maxwatdw=dzs(nsoil)*(smcwtd-smceqdeep) + + if(-totwater.le.maxwatdw)then + + smcwtd = smcwtd + totwater / dzs(nsoil) + wtd = max( ( smcwtd*dzs(nsoil) & + - smceqdeep*zsoil(nsoil) + smcmax*(zsoil(nsoil)-dzs(nsoil)) ) / & + ( smcmax-smceqdeep ) , zsoil(nsoil)-dzs(nsoil) ) + + else + + wtd=zsoil(nsoil)-dzs(nsoil) + smcwtd = smcwtd + totwater / dzs(nsoil) +!and now even further down + dzup=(smceqdeep-smcwtd)*dzs(nsoil)/(smcmax-smceqdeep) + wtd=wtd-dzup + smcwtd=smceqdeep + + endif + + else +!gmmequilibrium soil moisture content + wgpmid = smcmax * ( psisat / & + (psisat - (zsoil(nsoil)-wtd)) ) ** (1./bexp) +! wgpmid=max(wgpmid,smcwlt) + wgpmid=max(wgpmid,1.E-4) + syielddw=smcmax-wgpmid + wtdold=wtd + wtd = wtdold + totwater/syielddw +!update wtdwgp + smcwtd = (smcwtd*(zsoil(nsoil)-wtdold)+wgpmid*(wtdold-wtd) ) / (zsoil(nsoil)-wtd) + + endif + + qspring=0. + +ENDIF + + SH2O = SMC - SICE + + + end subroutine UPDATEWTD + +! ---------------------------------------------------------------------- + +END MODULE GroundWaterMmfMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/GroundWaterTopModelMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/GroundWaterTopModelMod.F90 new file mode 100644 index 0000000000..5e67f648b5 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/GroundWaterTopModelMod.F90 @@ -0,0 +1,216 @@ +module GroundWaterTopModelMod + +!!! Compute groundwater flow and subsurface runoff based on TOPMODEL (Niu et al., 2007) + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine GroundWaterTopModel(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: GROUNDWATER +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: LoopInd ! loop index + integer :: IndUnsatSoil ! layer index of the first unsaturated layer + real(kind=8) :: SatDegUnsatSoil ! degree of saturation of IndUnsatSoil layer + real(kind=kind_noahmp) :: SoilMatPotFrz ! soil matric potential (frozen effects) [mm] + real(kind=kind_noahmp) :: AquiferWatConduct ! aquifer hydraulic conductivity [mm/s] + real(kind=kind_noahmp) :: WaterHeadTbl ! water head at water table [mm] + real(kind=kind_noahmp) :: WaterHead ! water head at layer above water table [mm] + real(kind=kind_noahmp) :: WaterFillPore ! water used to fill air pore [mm] + real(kind=kind_noahmp) :: WatConductAcc ! sum of SoilWatConductTmp*ThicknessSoil + real(kind=kind_noahmp) :: SoilMoistureMin ! minimum soil moisture [m3/m3] + real(kind=kind_noahmp) :: WaterExcessSat ! excessive water above saturation [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: ThicknessSoil ! layer thickness [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: DepthSoilMid ! node depth [m] + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilLiqTmp ! liquid water mass [kg/m2 or mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilEffPorosity ! soil effective porosity + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilWatConductTmp ! hydraulic conductivity [mm/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilMoisture ! total soil water content [m3/m3] + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + SoilTimeStep => noahmp%config%domain%SoilTimeStep ,& ! in, noahmp soil timestep [s] + DepthSoilLayer => noahmp%config%domain%DepthSoilLayer ,& ! in, depth of soil layer-bottom [m] + SoilImpervFracMax => noahmp%water%state%SoilImpervFracMax ,& ! in, maximum soil imperviousness fraction + SoilIce => noahmp%water%state%SoilIce ,& ! in, soil ice content [m3/m3] + SoilWatConductivity => noahmp%water%state%SoilWatConductivity ,& ! in, soil hydraulic conductivity [m/s] + SoilMoistureSat => noahmp%water%param%SoilMoistureSat ,& ! in, saturated value of soil moisture [m3/m3] + GridTopoIndex => noahmp%water%param%GridTopoIndex ,& ! in, gridcell mean topgraphic index (global mean) + SoilMatPotentialSat => noahmp%water%param%SoilMatPotentialSat ,& ! in, saturated soil matric potential + SoilExpCoeffB => noahmp%water%param%SoilExpCoeffB ,& ! in, soil B parameter + SpecYieldGw => noahmp%water%param%SpecYieldGw ,& ! in, specific yield [-], default:0.2 + MicroPoreContent => noahmp%water%param%MicroPoreContent ,& ! in, microprore content (0.0-1.0), default:0.2 + SoilWatConductivitySat => noahmp%water%param%SoilWatConductivitySat ,& ! in, saturated soil hydraulic conductivity [m/s] + SoilLiqWater => noahmp%water%state%SoilLiqWater ,& ! inout, soil water content [m3/m3] + WaterTableDepth => noahmp%water%state%WaterTableDepth ,& ! inout, water table depth [m] + WaterStorageAquifer => noahmp%water%state%WaterStorageAquifer ,& ! inout, water storage in aquifer [mm] + WaterStorageSoilAqf => noahmp%water%state%WaterStorageSoilAqf ,& ! inout, water storage in aquifer + saturated soil [mm] + RunoffDecayFac => noahmp%water%param%RunoffDecayFac ,& ! inout, runoff decay factor (1/m) + BaseflowCoeff => noahmp%water%param%BaseflowCoeff ,& ! inout, baseflow coefficient [mm/s] + RechargeGw => noahmp%water%flux%RechargeGw ,& ! out, groundwater recharge rate [mm/s] + DischargeGw => noahmp%water%flux%DischargeGw & ! out, groundwater discharge rate [mm/s] + ) +! ---------------------------------------------------------------------- + + ! initialization + if (.not. allocated(DepthSoilMid) ) allocate(DepthSoilMid (1:NumSoilLayer)) + if (.not. allocated(ThicknessSoil) ) allocate(ThicknessSoil (1:NumSoilLayer)) + if (.not. allocated(SoilLiqTmp) ) allocate(SoilLiqTmp (1:NumSoilLayer)) + if (.not. allocated(SoilEffPorosity) ) allocate(SoilEffPorosity (1:NumSoilLayer)) + if (.not. allocated(SoilWatConductTmp)) allocate(SoilWatConductTmp(1:NumSoilLayer)) + if (.not. allocated(SoilMoisture) ) allocate(SoilMoisture (1:NumSoilLayer)) + DepthSoilMid = 0.0 + ThicknessSoil = 0.0 + SoilLiqTmp = 0.0 + SoilEffPorosity = 0.0 + SoilWatConductTmp = 0.0 + SoilMoisture = 0.0 + DischargeGw = 0.0 + RechargeGw = 0.0 + + ! Derive layer-bottom depth in [mm]; KWM:Derive layer thickness in mm + ThicknessSoil(1) = -DepthSoilLayer(1) * 1.0e3 + do LoopInd = 2, NumSoilLayer + ThicknessSoil(LoopInd) = 1.0e3 * (DepthSoilLayer(LoopInd-1) - DepthSoilLayer(LoopInd)) + enddo + + ! Derive node (middle) depth in [m]; KWM: Positive number, depth below ground surface in m + DepthSoilMid(1) = -DepthSoilLayer(1) / 2.0 + do LoopInd = 2, NumSoilLayer + DepthSoilMid(LoopInd) = -DepthSoilLayer(LoopInd-1) + & + 0.5 * (DepthSoilLayer(LoopInd-1) - DepthSoilLayer(LoopInd)) + enddo + + ! Convert volumetric soil moisture to mass + do LoopInd = 1, NumSoilLayer + SoilMoisture(LoopInd) = SoilLiqWater(LoopInd) + SoilIce(LoopInd) + SoilLiqTmp(LoopInd) = SoilLiqWater(LoopInd) * ThicknessSoil(LoopInd) + SoilEffPorosity(LoopInd) = max(0.01, SoilMoistureSat(LoopInd)-SoilIce(LoopInd)) + SoilWatConductTmp(LoopInd) = 1.0e3 * SoilWatConductivity(LoopInd) + enddo + + ! The layer index of the first unsaturated layer (the layer right above the water table) + IndUnsatSoil = NumSoilLayer + do LoopInd = 2, NumSoilLayer + if ( WaterTableDepth <= -DepthSoilLayer(LoopInd) ) then + IndUnsatSoil = LoopInd - 1 + exit + endif + enddo + + ! Groundwater discharge [mm/s] + !RunoffDecayFac = 6.0 + !BaseflowCoeff = 5.0 + !DischargeGw = (1.0 - SoilImpervFracMax) * BaseflowCoeff * & + ! exp(-GridTopoIndex) * exp(-RunoffDecayFac * (WaterTableDepth-2.0)) + ! Update from GY Niu 2022 + RunoffDecayFac = SoilExpCoeffB(IndUnsatSoil) / 3.0 + BaseflowCoeff = SoilWatConductTmp(IndUnsatSoil) * 1.0e3 * exp(3.0) ! [mm/s] + DischargeGw = (1.0 - SoilImpervFracMax) * BaseflowCoeff * exp(-GridTopoIndex) * & + exp(-RunoffDecayFac * WaterTableDepth) + + ! Matric potential at the layer above the water table + SatDegUnsatSoil = min(1.0, SoilMoisture(IndUnsatSoil)/SoilMoistureSat(IndUnsatSoil)) + SatDegUnsatSoil = max(SatDegUnsatSoil, real(0.01,kind=8)) + SoilMatPotFrz = -SoilMatPotentialSat(IndUnsatSoil) * 1000.0 * & + SatDegUnsatSoil**(-SoilExpCoeffB(IndUnsatSoil)) ! m -> mm + SoilMatPotFrz = max(-120000.0, MicroPoreContent*SoilMatPotFrz) + + ! Recharge rate qin to groundwater + !AquiferWatConduct = SoilWatConductTmp(IndUnsatSoil) + AquiferWatConduct = 2.0 * (SoilWatConductTmp(IndUnsatSoil) * SoilWatConductivitySat(IndUnsatSoil)*1.0e3) / & + (SoilWatConductTmp(IndUnsatSoil) + SoilWatConductivitySat(IndUnsatSoil)*1.0e3) ! harmonic average, GY Niu's update 2022 + WaterHeadTbl = -WaterTableDepth * 1.0e3 !(mm) + WaterHead = SoilMatPotFrz - DepthSoilMid(IndUnsatSoil) * 1.0e3 !(mm) + RechargeGw = -AquiferWatConduct * (WaterHeadTbl - WaterHead) / & + ((WaterTableDepth-DepthSoilMid(IndUnsatSoil)) * 1.0e3) + RechargeGw = max(-10.0/SoilTimeStep, min(10.0/SoilTimeStep, RechargeGw)) + + ! Water storage in the aquifer + saturated soil + WaterStorageSoilAqf = WaterStorageSoilAqf + (RechargeGw - DischargeGw) * SoilTimeStep !(mm) + if ( IndUnsatSoil == NumSoilLayer ) then + WaterStorageAquifer = WaterStorageAquifer + (RechargeGw - DischargeGw) * SoilTimeStep !(mm) + WaterStorageSoilAqf = WaterStorageAquifer + WaterTableDepth = (-DepthSoilLayer(NumSoilLayer) + 25.0) - & + WaterStorageAquifer / 1000.0 / SpecYieldGw !(m) + SoilLiqTmp(NumSoilLayer) = SoilLiqTmp(NumSoilLayer) - RechargeGw * SoilTimeStep ! [mm] + SoilLiqTmp(NumSoilLayer) = SoilLiqTmp(NumSoilLayer) + max(0.0, (WaterStorageAquifer-5000.0)) + WaterStorageAquifer = min(WaterStorageAquifer, 5000.0) + else + if ( IndUnsatSoil == NumSoilLayer-1 ) then + WaterTableDepth = -DepthSoilLayer(NumSoilLayer) - (WaterStorageSoilAqf - SpecYieldGw*1000.0*25.0) / & + (SoilEffPorosity(NumSoilLayer)) / 1000.0 + else + WaterFillPore = 0.0 ! water used to fill soil air pores + do LoopInd = IndUnsatSoil+2, NumSoilLayer + WaterFillPore = WaterFillPore + SoilEffPorosity(LoopInd) * ThicknessSoil(LoopInd) + enddo + WaterTableDepth = -DepthSoilLayer(IndUnsatSoil+1) - (WaterStorageSoilAqf - SpecYieldGw*1000.0*25.0 - & + WaterFillPore) / (SoilEffPorosity(IndUnsatSoil+1)) / 1000.0 + endif + WatConductAcc = 0.0 + do LoopInd = 1, NumSoilLayer + WatConductAcc = WatConductAcc + SoilWatConductTmp(LoopInd) * ThicknessSoil(LoopInd) + enddo + do LoopInd = 1, NumSoilLayer ! Removing subsurface runoff + SoilLiqTmp(LoopInd) = SoilLiqTmp(LoopInd) - DischargeGw * SoilTimeStep * & + SoilWatConductTmp(LoopInd) * ThicknessSoil(LoopInd) / WatConductAcc + enddo + endif + WaterTableDepth = max(1.5, WaterTableDepth) + + ! Limit SoilLiqTmp to be greater than or equal to SoilMoistureMin + ! Get water needed to bring SoilLiqTmp equal SoilMoistureMin from lower layer. + SoilMoistureMin = 0.01 + do LoopInd = 1, NumSoilLayer-1 + if ( SoilLiqTmp(LoopInd) < 0.0 ) then + WaterExcessSat = SoilMoistureMin - SoilLiqTmp(LoopInd) + else + WaterExcessSat = 0.0 + endif + SoilLiqTmp(LoopInd ) = SoilLiqTmp(LoopInd ) + WaterExcessSat + SoilLiqTmp(LoopInd+1) = SoilLiqTmp(LoopInd+1) - WaterExcessSat + enddo + LoopInd = NumSoilLayer + if ( SoilLiqTmp(LoopInd) < SoilMoistureMin ) then + WaterExcessSat = SoilMoistureMin - SoilLiqTmp(LoopInd) + else + WaterExcessSat = 0.0 + endif + SoilLiqTmp(LoopInd) = SoilLiqTmp(LoopInd) + WaterExcessSat + WaterStorageAquifer = WaterStorageAquifer - WaterExcessSat + WaterStorageSoilAqf = WaterStorageSoilAqf - WaterExcessSat + + ! update soil moisture + do LoopInd = 1, NumSoilLayer + SoilLiqWater(LoopInd) = SoilLiqTmp(LoopInd) / ThicknessSoil(LoopInd) + enddo + + ! deallocate local arrays to avoid memory leaks + deallocate(DepthSoilMid ) + deallocate(ThicknessSoil ) + deallocate(SoilLiqTmp ) + deallocate(SoilEffPorosity ) + deallocate(SoilWatConductTmp) + deallocate(SoilMoisture ) + + end associate + + end subroutine GroundWaterTopModel + +end module GroundWaterTopModelMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/HumiditySaturationMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/HumiditySaturationMod.F90 new file mode 100644 index 0000000000..8a912d1995 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/HumiditySaturationMod.F90 @@ -0,0 +1,63 @@ +module HumiditySaturationMod + +!!! Compute saturated surface specific humidity and changing rate to temperature + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine HumiditySaturation(TemperatureAir, PressureAir, MixingRatioSat, MixingRatioSatTempD) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: CALHUM +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + real(kind=kind_noahmp), intent(in) :: TemperatureAir ! air temperature (K) + real(kind=kind_noahmp), intent(in) :: PressureAir ! air pressure (pa) + real(kind=kind_noahmp), intent(out) :: MixingRatioSat ! saturated mixing ratio (g/g) + real(kind=kind_noahmp), intent(out) :: MixingRatioSatTempD ! d(MixingRatioSat)/d(T) + +! local variable + real(kind=kind_noahmp), parameter :: Const1 = 17.67 ! constant 1 + real(kind=kind_noahmp), parameter :: TemperatureFrz = 273.15 ! freezing temperature 0degC [K] + real(kind=kind_noahmp), parameter :: Const2 = 29.65 ! constant 2 + real(kind=kind_noahmp), parameter :: ConstLatHeatVap = 2.501e6 ! latent heat of vaporization [J/kg] + real(kind=kind_noahmp), parameter :: Const3 = Const1*(TemperatureFrz-Const2) ! constant 3 + real(kind=kind_noahmp), parameter :: VapPresSatFrz = 0.611 ! vapor pressure at 0 degC [Pa] + real(kind=kind_noahmp), parameter :: GasConstWatVap = 461.0 ! specific gas constant for water vapor [J/kg/K] + real(kind=kind_noahmp), parameter :: RatioGasConst = 0.622 ! ratio of gas constant of dry air to water vapor + real(kind=kind_noahmp) :: VapPresSatTemp ! saturated vapor pressure at air temperature [Pa] + real(kind=kind_noahmp) :: PressureAirKpa ! air pressure in KPa unit + +! ---------------------------------------------------------------------- + + ! calculated saturated vapor pressure at air temperature + VapPresSatTemp = VapPresSatFrz * exp(ConstLatHeatVap / GasConstWatVap * & + (1.0/TemperatureFrz - 1.0/TemperatureAir)) + + ! convert PressureAir from Pa to KPa + PressureAirKpa = PressureAir * 1.0e-3 + + ! calculate saturated mixing ratio + MixingRatioSat = RatioGasConst * VapPresSatTemp / (PressureAirKpa - VapPresSatTemp) + + ! convert from g/g to g/kg + MixingRatioSat = MixingRatioSat * 1.0e3 + + ! MixingRatioSatTempD is calculated assuming MixingRatioSat is a specific humidity + MixingRatioSatTempD = (MixingRatioSat / (1+MixingRatioSat)) * Const3 / (TemperatureAir-Const2)**2 + + ! MixingRatioSat needs to be in g/g when returned for surface flux calculation + MixingRatioSat = MixingRatioSat / 1.0e3 + + end subroutine HumiditySaturation + +end module HumiditySaturationMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/IrrigationFloodMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/IrrigationFloodMod.F90 new file mode 100644 index 0000000000..9ef7b7ad64 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/IrrigationFloodMod.F90 @@ -0,0 +1,70 @@ +module IrrigationFloodMod + +!!! Estimate irrigation water depth (m) based on surface flooding irrigation method +!!! Reference: chapter 4 of NRCS, Part 623 National Engineering Handbook +!!! Irrigation water is applied on the surface based on present soil moisture and +!!! infiltration rate of the soil. Flooding or overland flow is based on infiltration excess + + use Machine + use NoahmpVarType + use ConstantDefineMod + use IrrigationInfilPhilipMod, only : IrrigationInfilPhilip + + implicit none + +contains + + subroutine IrrigationFlood(noahmp) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: FLOOD_IRRIGATION +! Original code: P. Valayamkunnath (NCAR) (08/06/2020) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + real(kind=kind_noahmp) :: InfilRateSfc ! surface infiltration rate [m/s] + +! -------------------------------------------------------------------- + associate( & + SoilTimeStep => noahmp%config%domain%SoilTimeStep ,& ! in, noahmp soil time step [s] + NumSoilTimeStep => noahmp%config%domain%NumSoilTimeStep ,& ! in, number of time step for calculating soil processes + IrriFloodRateFac => noahmp%water%param%IrriFloodRateFac ,& ! in, flood application rate factor + IrrigationFracFlood => noahmp%water%state%IrrigationFracFlood ,& ! in, fraction of grid under flood irrigation (0 to 1) + IrrigationAmtFlood => noahmp%water%state%IrrigationAmtFlood ,& ! inout, flood irrigation water amount [m] + SoilSfcInflowAcc => noahmp%water%flux%SoilSfcInflowAcc ,& ! inout, accumulated water flux into soil during soil timestep [m/s * dt_soil/dt_main] + IrrigationRateFlood => noahmp%water%flux%IrrigationRateFlood & ! inout, flood irrigation water rate [m/timestep] + ) +! ---------------------------------------------------------------------- + + ! initialize local variables + InfilRateSfc = 0.0 + + ! estimate infiltration rate based on Philips Eq. + call IrrigationInfilPhilip(noahmp, SoilTimeStep, InfilRateSfc) + + ! irrigation rate of flood irrigation. It should be + ! greater than infiltration rate to get infiltration + ! excess runoff at the time of application + IrrigationRateFlood = InfilRateSfc * SoilTimeStep * IrriFloodRateFac ! Limit irrigation rate to fac*infiltration rate + IrrigationRateFlood = IrrigationRateFlood * IrrigationFracFlood + + if ( IrrigationRateFlood >= IrrigationAmtFlood ) then + IrrigationRateFlood = IrrigationAmtFlood + IrrigationAmtFlood = 0.0 + else + IrrigationAmtFlood = IrrigationAmtFlood - IrrigationRateFlood + endif + + ! update water flux going to surface soil + SoilSfcInflowAcc = SoilSfcInflowAcc + (IrrigationRateFlood / SoilTimeStep * NumSoilTimeStep) ! [m/s * dt_soil/dt_main] + + end associate + + end subroutine IrrigationFlood + +end module IrrigationFloodMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/IrrigationInfilPhilipMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/IrrigationInfilPhilipMod.F90 new file mode 100644 index 0000000000..49ef888463 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/IrrigationInfilPhilipMod.F90 @@ -0,0 +1,86 @@ +module IrrigationInfilPhilipMod + +!!! Estimate infiltration rate based on Philip's two parameter equation +!!! Reference: Eq.2 in Valiantzas (2010): New linearized two-parameter infiltration equation for direct +!!! determination of conductivity and sorptivity, J. Hydrology. + + use Machine + use NoahmpVarType + use ConstantDefineMod + use SoilHydraulicPropertyMod, only : SoilDiffusivityConductivityOpt2 + + implicit none + +contains + + subroutine IrrigationInfilPhilip(noahmp, TimeStep, InfilRateSfc) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: IRR_PHILIP_INFIL +! Original code: P. Valayamkunnath (NCAR) (08/06/2020) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + +! IN & OUT variables + type(noahmp_type) , intent(inout) :: noahmp + real(kind=kind_noahmp), intent(in) :: TimeStep ! time step [s] + real(kind=kind_noahmp), intent(out) :: InfilRateSfc ! surface infiltration rate [m/s] + +! local variables + integer :: LoopInd ! loop indices + integer :: IndSoilLayer ! soil layer index + real(kind=kind_noahmp) :: SoilSorptivity ! sorptivity [m s^-1/2] + real(kind=kind_noahmp) :: SoilWatConductInit ! intial hydraulic conductivity [m/s] + real(kind=kind_noahmp) :: SoilWatConductivity ! soil water conductivity [m/s] + real(kind=kind_noahmp) :: SoilWatDiffusivity ! soil water diffusivity [m2/s] + real(kind=kind_noahmp) :: SoilIceMaxTmp ! maximum soil ice content [m3/m3] + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! in, total soil moisture [m3/m3] + SoilLiqWater => noahmp%water%state%SoilLiqWater ,& ! in, soil water content [m3/m3] + SoilIce => noahmp%water%state%SoilIce ,& ! in, soil ice content [m3/m3] + SoilMoistureSat => noahmp%water%param%SoilMoistureSat ,& ! in, saturated value of soil moisture [m3/m3] + SoilWatDiffusivitySat => noahmp%water%param%SoilWatDiffusivitySat ,& ! in, saturated soil hydraulic diffusivity [m2/s] + SoilWatConductivitySat => noahmp%water%param%SoilWatConductivitySat & ! in, saturated soil hydraulic conductivity [m/s] + ) +! ---------------------------------------------------------------------- + + ! initialize out-only and local variables + SoilWatConductivity = 0.0 + SoilWatDiffusivity = 0.0 + SoilIceMaxTmp = 0.0 + SoilSorptivity = 0.0 + SoilWatConductInit = 0.0 + + ! maximum ice fraction + do LoopInd = 1, NumSoilLayer + if ( SoilIce(LoopInd) > SoilIceMaxTmp ) SoilIceMaxTmp = SoilIce(LoopInd) + enddo + + ! estimate initial soil hydraulic conductivty and diffusivity (Ki, D(theta) in the equation) + IndSoilLayer = 1 + call SoilDiffusivityConductivityOpt2(noahmp, SoilWatDiffusivity, SoilWatConductivity, & + SoilLiqWater(IndSoilLayer), SoilIceMaxTmp, IndSoilLayer) + + ! sorptivity based on Eq. 10b from Kutilek, Miroslav, and Jana Valentova (1986) + ! sorptivity approximations. Transport in Porous Media 1.1, 57-62. + SoilSorptivity = sqrt(2.0 * max(0.0, (SoilMoistureSat(IndSoilLayer) - SoilMoisture(IndSoilLayer))) * & + (SoilWatDiffusivitySat(IndSoilLayer) - SoilWatDiffusivity)) + + ! parameter A in Eq. 9 of Valiantzas (2010) is given by + SoilWatConductInit = min(SoilWatConductivity, (2.0/3.0) * SoilWatConductivitySat(IndSoilLayer)) + SoilWatConductInit = max(SoilWatConductInit , (1.0/3.0) * SoilWatConductivitySat(IndSoilLayer)) + + ! maximun infiltration rate, m/s + InfilRateSfc = 0.5 * SoilSorptivity * (TimeStep**(-0.5)) + SoilWatConductInit ! m/s + InfilRateSfc = max(0.0, InfilRateSfc) + + end associate + + end subroutine IrrigationInfilPhilip + +end module IrrigationInfilPhilipMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/IrrigationMicroMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/IrrigationMicroMod.F90 new file mode 100644 index 0000000000..d115e8b359 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/IrrigationMicroMod.F90 @@ -0,0 +1,73 @@ +module IrrigationMicroMod + +!!! Estimate irrigation water depth (m) based on Micro irrigation method +!!! Reference: chapter 7 of NRCS, Part 623 National Engineering Handbook +!!! Irrigation water is applied under the canopy, within first layer +!!! (at ~5 cm depth) considering current soil moisture + + use Machine + use NoahmpVarType + use ConstantDefineMod + use IrrigationInfilPhilipMod, only : IrrigationInfilPhilip + + implicit none + +contains + + subroutine IrrigationMicro(noahmp) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: MICRO_IRRIGATION +! Original code: P. Valayamkunnath (NCAR) (08/06/2020) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + real(kind=kind_noahmp) :: InfilRateSfc ! surface infiltration rate [m/s] + real(kind=kind_noahmp) :: IrriRateTmp ! temporary micro irrigation rate [m/timestep] + +! -------------------------------------------------------------------- + associate( & + SoilTimeStep => noahmp%config%domain%SoilTimeStep ,& ! in, noahmp soil time step [s] + DepthSoilLayer => noahmp%config%domain%DepthSoilLayer ,& ! in, depth [m] of layer-bottom from soil surface + IrrigationFracMicro => noahmp%water%state%IrrigationFracMicro ,& ! in, fraction of grid under micro irrigation (0 to 1) + IrriMicroRate => noahmp%water%param%IrriMicroRate ,& ! in, micro irrigation rate [mm/hr] + SoilLiqWater => noahmp%water%state%SoilLiqWater ,& ! inout, soil water content [m3/m3] + IrrigationAmtMicro => noahmp%water%state%IrrigationAmtMicro ,& ! inout, micro irrigation water amount [m] + IrrigationRateMicro => noahmp%water%flux%IrrigationRateMicro & ! inout, micro irrigation water rate [m/timestep] + ) +! ---------------------------------------------------------------------- + + ! initialize local variables + InfilRateSfc = 0.0 + IrriRateTmp = 0.0 + + ! estimate infiltration rate based on Philips Eq. + call IrrigationInfilPhilip(noahmp, SoilTimeStep, InfilRateSfc) + + ! irrigation rate of micro irrigation + IrriRateTmp = IrriMicroRate * (1.0/1000.0) * SoilTimeStep/ 3600.0 ! NRCS rate/time step - calibratable + IrrigationRateMicro = min(0.5*InfilRateSfc*SoilTimeStep, IrrigationAmtMicro, IrriRateTmp) ! Limit irrigation rate to minimum of 0.5*infiltration rate + ! and to the NRCS recommended rate, (m) + IrrigationRateMicro = IrrigationRateMicro * IrrigationFracMicro + + if ( IrrigationRateMicro >= IrrigationAmtMicro ) then + IrrigationRateMicro = IrrigationAmtMicro + IrrigationAmtMicro = 0.0 + else + IrrigationAmtMicro = IrrigationAmtMicro - IrrigationRateMicro + endif + + ! update soil moisture + ! we implement drip in first layer of the Noah-MP. Change layer 1 moisture wrt to irrigation rate + SoilLiqWater(1) = SoilLiqWater(1) + (IrrigationRateMicro / (-1.0*DepthSoilLayer(1))) + + end associate + + end subroutine IrrigationMicro + +end module IrrigationMicroMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/IrrigationPrepareMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/IrrigationPrepareMod.F90 new file mode 100644 index 0000000000..108bbe68d1 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/IrrigationPrepareMod.F90 @@ -0,0 +1,99 @@ +module IrrigationPrepareMod + +!!! Prepare dynamic irrigation variables and trigger irrigation based on conditions + + use Machine + use NoahmpVarType + use ConstantDefineMod + use IrrigationTriggerMod, only : IrrigationTrigger + + implicit none + +contains + + subroutine IrrigationPrepare(noahmp) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: None (embedded in NOAHMP_SFLX +! Original code: P. Valayamkunnath (NCAR) (08/06/2020) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + +! ---------------------------------------------------------------------- + associate( & + LandUseDataName => noahmp%config%domain%LandUseDataName ,& ! in, landuse data name (USGS or MODIS_IGBP) + VegType => noahmp%config%domain%VegType ,& ! in, vegetation type + FlagSoilProcess => noahmp%config%domain%FlagSoilProcess ,& ! in, flag to calculate soil processes + OptIrrigationMethod => noahmp%config%nmlist%OptIrrigationMethod ,& ! in, irrigation method option + IrriFracThreshold => noahmp%water%param%IrriFracThreshold ,& ! in, irrigation fraction threshold + IrriStopPrecipThr => noahmp%water%param%IrriStopPrecipThr ,& ! in, maximum precipitation to stop irrigation trigger + IrrigationFracGrid => noahmp%water%state%IrrigationFracGrid ,& ! in, total input irrigation fraction of a grid + IrrigationAmtSprinkler => noahmp%water%state%IrrigationAmtSprinkler ,& ! inout, irrigation water amount [m] to be applied, Sprinkler + IrrigationAmtFlood => noahmp%water%state%IrrigationAmtFlood ,& ! inout, flood irrigation water amount [m] + IrrigationAmtMicro => noahmp%water%state%IrrigationAmtMicro ,& ! inout, micro irrigation water amount [m] + RainfallRefHeight => noahmp%water%flux%RainfallRefHeight ,& ! inout, rainfall [mm/s] at reference height + FlagCropland => noahmp%config%domain%FlagCropland ,& ! out, flag to identify croplands + IrrigationFracSprinkler => noahmp%water%state%IrrigationFracSprinkler ,& ! out, sprinkler irrigation fraction (0 to 1) + IrrigationFracMicro => noahmp%water%state%IrrigationFracMicro ,& ! out, fraction of grid under micro irrigation (0 to 1) + IrrigationFracFlood => noahmp%water%state%IrrigationFracFlood & ! out, fraction of grid under flood irrigation (0 to 1) + ) +! ---------------------------------------------------------------------- + + ! initialize + FlagCropland = .false. + + ! determine cropland + if ( trim(LandUseDataName) == "USGS" ) then + if ( (VegType >= 3) .and. (VegType <= 6) ) FlagCropland = .true. + elseif ( trim(LandUseDataName) == "MODIFIED_IGBP_MODIS_NOAH") then + if ( (VegType == 12) .or. (VegType == 14) ) FlagCropland = .true. + endif + + ! if OptIrrigationMethod = 0 and if methods are unknown for certain area, then use sprinkler irrigation method + if ( (OptIrrigationMethod == 0) .and. (IrrigationFracSprinkler == 0.0) .and. (IrrigationFracMicro == 0.0) & + .and. (IrrigationFracFlood == 0.0) .and. (IrrigationFracGrid >= IrriFracThreshold) ) then + IrrigationFracSprinkler = 1.0 + endif + + ! choose method based on user namelist choice + if ( OptIrrigationMethod == 1 ) then + IrrigationFracSprinkler = 1.0 + IrrigationFracMicro = 0.0 + IrrigationFracFlood = 0.0 + elseif ( OptIrrigationMethod == 2 ) then + IrrigationFracSprinkler = 0.0 + IrrigationFracMicro = 1.0 + IrrigationFracFlood = 0.0 + elseif ( OptIrrigationMethod == 3 ) then + IrrigationFracSprinkler = 0.0 + IrrigationFracMicro = 0.0 + IrrigationFracFlood = 1.0 + endif + + ! trigger irrigation only at soil water timestep to be consistent for solving soil water + if ( FlagSoilProcess .eqv. .true. ) then + if ( (FlagCropland .eqv. .true.) .and. (IrrigationFracGrid >= IrriFracThreshold) .and. & + (RainfallRefHeight < (IrriStopPrecipThr/3600.0)) .and. & + ((IrrigationAmtSprinkler+IrrigationAmtMicro+IrrigationAmtFlood) == 0.0) ) then + call IrrigationTrigger(noahmp) + endif + + ! set irrigation off if larger than IrriStopPrecipThr mm/h for this time step and irr triggered last time step + if ( (RainfallRefHeight >= (IrriStopPrecipThr/3600.0)) .or. (IrrigationFracGrid < IrriFracThreshold) ) then + IrrigationAmtSprinkler = 0.0 + IrrigationAmtMicro = 0.0 + IrrigationAmtFlood = 0.0 + endif + endif + + end associate + + end subroutine IrrigationPrepare + +end module IrrigationPrepareMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/IrrigationSprinklerMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/IrrigationSprinklerMod.F90 new file mode 100644 index 0000000000..b5dc0eae9b --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/IrrigationSprinklerMod.F90 @@ -0,0 +1,109 @@ +module IrrigationSprinklerMod + +!!! Estimate irrigation water depth (m) based on sprinkler method +!!! Reference: chapter 11 of NRCS, Part 623 National Engineering Handbook. +!!! Irrigation water will be applied over the canopy, affecting present soil moisture, +!!! infiltration rate of the soil, and evaporative loss, which should be executed before canopy process. + + use Machine + use CheckNanMod + use NoahmpVarType + use ConstantDefineMod + use IrrigationInfilPhilipMod, only : IrrigationInfilPhilip + + implicit none + +contains + + subroutine IrrigationSprinkler(noahmp) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: SPRINKLER_IRRIGATION +! Original code: P. Valayamkunnath (NCAR) (08/06/2020) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + logical :: FlagNan ! NaN value flag: if NaN, return true + real(kind=kind_noahmp) :: InfilRateSfc ! surface infiltration rate [m/s] + real(kind=kind_noahmp) :: IrriRateTmp ! temporary irrigation rate [m/timestep] + real(kind=kind_noahmp) :: WindSpdTot ! total wind speed [m/s] + real(kind=kind_noahmp) :: IrriLossTmp ! temporary irrigation water loss [%] + real(kind=kind_noahmp) :: PressureVaporSat ! satuarated vapor pressure [Pa] + +! -------------------------------------------------------------------- + associate( & + MainTimeStep => noahmp%config%domain%MainTimeStep ,& ! in, noahmp main time step [s] + TemperatureAirRefHeight => noahmp%forcing%TemperatureAirRefHeight ,& ! in, air temperature [K] at reference height + WindEastwardRefHeight => noahmp%forcing%WindEastwardRefHeight ,& ! in, wind speed [m/s] in eastward direction at reference height + WindNorthwardRefHeight => noahmp%forcing%WindNorthwardRefHeight ,& ! in, wind speed [m/s] in northward direction at reference height + PressureVaporRefHeight => noahmp%energy%state%PressureVaporRefHeight ,& ! in, vapor pressure air [Pa] + IrriSprinklerRate => noahmp%water%param%IrriSprinklerRate ,& ! in, sprinkler irrigation rate [mm/h] + IrrigationFracSprinkler => noahmp%water%state%IrrigationFracSprinkler ,& ! in, sprinkler irrigation fraction (0 to 1) + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! in, total soil moisture [m3/m3] + SoilLiqWater => noahmp%water%state%SoilLiqWater ,& ! in, soil water content [m3/m3] + HeatLatentIrriEvap => noahmp%energy%flux%HeatLatentIrriEvap ,& ! inout, latent heating due to sprinkler evaporation [W/m2] + IrrigationAmtSprinkler => noahmp%water%state%IrrigationAmtSprinkler ,& ! inout, irrigation water amount [m] to be applied, Sprinkler + EvapIrriSprinkler => noahmp%water%flux%EvapIrriSprinkler ,& ! inout, evaporation of irrigation water, sprinkler [mm/s] + RainfallRefHeight => noahmp%water%flux%RainfallRefHeight ,& ! inout, rainfall [mm/s] at reference height + IrrigationRateSprinkler => noahmp%water%flux%IrrigationRateSprinkler ,& ! inout, rate of irrigation by sprinkler [m/timestep] + IrriEvapLossSprinkler => noahmp%water%flux%IrriEvapLossSprinkler ,& ! inout, loss of irrigation water to evaporation,sprinkler [m/timestep] + SoilIce => noahmp%water%state%SoilIce & ! out, soil ice content [m3/m3] + ) +! ---------------------------------------------------------------------- + + ! initialize + SoilIce(:) = max(0.0, SoilMoisture(:)-SoilLiqWater(:)) + + ! estimate infiltration rate based on Philips Eq. + call IrrigationInfilPhilip(noahmp, MainTimeStep, InfilRateSfc) + + ! irrigation rate of sprinkler + IrriRateTmp = IrriSprinklerRate * (1.0/1000.0) * MainTimeStep / 3600.0 ! NRCS rate/time step - calibratable + IrrigationRateSprinkler = min(InfilRateSfc*MainTimeStep, IrrigationAmtSprinkler, IrriRateTmp) ! Limit irrigation rate to minimum of infiltration rate + ! and to the NRCS recommended rate + ! evaporative loss from droplets: Based on Bavi et al., (2009). Evaporation + ! losses from sprinkler irrigation systems under various operating + ! conditions. Journal of Applied Sciences, 9(3), 597-600. + WindSpdTot = sqrt((WindEastwardRefHeight**2.0) + (WindNorthwardRefHeight**2.0)) + PressureVaporSat = 610.8 * exp((17.27*(TemperatureAirRefHeight-273.15)) / (237.3+(TemperatureAirRefHeight-273.15))) + + if ( TemperatureAirRefHeight > 273.15 ) then ! Equation (3) + IrriLossTmp = 4.375 * (exp(0.106*WindSpdTot)) * (((PressureVaporSat-PressureVaporRefHeight)*0.01)**(-0.092)) * & + ((TemperatureAirRefHeight-273.15)**(-0.102)) + else ! Equation (4) + IrriLossTmp = 4.337 * (exp(0.077*WindSpdTot)) * (((PressureVaporSat-PressureVaporRefHeight)*0.01)**(-0.098)) + endif + ! Old PGI Fortran compiler does not support ISNAN function + call CheckRealNaN(IrriLossTmp, FlagNan) + if ( FlagNan .eqv. .true. ) IrriLossTmp = 4.0 ! In case if IrriLossTmp is NaN + if ( (IrriLossTmp > 100.0) .or. (IrriLossTmp < 0.0) ) IrriLossTmp = 4.0 ! In case if IrriLossTmp is out of range + + ! Sprinkler water [m] for sprinkler fraction + IrrigationRateSprinkler = IrrigationRateSprinkler * IrrigationFracSprinkler + if ( IrrigationRateSprinkler >= IrrigationAmtSprinkler ) then + IrrigationRateSprinkler = IrrigationAmtSprinkler + IrrigationAmtSprinkler = 0.0 + else + IrrigationAmtSprinkler = IrrigationAmtSprinkler - IrrigationRateSprinkler + endif + + IrriEvapLossSprinkler = IrrigationRateSprinkler * IrriLossTmp * (1.0/100.0) + IrrigationRateSprinkler = IrrigationRateSprinkler - IrriEvapLossSprinkler + + ! include sprinkler water to total rain for canopy process later + RainfallRefHeight = RainfallRefHeight + (IrrigationRateSprinkler * 1000.0 / MainTimeStep) + + ! cooling and humidification due to sprinkler evaporation, per m^2 calculation + HeatLatentIrriEvap = IrriEvapLossSprinkler * 1000.0 * ConstLatHeatEvap / MainTimeStep ! heat used for evaporation [W/m2] + EvapIrriSprinkler = IrriEvapLossSprinkler * 1000.0 / MainTimeStep ! sprinkler evaporation [mm/s] + + end associate + + end subroutine IrrigationSprinkler + +end module IrrigationSprinklerMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/IrrigationTriggerMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/IrrigationTriggerMod.F90 new file mode 100644 index 0000000000..b0b96b709b --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/IrrigationTriggerMod.F90 @@ -0,0 +1,144 @@ +module IrrigationTriggerMod + +!!! Trigger irrigation if soil moisture less than the management allowable deficit (MAD) +!!! and estimate irrigation water depth [m] using current rootzone soil moisture and field +!!! capacity. There are two options here to trigger the irrigation scheme based on MAD +!!! OptIrrigation = 1 -> if irrigated fraction > threshold fraction +!!! OptIrrigation = 2 -> if irrigated fraction > threshold fraction and within crop season +!!! OptIrrigation = 3 -> if irrigated fraction > threshold fraction and LeafAreaIndex > threshold LeafAreaIndex + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine IrrigationTrigger(noahmp) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: TRIGGER_IRRIGATION +! Original code: P. Valayamkunnath (NCAR) (08/06/2020) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + logical :: FlagIrri ! flag for irrigation activation + integer :: LoopInd ! loop index + real(kind=kind_noahmp) :: SoilMoistAvail ! available soil moisture [m] at timestep + real(kind=kind_noahmp) :: SoilMoistAvailMax ! maximum available moisture [m] + real(kind=kind_noahmp) :: IrrigationWater ! irrigation water amount [m] + +! -------------------------------------------------------------------- + associate( & + DepthSoilLayer => noahmp%config%domain%DepthSoilLayer ,& ! in, depth [m] of layer-bottom from soil surface + DayJulianInYear => noahmp%config%domain%DayJulianInYear ,& ! in, Julian day of the year + OptIrrigation => noahmp%config%nmlist%OptIrrigation ,& ! in, irrigation option + OptIrrigationMethod => noahmp%config%nmlist%OptIrrigationMethod ,& ! in, irrigation method option + DatePlanting => noahmp%biochem%param%DatePlanting ,& ! in, Planting day (day of year) + DateHarvest => noahmp%biochem%param%DateHarvest ,& ! in, Harvest date (day of year) + SoilMoistureWilt => noahmp%water%param%SoilMoistureWilt ,& ! in, wilting point soil moisture [m3/m3] + SoilMoistureFieldCap => noahmp%water%param%SoilMoistureFieldCap ,& ! in, reference soil moisture (field capacity) (m3/m3) + NumSoilLayerRoot => noahmp%water%param%NumSoilLayerRoot ,& ! in, number of soil layers with root present + IrriStopDayBfHarvest => noahmp%water%param%IrriStopDayBfHarvest ,& ! in, number of days before harvest date to stop irrigation + IrriTriggerLaiMin => noahmp%water%param%IrriTriggerLaiMin ,& ! in, minimum lai to trigger irrigation + SoilWatDeficitAllow => noahmp%water%param%SoilWatDeficitAllow ,& ! in, management allowable deficit (0-1) + IrriFloodLossFrac => noahmp%water%param%IrriFloodLossFrac ,& ! in, factor of flood irrigation loss + VegFrac => noahmp%energy%state%VegFrac ,& ! in, greeness vegetation fraction + LeafAreaIndex => noahmp%energy%state%LeafAreaIndex ,& ! in, leaf area index [m2/m2] + IrrigationFracGrid => noahmp%water%state%IrrigationFracGrid ,& ! in, irrigated area fraction of a grid + SoilLiqWater => noahmp%water%state%SoilLiqWater ,& ! in, soil water content [m3/m3] + IrrigationFracMicro => noahmp%water%state%IrrigationFracMicro ,& ! in, fraction of grid under micro irrigation (0 to 1) + IrrigationFracFlood => noahmp%water%state%IrrigationFracFlood ,& ! in, fraction of grid under flood irrigation (0 to 1) + IrrigationFracSprinkler => noahmp%water%state%IrrigationFracSprinkler ,& ! in, sprinkler irrigation fraction (0 to 1) + IrrigationAmtMicro => noahmp%water%state%IrrigationAmtMicro ,& ! inout, irrigation water amount [m] to be applied, Micro + IrrigationAmtFlood => noahmp%water%state%IrrigationAmtFlood ,& ! inout, irrigation water amount [m] to be applied, Flood + IrrigationAmtSprinkler => noahmp%water%state%IrrigationAmtSprinkler ,& ! inout, irrigation water amount [m] to be applied, Sprinkler + IrrigationCntSprinkler => noahmp%water%state%IrrigationCntSprinkler ,& ! inout, irrigation event number, Sprinkler + IrrigationCntMicro => noahmp%water%state%IrrigationCntMicro ,& ! inout, irrigation event number, Micro + IrrigationCntFlood => noahmp%water%state%IrrigationCntFlood & ! inout, irrigation event number, Flood + ) +! ---------------------------------------------------------------------- + + FlagIrri = .true. + + ! check if irrigation is can be activated or not + if ( OptIrrigation == 2 ) then ! activate irrigation if within crop season + if ( (DayJulianInYear < DatePlanting) .or. (DayJulianInYear > (DateHarvest-IrriStopDayBfHarvest)) ) & + FlagIrri = .false. + elseif ( OptIrrigation == 3) then ! activate if LeafAreaIndex > threshold LeafAreaIndex + if ( LeafAreaIndex < IrriTriggerLaiMin) FlagIrri = .false. + elseif ( (OptIrrigation > 3) .or. (OptIrrigation < 1) ) then + FlagIrri = .false. + endif + + if ( FlagIrri .eqv. .true. ) then + ! estimate available water and field capacity for the root zone + SoilMoistAvail = 0.0 + SoilMoistAvailMax = 0.0 + SoilMoistAvail = (SoilLiqWater(1) - SoilMoistureWilt(1)) * (-1.0) * DepthSoilLayer(1) ! current soil water (m) + SoilMoistAvailMax = (SoilMoistureFieldCap(1) - SoilMoistureWilt(1)) * (-1.0) * DepthSoilLayer(1) ! available water (m) + do LoopInd = 2, NumSoilLayerRoot + SoilMoistAvail = SoilMoistAvail + (SoilLiqWater(LoopInd) - SoilMoistureWilt(LoopInd)) * & + (DepthSoilLayer(LoopInd-1) - DepthSoilLayer(LoopInd)) + SoilMoistAvailMax = SoilMoistAvailMax + (SoilMoistureFieldCap(LoopInd) - SoilMoistureWilt(LoopInd)) * & + (DepthSoilLayer(LoopInd-1) - DepthSoilLayer(LoopInd)) + enddo + + ! check if root zone soil moisture < SoilWatDeficitAllow (calibratable) + if ( (SoilMoistAvail/SoilMoistAvailMax) <= SoilWatDeficitAllow ) then + ! amount of water need to be added to bring soil moisture back to + ! field capacity, i.e., irrigation water amount (m) + IrrigationWater = (SoilMoistAvailMax - SoilMoistAvail) * IrrigationFracGrid * VegFrac + + ! sprinkler irrigation amount (m) based on 2D IrrigationFracSprinkler + if ( (IrrigationAmtSprinkler == 0.0) .and. (IrrigationFracSprinkler > 0.0) .and. (OptIrrigationMethod == 0) ) then + IrrigationAmtSprinkler = IrrigationFracSprinkler * IrrigationWater + IrrigationCntSprinkler = IrrigationCntSprinkler + 1 + ! sprinkler irrigation amount (m) based on namelist choice + elseif ( (IrrigationAmtSprinkler == 0.0) .and. (OptIrrigationMethod == 1) ) then + IrrigationAmtSprinkler = IrrigationWater + IrrigationCntSprinkler = IrrigationCntSprinkler + 1 + endif + + ! micro irrigation amount (m) based on 2D IrrigationFracMicro + if ( (IrrigationAmtMicro == 0.0) .and. (IrrigationFracMicro > 0.0) .and. (OptIrrigationMethod == 0) ) then + IrrigationAmtMicro = IrrigationFracMicro * IrrigationWater + IrrigationCntMicro = IrrigationCntMicro + 1 + ! micro irrigation amount (m) based on namelist choice + elseif ( (IrrigationAmtMicro == 0.0) .and. (OptIrrigationMethod == 2) ) then + IrrigationAmtMicro = IrrigationWater + IrrigationCntMicro = IrrigationCntMicro + 1 + endif + + ! flood irrigation amount (m): Assumed to saturate top two layers and + ! third layer to FC. As water moves from one end of the field to + ! another, surface layers will be saturated. + ! flood irrigation amount (m) based on 2D IrrigationFracFlood + if ( (IrrigationAmtFlood == 0.0) .and. (IrrigationFracFlood > 0.0) .and. (OptIrrigationMethod == 0) ) then + IrrigationAmtFlood = IrrigationFracFlood * IrrigationWater * (1.0/(1.0 - IrriFloodLossFrac)) + IrrigationCntFlood = IrrigationCntFlood + 1 + !flood irrigation amount (m) based on namelist choice + elseif ( (IrrigationAmtFlood == 0.0) .and. (OptIrrigationMethod == 3) ) then + IrrigationAmtFlood = IrrigationWater * (1.0/(1.0 - IrriFloodLossFrac)) + IrrigationCntFlood = IrrigationCntFlood + 1 + endif + else + IrrigationWater = 0.0 + IrrigationAmtSprinkler = 0.0 + IrrigationAmtMicro = 0.0 + IrrigationAmtFlood = 0.0 + endif + + endif + + end associate + + end subroutine IrrigationTrigger + +end module IrrigationTriggerMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/Makefile b/src/core_atmosphere/physics/physics_noahmp/src/Makefile new file mode 100644 index 0000000000..675bdf9dff --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/Makefile @@ -0,0 +1,351 @@ +.SUFFIXES: .F90 .o + +.PHONY: src src_lib + +# +# The Noah-MP code fails to build with the GNU compilers with -std=f2008, +# so remove that flag here if it is present in FFLAGS +# +FFLAGS_NONSTD = $(shell printf "%s" "$(FFLAGS)" | sed -e 's/-std=f2008//g' ) + +all: dummy src + +dummy: + echo "****** compiling physics_noahmp/utility ******" + +OBJS = ConstantDefineMod.o \ + ConfigVarType.o \ + ForcingVarType.o \ + EnergyVarType.o \ + WaterVarType.o \ + BiochemVarType.o \ + NoahmpVarType.o \ + ConfigVarInitMod.o \ + ForcingVarInitMod.o \ + EnergyVarInitMod.o \ + WaterVarInitMod.o \ + BiochemVarInitMod.o \ + CanopyHydrologyMod.o \ + GroundWaterTopModelMod.o \ + IrrigationFloodMod.o \ + IrrigationInfilPhilipMod.o \ + IrrigationMicroMod.o \ + MatrixSolverTriDiagonalMod.o \ + RunoffSubSurfaceDrainageMod.o \ + RunoffSubSurfaceEquiWaterTableMod.o \ + RunoffSubSurfaceGroundWaterMod.o \ + RunoffSubSurfaceShallowMmfMod.o \ + RunoffSurfaceBatsMod.o \ + RunoffSurfaceDynamicVicMod.o \ + RunoffSurfaceExcessDynamicVicMod.o \ + RunoffSurfaceFreeDrainMod.o \ + RunoffSurfaceTopModelEquiMod.o \ + RunoffSurfaceTopModelGrdMod.o \ + RunoffSurfaceTopModelMmfMod.o \ + RunoffSurfaceVicMod.o \ + RunoffSurfaceXinAnJiangMod.o \ + ShallowWaterTableMmfMod.o \ + SnowfallBelowCanopyMod.o \ + SnowLayerCombineMod.o \ + SnowLayerDivideMod.o \ + SnowLayerWaterComboMod.o \ + SnowpackCompactionMod.o \ + SnowpackHydrologyMod.o \ + SnowWaterMainMod.o \ + SoilHydraulicPropertyMod.o \ + SoilMoistureSolverMod.o \ + SoilWaterDiffusionRichardsMod.o \ + SoilWaterInfilGreenAmptMod.o \ + SoilWaterInfilPhilipMod.o \ + SoilWaterInfilSmithParlangeMod.o \ + SoilWaterMainMod.o \ + TileDrainageEquiDepthMod.o \ + TileDrainageHooghoudtMod.o \ + TileDrainageSimpleMod.o \ + WaterMainMod.o \ + WaterTableDepthSearchMod.o \ + WaterTableEquilibriumMod.o \ + IrrigationTriggerMod.o \ + IrrigationSprinklerMod.o \ + CanopyWaterInterceptMod.o \ + PrecipitationHeatAdvectMod.o \ + SnowThermalPropertyMod.o \ + SoilThermalPropertyMod.o \ + GroundThermalPropertyMod.o \ + EnergyMainMod.o \ + NoahmpMainMod.o \ + SnowAgingBatsMod.o \ + SnowAlbedoBatsMod.o \ + SnowAlbedoClassMod.o \ + GroundAlbedoMod.o \ + CanopyRadiationTwoStreamMod.o \ + SurfaceAlbedoMod.o \ + SurfaceRadiationMod.o \ + HumiditySaturationMod.o \ + ResistanceAboveCanopyChen97Mod.o \ + ResistanceAboveCanopyMostMod.o \ + ResistanceCanopyStomataBallBerryMod.o \ + ResistanceCanopyStomataJarvisMod.o \ + ResistanceLeafToGroundMod.o \ + VaporPressureSaturationMod.o \ + SurfaceEnergyFluxVegetatedMod.o \ + ResistanceBareGroundChen97Mod.o \ + ResistanceBareGroundMostMod.o \ + SurfaceEnergyFluxBareGroundMod.o \ + SoilSnowTemperatureMainMod.o \ + SoilSnowTemperatureSolverMod.o \ + SoilSnowThermalDiffusionMod.o \ + SoilSnowWaterPhaseChangeMod.o \ + SoilWaterSupercoolKoren99Mod.o \ + SoilWaterSupercoolNiu06Mod.o \ + SnowCoverGroundNiu07Mod.o \ + GroundRoughnessPropertyMod.o \ + SurfaceEmissivityMod.o \ + PsychrometricVariableMod.o \ + ResistanceGroundEvaporationMod.o \ + SoilWaterTranspirationMod.o \ + AtmosForcingMod.o \ + PhenologyMainMod.o \ + BiochemCropMainMod.o \ + BiochemNatureVegMainMod.o \ + CarbonFluxCropMod.o \ + CarbonFluxNatureVegMod.o \ + CropGrowDegreeDayMod.o \ + CropPhotosynthesisMod.o \ + IrrigationPrepareMod.o \ + BalanceErrorCheckMod.o \ + GeneralInitMod.o \ + BalanceErrorCheckGlacierMod.o \ + EnergyMainGlacierMod.o \ + GeneralInitGlacierMod.o \ + GlacierIceThermalPropertyMod.o \ + GlacierPhaseChangeMod.o \ + GlacierTemperatureMainMod.o \ + GlacierTemperatureSolverMod.o \ + GlacierThermalDiffusionMod.o \ + GroundAlbedoGlacierMod.o \ + GroundRoughnessPropertyGlacierMod.o \ + GroundThermalPropertyGlacierMod.o \ + NoahmpMainGlacierMod.o \ + PrecipitationHeatAdvectGlacierMod.o \ + PsychrometricVariableGlacierMod.o \ + ResistanceGroundEvaporationGlacierMod.o \ + SnowCoverGlacierMod.o \ + SnowWaterMainGlacierMod.o \ + SnowpackHydrologyGlacierMod.o \ + SurfaceAlbedoGlacierMod.o \ + SurfaceEmissivityGlacierMod.o \ + SurfaceEnergyFluxGlacierMod.o \ + SurfaceRadiationGlacierMod.o \ + WaterMainGlacierMod.o + +src: $(OBJS) + +src_lib: + ar -ru ./../../libphys.a $(OBJS) + +# DEPENDENCIES: + +ConstantDefineMod.o: ../utility/Machine.o +ConfigVarType.o: ../utility/Machine.o +ForcingVarType.o: ../utility/Machine.o +EnergyVarType.o: ../utility/Machine.o +WaterVarType.o: ../utility/Machine.o +BiochemVarType.o: ../utility/Machine.o +NoahmpVarType.o: ConfigVarType.o ForcingVarType.o EnergyVarType.o \ + WaterVarType.o BiochemVarType.o +ConfigVarInitMod.o: ../utility/Machine.o NoahmpVarType.o +ForcingVarInitMod.o: ../utility/Machine.o NoahmpVarType.o +EnergyVarInitMod.o: ../utility/Machine.o NoahmpVarType.o +WaterVarInitMod.o: ../utility/Machine.o NoahmpVarType.o +BiochemVarInitMod.o: ../utility/Machine.o NoahmpVarType.o +CanopyHydrologyMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +GroundWaterTopModelMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +IrrigationFloodMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + IrrigationInfilPhilipMod.o +IrrigationInfilPhilipMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + SoilHydraulicPropertyMod.o +IrrigationMicroMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + IrrigationInfilPhilipMod.o +MatrixSolverTriDiagonalMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +RunoffSubSurfaceDrainageMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +RunoffSubSurfaceEquiWaterTableMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + WaterTableEquilibriumMod.o +RunoffSubSurfaceGroundWaterMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + GroundWaterTopModelMod.o +RunoffSubSurfaceShallowMmfMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + ShallowWaterTableMmfMod.o +RunoffSurfaceBatsMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +RunoffSurfaceDynamicVicMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + SoilWaterInfilPhilipMod.o RunoffSurfaceExcessDynamicVicMod.o \ + SoilWaterInfilSmithParlangeMod.o SoilWaterInfilGreenAmptMod.o +RunoffSurfaceExcessDynamicVicMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +RunoffSurfaceFreeDrainMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + SoilHydraulicPropertyMod.o +RunoffSurfaceTopModelEquiMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +RunoffSurfaceTopModelGrdMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +RunoffSurfaceTopModelMmfMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +RunoffSurfaceVicMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +RunoffSurfaceXinAnJiangMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +ShallowWaterTableMmfMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +SnowfallBelowCanopyMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +SnowLayerCombineMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + SnowLayerWaterComboMod.o +SnowLayerDivideMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + SnowLayerWaterComboMod.o +SnowLayerWaterComboMod.o: ../utility/Machine.o ConstantDefineMod.o +SnowpackCompactionMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +SnowpackHydrologyMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + SnowLayerCombineMod.o +SnowWaterMainMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + SnowfallBelowCanopyMod.o SnowpackCompactionMod.o SnowLayerDivideMod.o \ + SnowLayerCombineMod.o SnowpackHydrologyMod.o +SoilHydraulicPropertyMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +SoilMoistureSolverMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + MatrixSolverTriDiagonalMod.o +SoilWaterDiffusionRichardsMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + SoilHydraulicPropertyMod.o +SoilWaterInfilGreenAmptMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + SoilHydraulicPropertyMod.o +SoilWaterInfilPhilipMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + SoilHydraulicPropertyMod.o +SoilWaterInfilSmithParlangeMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + SoilHydraulicPropertyMod.o +SoilWaterMainMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + RunoffSurfaceTopModelGrdMod.o RunoffSurfaceTopModelEquiMod.o \ + RunoffSurfaceFreeDrainMod.o RunoffSurfaceBatsMod.o \ + RunoffSurfaceTopModelMmfMod.o RunoffSurfaceVicMod.o \ + RunoffSurfaceXinAnJiangMod.o RunoffSurfaceDynamicVicMod.o \ + RunoffSubSurfaceEquiWaterTableMod.o RunoffSubSurfaceGroundWaterMod.o \ + RunoffSubSurfaceDrainageMod.o RunoffSubSurfaceShallowMmfMod.o \ + SoilWaterDiffusionRichardsMod.o SoilMoistureSolverMod.o \ + TileDrainageSimpleMod.o TileDrainageHooghoudtMod.o +TileDrainageEquiDepthMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +TileDrainageHooghoudtMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + TileDrainageEquiDepthMod.o WaterTableDepthSearchMod.o \ + WaterTableEquilibriumMod.o +TileDrainageSimpleMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +WaterMainMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + CanopyHydrologyMod.o SnowWaterMainMod.o IrrigationFloodMod.o \ + IrrigationMicroMod.o SoilWaterMainMod.o +WaterTableDepthSearchMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +WaterTableEquilibriumMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +IrrigationTriggerMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +IrrigationSprinklerMod.o: ../utility/Machine.o ../utility/CheckNanMod.o \ + NoahmpVarType.o ConstantDefineMod.o IrrigationInfilPhilipMod.o +CanopyWaterInterceptMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +PrecipitationHeatAdvectMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +SnowThermalPropertyMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +SoilThermalPropertyMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +GroundThermalPropertyMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + SnowThermalPropertyMod.o SoilThermalPropertyMod.o +CanopyRadiationTwoStreamMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +GroundAlbedoMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +SnowAgingBatsMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +SnowAlbedoBatsMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +SnowAlbedoClassMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +SurfaceAlbedoMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + SnowAgingBatsMod.o SnowAlbedoBatsMod.o SnowAlbedoClassMod.o \ + GroundAlbedoMod.o CanopyRadiationTwoStreamMod.o +SurfaceRadiationMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +EnergyMainMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + GroundThermalPropertyMod.o SurfaceEnergyFluxVegetatedMod.o \ + SurfaceEnergyFluxBareGroundMod.o SoilSnowTemperatureMainMod.o \ + SoilSnowWaterPhaseChangeMod.o SnowCoverGroundNiu07Mod.o SurfaceEmissivityMod.o \ + GroundRoughnessPropertyMod.o PsychrometricVariableMod.o ResistanceGroundEvaporationMod.o \ + SoilWaterTranspirationMod.o SurfaceAlbedoMod.o SurfaceRadiationMod.o +NoahmpMainMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + IrrigationPrepareMod.o IrrigationSprinklerMod.o CanopyWaterInterceptMod.o \ + PrecipitationHeatAdvectMod.o EnergyMainMod.o WaterMainMod.o AtmosForcingMod.o \ + BiochemCropMainMod.o BiochemNatureVegMainMod.o PhenologyMainMod.o BalanceErrorCheckMod.o \ + GeneralInitMod.o +HumiditySaturationMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +ResistanceAboveCanopyChen97Mod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +ResistanceAboveCanopyMostMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +ResistanceCanopyStomataBallBerryMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +ResistanceCanopyStomataJarvisMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + HumiditySaturationMod.o +ResistanceLeafToGroundMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +VaporPressureSaturationMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +SurfaceEnergyFluxVegetatedMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + VaporPressureSaturationMod.o ResistanceAboveCanopyMostMod.o \ + ResistanceAboveCanopyChen97Mod.o ResistanceLeafToGroundMod.o \ + ResistanceCanopyStomataBallBerryMod.o ResistanceCanopyStomataJarvisMod.o +ResistanceBareGroundChen97Mod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +ResistanceBareGroundMostMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +SurfaceEnergyFluxBareGroundMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + VaporPressureSaturationMod.o ResistanceBareGroundMostMod.o \ + ResistanceBareGroundChen97Mod.o +SoilSnowTemperatureSolverMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + MatrixSolverTriDiagonalMod.o +SoilSnowThermalDiffusionMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +SoilSnowTemperatureMainMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + SoilSnowTemperatureSolverMod.o SoilSnowThermalDiffusionMod.o +SoilWaterSupercoolKoren99Mod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +SoilWaterSupercoolNiu06Mod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +SoilSnowWaterPhaseChangeMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + SoilWaterSupercoolKoren99Mod.o SoilWaterSupercoolNiu06Mod.o +GroundRoughnessPropertyMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +PsychrometricVariableMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +ResistanceGroundEvaporationMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +SnowCoverGroundNiu07Mod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +SoilWaterTranspirationMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +SurfaceEmissivityMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +AtmosForcingMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +PhenologyMainMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +CropPhotosynthesisMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +CropGrowDegreeDayMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +CarbonFluxNatureVegMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +CarbonFluxCropMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +BiochemNatureVegMainMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o CarbonFluxNatureVegMod.o +BiochemCropMainMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o CarbonFluxCropMod.o \ + CropGrowDegreeDayMod.o CropPhotosynthesisMod.o +IrrigationPrepareMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o IrrigationTriggerMod.o +BalanceErrorCheckMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +GeneralInitMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +GroundWaterMmfMod.o: ../utility/Machine.o NoahmpVarType.o ../drivers/hrldas/NoahmpIOVarType.o +BalanceErrorCheckGlacierMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +EnergyMainGlacierMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o SnowCoverGlacierMod.o \ + GroundRoughnessPropertyGlacierMod.o GroundThermalPropertyGlacierMod.o \ + SurfaceAlbedoGlacierMod.o SurfaceRadiationGlacierMod.o SurfaceEmissivityGlacierMod.o \ + ResistanceGroundEvaporationGlacierMod.o PsychrometricVariableGlacierMod.o \ + SurfaceEnergyFluxGlacierMod.o GlacierTemperatureMainMod.o GlacierPhaseChangeMod.o +GeneralInitGlacierMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +GlacierIceThermalPropertyMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +GlacierPhaseChangeMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +GlacierTemperatureMainMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + GlacierTemperatureSolverMod.o GlacierThermalDiffusionMod.o +GlacierTemperatureSolverMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o MatrixSolverTriDiagonalMod.o +GlacierThermalDiffusionMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +GroundAlbedoGlacierMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +GroundRoughnessPropertyGlacierMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +GroundThermalPropertyGlacierMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + SnowThermalPropertyMod.o GlacierIceThermalPropertyMod.o +NoahmpMainGlacierMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o AtmosForcingMod.o \ + GeneralInitGlacierMod.o PrecipitationHeatAdvectGlacierMod.o EnergyMainGlacierMod.o \ + WaterMainGlacierMod.o BalanceErrorCheckGlacierMod.o +PrecipitationHeatAdvectGlacierMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +PsychrometricVariableGlacierMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +ResistanceGroundEvaporationGlacierMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +SnowCoverGlacierMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +SnowWaterMainGlacierMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o SnowfallBelowCanopyMod.o \ + SnowpackCompactionMod.o SnowLayerCombineMod.o SnowLayerDivideMod.o \ + SnowpackHydrologyGlacierMod.o +SnowpackHydrologyGlacierMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o SnowLayerCombineMod.o +SurfaceAlbedoGlacierMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o SnowAgingBatsMod.o \ + SnowAlbedoBatsMod.o SnowAlbedoClassMod.o GroundAlbedoGlacierMod.o +SurfaceEmissivityGlacierMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +SurfaceEnergyFluxGlacierMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + VaporPressureSaturationMod.o ResistanceBareGroundMostMod.o +SurfaceRadiationGlacierMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +WaterMainGlacierMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o SnowWaterMainGlacierMod.o + +clean: + $(RM) *.f90 *.o *.mod + @# Certain systems with intel compilers generate *.i files + @# This removes them during the clean process + $(RM) *.i + +.F90.o: + $(FC) $(CPPFLAGS) $(COREDEF) $(FFLAGS_NONSTD) -c $*.F90 $(CPPINCLUDES) $(FCINCLUDES) -I../utility -I../../../../framework + diff --git a/src/core_atmosphere/physics/physics_noahmp/src/MatrixSolverTriDiagonalMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/MatrixSolverTriDiagonalMod.F90 new file mode 100644 index 0000000000..b67a1faf45 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/MatrixSolverTriDiagonalMod.F90 @@ -0,0 +1,73 @@ +module MatrixSolverTriDiagonalMod + +!!! Solve tri-diagonal matrix problem + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine MatrixSolverTriDiagonal(P, A, B, C, D, Delta, IndTopLayer, NumSoilLayer, NumSnowLayerMax) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: ROSR12 +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- +! INVERT (SOLVE) THE TRI-DIAGONAL MATRIX PROBLEM SHOWN BELOW: +! ### ### ### ### ### ### +! #B(1), C(1), 0 , 0 , 0 , . . . , 0 # # # # # +! #A(2), B(2), C(2), 0 , 0 , . . . , 0 # # # # # +! # 0 , A(3), B(3), C(3), 0 , . . . , 0 # # # # D(3) # +! # 0 , 0 , A(4), B(4), C(4), . . . , 0 # # P(4) # # D(4) # +! # 0 , 0 , 0 , A(5), B(5), . . . , 0 # # P(5) # # D(5) # +! # . . # # . # = # . # +! # . . # # . # # . # +! # . . # # . # # . # +! # 0 , . . . , 0 , A(M-2), B(M-2), C(M-2), 0 # #P(M-2)# #D(M-2)# +! # 0 , . . . , 0 , 0 , A(M-1), B(M-1), C(M-1)# #P(M-1)# #D(M-1)# +! # 0 , . . . , 0 , 0 , 0 , A(M) , B(M) # # P(M) # # D(M) # +! ### ### ### ### ### ### +! ---------------------------------------------------------------------- + + implicit none + +! in & out variables + integer , intent(in) :: IndTopLayer ! top layer index: soil layer starts from IndTopLayer = 1 + integer , intent(in) :: NumSoilLayer ! number of soil layers + integer , intent(in) :: NumSnowLayerMax ! maximum number of snow layers + real(kind=kind_noahmp), dimension(-NumSnowLayerMax+1:NumSoilLayer), intent(in) :: A, B, D ! Tri-diagonal matrix elements + real(kind=kind_noahmp), dimension(-NumSnowLayerMax+1:NumSoilLayer), intent(inout) :: C,P,Delta ! Tri-diagonal matrix elements + +! local variables + integer :: K, KK ! loop indices +! ---------------------------------------------------------------------- + + ! INITIALIZE EQN COEF C FOR THE LOWEST SOIL LAYER + C (NumSoilLayer) = 0.0 + P (IndTopLayer) = - C (IndTopLayer) / B (IndTopLayer) + + ! SOLVE THE COEFS FOR THE 1ST SOIL LAYER + Delta (IndTopLayer) = D (IndTopLayer) / B (IndTopLayer) + + ! SOLVE THE COEFS FOR SOIL LAYERS 2 THRU NumSoilLayer + do K = IndTopLayer+1, NumSoilLayer + P (K) = - C (K) * ( 1.0 / (B (K) + A (K) * P (K -1)) ) + Delta (K) = (D (K) - A (K) * Delta (K -1)) * (1.0 / (B (K) + A (K) * P (K -1))) + enddo + + ! SET P TO Delta FOR LOWEST SOIL LAYER + P (NumSoilLayer) = Delta (NumSoilLayer) + + ! ADJUST P FOR SOIL LAYERS 2 THRU NumSoilLayer + do K = IndTopLayer+1, NumSoilLayer + KK = NumSoilLayer - K + (IndTopLayer-1) + 1 + P (KK) = P (KK) * P (KK +1) + Delta (KK) + enddo + + end subroutine MatrixSolverTriDiagonal + +end module MatrixSolverTriDiagonalMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/NoahmpMainGlacierMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/NoahmpMainGlacierMod.F90 new file mode 100644 index 0000000000..4fb104c67b --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/NoahmpMainGlacierMod.F90 @@ -0,0 +1,77 @@ +module NoahmpMainGlacierMod + +!!! Main NoahMP glacier module including all glacier processes +!!! atmos forcing -> precip heat advect -> main energy -> main water -> balance check + + use Machine + use NoahmpVarType + use ConstantDefineMod + use AtmosForcingMod, only : ProcessAtmosForcing + use GeneralInitGlacierMod, only : GeneralInitGlacier + use PrecipitationHeatAdvectGlacierMod, only : PrecipitationHeatAdvectGlacier + use EnergyMainGlacierMod, only : EnergyMainGlacier + use WaterMainGlacierMod, only : WaterMainGlacier + use BalanceErrorCheckGlacierMod, only : BalanceWaterInitGlacier, & + BalanceWaterCheckGlacier, BalanceEnergyCheckGlacier + + implicit none + +contains + + subroutine NoahmpMainGlacier(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: NOAHMP_SFLX +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + + !--------------------------------------------------------------------- + ! Atmospheric forcing processing + !--------------------------------------------------------------------- + + call ProcessAtmosForcing(noahmp) + + !--------------------------------------------------------------------- + ! General initialization to prepare key variables + !--------------------------------------------------------------------- + + call GeneralInitGlacier(noahmp) + + !--------------------------------------------------------------------- + ! Prepare for water balance check + !--------------------------------------------------------------------- + + call BalanceWaterInitGlacier(noahmp) + + !--------------------------------------------------------------------- + ! Energy processes + !--------------------------------------------------------------------- + + call PrecipitationHeatAdvectGlacier(noahmp) + call EnergyMainGlacier(noahmp) + + !--------------------------------------------------------------------- + ! Water processes + !--------------------------------------------------------------------- + + call WaterMainGlacier(noahmp) + + !--------------------------------------------------------------------- + ! Error check for energy and water balance + !--------------------------------------------------------------------- + + call BalanceWaterCheckGlacier(noahmp) + call BalanceEnergyCheckGlacier(noahmp) + + !--------------------------------------------------------------------- + ! End of all NoahMP glacier processes + !--------------------------------------------------------------------- + + end subroutine NoahmpMainGlacier + +end module NoahmpMainGlacierMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/NoahmpMainMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/NoahmpMainMod.F90 new file mode 100644 index 0000000000..c18beb2b71 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/NoahmpMainMod.F90 @@ -0,0 +1,131 @@ +module NoahmpMainMod + +!!! Main NoahMP module including all column model processes +!!! atmos forcing -> canopy intercept -> precip heat advect -> main energy -> main water -> main biogeochemistry -> balance check + + use Machine + use NoahmpVarType + use ConstantDefineMod + use AtmosForcingMod, only : ProcessAtmosForcing + use GeneralInitMod, only : GeneralInit + use PhenologyMainMod, only : PhenologyMain + use IrrigationPrepareMod, only : IrrigationPrepare + use IrrigationSprinklerMod, only : IrrigationSprinkler + use CanopyWaterInterceptMod, only : CanopyWaterIntercept + use PrecipitationHeatAdvectMod, only : PrecipitationHeatAdvect + use EnergyMainMod, only : EnergyMain + use WaterMainMod, only : WaterMain + use BiochemNatureVegMainMod, only : BiochemNatureVegMain + use BiochemCropMainMod, only : BiochemCropMain + use BalanceErrorCheckMod, only : BalanceWaterInit, BalanceWaterCheck, BalanceEnergyCheck + + implicit none + +contains + + subroutine NoahmpMain(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: NOAHMP_SFLX +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! -------------------------------------------------------------------- + associate( & + FlagDynamicVeg => noahmp%config%domain%FlagDynamicVeg ,& ! in, flag to activate dynamic vegetation model + FlagDynamicCrop => noahmp%config%domain%FlagDynamicCrop ,& ! in, flag to activate dynamic crop model + OptCropModel => noahmp%config%nmlist%OptCropModel ,& ! in, option for crop model + IrrigationAmtSprinkler => noahmp%water%state%IrrigationAmtSprinkler ,& ! inout, irrigation water amount [m] for sprinkler + FlagCropland => noahmp%config%domain%FlagCropland & ! out, flag to identify croplands + ) +! ---------------------------------------------------------------------- + + !--------------------------------------------------------------------- + ! Atmospheric forcing processing + !--------------------------------------------------------------------- + + call ProcessAtmosForcing(noahmp) + + !--------------------------------------------------------------------- + ! General initialization to prepare key variables + !--------------------------------------------------------------------- + + call GeneralInit(noahmp) + + !--------------------------------------------------------------------- + ! Prepare for water balance check + !--------------------------------------------------------------------- + + call BalanceWaterInit(noahmp) + + !--------------------------------------------------------------------- + ! Phenology + !--------------------------------------------------------------------- + + call PhenologyMain(noahmp) + + !--------------------------------------------------------------------- + ! Irrigation prepare including trigger + !--------------------------------------------------------------------- + + call IrrigationPrepare(noahmp) + + !--------------------------------------------------------------------- + ! Sprinkler irrigation + !--------------------------------------------------------------------- + + ! call sprinkler irrigation before canopy process to have canopy interception + if ( (FlagCropland .eqv. .true.) .and. (IrrigationAmtSprinkler > 0.0) ) & + call IrrigationSprinkler(noahmp) + + !--------------------------------------------------------------------- + ! Canopy water interception and precip heat advection + !--------------------------------------------------------------------- + + call CanopyWaterIntercept(noahmp) + call PrecipitationHeatAdvect(noahmp) + + !--------------------------------------------------------------------- + ! Energy processes + !--------------------------------------------------------------------- + + call EnergyMain(noahmp) + + !--------------------------------------------------------------------- + ! Water processes + !--------------------------------------------------------------------- + + call WaterMain(noahmp) + + !--------------------------------------------------------------------- + ! Biochem processes (crop and carbon) + !--------------------------------------------------------------------- + + ! for generic vegetation + if ( FlagDynamicVeg .eqv. .true. ) call BiochemNatureVegMain(noahmp) + + ! for explicit crop treatment + if ( (OptCropModel == 1) .and. (FlagDynamicCrop .eqv. .true.) ) & + call BiochemCropMain(noahmp) + + !--------------------------------------------------------------------- + ! Error check for energy and water balance + !--------------------------------------------------------------------- + + call BalanceWaterCheck(noahmp) + call BalanceEnergyCheck(noahmp) + + !--------------------------------------------------------------------- + ! End of all NoahMP column processes + !--------------------------------------------------------------------- + + end associate + + end subroutine NoahmpMain + +end module NoahmpMainMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/NoahmpVarType.F90 b/src/core_atmosphere/physics/physics_noahmp/src/NoahmpVarType.F90 new file mode 100644 index 0000000000..e53501117a --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/NoahmpVarType.F90 @@ -0,0 +1,31 @@ +module NoahmpVarType + +!!! Define column (1-D) Noah-MP model variable data types + +! ------------------------ Code history ----------------------------------- +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + use ForcingVarType + use ConfigVarType + use EnergyVarType + use WaterVarType + use BiochemVarType + + implicit none + save + private + + type, public :: noahmp_type + + ! define specific variable types for Noah-MP + type(forcing_type) :: forcing + type(config_type) :: config + type(energy_type) :: energy + type(water_type) :: water + type(biochem_type) :: biochem + + end type noahmp_type + +end module NoahmpVarType diff --git a/src/core_atmosphere/physics/physics_noahmp/src/PhenologyMainMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/PhenologyMainMod.F90 new file mode 100644 index 0000000000..e23193500f --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/PhenologyMainMod.F90 @@ -0,0 +1,169 @@ +module PhenologyMainMod + +!!! Main Phenology module to estimate vegetation phenology +!!! considering vegeation canopy being buries by snow and evolution in time + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine PhenologyMain (noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: PHENOLOGY +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variables + integer :: IntpMonth1,IntpMonth2 ! interpolation months + real(kind=kind_noahmp) :: ThicknessCanBury ! thickness of canopy buried by snow [m] + real(kind=kind_noahmp) :: SnowDepthVegBury ! critical snow depth at which short vege is fully covered by snow + real(kind=kind_noahmp) :: DayCurrent ! current day of year (0<=DayCurrent noahmp%config%nmlist%OptDynamicVeg ,& ! in, dynamic vegetation option + OptCropModel => noahmp%config%nmlist%OptCropModel ,& ! in, crop model option + VegType => noahmp%config%domain%VegType ,& ! in, vegetation type + CropType => noahmp%config%domain%CropType ,& ! in, crop type + IndexIcePoint => noahmp%config%domain%IndexIcePoint ,& ! in, land ice flag + IndexBarrenPoint => noahmp%config%domain%IndexBarrenPoint ,& ! in, bare soil flag + IndexWaterPoint => noahmp%config%domain%IndexWaterPoint ,& ! in, water point flag + FlagUrban => noahmp%config%domain%FlagUrban ,& ! in, urban point flag + FlagDynamicVeg => noahmp%config%domain%FlagDynamicVeg ,& ! in, flag to activate dynamic vegetation model + FlagDynamicCrop => noahmp%config%domain%FlagDynamicCrop ,& ! in, flag to activate dynamic crop model + Latitude => noahmp%config%domain%Latitude ,& ! in, latitude [deg] + NumDayInYear => noahmp%config%domain%NumDayInYear ,& ! in, Number of days in the particular year + DayJulianInYear => noahmp%config%domain%DayJulianInYear ,& ! in, Julian day of year + HeightCanopyTop => noahmp%energy%param%HeightCanopyTop ,& ! in, top of canopy [m] + HeightCanopyBot => noahmp%energy%param%HeightCanopyBot ,& ! in, bottom of canopy [m] + LeafAreaIndexMon => noahmp%energy%param%LeafAreaIndexMon ,& ! in, monthly leaf area index, one-sided + StemAreaIndexMon => noahmp%energy%param%StemAreaIndexMon ,& ! in, monthly stem area index, one-sided + VegFracAnnMax => noahmp%energy%param%VegFracAnnMax ,& ! in, annual maximum vegetation fraction + VegFracGreen => noahmp%energy%param%VegFracGreen ,& ! in, green vegetation fraction + TemperatureMinPhotosyn => noahmp%biochem%param%TemperatureMinPhotosyn ,& ! in, minimum temperature for photosynthesis [K] + PlantGrowStage => noahmp%biochem%state%PlantGrowStage ,& ! in, plant growing stage + SnowDepth => noahmp%water%state%SnowDepth ,& ! in, snow depth [m] + TemperatureCanopy => noahmp%energy%state%TemperatureCanopy ,& ! in, vegetation temperature [K] + LeafAreaIndex => noahmp%energy%state%LeafAreaIndex ,& ! inout, LeafAreaIndex, unadjusted for burying by snow + StemAreaIndex => noahmp%energy%state%StemAreaIndex ,& ! inout, StemAreaIndex, unadjusted for burying by snow + LeafAreaIndEff => noahmp%energy%state%LeafAreaIndEff ,& ! out, leaf area index, after burying by snow + StemAreaIndEff => noahmp%energy%state%StemAreaIndEff ,& ! out, stem area index, after burying by snow + VegFrac => noahmp%energy%state%VegFrac ,& ! out, green vegetation fraction + CanopyFracSnowBury => noahmp%energy%state%CanopyFracSnowBury ,& ! out, fraction of canopy buried by snow + IndexGrowSeason => noahmp%biochem%state%IndexGrowSeason & ! out, growing season index (0=off, 1=on) + ) +!---------------------------------------------------------------------- + + ! compute LeafAreaIndex based on dynamic vegetation option + if ( CropType == 0 ) then + + ! no dynamic vegetation, use table LeafAreaIndex + if ( (OptDynamicVeg == 1) .or. (OptDynamicVeg == 3) .or. (OptDynamicVeg == 4) ) then + if ( Latitude >= 0.0 ) then + ! Northern Hemisphere + DayCurrent = DayJulianInYear + else + ! Southern Hemisphere. DayCurrent is shifted by 1/2 year. + DayCurrent = mod(DayJulianInYear+(0.5*NumDayInYear), real(NumDayInYear)) + endif + ! interpolate from monthly data to target time point + MonthCurrent = 12.0 * DayCurrent / real(NumDayInYear) + IntpMonth1 = MonthCurrent + 0.5 + IntpMonth2 = IntpMonth1 + 1 + IntpWgt1 = (IntpMonth1 + 0.5) - MonthCurrent + IntpWgt2 = 1.0 - IntpWgt1 + if ( IntpMonth1 < 1 ) IntpMonth1 = 12 + if ( IntpMonth2 > 12 ) IntpMonth2 = 1 + LeafAreaIndex = IntpWgt1 * LeafAreaIndexMon(IntpMonth1) + IntpWgt2 * LeafAreaIndexMon(IntpMonth2) + StemAreaIndex = IntpWgt1 * StemAreaIndexMon(IntpMonth1) + IntpWgt2 * StemAreaIndexMon(IntpMonth2) + endif + + ! no dynamic vegetation, use input LeafAreaIndex time series + if ( (OptDynamicVeg == 7) .or. (OptDynamicVeg == 8) .or. (OptDynamicVeg == 9) ) then + StemAreaIndex = max(0.05, 0.1*LeafAreaIndex) ! set StemAreaIndex to 10% LeafAreaIndex, but not below 0.05 MB: v3.8 + if ( LeafAreaIndex < 0.05 ) StemAreaIndex = 0.0 ! if LeafAreaIndex below minimum, make sure StemAreaIndex = 0 + endif + if ( StemAreaIndex < 0.05 ) StemAreaIndex = 0.0 ! MB: StemAreaIndex CHECK, change to 0.05 v3.6 + if ( (LeafAreaIndex < 0.05) .or. (StemAreaIndex == 0.0) ) LeafAreaIndex = 0.0 ! MB: LeafAreaIndex CHECK + + ! for non-vegetation point + if ( (VegType == IndexWaterPoint) .or. (VegType == IndexBarrenPoint) .or. & + (VegType == IndexIcePoint ) .or. (FlagUrban .eqv. .true.) ) then + LeafAreaIndex = 0.0 + StemAreaIndex = 0.0 + endif + + endif ! CropType == 0 + + ! vegetation fraction buried by snow + ThicknessCanBury = min(max(SnowDepth-HeightCanopyBot,0.0), (HeightCanopyTop-HeightCanopyBot)) + CanopyFracSnowBury = ThicknessCanBury / max(1.0e-06, (HeightCanopyTop-HeightCanopyBot)) ! snow buried fraction + if ( (HeightCanopyTop > 0.0) .and. (HeightCanopyTop <= 1.0) ) then ! MB: change to 1.0 & 0.2 to reflect changes to HeightCanopyTop in MPTABLE + SnowDepthVegBury = HeightCanopyTop * exp(-SnowDepth / 0.2) + CanopyFracSnowBury = min(SnowDepth, SnowDepthVegBury) / SnowDepthVegBury + endif + + ! adjust LeafAreaIndex and StemAreaIndex bused on snow bury + LeafAreaIndEff = LeafAreaIndex * (1.0 - CanopyFracSnowBury) + StemAreaIndEff = StemAreaIndex * (1.0 - CanopyFracSnowBury) + if ( (StemAreaIndEff < 0.05) .and. (CropType == 0) ) StemAreaIndEff = 0.0 ! MB: StemAreaIndEff CHECK, change to 0.05 v3.6 + if ( ((LeafAreaIndEff < 0.05) .or. (StemAreaIndEff == 0.0)) .and. (CropType == 0) ) & + LeafAreaIndEff = 0.0 ! MB: LeafAreaIndex CHECK + + ! set growing season flag + if ( ((TemperatureCanopy > TemperatureMinPhotosyn) .and. (CropType == 0)) .or. & + ((PlantGrowStage > 2) .and. (PlantGrowStage < 7) .and. (CropType > 0))) then + IndexGrowSeason = 1.0 + else + IndexGrowSeason = 0.0 + endif + + ! compute vegetation fraction + ! input green vegetation fraction should be consistent with LeafAreaIndex + if ( (OptDynamicVeg == 1) .or. (OptDynamicVeg == 6) .or. (OptDynamicVeg == 7) ) then ! use VegFrac = VegFracGreen from input + VegFrac = VegFracGreen + elseif ( (OptDynamicVeg == 2) .or. (OptDynamicVeg == 3) .or. (OptDynamicVeg == 8) ) then ! computed VegFrac from LeafAreaIndex & StemAreaIndex + VegFrac = 1.0 - exp(-0.52 * (LeafAreaIndex + StemAreaIndex)) + elseif ( (OptDynamicVeg == 4) .or. (OptDynamicVeg == 5) .or. (OptDynamicVeg == 9) ) then ! use yearly maximum vegetation fraction + VegFrac = VegFracAnnMax + else ! outside existing vegetation options + write(*,*) "Un-recognized dynamic vegetation option (OptDynamicVeg)... " + stop "Error: Namelist parameter OptDynamicVeg unknown" + endif + ! use maximum vegetation fraction for crop run + if ( (OptCropModel > 0) .and. (CropType > 0) ) then + VegFrac = VegFracAnnMax + endif + + ! adjust unreasonable vegetation fraction + if ( VegFrac <= 0.05 ) VegFrac = 0.05 + if ( (FlagUrban .eqv. .true.) .or. (VegType == IndexBarrenPoint) ) VegFrac = 0.0 + if ( (LeafAreaIndEff+StemAreaIndEff) == 0.0 ) VegFrac = 0.0 + + ! determine if activate dynamic vegetation or crop run + FlagDynamicCrop = .false. + FlagDynamicVeg = .false. + if ( (OptDynamicVeg == 2) .or. (OptDynamicVeg == 5) .or. (OptDynamicVeg == 6) ) & + FlagDynamicVeg = .true. + if ( (OptCropModel > 0) .and. (CropType > 0) ) then + FlagDynamicCrop = .true. + FlagDynamicVeg = .false. + endif + + end associate + + end subroutine PhenologyMain + +end module PhenologyMainMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/PrecipitationHeatAdvectGlacierMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/PrecipitationHeatAdvectGlacierMod.F90 new file mode 100644 index 0000000000..cf0611e742 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/PrecipitationHeatAdvectGlacierMod.F90 @@ -0,0 +1,64 @@ +module PrecipitationHeatAdvectGlacierMod + +!!! Estimate heat flux advected from precipitation to glacier ground + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine PrecipitationHeatAdvectGlacier(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: none (adapted from PRECIP_HEAT) +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + real(kind=kind_noahmp) :: HeatPrcpAirToGrd ! precipitation advected heat - air to ground [W/m2] + +! -------------------------------------------------------------------- + associate( & + TemperatureAirRefHeight => noahmp%forcing%TemperatureAirRefHeight ,& ! in, air temperature [K] at reference height + TemperatureGrd => noahmp%energy%state%TemperatureGrd ,& ! in, ground temperature [K] + RainfallRefHeight => noahmp%water%flux%RainfallRefHeight ,& ! in, total liquid rainfall [mm/s] before interception + SnowfallRefHeight => noahmp%water%flux%SnowfallRefHeight ,& ! in, total snowfall [mm/s] before interception + SnowfallGround => noahmp%water%flux%SnowfallGround ,& ! out, snowfall at ground surface [mm/s] + RainfallGround => noahmp%water%flux%RainfallGround ,& ! out, rainfall at ground surface [mm/s] + HeatPrecipAdvBareGrd => noahmp%energy%flux%HeatPrecipAdvBareGrd & ! out, precipitation advected heat - bare ground net [W/m2] + ) +! ---------------------------------------------------------------------- + + ! initialization + HeatPrcpAirToGrd = 0.0 + HeatPrecipAdvBareGrd = 0.0 + RainfallGround = RainfallRefHeight + SnowfallGround = SnowfallRefHeight + + ! Heat advection for liquid rainfall + HeatPrcpAirToGrd = RainfallGround * (ConstHeatCapacWater/1000.0) * (TemperatureAirRefHeight - TemperatureGrd) + + ! Heat advection for snowfall + HeatPrcpAirToGrd = HeatPrcpAirToGrd + & + SnowfallGround * (ConstHeatCapacIce/1000.0) * (TemperatureAirRefHeight - TemperatureGrd) + + ! net heat advection + HeatPrecipAdvBareGrd = HeatPrcpAirToGrd + + ! Put some artificial limits here for stability + HeatPrecipAdvBareGrd = max(HeatPrecipAdvBareGrd, -20.0) + HeatPrecipAdvBareGrd = min(HeatPrecipAdvBareGrd, 20.0) + + end associate + + end subroutine PrecipitationHeatAdvectGlacier + +end module PrecipitationHeatAdvectGlacierMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/PrecipitationHeatAdvectMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/PrecipitationHeatAdvectMod.F90 new file mode 100644 index 0000000000..e10f9cac19 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/PrecipitationHeatAdvectMod.F90 @@ -0,0 +1,99 @@ +module PrecipitationHeatAdvectMod + +!!! Estimate heat flux advected from precipitation to vegetation and ground + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine PrecipitationHeatAdvect(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: PRECIP_HEAT +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! The water and heat portions of PRECIP_HEAT are separated in refactored code +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + real(kind=kind_noahmp) :: HeatPrcpAirToCan ! precipitation advected heat - air to canopy [W/m2] + real(kind=kind_noahmp) :: HeatPrcpCanToGrd ! precipitation advected heat - canopy to ground [W/m2] + real(kind=kind_noahmp) :: HeatPrcpAirToGrd ! precipitation advected heat - air to ground [W/m2] + +! -------------------------------------------------------------------- + associate( & + TemperatureAirRefHeight => noahmp%forcing%TemperatureAirRefHeight ,& ! in, air temperature [K] at reference height + TemperatureCanopy => noahmp%energy%state%TemperatureCanopy ,& ! in, vegetation temperature [K] + TemperatureGrd => noahmp%energy%state%TemperatureGrd ,& ! in, ground temperature [K] + VegFrac => noahmp%energy%state%VegFrac ,& ! in, greeness vegetation fraction + RainfallRefHeight => noahmp%water%flux%RainfallRefHeight ,& ! in, total liquid rainfall [mm/s] before interception + SnowfallRefHeight => noahmp%water%flux%SnowfallRefHeight ,& ! in, total snowfall [mm/s] before interception + DripCanopyRain => noahmp%water%flux%DripCanopyRain ,& ! in, drip rate for intercepted rain [mm/s] + ThroughfallRain => noahmp%water%flux%ThroughfallRain ,& ! in, throughfall for rain [mm/s] + DripCanopySnow => noahmp%water%flux%DripCanopySnow ,& ! in, drip (unloading) rate for intercepted snow [mm/s] + ThroughfallSnow => noahmp%water%flux%ThroughfallSnow ,& ! in, throughfall of snowfall [mm/s] + HeatPrecipAdvCanopy => noahmp%energy%flux%HeatPrecipAdvCanopy ,& ! out, precipitation advected heat - vegetation net [W/m2] + HeatPrecipAdvVegGrd => noahmp%energy%flux%HeatPrecipAdvVegGrd ,& ! out, precipitation advected heat - under canopy net [W/m2] + HeatPrecipAdvBareGrd => noahmp%energy%flux%HeatPrecipAdvBareGrd & ! out, precipitation advected heat - bare ground net [W/m2] + ) +! ---------------------------------------------------------------------- + + ! initialization + HeatPrcpAirToCan = 0.0 + HeatPrcpCanToGrd = 0.0 + HeatPrcpAirToGrd = 0.0 + HeatPrecipAdvCanopy = 0.0 + HeatPrecipAdvVegGrd = 0.0 + HeatPrecipAdvBareGrd = 0.0 + + ! Heat advection for liquid rainfall + HeatPrcpAirToCan = VegFrac * RainfallRefHeight * (ConstHeatCapacWater/1000.0) * (TemperatureAirRefHeight-TemperatureCanopy) + HeatPrcpCanToGrd = DripCanopyRain * (ConstHeatCapacWater/1000.0) * (TemperatureCanopy-TemperatureGrd) + HeatPrcpAirToGrd = ThroughfallRain * (ConstHeatCapacWater/1000.0) * (TemperatureAirRefHeight-TemperatureGrd) + + ! Heat advection for snowfall + HeatPrcpAirToCan = HeatPrcpAirToCan + & + VegFrac * SnowfallRefHeight * (ConstHeatCapacIce/1000.0) * (TemperatureAirRefHeight-TemperatureCanopy) + HeatPrcpCanToGrd = HeatPrcpCanToGrd + & + DripCanopySnow * (ConstHeatCapacIce/1000.0) * (TemperatureCanopy-TemperatureGrd) + HeatPrcpAirToGrd = HeatPrcpAirToGrd + & + ThroughfallSnow * (ConstHeatCapacIce/1000.0) * (TemperatureAirRefHeight-TemperatureGrd) + + ! net heat advection + HeatPrecipAdvCanopy = HeatPrcpAirToCan - HeatPrcpCanToGrd + HeatPrecipAdvVegGrd = HeatPrcpCanToGrd + HeatPrecipAdvBareGrd = HeatPrcpAirToGrd + + ! adjust for VegFrac + if ( (VegFrac > 0.0) .and. (VegFrac < 1.0) ) then + HeatPrecipAdvVegGrd = HeatPrecipAdvVegGrd / VegFrac ! these will be multiplied by fraction later + HeatPrecipAdvBareGrd = HeatPrecipAdvBareGrd / (1.0-VegFrac) + elseif ( VegFrac <= 0.0 ) then + HeatPrecipAdvBareGrd = HeatPrecipAdvVegGrd + HeatPrecipAdvBareGrd ! for case of canopy getting buried + HeatPrecipAdvVegGrd = 0.0 + HeatPrecipAdvCanopy = 0.0 + elseif ( VegFrac >= 1.0 ) then + HeatPrecipAdvBareGrd = 0.0 + endif + + ! Put some artificial limits here for stability + HeatPrecipAdvCanopy = max(HeatPrecipAdvCanopy , -20.0) + HeatPrecipAdvCanopy = min(HeatPrecipAdvCanopy , 20.0) + HeatPrecipAdvVegGrd = max(HeatPrecipAdvVegGrd , -20.0) + HeatPrecipAdvVegGrd = min(HeatPrecipAdvVegGrd , 20.0) + HeatPrecipAdvBareGrd = max(HeatPrecipAdvBareGrd, -20.0) + HeatPrecipAdvBareGrd = min(HeatPrecipAdvBareGrd, 20.0) + + end associate + + end subroutine PrecipitationHeatAdvect + +end module PrecipitationHeatAdvectMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/PsychrometricVariableGlacierMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/PsychrometricVariableGlacierMod.F90 new file mode 100644 index 0000000000..9d645bab4f --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/PsychrometricVariableGlacierMod.F90 @@ -0,0 +1,40 @@ +module PsychrometricVariableGlacierMod + +!!! Compute psychrometric variables for glacier ground + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine PsychrometricVariableGlacier(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: None (embedded in ENERGY_GLACIER subroutine) +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! -------------------------------------------------------------------- + associate( & + PressureAirRefHeight => noahmp%forcing%PressureAirRefHeight ,& ! in, air pressure [Pa] at reference height + LatHeatVapGrd => noahmp%energy%state%LatHeatVapGrd ,& ! out, latent heat of vaporization/subli [J/kg], ground + PsychConstGrd => noahmp%energy%state%PsychConstGrd & ! out, psychrometric constant [Pa/K], ground + ) +! ---------------------------------------------------------------------- + + LatHeatVapGrd = ConstLatHeatSublim + PsychConstGrd = ConstHeatCapacAir * PressureAirRefHeight / (0.622 * LatHeatVapGrd) + + end associate + + end subroutine PsychrometricVariableGlacier + +end module PsychrometricVariableGlacierMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/PsychrometricVariableMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/PsychrometricVariableMod.F90 new file mode 100644 index 0000000000..66ac20ae98 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/PsychrometricVariableMod.F90 @@ -0,0 +1,63 @@ +module PsychrometricVariableMod + +!!! Compute psychrometric variables for canopy and ground + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine PsychrometricVariable(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: None (embedded in ENERGY subroutine) +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! -------------------------------------------------------------------- + associate( & + PressureAirRefHeight => noahmp%forcing%PressureAirRefHeight ,& ! in, air pressure [Pa] at reference height + TemperatureCanopy => noahmp%energy%state%TemperatureCanopy ,& ! in, vegetation temperature [K] + TemperatureGrd => noahmp%energy%state%TemperatureGrd ,& ! in, ground temperature [K] + LatHeatVapCanopy => noahmp%energy%state%LatHeatVapCanopy ,& ! out, latent heat of vaporization/subli [J/kg], canopy + LatHeatVapGrd => noahmp%energy%state%LatHeatVapGrd ,& ! out, latent heat of vaporization/subli [J/kg], ground + FlagFrozenCanopy => noahmp%energy%state%FlagFrozenCanopy ,& ! out, used to define latent heat pathway + FlagFrozenGround => noahmp%energy%state%FlagFrozenGround ,& ! out, frozen ground (logical) to define latent heat pathway + PsychConstCanopy => noahmp%energy%state%PsychConstCanopy ,& ! out, psychrometric constant [Pa/K], canopy + PsychConstGrd => noahmp%energy%state%PsychConstGrd & ! out, psychrometric constant [Pa/K], ground + ) +! ---------------------------------------------------------------------- + + ! for canopy ! Barlage: add distinction between ground and vegetation in v3.6 + if ( TemperatureCanopy > ConstFreezePoint ) then + LatHeatVapCanopy = ConstLatHeatEvap + FlagFrozenCanopy = .false. + else + LatHeatVapCanopy = ConstLatHeatSublim + FlagFrozenCanopy = .true. + endif + PsychConstCanopy = ConstHeatCapacAir * PressureAirRefHeight / (0.622*LatHeatVapCanopy) + + ! for ground + if ( TemperatureGrd > ConstFreezePoint ) then + LatHeatVapGrd = ConstLatHeatEvap + FlagFrozenGround = .false. + else + LatHeatVapGrd = ConstLatHeatSublim + FlagFrozenGround = .true. + endif + PsychConstGrd = ConstHeatCapacAir * PressureAirRefHeight / (0.622*LatHeatVapGrd) + + end associate + + end subroutine PsychrometricVariable + +end module PsychrometricVariableMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/ResistanceAboveCanopyChen97Mod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/ResistanceAboveCanopyChen97Mod.F90 new file mode 100644 index 0000000000..1020acb2ac --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/ResistanceAboveCanopyChen97Mod.F90 @@ -0,0 +1,209 @@ +module ResistanceAboveCanopyChen97Mod + +!!! Compute surface resistance and exchange coefficient for momentum and heat +!!! based on Chen et al. (1997, BLM) +!!! This scheme can handle both over open water and over solid surface + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine ResistanceAboveCanopyChen97(noahmp, IterationInd) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: SFCDIF2 for vegetated portion +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + integer , intent(in ) :: IterationInd ! iteration index + type(noahmp_type) , intent(inout) :: noahmp + +! local variables + integer :: ILECH, ITR + real(kind=kind_noahmp) :: ZZ, PSLMU, PSLMS, PSLHU, PSLHS + real(kind=kind_noahmp) :: XX, PSPMU, YY, PSPMS, PSPHU, PSPHS + real(kind=kind_noahmp) :: ZILFC, ZU, ZT, RDZ, CXCH, DTHV, DU2 + real(kind=kind_noahmp) :: BTGH, ZSLU, ZSLT, RLOGU, RLOGT, RLMA + real(kind=kind_noahmp) :: ZETALT, ZETALU, ZETAU, ZETAT, XLU4 + real(kind=kind_noahmp) :: XLT4, XU4, XT4, XLU, XLT, XU, XT + real(kind=kind_noahmp) :: PSMZ, SIMM, PSHZ, SIMH, USTARK, RLMN +! local parameters + integer , parameter :: ITRMX = 5 + real(kind=kind_noahmp), parameter :: WWST = 1.2 + real(kind=kind_noahmp), parameter :: WWST2 = WWST * WWST + real(kind=kind_noahmp), parameter :: VKRM = 0.40 + real(kind=kind_noahmp), parameter :: EXCM = 0.001 + real(kind=kind_noahmp), parameter :: BETA = 1.0 / 270.0 + real(kind=kind_noahmp), parameter :: BTG = BETA * ConstGravityAcc + real(kind=kind_noahmp), parameter :: ELFC = VKRM * BTG + real(kind=kind_noahmp), parameter :: WOLD = 0.15 + real(kind=kind_noahmp), parameter :: WNEW = 1.0 - WOLD + real(kind=kind_noahmp), parameter :: PIHF = 3.14159265 / 2.0 + real(kind=kind_noahmp), parameter :: EPSU2 = 1.0e-4 + real(kind=kind_noahmp), parameter :: EPSUST = 0.07 + real(kind=kind_noahmp), parameter :: EPSIT = 1.0e-4 + real(kind=kind_noahmp), parameter :: EPSA = 1.0e-8 + real(kind=kind_noahmp), parameter :: ZTMIN = -5.0 + real(kind=kind_noahmp), parameter :: ZTMAX = 1.0 + real(kind=kind_noahmp), parameter :: HPBL = 1000.0 + real(kind=kind_noahmp), parameter :: SQVISC = 258.2 + real(kind=kind_noahmp), parameter :: RIC = 0.183 + real(kind=kind_noahmp), parameter :: RRIC = 1.0 / RIC + real(kind=kind_noahmp), parameter :: FHNEU = 0.8 + real(kind=kind_noahmp), parameter :: RFC = 0.191 + real(kind=kind_noahmp), parameter :: RFAC = RIC / ( FHNEU * RFC * RFC ) +! local statement functions + ! LECH'S surface functions + PSLMU(ZZ) = -0.96 * log(1.0 - 4.5 * ZZ) + PSLMS(ZZ) = ZZ * RRIC - 2.076 * (1.0 - 1.0/(ZZ + 1.0)) + PSLHU(ZZ) = -0.96 * log(1.0 - 4.5 * ZZ) + PSLHS(ZZ) = ZZ * RFAC - 2.076 * (1.0 - 1.0/(ZZ + 1.0)) + ! PAULSON'S surface functions + PSPMU(XX) = -2.0*log( (XX+1.0)*0.5 ) - log( (XX*XX+1.0)*0.5 ) + 2.0*atan(XX) - PIHF + PSPMS(YY) = 5.0 * YY + PSPHU(XX) = -2.0 * log( (XX*XX + 1.0)*0.5 ) + PSPHS(YY) = 5.0 * YY + +! -------------------------------------------------------------------- + associate( & + ZilitinkevichCoeff => noahmp%energy%param%ZilitinkevichCoeff ,& ! in, Calculate roughness length of heat + RefHeightAboveGrd => noahmp%energy%state%RefHeightAboveGrd ,& ! in, reference height [m] above ground + TemperaturePotRefHeight => noahmp%energy%state%TemperaturePotRefHeight ,& ! in, potential temp at reference height [K] + WindSpdRefHeight => noahmp%energy%state%WindSpdRefHeight ,& ! in, wind speed [m/s] at reference height + RoughLenMomSfc => noahmp%energy%state%RoughLenMomSfc ,& ! in, roughness length [m], momentum, surface + TemperatureCanopyAir => noahmp%energy%state%TemperatureCanopyAir ,& ! in, canopy air temperature [K] + ExchCoeffMomAbvCan => noahmp%energy%state%ExchCoeffMomAbvCan ,& ! inout, exchange coeff [m/s] for momentum, above ZeroPlaneDisp, vegetated + ExchCoeffShAbvCan => noahmp%energy%state%ExchCoeffShAbvCan ,& ! inout, exchange coeff [m/s] for heat, above ZeroPlaneDisp, vegetated + MoStabParaAbvCan => noahmp%energy%state%MoStabParaAbvCan ,& ! inout, Monin-Obukhov stability (z/L), above ZeroPlaneDisp, vegetated + FrictionVelVertVeg => noahmp%energy%state%FrictionVelVertVeg ,& ! inout, friction velocity [m/s] in vertical direction, vegetated + FrictionVelVeg => noahmp%energy%state%FrictionVelVeg ,& ! inout, friction velocity [m/s], vegetated + ResistanceMomAbvCan => noahmp%energy%state%ResistanceMomAbvCan ,& ! out, aerodynamic resistance for momentum [s/m], above canopy + ResistanceShAbvCan => noahmp%energy%state%ResistanceShAbvCan ,& ! out, aerodynamic resistance for sensible heat [s/m], above canopy + ResistanceLhAbvCan => noahmp%energy%state%ResistanceLhAbvCan & ! out, aerodynamic resistance for water vapor [s/m], above canopy + ) +! ---------------------------------------------------------------------- + + ! ZTFC: RATIO OF ZOH/ZOM LESS OR EQUAL THAN 1 + ! C......ZTFC=0.1 + ! ZilitinkevichCoeff: CONSTANT C IN Zilitinkevich, S. S.1995,:NOTE ABOUT ZT + ILECH = 0 + ZILFC = -ZilitinkevichCoeff * VKRM * SQVISC + ZU = RoughLenMomSfc + RDZ = 1.0 / RefHeightAboveGrd + CXCH = EXCM * RDZ + DTHV = TemperaturePotRefHeight - TemperatureCanopyAir + + ! BELJARS correction of friction velocity u* + DU2 = max(WindSpdRefHeight*WindSpdRefHeight, EPSU2) + BTGH = BTG * HPBL + if ( IterationInd == 1 ) then + if ( (BTGH*ExchCoeffShAbvCan*DTHV) /= 0.0 ) then + FrictionVelVertVeg = WWST2 * abs(BTGH*ExchCoeffShAbvCan*DTHV)**(2.0/3.0) + else + FrictionVelVertVeg = 0.0 + endif + FrictionVelVeg = max(sqrt(ExchCoeffMomAbvCan*sqrt(DU2+FrictionVelVertVeg)), EPSUST) + MoStabParaAbvCan = ELFC * ExchCoeffShAbvCan * DTHV / FrictionVelVeg**3 + endif + + ! ZILITINKEVITCH approach for ZT + ZT = max(1.0e-6, exp(ZILFC*sqrt(FrictionVelVeg*RoughLenMomSfc))*RoughLenMomSfc) + ZSLU = RefHeightAboveGrd + ZU + ZSLT = RefHeightAboveGrd + ZT + RLOGU = log(ZSLU/ZU) + RLOGT = log(ZSLT/ZT) + + ! Monin-Obukhov length scale + ZETALT = max(ZSLT*MoStabParaAbvCan, ZTMIN) + MoStabParaAbvCan = ZETALT / ZSLT + ZETALU = ZSLU * MoStabParaAbvCan + ZETAU = ZU * MoStabParaAbvCan + ZETAT = ZT * MoStabParaAbvCan + if ( ILECH == 0 ) then + if ( MoStabParaAbvCan < 0.0 ) then + XLU4 = 1.0 - 16.0 * ZETALU + XLT4 = 1.0 - 16.0 * ZETALT + XU4 = 1.0 - 16.0 * ZETAU + XT4 = 1.0 - 16.0 * ZETAT + XLU = sqrt(sqrt(XLU4)) + XLT = sqrt(sqrt(XLT4)) + XU = sqrt(sqrt(XU4)) + XT = sqrt(sqrt(XT4)) + PSMZ = PSPMU(XU) + SIMM = PSPMU(XLU) - PSMZ + RLOGU + PSHZ = PSPHU(XT) + SIMH = PSPHU(XLT) - PSHZ + RLOGT + else + ZETALU = min(ZETALU, ZTMAX) + ZETALT = min(ZETALT, ZTMAX) + ZETAU = min(ZETAU, ZTMAX/(ZSLU/ZU)) ! Barlage: add limit on ZETAU/ZETAT + ZETAT = min(ZETAT, ZTMAX/(ZSLT/ZT)) ! Barlage: prevent SIMM/SIMH < 0 + PSMZ = PSPMS(ZETAU) + SIMM = PSPMS(ZETALU) - PSMZ + RLOGU + PSHZ = PSPHS(ZETAT) + SIMH = PSPHS(ZETALT) - PSHZ + RLOGT + endif + else ! LECH's functions + if ( MoStabParaAbvCan < 0.0 ) then + PSMZ = PSLMU(ZETAU) + SIMM = PSLMU(ZETALU) - PSMZ + RLOGU + PSHZ = PSLHU(ZETAT) + SIMH = PSLHU(ZETALT) - PSHZ + RLOGT + else + ZETALU = min(ZETALU, ZTMAX) + ZETALT = min(ZETALT, ZTMAX) + PSMZ = PSLMS(ZETAU) + SIMM = PSLMS(ZETALU) - PSMZ + RLOGU + PSHZ = PSLHS(ZETAT) + SIMH = PSLHS(ZETALT) - PSHZ + RLOGT + endif + endif + + ! BELJARS correction of friction velocity u* + FrictionVelVeg = max(sqrt(ExchCoeffMomAbvCan*sqrt(DU2+FrictionVelVertVeg)), EPSUST) + + ! ZILITINKEVITCH fix for ZT + ZT = max(1.0e-6, exp(ZILFC*sqrt(FrictionVelVeg*RoughLenMomSfc))*RoughLenMomSfc) + ZSLT = RefHeightAboveGrd + ZT + RLOGT = log(ZSLT/ZT) + USTARK = FrictionVelVeg * VKRM + + ! avoid tangent linear problems near zero + if ( SIMM < 1.0e-6 ) SIMM = 1.0e-6 ! Limit stability function + ExchCoeffMomAbvCan = max(USTARK/SIMM, CXCH) + if ( SIMH < 1.0e-6 ) SIMH = 1.0e-6 ! Limit stability function + ExchCoeffShAbvCan = max(USTARK/SIMH, CXCH) + + ! update vertical friction velocity w* + if ( (BTGH*ExchCoeffShAbvCan*DTHV) /= 0.0 ) then + FrictionVelVertVeg = WWST2 * abs(BTGH*ExchCoeffShAbvCan*DTHV)**(2.0/3.0) + else + FrictionVelVertVeg = 0.0 + endif + + ! update M-O stability parameter + RLMN = ELFC * ExchCoeffShAbvCan * DTHV / FrictionVelVeg**3 + RLMA = MoStabParaAbvCan * WOLD + RLMN * WNEW + MoStabParaAbvCan = RLMA + + ! Undo the multiplication by windspeed that applies to exchange coeff + ExchCoeffShAbvCan = ExchCoeffShAbvCan / WindSpdRefHeight + ExchCoeffMomAbvCan = ExchCoeffMomAbvCan / WindSpdRefHeight + + ! compute aerodynamic resistance + ResistanceMomAbvCan = max(1.0, 1.0/(ExchCoeffMomAbvCan*WindSpdRefHeight)) + ResistanceShAbvCan = max(1.0, 1.0/(ExchCoeffShAbvCan*WindSpdRefHeight)) + ResistanceLhAbvCan = ResistanceShAbvCan + + end associate + + end subroutine ResistanceAboveCanopyChen97 + +end module ResistanceAboveCanopyChen97Mod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/ResistanceAboveCanopyMostMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/ResistanceAboveCanopyMostMod.F90 new file mode 100644 index 0000000000..f257c39745 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/ResistanceAboveCanopyMostMod.F90 @@ -0,0 +1,176 @@ +module ResistanceAboveCanopyMostMod + +!!! Compute surface resistance and drag coefficient for momentum and heat +!!! based on Monin-Obukhov (M-O) Similarity Theory (MOST) + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine ResistanceAboveCanopyMOST(noahmp, IterationInd, HeatSensibleTmp, MoStabParaSgn) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: SFCDIF1 for vegetated portion +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + integer , intent(in ) :: IterationInd ! iteration index + integer , intent(inout) :: MoStabParaSgn ! number of times moz changes sign + real(kind=kind_noahmp), intent(in ) :: HeatSensibleTmp ! temporary sensible heat flux (w/m2) in each iteration + type(noahmp_type) , intent(inout) :: noahmp + +! local variable + real(kind=kind_noahmp) :: MPE ! prevents overflow for division by zero + real(kind=kind_noahmp) :: TMPCM ! temporary calculation for ExchCoeffMomAbvCan + real(kind=kind_noahmp) :: TMPCH ! temporary calculation for CH + real(kind=kind_noahmp) :: FMNEW ! stability correction factor, momentum, for current moz + real(kind=kind_noahmp) :: FHNEW ! stability correction factor, sen heat, for current moz + real(kind=kind_noahmp) :: MOZOLD ! Monin-Obukhov stability parameter from prior iteration + real(kind=kind_noahmp) :: TMP1,TMP2,TMP3,TMP4,TMP5 ! temporary calculation + real(kind=kind_noahmp) :: TVIR ! temporary virtual temperature [K] + real(kind=kind_noahmp) :: TMPCM2 ! temporary calculation for CM2 + real(kind=kind_noahmp) :: TMPCH2 ! temporary calculation for CH2 + real(kind=kind_noahmp) :: FM2NEW ! stability correction factor, momentum, for current moz + real(kind=kind_noahmp) :: FH2NEW ! stability correction factor, sen heat, for current moz + real(kind=kind_noahmp) :: TMP12,TMP22,TMP32 ! temporary calculation + real(kind=kind_noahmp) :: CMFM, CHFH, CM2FM2, CH2FH2 ! temporary calculation + +! -------------------------------------------------------------------- + associate( & + TemperatureAirRefHeight => noahmp%forcing%TemperatureAirRefHeight ,& ! in, air temperature [K] at reference height + SpecHumidityRefHeight => noahmp%forcing%SpecHumidityRefHeight ,& ! in, specific humidity [kg/kg] at reference height + RefHeightAboveGrd => noahmp%energy%state%RefHeightAboveGrd ,& ! in, reference height [m] above ground + DensityAirRefHeight => noahmp%energy%state%DensityAirRefHeight ,& ! in, density air [kg/m3] + WindSpdRefHeight => noahmp%energy%state%WindSpdRefHeight ,& ! in, wind speed [m/s] at reference height + ZeroPlaneDispSfc => noahmp%energy%state%ZeroPlaneDispSfc ,& ! in, zero plane displacement [m] + RoughLenShCanopy => noahmp%energy%state%RoughLenShCanopy ,& ! in, roughness length [m], sensible heat, vegetated + RoughLenMomSfc => noahmp%energy%state%RoughLenMomSfc ,& ! in, roughness length [m], momentum, surface + MoStabCorrMomAbvCan => noahmp%energy%state%MoStabCorrMomAbvCan ,& ! inout, M-O momentum stability correction, above ZeroPlaneDispSfc, vegetated + MoStabCorrShAbvCan => noahmp%energy%state%MoStabCorrShAbvCan ,& ! inout, M-O sen heat stability correction, above ZeroPlaneDispSfc, vegetated + MoStabCorrMomVeg2m => noahmp%energy%state%MoStabCorrMomVeg2m ,& ! inout, M-O momentum stability correction, 2m, vegetated + MoStabCorrShVeg2m => noahmp%energy%state%MoStabCorrShVeg2m ,& ! inout, M-O sen heat stability correction, 2m, vegetated + MoStabParaAbvCan => noahmp%energy%state%MoStabParaAbvCan ,& ! inout, Monin-Obukhov stability (z/L), above ZeroPlaneDispSfc, vegetated + FrictionVelVeg => noahmp%energy%state%FrictionVelVeg ,& ! inout, friction velocity [m/s], vegetated + MoStabParaVeg2m => noahmp%energy%state%MoStabParaVeg2m ,& ! out, Monin-Obukhov stability (z/L), 2m, vegetated + MoLengthAbvCan => noahmp%energy%state%MoLengthAbvCan ,& ! out, Monin-Obukhov length [m], above ZeroPlaneDispSfc, vegetated + ExchCoeffMomAbvCan => noahmp%energy%state%ExchCoeffMomAbvCan ,& ! out, drag coefficient for momentum, above ZeroPlaneDispSfc, vegetated + ExchCoeffShAbvCan => noahmp%energy%state%ExchCoeffShAbvCan ,& ! out, exchange coefficient for heat, above ZeroPlaneDispSfc, vegetated + ExchCoeffSh2mVegMo => noahmp%energy%state%ExchCoeffSh2mVegMo ,& ! out, exchange coefficient for heat, 2m, vegetated + ResistanceMomAbvCan => noahmp%energy%state%ResistanceMomAbvCan ,& ! out, aerodynamic resistance for momentum [s/m], above canopy + ResistanceShAbvCan => noahmp%energy%state%ResistanceShAbvCan ,& ! out, aerodynamic resistance for sensible heat [s/m], above canopy + ResistanceLhAbvCan => noahmp%energy%state%ResistanceLhAbvCan & ! out, aerodynamic resistance for water vapor [s/m], above canopy + ) +! ---------------------------------------------------------------------- + + ! initialization + MPE = 1.0e-6 + MOZOLD = MoStabParaAbvCan ! M-O stability parameter for next iteration + if ( RefHeightAboveGrd <= ZeroPlaneDispSfc ) then + write(*,*) "WARNING: critical problem: RefHeightAboveGrd <= ZeroPlaneDispSfc; model stops" + stop "Error in ResistanceAboveCanopyMostMod.F90" + endif + + ! temporary drag coefficients + TMPCM = log((RefHeightAboveGrd - ZeroPlaneDispSfc) / RoughLenMomSfc) + TMPCH = log((RefHeightAboveGrd - ZeroPlaneDispSfc) / RoughLenShCanopy) + TMPCM2 = log((2.0 + RoughLenMomSfc) / RoughLenMomSfc) + TMPCH2 = log((2.0 + RoughLenShCanopy) / RoughLenShCanopy) + + ! compute M-O stability parameter + if ( IterationInd == 1 ) then + FrictionVelVeg = 0.0 + MoStabParaAbvCan = 0.0 + MoLengthAbvCan = 0.0 + MoStabParaVeg2m = 0.0 + else + TVIR = (1.0 + 0.61*SpecHumidityRefHeight) * TemperatureAirRefHeight + TMP1 = ConstVonKarman * (ConstGravityAcc/TVIR) * HeatSensibleTmp / (DensityAirRefHeight*ConstHeatCapacAir) + if ( abs(TMP1) <= MPE ) TMP1 = MPE + MoLengthAbvCan = -1.0 * FrictionVelVeg**3 / TMP1 + MoStabParaAbvCan = min((RefHeightAboveGrd - ZeroPlaneDispSfc) / MoLengthAbvCan, 1.0) + MoStabParaVeg2m = min((2.0 + RoughLenShCanopy) / MoLengthAbvCan, 1.0) + endif + + ! accumulate number of times moz changes sign. + if ( MOZOLD*MoStabParaAbvCan < 0.0 ) MoStabParaSgn = MoStabParaSgn + 1 + if ( MoStabParaSgn >= 2 ) then + MoStabParaAbvCan = 0.0 + MoStabCorrMomAbvCan = 0.0 + MoStabCorrShAbvCan = 0.0 + MoStabParaVeg2m = 0.0 + MoStabCorrMomVeg2m = 0.0 + MoStabCorrShVeg2m = 0.0 + endif + + ! evaluate stability-dependent variables using moz from prior iteration + if ( MoStabParaAbvCan < 0.0 ) then + TMP1 = (1.0 - 16.0 * MoStabParaAbvCan)**0.25 + TMP2 = log((1.0 + TMP1*TMP1) / 2.0) + TMP3 = log((1.0 + TMP1) / 2.0) + FMNEW = 2.0 * TMP3 + TMP2 - 2.0 * atan(TMP1) + 1.5707963 + FHNEW = 2 * TMP2 + ! 2-meter quantities + TMP12 = (1.0 - 16.0 * MoStabParaVeg2m)**0.25 + TMP22 = log((1.0 + TMP12*TMP12) / 2.0) + TMP32 = log((1.0 + TMP12) / 2.0) + FM2NEW = 2.0 * TMP32 + TMP22 - 2.0 * atan(TMP12) + 1.5707963 + FH2NEW = 2 * TMP22 + else + FMNEW = -5.0 * MoStabParaAbvCan + FHNEW = FMNEW + FM2NEW = -5.0 * MoStabParaVeg2m + FH2NEW = FM2NEW + endif + + ! except for first iteration, weight stability factors for previous + ! iteration to help avoid flip-flops from one iteration to the next + if ( IterationInd == 1 ) then + MoStabCorrMomAbvCan = FMNEW + MoStabCorrShAbvCan = FHNEW + MoStabCorrMomVeg2m = FM2NEW + MoStabCorrShVeg2m = FH2NEW + else + MoStabCorrMomAbvCan = 0.5 * (MoStabCorrMomAbvCan + FMNEW) + MoStabCorrShAbvCan = 0.5 * (MoStabCorrShAbvCan + FHNEW) + MoStabCorrMomVeg2m = 0.5 * (MoStabCorrMomVeg2m + FM2NEW) + MoStabCorrShVeg2m = 0.5 * (MoStabCorrShVeg2m + FH2NEW) + endif + + ! exchange coefficients + MoStabCorrShAbvCan = min(MoStabCorrShAbvCan , 0.9*TMPCH) + MoStabCorrMomAbvCan = min(MoStabCorrMomAbvCan, 0.9*TMPCM) + MoStabCorrShVeg2m = min(MoStabCorrShVeg2m , 0.9*TMPCH2) + MoStabCorrMomVeg2m = min(MoStabCorrMomVeg2m , 0.9*TMPCM2) + CMFM = TMPCM - MoStabCorrMomAbvCan + CHFH = TMPCH - MoStabCorrShAbvCan + CM2FM2 = TMPCM2 - MoStabCorrMomVeg2m + CH2FH2 = TMPCH2 - MoStabCorrShVeg2m + if ( abs(CMFM) <= MPE ) CMFM = MPE + if ( abs(CHFH) <= MPE ) CHFH = MPE + if ( abs(CM2FM2) <= MPE ) CM2FM2 = MPE + if ( abs(CH2FH2) <= MPE ) CH2FH2 = MPE + ExchCoeffMomAbvCan = ConstVonKarman * ConstVonKarman / (CMFM * CMFM) + ExchCoeffShAbvCan = ConstVonKarman * ConstVonKarman / (CMFM * CHFH) + !ExchCoeffSh2mVegMo = ConstVonKarman * ConstVonKarman / (CM2FM2 * CH2FH2) + + ! friction velocity + FrictionVelVeg = WindSpdRefHeight * sqrt(ExchCoeffMomAbvCan) + ExchCoeffSh2mVegMo = ConstVonKarman * FrictionVelVeg / CH2FH2 + + ! aerodynamic resistance + ResistanceMomAbvCan = max(1.0, 1.0/(ExchCoeffMomAbvCan*WindSpdRefHeight)) + ResistanceShAbvCan = max(1.0, 1.0/(ExchCoeffShAbvCan*WindSpdRefHeight)) + ResistanceLhAbvCan = ResistanceShAbvCan + + end associate + + end subroutine ResistanceAboveCanopyMOST + +end module ResistanceAboveCanopyMostMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/ResistanceBareGroundChen97Mod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/ResistanceBareGroundChen97Mod.F90 new file mode 100644 index 0000000000..f3510ce0ec --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/ResistanceBareGroundChen97Mod.F90 @@ -0,0 +1,215 @@ +module ResistanceBareGroundChen97Mod + +!!! Compute bare ground resistance and exchange coefficient for momentum and heat +!!! based on Chen et al. (1997, BLM) +!!! This scheme can handle both over open water and over solid surface + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine ResistanceBareGroundChen97(noahmp, IndIter) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: SFCDIF2 for bare ground portion +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + +! in & out variables + integer , intent(in ) :: IndIter ! iteration index + type(noahmp_type) , intent(inout) :: noahmp + +! local variables + integer :: ILECH, ITR + real(kind=kind_noahmp) :: ZZ, PSLMU, PSLMS, PSLHU, PSLHS + real(kind=kind_noahmp) :: XX, PSPMU, YY, PSPMS, PSPHU, PSPHS + real(kind=kind_noahmp) :: ZILFC, ZU, ZT, RDZ, CXCH, DTHV, DU2 + real(kind=kind_noahmp) :: BTGH, ZSLU, ZSLT, RLOGU, RLOGT, RLMA + real(kind=kind_noahmp) :: ZETALT, ZETALU, ZETAU, ZETAT, XLU4 + real(kind=kind_noahmp) :: XLT4, XU4, XT4, XLU, XLT, XU, XT + real(kind=kind_noahmp) :: PSMZ, SIMM, PSHZ, SIMH, USTARK, RLMN +! local parameters + integer , parameter :: ITRMX = 5 + real(kind=kind_noahmp), parameter :: WWST = 1.2 + real(kind=kind_noahmp), parameter :: WWST2 = WWST * WWST + real(kind=kind_noahmp), parameter :: VKRM = 0.40 + real(kind=kind_noahmp), parameter :: EXCM = 0.001 + real(kind=kind_noahmp), parameter :: BETA = 1.0 / 270.0 + real(kind=kind_noahmp), parameter :: BTG = BETA * ConstGravityAcc + real(kind=kind_noahmp), parameter :: ELFC = VKRM * BTG + real(kind=kind_noahmp), parameter :: WOLD = 0.15 + real(kind=kind_noahmp), parameter :: WNEW = 1.0 - WOLD + real(kind=kind_noahmp), parameter :: PIHF = 3.14159265 / 2.0 + real(kind=kind_noahmp), parameter :: EPSU2 = 1.0e-4 + real(kind=kind_noahmp), parameter :: EPSUST = 0.07 + real(kind=kind_noahmp), parameter :: EPSIT = 1.0e-4 + real(kind=kind_noahmp), parameter :: EPSA = 1.0e-8 + real(kind=kind_noahmp), parameter :: ZTMIN = -5.0 + real(kind=kind_noahmp), parameter :: ZTMAX = 1.0 + real(kind=kind_noahmp), parameter :: HPBL = 1000.0 + real(kind=kind_noahmp), parameter :: SQVISC = 258.2 + real(kind=kind_noahmp), parameter :: RIC = 0.183 + real(kind=kind_noahmp), parameter :: RRIC = 1.0 / RIC + real(kind=kind_noahmp), parameter :: FHNEU = 0.8 + real(kind=kind_noahmp), parameter :: RFC = 0.191 + real(kind=kind_noahmp), parameter :: RFAC = RIC / ( FHNEU * RFC * RFC ) +! local statement functions + ! LECH'S surface functions + PSLMU(ZZ) = -0.96 * log(1.0 - 4.5 * ZZ) + PSLMS(ZZ) = ZZ * RRIC - 2.076 * (1.0 - 1.0/(ZZ + 1.0)) + PSLHU(ZZ) = -0.96 * log(1.0 - 4.5 * ZZ) + PSLHS(ZZ) = ZZ * RFAC - 2.076 * (1.0 - 1.0/(ZZ + 1.0)) + ! PAULSON'S surface functions + PSPMU(XX) = -2.0*log( (XX+1.0)*0.5 ) - log( (XX*XX+1.0)*0.5 ) + 2.0*atan(XX) - PIHF + PSPMS(YY) = 5.0 * YY + PSPHU(XX) = -2.0 * log( (XX*XX + 1.0)*0.5 ) + PSPHS(YY) = 5.0 * YY + +! -------------------------------------------------------------------- + associate( & + SnowDepth => noahmp%water%state%SnowDepth ,& ! in, snow depth [m] + ZilitinkevichCoeff => noahmp%energy%param%ZilitinkevichCoeff ,& ! in, Calculate roughness length of heat + RefHeightAboveGrd => noahmp%energy%state%RefHeightAboveGrd ,& ! in, reference height [m] above ground + TemperaturePotRefHeight => noahmp%energy%state%TemperaturePotRefHeight ,& ! in, potential temp at reference height [K] + WindSpdRefHeight => noahmp%energy%state%WindSpdRefHeight ,& ! in, wind speed [m/s] at reference height + RoughLenMomGrd => noahmp%energy%state%RoughLenMomGrd ,& ! in, roughness length [m], momentum, ground + TemperatureGrdBare => noahmp%energy%state%TemperatureGrdBare ,& ! in, bare ground temperature [K] + ExchCoeffMomBare => noahmp%energy%state%ExchCoeffMomBare ,& ! inout, exchange coeff [m/s] momentum, above ZeroPlaneDisp, bare ground + ExchCoeffShBare => noahmp%energy%state%ExchCoeffShBare ,& ! inout, exchange coeff [m/s] for heat, above ZeroPlaneDisp, bare ground + MoStabParaBare => noahmp%energy%state%MoStabParaBare ,& ! inout, Monin-Obukhov stability (z/L), above ZeroPlaneDisp, bare ground + FrictionVelVertBare => noahmp%energy%state%FrictionVelVertBare ,& ! inout, friction velocity [m/s] in vertical direction, bare ground + FrictionVelBare => noahmp%energy%state%FrictionVelBare ,& ! inout, friction velocity [m/s], bare ground + ResistanceMomBareGrd => noahmp%energy%state%ResistanceMomBareGrd ,& ! out, aerodynamic resistance for momentum [s/m], bare ground + ResistanceShBareGrd => noahmp%energy%state%ResistanceShBareGrd ,& ! out, aerodynamic resistance for sensible heat [s/m], bare ground + ResistanceLhBareGrd => noahmp%energy%state%ResistanceLhBareGrd & ! out, aerodynamic resistance for water vapor [s/m], bare ground + ) +! ---------------------------------------------------------------------- + + ! ZTFC: RATIO OF ZOH/ZOM LESS OR EQUAL THAN 1 + ! C......ZTFC=0.1 + ! ZilitinkevichCoeff: CONSTANT C IN Zilitinkevich, S. S.1995,:NOTE ABOUT ZT + ILECH = 0 + ZILFC = -ZilitinkevichCoeff * VKRM * SQVISC + ZU = RoughLenMomGrd + RDZ = 1.0 / RefHeightAboveGrd + CXCH = EXCM * RDZ + DTHV = TemperaturePotRefHeight - TemperatureGrdBare + + ! BELJARS correction of friction velocity u* + DU2 = max(WindSpdRefHeight*WindSpdRefHeight, EPSU2) + BTGH = BTG * HPBL + if ( IndIter == 1 ) then + if ( (BTGH*ExchCoeffShBare*DTHV) /= 0.0 ) then + FrictionVelVertBare = WWST2 * abs(BTGH*ExchCoeffShBare*DTHV)**(2.0/3.0) + else + FrictionVelVertBare = 0.0 + endif + FrictionVelBare = max(sqrt(ExchCoeffMomBare*sqrt(DU2+FrictionVelVertBare)), EPSUST) + MoStabParaBare = ELFC * ExchCoeffShBare * DTHV / FrictionVelBare**3 + endif + + ! ZILITINKEVITCH approach for ZT + ZT = max(1.0e-6, exp(ZILFC*sqrt(FrictionVelBare*RoughLenMomGrd))*RoughLenMomGrd) + ZSLU = RefHeightAboveGrd + ZU + ZSLT = RefHeightAboveGrd + ZT + RLOGU = log(ZSLU / ZU) + RLOGT = log(ZSLT / ZT) + + ! Monin-Obukhov length scale + ZETALT = max(ZSLT*MoStabParaBare, ZTMIN) + MoStabParaBare = ZETALT / ZSLT + ZETALU = ZSLU * MoStabParaBare + ZETAU = ZU * MoStabParaBare + ZETAT = ZT * MoStabParaBare + if ( ILECH == 0 ) then + if ( MoStabParaBare < 0.0 ) then + XLU4 = 1.0 - 16.0 * ZETALU + XLT4 = 1.0 - 16.0 * ZETALT + XU4 = 1.0 - 16.0 * ZETAU + XT4 = 1.0 - 16.0 * ZETAT + XLU = sqrt(sqrt(XLU4)) + XLT = sqrt(sqrt(XLT4)) + XU = sqrt(sqrt(XU4)) + XT = sqrt(sqrt(XT4)) + PSMZ = PSPMU(XU) + SIMM = PSPMU(XLU) - PSMZ + RLOGU + PSHZ = PSPHU(XT) + SIMH = PSPHU(XLT) - PSHZ + RLOGT + else + ZETALU = min(ZETALU, ZTMAX) + ZETALT = min(ZETALT, ZTMAX) + ZETAU = min(ZETAU, ZTMAX/(ZSLU/ZU)) ! Barlage: add limit on ZETAU/ZETAT + ZETAT = min(ZETAT, ZTMAX/(ZSLT/ZT)) ! Barlage: prevent SIMM/SIMH < 0 + PSMZ = PSPMS(ZETAU) + SIMM = PSPMS(ZETALU) - PSMZ + RLOGU + PSHZ = PSPHS(ZETAT) + SIMH = PSPHS(ZETALT) - PSHZ + RLOGT + endif + else ! LECH's functions + if ( MoStabParaBare < 0.0 ) then + PSMZ = PSLMU(ZETAU) + SIMM = PSLMU(ZETALU) - PSMZ + RLOGU + PSHZ = PSLHU(ZETAT) + SIMH = PSLHU(ZETALT) - PSHZ + RLOGT + else + ZETALU = min(ZETALU, ZTMAX) + ZETALT = min(ZETALT, ZTMAX) + PSMZ = PSLMS(ZETAU) + SIMM = PSLMS(ZETALU) - PSMZ + RLOGU + PSHZ = PSLHS(ZETAT) + SIMH = PSLHS(ZETALT) - PSHZ + RLOGT + endif + endif + + ! BELJARS correction of friction velocity u* + FrictionVelBare = max(sqrt(ExchCoeffMomBare*sqrt(DU2+FrictionVelVertBare)), EPSUST) + + ! ZILITINKEVITCH fix for ZT + ZT = max(1.0e-6, exp(ZILFC*sqrt(FrictionVelBare*RoughLenMomGrd))*RoughLenMomGrd) + ZSLT = RefHeightAboveGrd + ZT + RLOGT = log(ZSLT/ZT) + USTARK = FrictionVelBare * VKRM + + ! avoid tangent linear problems near zero + if ( SIMM < 1.0e-6 ) SIMM = 1.0e-6 ! Limit stability function + ExchCoeffMomBare = max(USTARK/SIMM, CXCH) + if ( SIMH < 1.0e-6 ) SIMH = 1.0e-6 ! Limit stability function + ExchCoeffShBare = max(USTARK/SIMH, CXCH) + + ! update vertical friction velocity w* + if ( BTGH*ExchCoeffShBare*DTHV /= 0.0 ) then + FrictionVelVertBare = WWST2 * abs(BTGH*ExchCoeffShBare*DTHV)**(2.0/3.0) + else + FrictionVelVertBare = 0.0 + endif + + ! update M-O stability parameter + RLMN = ELFC * ExchCoeffShBare * DTHV / FrictionVelBare**3 + RLMA = MoStabParaBare * WOLD + RLMN * WNEW + MoStabParaBare = RLMA + + ! Undo the multiplication by windspeed that applies to exchange coeff + ExchCoeffShBare = ExchCoeffShBare / WindSpdRefHeight + ExchCoeffMomBare = ExchCoeffMomBare / WindSpdRefHeight + if ( SnowDepth > 0.0 ) then + ExchCoeffMomBare = min(0.01, ExchCoeffMomBare) ! exch coeff is too large, causing + ExchCoeffShBare = min(0.01, ExchCoeffShBare) ! computational instability + endif + + ! compute aerodynamic resistance + ResistanceMomBareGrd = max(1.0, 1.0/(ExchCoeffMomBare*WindSpdRefHeight)) + ResistanceShBareGrd = max(1.0, 1.0/(ExchCoeffShBare*WindSpdRefHeight)) + ResistanceLhBareGrd = ResistanceShBareGrd + + end associate + + end subroutine ResistanceBareGroundChen97 + +end module ResistanceBareGroundChen97Mod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/ResistanceBareGroundMostMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/ResistanceBareGroundMostMod.F90 new file mode 100644 index 0000000000..5c47e7437f --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/ResistanceBareGroundMostMod.F90 @@ -0,0 +1,177 @@ +module ResistanceBareGroundMostMod + +!!! Compute bare ground resistance and drag coefficient for momentum and heat +!!! based on Monin-Obukhov (M-O) Similarity Theory (MOST) + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine ResistanceBareGroundMOST(noahmp, IndIter, HeatSensibleTmp, MoStabParaSgn) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: SFCDIF1 for bare ground portion +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + +! in & out variables + integer , intent(in ) :: IndIter ! iteration index + integer , intent(inout) :: MoStabParaSgn ! number of times moz changes sign + real(kind=kind_noahmp), intent(in ) :: HeatSensibleTmp ! temporary sensible heat flux (w/m2) in each iteration + type(noahmp_type) , intent(inout) :: noahmp + +! local variable + real(kind=kind_noahmp) :: MPE ! prevents overflow for division by zero + real(kind=kind_noahmp) :: TMPCM ! temporary calculation for CM + real(kind=kind_noahmp) :: TMPCH ! temporary calculation for CH + real(kind=kind_noahmp) :: FMNEW ! stability correction factor, momentum, for current moz + real(kind=kind_noahmp) :: FHNEW ! stability correction factor, sen heat, for current moz + real(kind=kind_noahmp) :: MOZOLD ! Monin-Obukhov stability parameter from prior iteration + real(kind=kind_noahmp) :: TMP1,TMP2,TMP3,TMP4,TMP5 ! temporary calculation + real(kind=kind_noahmp) :: TVIR ! temporary virtual temperature (k) + real(kind=kind_noahmp) :: TMPCM2 ! temporary calculation for CM2 + real(kind=kind_noahmp) :: TMPCH2 ! temporary calculation for CH2 + real(kind=kind_noahmp) :: FM2NEW ! stability correction factor, momentum, for current moz + real(kind=kind_noahmp) :: FH2NEW ! stability correction factor, sen heat, for current moz + real(kind=kind_noahmp) :: TMP12,TMP22,TMP32 ! temporary calculation + real(kind=kind_noahmp) :: CMFM, CHFH, CM2FM2, CH2FH2 ! temporary calculation + +! -------------------------------------------------------------------- + associate( & + TemperatureAirRefHeight => noahmp%forcing%TemperatureAirRefHeight ,& ! in, air temperature [K] at reference height + SpecHumidityRefHeight => noahmp%forcing%SpecHumidityRefHeight ,& ! in, specific humidity [kg/kg] at reference height + RefHeightAboveGrd => noahmp%energy%state%RefHeightAboveGrd ,& ! in, reference height [m] above ground + DensityAirRefHeight => noahmp%energy%state%DensityAirRefHeight ,& ! in, density air [kg/m3] + WindSpdRefHeight => noahmp%energy%state%WindSpdRefHeight ,& ! in, wind speed [m/s] at reference height + ZeroPlaneDispGrd => noahmp%energy%state%ZeroPlaneDispGrd ,& ! in, ground zero plane displacement [m] + RoughLenShBareGrd => noahmp%energy%state%RoughLenShBareGrd ,& ! in, roughness length [m], sensible heat, bare ground + RoughLenMomGrd => noahmp%energy%state%RoughLenMomGrd ,& ! in, roughness length [m], momentum, ground + MoStabCorrMomBare => noahmp%energy%state%MoStabCorrMomBare ,& ! inout, M-O momentum stability correction, above ZeroPlaneDisp, bare ground + MoStabCorrShBare => noahmp%energy%state%MoStabCorrShBare ,& ! inout, M-O sen heat stability correction, above ZeroPlaneDisp, bare ground + MoStabCorrMomBare2m => noahmp%energy%state%MoStabCorrMomBare2m ,& ! inout, M-O momentum stability correction, 2m, bare ground + MoStabCorrShBare2m => noahmp%energy%state%MoStabCorrShBare2m ,& ! inout, M-O sen heat stability correction, 2m, bare ground + FrictionVelBare => noahmp%energy%state%FrictionVelBare ,& ! inout, friction velocity [m/s], bare ground + MoStabParaBare => noahmp%energy%state%MoStabParaBare ,& ! inout, Monin-Obukhov stability (z/L), above ZeroPlaneDisp, bare ground + MoStabParaBare2m => noahmp%energy%state%MoStabParaBare2m ,& ! out, Monin-Obukhov stability (z/L), 2m, bare ground + MoLengthBare => noahmp%energy%state%MoLengthBare ,& ! out, Monin-Obukhov length [m], above ZeroPlaneDisp, bare ground + ExchCoeffMomBare => noahmp%energy%state%ExchCoeffMomBare ,& ! out, exchange coeff [m/s] for momentum, above ZeroPlaneDisp, bare ground + ExchCoeffShBare => noahmp%energy%state%ExchCoeffShBare ,& ! out, exchange coeff [m/s] for heat, above ZeroPlaneDisp, bare ground + ExchCoeffSh2mBareMo => noahmp%energy%state%ExchCoeffSh2mBareMo ,& ! out, exchange coeff [m/s] for heat, 2m, bare ground + ResistanceMomBareGrd => noahmp%energy%state%ResistanceMomBareGrd ,& ! out, aerodynamic resistance for momentum [s/m], bare ground + ResistanceShBareGrd => noahmp%energy%state%ResistanceShBareGrd ,& ! out, aerodynamic resistance for sensible heat [s/m], bare ground + ResistanceLhBareGrd => noahmp%energy%state%ResistanceLhBareGrd & ! out, aerodynamic resistance for water vapor [s/m], bare ground + ) +! ---------------------------------------------------------------------- + + ! initialization + MPE = 1.0e-6 + MOZOLD = MoStabParaBare ! M-O stability parameter for next iteration + if ( RefHeightAboveGrd <= ZeroPlaneDispGrd ) then + write(*,*) "WARNING: critical problem: RefHeightAboveGrd <= ZeroPlaneDispGrd; model stops" + stop "Error in ResistanceBareGroundMostMod.F90" + endif + + ! temporary drag coefficients + TMPCM = log((RefHeightAboveGrd - ZeroPlaneDispGrd) / RoughLenMomGrd) + TMPCH = log((RefHeightAboveGrd - ZeroPlaneDispGrd) / RoughLenShBareGrd) + TMPCM2 = log((2.0 + RoughLenMomGrd) / RoughLenMomGrd) + TMPCH2 = log((2.0 + RoughLenShBareGrd) / RoughLenShBareGrd) + + ! compute M-O stability parameter + if ( IndIter == 1 ) then + FrictionVelBare = 0.0 + MoStabParaBare = 0.0 + MoLengthBare = 0.0 + MoStabParaBare2m = 0.0 + else + TVIR = (1.0 + 0.61*SpecHumidityRefHeight) * TemperatureAirRefHeight + TMP1 = ConstVonKarman * (ConstGravityAcc/TVIR) * HeatSensibleTmp / (DensityAirRefHeight*ConstHeatCapacAir) + if ( abs(TMP1) <= MPE ) TMP1 = MPE + MoLengthBare = -1.0 * FrictionVelBare**3 / TMP1 + MoStabParaBare = min((RefHeightAboveGrd - ZeroPlaneDispGrd) / MoLengthBare, 1.0) + MoStabParaBare2m = min((2.0 + RoughLenShBareGrd) / MoLengthBare, 1.0) + endif + + ! accumulate number of times moz changes sign. + if ( MOZOLD*MoStabParaBare < 0.0 ) MoStabParaSgn = MoStabParaSgn + 1 + if ( MoStabParaSgn >= 2 ) then + MoStabParaBare = 0.0 + MoStabCorrMomBare = 0.0 + MoStabCorrShBare = 0.0 + MoStabParaBare2m = 0.0 + MoStabCorrMomBare2m = 0.0 + MoStabCorrShBare2m = 0.0 + endif + + ! evaluate stability-dependent variables using moz from prior iteration + if ( MoStabParaBare < 0.0 ) then + TMP1 = (1.0 - 16.0 * MoStabParaBare)**0.25 + TMP2 = log((1.0 + TMP1*TMP1) / 2.0) + TMP3 = log((1.0 + TMP1) / 2.0) + FMNEW = 2.0 * TMP3 + TMP2 - 2.0 * atan(TMP1) + 1.5707963 + FHNEW = 2 * TMP2 + ! 2-meter quantities + TMP12 = (1.0 - 16.0 * MoStabParaBare2m)**0.25 + TMP22 = log((1.0 + TMP12*TMP12) / 2.0) + TMP32 = log((1.0 + TMP12) / 2.0) + FM2NEW = 2.0 * TMP32 + TMP22 - 2.0 * atan(TMP12) + 1.5707963 + FH2NEW = 2 * TMP22 + else + FMNEW = -5.0 * MoStabParaBare + FHNEW = FMNEW + FM2NEW = -5.0 * MoStabParaBare2m + FH2NEW = FM2NEW + endif + + ! except for first iteration, weight stability factors for previous + ! iteration to help avoid flip-flops from one iteration to the next + if ( IndIter == 1 ) then + MoStabCorrMomBare = FMNEW + MoStabCorrShBare = FHNEW + MoStabCorrMomBare2m = FM2NEW + MoStabCorrShBare2m = FH2NEW + else + MoStabCorrMomBare = 0.5 * (MoStabCorrMomBare + FMNEW) + MoStabCorrShBare = 0.5 * (MoStabCorrShBare + FHNEW) + MoStabCorrMomBare2m = 0.5 * (MoStabCorrMomBare2m + FM2NEW) + MoStabCorrShBare2m = 0.5 * (MoStabCorrShBare2m + FH2NEW) + endif + + ! exchange coefficients + MoStabCorrShBare = min(MoStabCorrShBare , 0.9*TMPCH ) + MoStabCorrMomBare = min(MoStabCorrMomBare , 0.9*TMPCM ) + MoStabCorrShBare2m = min(MoStabCorrShBare2m , 0.9*TMPCH2) + MoStabCorrMomBare2m = min(MoStabCorrMomBare2m, 0.9*TMPCM2) + CMFM = TMPCM - MoStabCorrMomBare + CHFH = TMPCH - MoStabCorrShBare + CM2FM2 = TMPCM2 - MoStabCorrMomBare2m + CH2FH2 = TMPCH2 - MoStabCorrShBare2m + if ( abs(CMFM) <= MPE ) CMFM = MPE + if ( abs(CHFH) <= MPE ) CHFH = MPE + if ( abs(CM2FM2) <= MPE ) CM2FM2 = MPE + if ( abs(CH2FH2) <= MPE ) CH2FH2 = MPE + ExchCoeffMomBare = ConstVonKarman * ConstVonKarman / (CMFM * CMFM) + ExchCoeffShBare = ConstVonKarman * ConstVonKarman / (CMFM * CHFH) + !ExchCoeffSh2mBareMo = ConstVonKarman * ConstVonKarman / (CM2FM2 * CH2FH2) + + ! friction velocity + FrictionVelBare = WindSpdRefHeight * sqrt(ExchCoeffMomBare) + ExchCoeffSh2mBareMo = ConstVonKarman * FrictionVelBare / CH2FH2 + + ! aerodynamic resistance + ResistanceMomBareGrd = max(1.0, 1.0/(ExchCoeffMomBare*WindSpdRefHeight)) + ResistanceShBareGrd = max(1.0, 1.0/(ExchCoeffShBare*WindSpdRefHeight)) + ResistanceLhBareGrd = ResistanceShBareGrd + + end associate + + end subroutine ResistanceBareGroundMOST + +end module ResistanceBareGroundMostMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/ResistanceCanopyStomataBallBerryMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/ResistanceCanopyStomataBallBerryMod.F90 new file mode 100644 index 0000000000..d479bec047 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/ResistanceCanopyStomataBallBerryMod.F90 @@ -0,0 +1,173 @@ +module ResistanceCanopyStomataBallBerryMod + +!!! Compute canopy stomatal resistance and foliage photosynthesis based on Ball-Berry scheme + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine ResistanceCanopyStomataBallBerry(noahmp, IndexShade) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: STOMATA +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + integer , intent(in ) :: IndexShade ! index for sunlit/shaded (0=sunlit;1=shaded) + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: IndIter ! iteration index + integer, parameter :: NumIter = 3 ! number of iterations + real(kind=kind_noahmp) :: RadPhotoActAbsTmp ! temporary absorbed par for leaves [W/m2] + real(kind=kind_noahmp) :: ResistanceStomataTmp ! temporary leaf stomatal resistance [s/m] + real(kind=kind_noahmp) :: PhotosynLeafTmp ! temporary leaf photosynthesis [umol co2/m2/s] + real(kind=kind_noahmp) :: NitrogenFoliageFac ! foliage nitrogen adjustment factor (0 to 1) + real(kind=kind_noahmp) :: CarboxylRateMax ! maximum rate of carbonylation [umol co2/m2/s] + real(kind=kind_noahmp) :: MPE ! prevents overflow for division by zero + real(kind=kind_noahmp) :: RLB ! boundary layer resistance [s m2 / umol] + real(kind=kind_noahmp) :: TC ! foliage temperature [deg C] + real(kind=kind_noahmp) :: CS ! co2 concentration at leaf surface [Pa] + real(kind=kind_noahmp) :: KC ! co2 Michaelis-Menten constant [Pa] + real(kind=kind_noahmp) :: KO ! o2 Michaelis-Menten constant [Pa] + real(kind=kind_noahmp) :: A,B,C,Q ! intermediate calculations for RS + real(kind=kind_noahmp) :: R1,R2 ! roots for RS + real(kind=kind_noahmp) :: PPF ! absorb photosynthetic photon flux [umol photons/m2/s] + real(kind=kind_noahmp) :: WC ! Rubisco limited photosynthesis [umol co2/m2/s] + real(kind=kind_noahmp) :: WJ ! light limited photosynthesis [umol co2/m2/s] + real(kind=kind_noahmp) :: WE ! export limited photosynthesis [umol co2/m2/s] + real(kind=kind_noahmp) :: CP ! co2 compensation point [Pa] + real(kind=kind_noahmp) :: CI ! internal co2 [Pa] + real(kind=kind_noahmp) :: AWC ! intermediate calculation for wc + real(kind=kind_noahmp) :: J ! electron transport [umol co2/m2/s] + real(kind=kind_noahmp) :: CEA ! constrain ea or else model blows up + real(kind=kind_noahmp) :: CF ! [s m2/umol] -> [s/m] + real(kind=kind_noahmp) :: T ! temporary var +! local statement functions + real(kind=kind_noahmp) :: F1 ! generic temperature response (statement function) + real(kind=kind_noahmp) :: F2 ! generic temperature inhibition (statement function) + real(kind=kind_noahmp) :: AB ! used in statement functions + real(kind=kind_noahmp) :: BC ! used in statement functions + F1(AB, BC) = AB**( (BC - 25.0) / 10.0 ) + F2(AB) = 1.0 + exp( (-2.2e05 + 710.0 * (AB + 273.16)) / (8.314 * (AB + 273.16)) ) + +! -------------------------------------------------------------------- + associate( & + PressureAirRefHeight => noahmp%forcing%PressureAirRefHeight ,& ! in, air pressure [Pa] at reference height + TemperatureAirRefHeight => noahmp%forcing%TemperatureAirRefHeight ,& ! in, air temperature [K] at reference height + SoilTranspFacAcc => noahmp%water%state%SoilTranspFacAcc ,& ! in, accumulated soil water transpiration factor (0 to 1) + IndexGrowSeason => noahmp%biochem%state%IndexGrowSeason ,& ! in, growing season index (0=off, 1=on) + NitrogenConcFoliage => noahmp%biochem%state%NitrogenConcFoliage ,& ! in, foliage nitrogen concentration [%] + NitrogenConcFoliageMax => noahmp%biochem%param%NitrogenConcFoliageMax ,& ! in, foliage nitrogen concentration when f(n)=1 [%] + QuantumEfficiency25C => noahmp%biochem%param%QuantumEfficiency25C ,& ! in, quantum efficiency at 25c [umol co2 / umol photon] + CarboxylRateMax25C => noahmp%biochem%param%CarboxylRateMax25C ,& ! in, maximum rate of carboxylation at 25c [umol co2/m**2/s] + CarboxylRateMaxQ10 => noahmp%biochem%param%CarboxylRateMaxQ10 ,& ! in, change in maximum rate of carboxylation for each 10C temp change + PhotosynPathC3 => noahmp%biochem%param%PhotosynPathC3 ,& ! in, C3 photosynthetic pathway indicator: 0. = c4, 1. = c3 + SlopeConductToPhotosyn => noahmp%biochem%param%SlopeConductToPhotosyn ,& ! in, slope of conductance-to-photosynthesis relationship + Co2MmConst25C => noahmp%energy%param%Co2MmConst25C ,& ! in, co2 michaelis-menten constant at 25c [Pa] + O2MmConst25C => noahmp%energy%param%O2MmConst25C ,& ! in, o2 michaelis-menten constant at 25c [Pa] + Co2MmConstQ10 => noahmp%energy%param%Co2MmConstQ10 ,& ! in, q10 for Co2MmConst25C + O2MmConstQ10 => noahmp%energy%param%O2MmConstQ10 ,& ! in, q10 for ko25 + ConductanceLeafMin => noahmp%energy%param%ConductanceLeafMin ,& ! in, minimum leaf conductance [umol/m**2/s] + TemperatureCanopy => noahmp%energy%state%TemperatureCanopy ,& ! in, vegetation temperature [K] + VapPresSatCanopy => noahmp%energy%state%VapPresSatCanopy ,& ! in, canopy saturation vapor pressure at TV [Pa] + PressureVaporCanAir => noahmp%energy%state%PressureVaporCanAir ,& ! in, canopy air vapor pressure [Pa] + PressureAtmosO2 => noahmp%energy%state%PressureAtmosO2 ,& ! in, atmospheric o2 pressure [Pa] + PressureAtmosCO2 => noahmp%energy%state%PressureAtmosCO2 ,& ! in, atmospheric co2 pressure [Pa] + ResistanceLeafBoundary => noahmp%energy%state%ResistanceLeafBoundary ,& ! in, leaf boundary layer resistance [s/m] + VegFrac => noahmp%energy%state%VegFrac ,& ! in, greeness vegetation fraction + RadPhotoActAbsSunlit => noahmp%energy%flux%RadPhotoActAbsSunlit ,& ! in, average absorbed par for sunlit leaves [W/m2] + RadPhotoActAbsShade => noahmp%energy%flux%RadPhotoActAbsShade ,& ! in, average absorbed par for shaded leaves [W/m2] + ResistanceStomataSunlit => noahmp%energy%state%ResistanceStomataSunlit ,& ! out, sunlit leaf stomatal resistance [s/m] + ResistanceStomataShade => noahmp%energy%state%ResistanceStomataShade ,& ! out, shaded leaf stomatal resistance [s/m] + PhotosynLeafSunlit => noahmp%biochem%flux%PhotosynLeafSunlit ,& ! out, sunlit leaf photosynthesis [umol co2/m2/s] + PhotosynLeafShade => noahmp%biochem%flux%PhotosynLeafShade & ! out, shaded leaf photosynthesis [umol co2/m2/s] + ) +! ---------------------------------------------------------------------- + + ! initialization + MPE = 1.0e-6 + + ! initialize ResistanceStomata=maximum value and photosynthesis=0 because will only do calculations + ! for RadPhotoActAbs > 0, in which case ResistanceStomata <= maximum value and photosynthesis >= 0 + CF = PressureAirRefHeight / (8.314 * TemperatureAirRefHeight) * 1.0e06 ! unit conversion factor + ResistanceStomataTmp = 1.0 / ConductanceLeafMin * CF + PhotosynLeafTmp = 0.0 + if ( IndexShade == 0 ) RadPhotoActAbsTmp = RadPhotoActAbsSunlit / max(VegFrac,1.0e-6) ! Sunlit case + if ( IndexShade == 1 ) RadPhotoActAbsTmp = RadPhotoActAbsShade / max(VegFrac,1.0e-6) ! Shaded case + + ! only compute when there is radiation absorption + if ( RadPhotoActAbsTmp > 0.0 ) then + + NitrogenFoliageFac = min(NitrogenConcFoliage/max(MPE, NitrogenConcFoliageMax), 1.0) + TC = TemperatureCanopy - ConstFreezePoint + PPF = 4.6 * RadPhotoActAbsTmp + J = PPF * QuantumEfficiency25C + KC = Co2MmConst25C * F1(Co2MmConstQ10, TC) + KO = O2MmConst25C * F1(O2MmConstQ10, TC) + AWC = KC * ( 1.0 + PressureAtmosO2 / KO ) + CP = 0.5 * KC / KO * PressureAtmosO2 * 0.21 + CarboxylRateMax = CarboxylRateMax25C / F2(TC) * NitrogenFoliageFac * & + SoilTranspFacAcc * F1(CarboxylRateMaxQ10, TC) + ! first guess ci + CI = 0.7 * PressureAtmosCO2 * PhotosynPathC3 + 0.4 * PressureAtmosCO2 * (1.0 - PhotosynPathC3) + ! ResistanceLeafBoundary: s/m -> s m**2 / umol + RLB = ResistanceLeafBoundary / CF + ! constrain PressureVaporCanAir + CEA = max(0.25*VapPresSatCanopy*PhotosynPathC3 + 0.40*VapPresSatCanopy*(1.0-PhotosynPathC3), & + min(PressureVaporCanAir,VapPresSatCanopy)) + + ! ci iteration + do IndIter = 1, NumIter + WJ = max(CI-CP, 0.0) * J / (CI + 2.0*CP) * PhotosynPathC3 + J * (1.0 - PhotosynPathC3) + WC = max(CI-CP, 0.0) * CarboxylRateMax / (CI + AWC) * PhotosynPathC3 + & + CarboxylRateMax * (1.0 - PhotosynPathC3) + WE = 0.5 * CarboxylRateMax * PhotosynPathC3 + & + 4000.0 * CarboxylRateMax * CI / PressureAirRefHeight * (1.0 - PhotosynPathC3) + PhotosynLeafTmp = min(WJ, WC, WE) * IndexGrowSeason + CS = max(PressureAtmosCO2-1.37*RLB*PressureAirRefHeight*PhotosynLeafTmp, MPE) + A = SlopeConductToPhotosyn * PhotosynLeafTmp * PressureAirRefHeight * CEA / & + (CS * VapPresSatCanopy) + ConductanceLeafMin + B = (SlopeConductToPhotosyn * PhotosynLeafTmp * PressureAirRefHeight / CS + ConductanceLeafMin) * & + RLB - 1.0 + C = -RLB + if ( B >= 0.0 ) then + Q = -0.5 * (B + sqrt(B*B-4.0*A*C)) + else + Q = -0.5 * (B - sqrt(B*B-4.0*A*C)) + endif + R1 = Q / A + R2 = C / Q + ResistanceStomataTmp = max(R1, R2) + CI = max(CS-PhotosynLeafTmp*PressureAirRefHeight*1.65*ResistanceStomataTmp, 0.0) + enddo + + ! ResistanceStomata: s m**2 / umol -> s/m + ResistanceStomataTmp = ResistanceStomataTmp * CF + + endif ! RadPhotoActAbsTmp > 0.0 + + ! assign updated values + ! Sunlit case + if ( IndexShade == 0 ) then + ResistanceStomataSunlit = ResistanceStomataTmp + PhotosynLeafSunlit = PhotosynLeafTmp + endif + ! Shaded case + if ( IndexShade == 1 ) then + ResistanceStomataShade = ResistanceStomataTmp + PhotosynLeafShade = PhotosynLeafTmp + endif + + end associate + + end subroutine ResistanceCanopyStomataBallBerry + +end module ResistanceCanopyStomataBallBerryMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/ResistanceCanopyStomataJarvisMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/ResistanceCanopyStomataJarvisMod.F90 new file mode 100644 index 0000000000..39388bd1cb --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/ResistanceCanopyStomataJarvisMod.F90 @@ -0,0 +1,112 @@ +module ResistanceCanopyStomataJarvisMod + +!!! Compute canopy stomatal resistance and foliage photosynthesis based on Jarvis scheme +!!! Canopy resistance which depends on incoming solar radiation, air temperature, +!!! atmospheric water vapor pressure deficit at the lowest model level, and soil moisture (preferably +!!! unfrozen soil moisture rather than total). +!!! Source: Jarvis (1976), Noilhan and Planton (1989), Jacquemin and Noilhan (1990). +!!! See also Chen et al (1996, JGR, Vol 101(D3), 7251-7268): Eqns 12-14 and Table 2 of Sec. 3.1.2 + + use Machine + use NoahmpVarType + use ConstantDefineMod + use HumiditySaturationMod, only : HumiditySaturation + + implicit none + +contains + + subroutine ResistanceCanopyStomataJarvis(noahmp, IndexShade) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: CANRES +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + integer , intent(in ) :: IndexShade ! index for sunlit/shaded (0=sunlit;1=shaded) + type(noahmp_type), intent(inout) :: noahmp + +! local variables + real(kind=kind_noahmp) :: ResistanceVapDef ! canopy resistance multiplier + real(kind=kind_noahmp) :: ResistanceSolar ! canopy resistance multiplier + real(kind=kind_noahmp) :: ResistanceTemp ! canopy resistance multiplier + real(kind=kind_noahmp) :: RadFac ! solar radiation factor for resistance + real(kind=kind_noahmp) :: SpecHumidityTmp ! specific humidity [kg/kg] + real(kind=kind_noahmp) :: MixingRatioTmp ! mixing ratio [kg/kg] + real(kind=kind_noahmp) :: MixingRatioSat ! saturated mixing ratio [kg/kg] + real(kind=kind_noahmp) :: MixingRatioSatTempD ! d(MixingRatioSat)/d(T) + real(kind=kind_noahmp) :: RadPhotoActAbsTmp ! temporary absorbed par for leaves [W/m2] + real(kind=kind_noahmp) :: ResistanceStomataTmp ! temporary leaf stomatal resistance [s/m] + real(kind=kind_noahmp) :: PhotosynLeafTmp ! temporary leaf photosynthesis [umol co2/m2/s] + +! -------------------------------------------------------------------- + associate( & + PressureAirRefHeight => noahmp%forcing%PressureAirRefHeight ,& ! in, air pressure [Pa] at reference height + SoilTranspFacAcc => noahmp%water%state%SoilTranspFacAcc ,& ! in, accumulated soil water transpiration factor (0 to 1) + RadiationStressFac => noahmp%energy%param%RadiationStressFac ,& ! in, Parameter used in radiation stress function + ResistanceStomataMin => noahmp%energy%param%ResistanceStomataMin ,& ! in, Minimum stomatal resistance [s m-1] + ResistanceStomataMax => noahmp%energy%param%ResistanceStomataMax ,& ! in, Maximal stomatal resistance [s m-1] + AirTempOptimTransp => noahmp%energy%param%AirTempOptimTransp ,& ! in, Optimum transpiration air temperature [K] + VaporPresDeficitFac => noahmp%energy%param%VaporPresDeficitFac ,& ! in, Parameter used in vapor pressure deficit function + TemperatureCanopy => noahmp%energy%state%TemperatureCanopy ,& ! in, vegetation temperature [K] + PressureVaporCanAir => noahmp%energy%state%PressureVaporCanAir ,& ! in, canopy air vapor pressure [Pa] + VegFrac => noahmp%energy%state%VegFrac ,& ! in, greeness vegetation fraction + RadPhotoActAbsSunlit => noahmp%energy%flux%RadPhotoActAbsSunlit ,& ! in, average absorbed par for sunlit leaves [W/m2] + RadPhotoActAbsShade => noahmp%energy%flux%RadPhotoActAbsShade ,& ! in, average absorbed par for shaded leaves [W/m2] + ResistanceStomataSunlit => noahmp%energy%state%ResistanceStomataSunlit ,& ! out, sunlit leaf stomatal resistance [s/m] + ResistanceStomataShade => noahmp%energy%state%ResistanceStomataShade ,& ! out, shaded leaf stomatal resistance [s/m] + PhotosynLeafSunlit => noahmp%biochem%flux%PhotosynLeafSunlit ,& ! out, sunlit leaf photosynthesis [umol CO2/m2/s] + PhotosynLeafShade => noahmp%biochem%flux%PhotosynLeafShade & ! out, shaded leaf photosynthesis [umol CO2/m2/s] + ) +! ---------------------------------------------------------------------- + + ! initialization + ResistanceSolar = 0.0 + ResistanceTemp = 0.0 + ResistanceVapDef = 0.0 + ResistanceStomataTmp = 0.0 + if ( IndexShade == 0 ) RadPhotoActAbsTmp = RadPhotoActAbsSunlit / max(VegFrac,1.0e-6) ! Sunlit case + if ( IndexShade == 1 ) RadPhotoActAbsTmp = RadPhotoActAbsShade / max(VegFrac,1.0e-6) ! Shaded case + + ! compute MixingRatioTmp and MixingRatioSat + SpecHumidityTmp = 0.622 * PressureVaporCanAir / (PressureAirRefHeight - 0.378*PressureVaporCanAir) ! specific humidity + MixingRatioTmp = SpecHumidityTmp / (1.0 - SpecHumidityTmp) ! convert to mixing ratio [kg/kg] + call HumiditySaturation(TemperatureCanopy, PressureAirRefHeight, MixingRatioSat, MixingRatioSatTempD) + + ! contribution due to incoming solar radiation + RadFac = 2.0 * RadPhotoActAbsTmp / RadiationStressFac + ResistanceSolar = (RadFac + ResistanceStomataMin/ResistanceStomataMax) / (1.0 + RadFac) + ResistanceSolar = max(ResistanceSolar, 0.0001) + + ! contribution due to air temperature + ResistanceTemp = 1.0 - 0.0016 * ((AirTempOptimTransp - TemperatureCanopy)**2.0) + ResistanceTemp = max(ResistanceTemp, 0.0001) + + ! contribution due to vapor pressure deficit + ResistanceVapDef = 1.0 / (1.0 + VaporPresDeficitFac * max(0.0, MixingRatioSat - MixingRatioTmp)) + ResistanceVapDef = max(ResistanceVapDef, 0.01) + + ! determine canopy resistance due to all factors + ResistanceStomataTmp = ResistanceStomataMin / (ResistanceSolar * ResistanceTemp * ResistanceVapDef * SoilTranspFacAcc) + PhotosynLeafTmp = -999.99 ! photosynthesis not applied for dynamic carbon + + ! assign updated values + ! Sunlit case + if ( IndexShade == 0 ) then + ResistanceStomataSunlit = ResistanceStomataTmp + PhotosynLeafSunlit = PhotosynLeafTmp + endif + ! Shaded case + if ( IndexShade == 1 ) then + ResistanceStomataShade = ResistanceStomataTmp + PhotosynLeafShade = PhotosynLeafTmp + endif + + end associate + + end subroutine ResistanceCanopyStomataJarvis + +end module ResistanceCanopyStomataJarvisMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/ResistanceGroundEvaporationGlacierMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/ResistanceGroundEvaporationGlacierMod.F90 new file mode 100644 index 0000000000..389536f642 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/ResistanceGroundEvaporationGlacierMod.F90 @@ -0,0 +1,44 @@ +module ResistanceGroundEvaporationGlacierMod + +!!! Compute glacier surface resistance to ground evaporation/sublimation +!!! It represents the resistance imposed by the molecular diffusion in +!!! surface (as opposed to aerodynamic resistance computed elsewhere in the model) + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine ResistanceGroundEvaporationGlacier(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: None (embedded in ENERGY_GLACIER subroutine) +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + +! in & out variables + type(noahmp_type), intent(inout) :: noahmp + +! local variables + +! -------------------------------------------------------------------- + associate( & + ResistanceGrdEvap => noahmp%energy%state%ResistanceGrdEvap ,& ! out, ground surface resistance [s/m] to evaporation + RelHumidityGrd => noahmp%energy%state%RelHumidityGrd & ! out, raltive humidity in surface glacier/snow air space + ) +! ---------------------------------------------------------------------- + + ResistanceGrdEvap = 1.0 + RelHumidityGrd = 1.0 + + end associate + + end subroutine ResistanceGroundEvaporationGlacier + +end module ResistanceGroundEvaporationGlacierMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/ResistanceGroundEvaporationMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/ResistanceGroundEvaporationMod.F90 new file mode 100644 index 0000000000..13a48b63ab --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/ResistanceGroundEvaporationMod.F90 @@ -0,0 +1,101 @@ +module ResistanceGroundEvaporationMod + +!!! Compute soil surface resistance to ground evaporation/sublimation +!!! It represents the resistance imposed by the molecular diffusion in soil +!!! surface (as opposed to aerodynamic resistance computed elsewhere in the model) + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine ResistanceGroundEvaporation(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: None (embedded in ENERGY subroutine) +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + +! in & out variables + type(noahmp_type), intent(inout) :: noahmp + +! local variables + real(kind=kind_noahmp) :: SoilEvapFac ! soil water evaporation factor (0- 1) + real(kind=kind_noahmp) :: DrySoilThickness ! Dry-layer thickness [m] for computing RSURF (Sakaguchi and Zeng, 2009) + real(kind=kind_noahmp) :: VapDiffuseRed ! Reduced vapor diffusivity [m2/s] in soil for computing RSURF (SZ09) + real(kind=kind_noahmp) :: SoilMatPotentialSfc ! surface layer soil matric potential [m] + +! -------------------------------------------------------------------- + associate( & + SurfaceType => noahmp%config%domain%SurfaceType ,& ! in, surface type 1-soil; 2-lake + DepthSoilLayer => noahmp%config%domain%DepthSoilLayer ,& ! in, depth [m] of layer-bottom from soil surface + FlagUrban => noahmp%config%domain%FlagUrban ,& ! in, logical flag for urban grid + OptGroundResistanceEvap => noahmp%config%nmlist%OptGroundResistanceEvap ,& ! in, options for ground resistance to evaporation/sublimation + ResistanceSoilExp => noahmp%energy%param%ResistanceSoilExp ,& ! in, exponent in the shape parameter for soil resistance + ResistanceSnowSfc => noahmp%energy%param%ResistanceSnowSfc ,& ! in, surface resistance for snow [s/m] + SoilMoistureSat => noahmp%water%param%SoilMoistureSat ,& ! in, saturated value of soil moisture [m3/m3] + SoilMoistureWilt => noahmp%water%param%SoilMoistureWilt ,& ! in, wilting point soil moisture [m3/m3] + SoilExpCoeffB => noahmp%water%param%SoilExpCoeffB ,& ! in, soil B parameter + SoilMatPotentialSat => noahmp%water%param%SoilMatPotentialSat ,& ! in, saturated soil matric potential [m] + SoilLiqWater => noahmp%water%state%SoilLiqWater ,& ! in, soil water content [m3/m3] + SnowCoverFrac => noahmp%water%state%SnowCoverFrac ,& ! in, snow cover fraction + SnowDepth => noahmp%water%state%SnowDepth ,& ! in, snow depth [m] + TemperatureGrd => noahmp%energy%state%TemperatureGrd ,& ! in, ground temperature [K] + ResistanceGrdEvap => noahmp%energy%state%ResistanceGrdEvap ,& ! out, ground surface resistance [s/m] to evaporation + RelHumidityGrd => noahmp%energy%state%RelHumidityGrd & ! out, raltive humidity in surface soil/snow air space + ) +! ---------------------------------------------------------------------- + + ! initialization + SoilEvapFac = max(0.0, SoilLiqWater(1)/SoilMoistureSat(1)) + + if ( SurfaceType == 2 ) then ! lake point + ResistanceGrdEvap = 1.0 ! avoid being divided by 0 + RelHumidityGrd = 1.0 + else ! soil point + ! Sakaguchi and Zeng, 2009 + if ( (OptGroundResistanceEvap == 1) .or. (OptGroundResistanceEvap == 4) ) then + DrySoilThickness = (-DepthSoilLayer(1)) * (exp((1.0 - min(1.0,SoilLiqWater(1)/SoilMoistureSat(1))) ** & + ResistanceSoilExp) - 1.0) / (2.71828-1.0) + VapDiffuseRed = 2.2e-5 * SoilMoistureSat(1) * SoilMoistureSat(1) * & + (1.0 - SoilMoistureWilt(1)/SoilMoistureSat(1)) ** (2.0 + 3.0/SoilExpCoeffB(1)) + ResistanceGrdEvap = DrySoilThickness / VapDiffuseRed + + ! Sellers (1992) original + elseif ( OptGroundResistanceEvap == 2 ) then + ResistanceGrdEvap = SnowCoverFrac * 1.0 + (1.0 - SnowCoverFrac) * exp(8.25 - 4.225*SoilEvapFac) + + ! Sellers (1992) adjusted to decrease ResistanceGrdEvap for wet soil + elseif ( OptGroundResistanceEvap == 3 ) then + ResistanceGrdEvap = SnowCoverFrac * 1.0 + (1.0 - SnowCoverFrac) * exp(8.25 - 6.0*SoilEvapFac) + endif + + ! SnowCoverFrac weighted; snow ResistanceGrdEvap set in MPTABLE v3.8 + if ( OptGroundResistanceEvap == 4 ) then + ResistanceGrdEvap = 1.0 / (SnowCoverFrac * (1.0/ResistanceSnowSfc) + & + (1.0-SnowCoverFrac) * (1.0/max(ResistanceGrdEvap,0.001))) + endif + if ( (SoilLiqWater(1) < 0.01) .and. (SnowDepth == 0.0) ) ResistanceGrdEvap = 1.0e6 + + SoilMatPotentialSfc = -SoilMatPotentialSat(1) * & + (max(0.01,SoilLiqWater(1)) / SoilMoistureSat(1)) ** (-SoilExpCoeffB(1)) + RelHumidityGrd = SnowCoverFrac + & + (1.0-SnowCoverFrac) * exp(SoilMatPotentialSfc*ConstGravityAcc/(ConstGasWaterVapor*TemperatureGrd)) + endif + + ! urban + if ( (FlagUrban .eqv. .true.) .and. (SnowDepth == 0.0) ) then + ResistanceGrdEvap = 1.0e6 + endif + + end associate + + end subroutine ResistanceGroundEvaporation + +end module ResistanceGroundEvaporationMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/ResistanceLeafToGroundMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/ResistanceLeafToGroundMod.F90 new file mode 100644 index 0000000000..8f2811d6d0 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/ResistanceLeafToGroundMod.F90 @@ -0,0 +1,106 @@ +module ResistanceLeafToGroundMod + +!!! Compute under-canopy aerodynamic resistance and leaf boundary layer resistance + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine ResistanceLeafToGround(noahmp, IndIter, VegAreaIndEff, HeatSenGrdTmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: RAGRB +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + integer , intent(in ) :: IndIter ! iteration index + real(kind=kind_noahmp), intent(in ) :: HeatSenGrdTmp ! temporary ground sensible heat flux (w/m2) in each iteration + real(kind=kind_noahmp), intent(in ) :: VegAreaIndEff ! temporary effective vegetation area index with constraint (<=6.0) + type(noahmp_type) , intent(inout) :: noahmp + +! local variable + real(kind=kind_noahmp) :: MPE ! prevents overflow for division by zero + real(kind=kind_noahmp) :: KH ! turbulent transfer coefficient, sensible heat, (m2/s) + real(kind=kind_noahmp) :: TMP1 ! temporary calculation + real(kind=kind_noahmp) :: TMP2 ! temporary calculation + real(kind=kind_noahmp) :: TMPRAH2 ! temporary calculation for aerodynamic resistances + real(kind=kind_noahmp) :: TMPRB ! temporary calculation for rb + real(kind=kind_noahmp) :: FHGNEW ! temporary vars + +! -------------------------------------------------------------------- + associate( & + LeafDimLength => noahmp%energy%param%LeafDimLength ,& ! in, characteristic leaf dimension [m] + CanopyWindExtFac => noahmp%energy%param%CanopyWindExtFac ,& ! in, canopy wind extinction parameter + DensityAirRefHeight => noahmp%energy%state%DensityAirRefHeight ,& ! in, density air [kg/m3] + TemperatureCanopyAir => noahmp%energy%state%TemperatureCanopyAir ,& ! in, canopy air temperature [K] + ZeroPlaneDispSfc => noahmp%energy%state%ZeroPlaneDispSfc ,& ! in, zero plane displacement [m] + RoughLenMomGrd => noahmp%energy%state%RoughLenMomGrd ,& ! in, roughness length [m], momentum, ground + CanopyHeight => noahmp%energy%state%CanopyHeight ,& ! in, canopy height [m] + WindSpdCanopyTop => noahmp%energy%state%WindSpdCanopyTop ,& ! in, wind speed at top of canopy [m/s] + RoughLenShCanopy => noahmp%energy%state%RoughLenShCanopy ,& ! in, roughness length [m], sensible heat, canopy + RoughLenShVegGrd => noahmp%energy%state%RoughLenShVegGrd ,& ! in, roughness length [m], sensible heat ground, below canopy + FrictionVelVeg => noahmp%energy%state%FrictionVelVeg ,& ! in, friction velocity [m/s], vegetated + MoStabCorrShUndCan => noahmp%energy%state%MoStabCorrShUndCan ,& ! inout, stability correction ground, below canopy + WindExtCoeffCanopy => noahmp%energy%state%WindExtCoeffCanopy ,& ! out, canopy wind extinction coefficient + MoStabParaUndCan => noahmp%energy%state%MoStabParaUndCan ,& ! out, Monin-Obukhov stability parameter ground, below canopy + MoLengthUndCan => noahmp%energy%state%MoLengthUndCan ,& ! out, Monin-Obukhov length [m], ground, below canopy + ResistanceMomUndCan => noahmp%energy%state%ResistanceMomUndCan ,& ! out, ground aerodynamic resistance for momentum [s/m] + ResistanceShUndCan => noahmp%energy%state%ResistanceShUndCan ,& ! out, ground aerodynamic resistance for sensible heat [s/m] + ResistanceLhUndCan => noahmp%energy%state%ResistanceLhUndCan ,& ! out, ground aerodynamic resistance for water vapor [s/m] + ResistanceLeafBoundary => noahmp%energy%state%ResistanceLeafBoundary & ! out, bulk leaf boundary layer resistance [s/m] + ) +! ---------------------------------------------------------------------- + + ! initialization + MPE = 1.0e-6 + MoStabParaUndCan = 0.0 + MoLengthUndCan = 0.0 + + ! stability correction to below canopy resistance + if ( IndIter > 1 ) then + TMP1 = ConstVonKarman * (ConstGravityAcc / TemperatureCanopyAir) * HeatSenGrdTmp / & + (DensityAirRefHeight * ConstHeatCapacAir) + if ( abs(TMP1) <= MPE ) TMP1 = MPE + MoLengthUndCan = -1.0 * FrictionVelVeg**3 / TMP1 + MoStabParaUndCan = min((ZeroPlaneDispSfc-RoughLenMomGrd)/MoLengthUndCan, 1.0) + endif + if ( MoStabParaUndCan < 0.0 ) then + FHGNEW = (1.0 - 15.0 * MoStabParaUndCan)**(-0.25) + else + FHGNEW = 1.0 + 4.7 * MoStabParaUndCan + endif + if ( IndIter == 1 ) then + MoStabCorrShUndCan = FHGNEW + else + MoStabCorrShUndCan = 0.5 * (MoStabCorrShUndCan + FHGNEW) + endif + + ! wind attenuation within canopy + WindExtCoeffCanopy = (CanopyWindExtFac * VegAreaIndEff * CanopyHeight * MoStabCorrShUndCan)**0.5 + TMP1 = exp(-WindExtCoeffCanopy * RoughLenShVegGrd / CanopyHeight) + TMP2 = exp(-WindExtCoeffCanopy * (RoughLenShCanopy + ZeroPlaneDispSfc) / CanopyHeight) + TMPRAH2 = CanopyHeight * exp(WindExtCoeffCanopy) / WindExtCoeffCanopy * (TMP1-TMP2) + + ! aerodynamic resistances raw and rah between heights ZeroPlaneDisp+RoughLenShVegGrd and RoughLenShVegGrd. + KH = max(ConstVonKarman*FrictionVelVeg*(CanopyHeight-ZeroPlaneDispSfc), MPE) + ResistanceMomUndCan = 0.0 + ResistanceShUndCan = TMPRAH2 / KH + ResistanceLhUndCan = ResistanceShUndCan + + ! leaf boundary layer resistance + TMPRB = WindExtCoeffCanopy * 50.0 / (1.0 - exp(-WindExtCoeffCanopy/2.0)) + ResistanceLeafBoundary = TMPRB * sqrt(LeafDimLength / WindSpdCanopyTop) + ResistanceLeafBoundary = min(max(ResistanceLeafBoundary, 5.0), 50.0) ! limit ResistanceLeafBoundary to 5-50, typically <50 + + end associate + + end subroutine ResistanceLeafToGround + +end module ResistanceLeafToGroundMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/RunoffSubSurfaceDrainageMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/RunoffSubSurfaceDrainageMod.F90 new file mode 100644 index 0000000000..495756a2a4 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/RunoffSubSurfaceDrainageMod.F90 @@ -0,0 +1,39 @@ +module RunoffSubSurfaceDrainageMod + +!!! Calculate subsurface runoff using derived soil water drainage rate + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine RunoffSubSurfaceDrainage(noahmp) + +! ------------------------ Code history -------------------------------------------------- +! Originally embeded in WATER subroutine instead of as a separate subroutine +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! -------------------------------------------------------------------- + associate( & + DrainSoilBot => noahmp%water%flux%DrainSoilBot ,& ! in, soil bottom drainage [mm/s] + RunoffSubsurface => noahmp%water%flux%RunoffSubsurface & ! inout, subsurface runoff [mm/s] + ) +! ---------------------------------------------------------------------- + + ! compuate subsurface runoff mm/s + RunoffSubsurface = RunoffSubsurface + DrainSoilBot + + end associate + + end subroutine RunoffSubSurfaceDrainage + +end module RunoffSubSurfaceDrainageMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/RunoffSubSurfaceEquiWaterTableMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/RunoffSubSurfaceEquiWaterTableMod.F90 new file mode 100644 index 0000000000..fa87cba82f --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/RunoffSubSurfaceEquiWaterTableMod.F90 @@ -0,0 +1,52 @@ +module RunoffSubSurfaceEquiWaterTableMod + +!!! Calculate subsurface runoff using equilibrium water table depth (Niu et al., 2005) + + use Machine + use NoahmpVarType + use ConstantDefineMod + use WaterTableEquilibriumMod, only : WaterTableEquilibrium + + implicit none + +contains + + subroutine RunoffSubSurfaceEquiWaterTable(noahmp) + +! ------------------------ Code history -------------------------------------------------- +! Originally embeded in SOILWATER subroutine instead of as a separate subroutine +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! -------------------------------------------------------------------- + associate( & + SoilImpervFracMax => noahmp%water%state%SoilImpervFracMax ,& ! in, maximum soil imperviousness fraction + GridTopoIndex => noahmp%water%param%GridTopoIndex ,& ! in, gridcell mean topgraphic index (global mean) + RunoffDecayFac => noahmp%water%param%RunoffDecayFac ,& ! in, runoff decay factor [m-1] + BaseflowCoeff => noahmp%water%param%BaseflowCoeff ,& ! inout, baseflow coefficient [mm/s] + WaterTableDepth => noahmp%water%state%WaterTableDepth ,& ! out, water table depth [m] + RunoffSubsurface => noahmp%water%flux%RunoffSubsurface & ! out, subsurface runoff [mm/s] + ) +! ---------------------------------------------------------------------- + + ! set parameter values specific for this scheme + RunoffDecayFac = 2.0 + BaseflowCoeff = 4.0 + + ! compute equilibrium water table depth + call WaterTableEquilibrium(noahmp) + + ! compuate subsurface runoff mm/s + RunoffSubsurface = (1.0 - SoilImpervFracMax) * BaseflowCoeff * & + exp(-GridTopoIndex) * exp(-RunoffDecayFac * WaterTableDepth) + + end associate + + end subroutine RunoffSubSurfaceEquiWaterTable + +end module RunoffSubSurfaceEquiWaterTableMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/RunoffSubSurfaceGroundWaterMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/RunoffSubSurfaceGroundWaterMod.F90 new file mode 100644 index 0000000000..7659c7e5ef --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/RunoffSubSurfaceGroundWaterMod.F90 @@ -0,0 +1,43 @@ +module RunoffSubSurfaceGroundWaterMod + +!!! Calculate subsurface runoff based on TOPMODEL with groundwater (Niu et al 2007) + + use Machine + use NoahmpVarType + use ConstantDefineMod + use GroundWaterTopModelMod, only : GroundWaterTopModel + + implicit none + +contains + + subroutine RunoffSubSurfaceGroundWater(noahmp) + +! ------------------------ Code history -------------------------------------------------- +! Originally embeded in WATER subroutine instead of as a separate subroutine +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! -------------------------------------------------------------------- + associate( & + DischargeGw => noahmp%water%flux%DischargeGw ,& ! out, groundwater discharge [mm/s] + RunoffSubsurface => noahmp%water%flux%RunoffSubsurface & ! out, subsurface runoff [mm/s] + ) +! ---------------------------------------------------------------------- + + ! compute ground water + call GroundWaterTopModel(noahmp) + + ! compute subsurface runoff as groundwater discharge + RunoffSubsurface = DischargeGw + + end associate + + end subroutine RunoffSubSurfaceGroundWater + +end module RunoffSubSurfaceGroundWaterMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/RunoffSubSurfaceShallowMmfMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/RunoffSubSurfaceShallowMmfMod.F90 new file mode 100644 index 0000000000..302f8c79bc --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/RunoffSubSurfaceShallowMmfMod.F90 @@ -0,0 +1,52 @@ +module RunoffSubSurfaceShallowMmfMod + +!!! Calculate subsurface runoff based on MMF groundwater scheme + + use Machine + use NoahmpVarType + use ConstantDefineMod + use ShallowWaterTableMmfMod, only : ShallowWaterTableMMF + + implicit none + +contains + + subroutine RunoffSubSurfaceShallowWaterMMF(noahmp) + +! ------------------------ Code history -------------------------------------------------- +! Originally embeded in WATER subroutine instead of as a separate subroutine +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + SoilIce => noahmp%water%state%SoilIce ,& ! in, soil ice content [m3/m3] + DrainSoilBot => noahmp%water%flux%DrainSoilBot ,& ! in, soil bottom drainage [mm/s] + SoilLiqWater => noahmp%water%state%SoilLiqWater ,& ! inout, soil water content [m3/m3] + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! inout, total soil water content [m3/m3] + WaterStorageAquifer => noahmp%water%state%WaterStorageAquifer ,& ! inout, water storage in aquifer [mm] + RunoffSubsurface => noahmp%water%flux%RunoffSubsurface & ! out, subsurface runoff [mm/s] + ) +! ---------------------------------------------------------------------- + + ! compute shallow water table and moisture + call ShallowWaterTableMMF(noahmp) + + ! update moisture + SoilLiqWater(NumSoilLayer) = SoilMoisture(NumSoilLayer) - SoilIce(NumSoilLayer) + + ! compute subsurface runoff + RunoffSubsurface = RunoffSubsurface + DrainSoilBot + WaterStorageAquifer = 0.0 + + end associate + + end subroutine RunoffSubSurfaceShallowWaterMMF + +end module RunoffSubSurfaceShallowMmfMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/RunoffSurfaceBatsMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/RunoffSurfaceBatsMod.F90 new file mode 100644 index 0000000000..1b9204b7e0 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/RunoffSurfaceBatsMod.F90 @@ -0,0 +1,68 @@ +module RunoffSurfaceBatsMod + +!!! Calculate surface runoff based on BATS scheme + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine RunoffSurfaceBATS(noahmp) + +! ------------------------ Code history -------------------------------------------------- +! Originally embeded in SOILWATER subroutine instead of as a separate subroutine +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variables + integer :: LoopInd ! loop index + real(kind=kind_noahmp) :: SoilMoistureTmp ! 2-m averaged soil moisture (m3/m3) + real(kind=kind_noahmp) :: SoilDepthTmp ! 2-m soil depth (m) + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! in, thickness of snow/soil layers [m] + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! in, total soil water content [m3/m3] + SoilImpervFrac => noahmp%water%state%SoilImpervFrac ,& ! in, impervious fraction due to frozen soil + SoilSfcInflowMean => noahmp%water%flux%SoilSfcInflowMean ,& ! in, water input on soil surface [m/s] + SoilMoistureSat => noahmp%water%param%SoilMoistureSat ,& ! in, saturated value of soil moisture [m3/m3] + SoilSaturateFrac => noahmp%water%state%SoilSaturateFrac ,& ! out, fractional saturated area for soil moisture + RunoffSurface => noahmp%water%flux%RunoffSurface ,& ! out, surface runoff [m/s] + InfilRateSfc => noahmp%water%flux%InfilRateSfc & ! out, infiltration rate at surface [m/s] + ) +! ---------------------------------------------------------------------- + + ! initialization + SoilMoistureTmp = 0.0 + SoilDepthTmp = 0.0 + + ! compute mean soil moisture, depth and saturation fraction + do LoopInd = 1, NumSoilLayer + SoilDepthTmp = SoilDepthTmp + ThicknessSnowSoilLayer(LoopInd) + SoilMoistureTmp = SoilMoistureTmp + & + SoilMoisture(LoopInd) / SoilMoistureSat(LoopInd) * ThicknessSnowSoilLayer(LoopInd) + if ( SoilDepthTmp >= 2.0 ) exit + enddo + SoilMoistureTmp = SoilMoistureTmp / SoilDepthTmp + SoilSaturateFrac = max(0.01, SoilMoistureTmp)**4.0 ! BATS + + ! compute surface runoff and infiltration m/s + if ( SoilSfcInflowMean > 0.0 ) then + RunoffSurface = SoilSfcInflowMean * ((1.0-SoilImpervFrac(1)) * SoilSaturateFrac + SoilImpervFrac(1)) + InfilRateSfc = SoilSfcInflowMean - RunoffSurface + endif + + end associate + + end subroutine RunoffSurfaceBATS + +end module RunoffSurfaceBatsMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/RunoffSurfaceDynamicVicMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/RunoffSurfaceDynamicVicMod.F90 new file mode 100644 index 0000000000..d9f75e40ba --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/RunoffSurfaceDynamicVicMod.F90 @@ -0,0 +1,300 @@ +module RunoffSurfaceDynamicVicMod + +!!! Compuate inflitration rate at soil surface and estimate surface runoff based on dynamic VIC scheme +!!! Reference: Liang, X., & Xie, Z. (2001). A new surface runoff parameterization with subgrid-scale +!!! soil heterogeneity for land surface models. Advances in Water Resources, 24(9-10), 1173-1193. + + use Machine + use NoahmpVarType + use ConstantDefineMod + use SoilWaterInfilPhilipMod, only : SoilWaterInfilPhilip + use SoilWaterInfilGreenAmptMod, only : SoilWaterInfilGreenAmpt + use SoilWaterInfilSmithParlangeMod, only : SoilWaterInfilSmithParlange + use RunoffSurfaceExcessDynamicVicMod + + implicit none + +contains + + subroutine RunoffSurfaceDynamicVic(noahmp, TimeStep, InfilRateAcc) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: DYNAMIC_VIC +! Original code: Prasanth Valayamkunnath +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + +! in & out variabls + type(noahmp_type) , intent(inout) :: noahmp + real(kind=kind_noahmp), intent(in) :: TimeStep ! timestep (may not be the same as model timestep) + real(kind=kind_noahmp), intent(inout) :: InfilRateAcc ! accumulated infiltration rate (m/s) + +! local variable + integer :: IndIter ! iteration index + integer :: NumIter ! number of interation + integer :: IndInfilMax ! index to check maximum infiltration at SoilMoistureWilt + real(kind=kind_noahmp) :: InfilExpB ! B parameter for infiltration scaling curve + real(kind=kind_noahmp) :: WaterDepthTop ! actual water depth in top layers [m] + real(kind=kind_noahmp) :: WaterDepthSatTop ! saturated water depth in top layers [m] + real(kind=kind_noahmp) :: WaterInSoilSfc ! water input on soil surface [m] + real(kind=kind_noahmp) :: WaterDepthInit ! initial water depth [m] + real(kind=kind_noahmp) :: WaterDepthMax ! maximum water depth [m] + real(kind=kind_noahmp) :: InfilSfcTmp ! surface infiltration rate [m/s] + real(kind=kind_noahmp) :: InfilSfcMax ! maximum infiltration rate [m/s] + real(kind=kind_noahmp) :: RunoffSatExcess ! saturation excess runoff [m/s] + real(kind=kind_noahmp) :: RunoffInfilExcess ! infiltration excess runoff [m/s] + real(kind=kind_noahmp) :: InfilTmp ! infiltration [m/s] + real(kind=kind_noahmp) :: RunoffSatExcTmp ! temporary saturation excess runoff [m/s] + real(kind=kind_noahmp) :: RunoffInfExcTmp ! temporary infiltration excess runoff [m/s] + real(kind=kind_noahmp) :: RunoffSatExcTmp1 ! saturation excess runoff [m/s] + real(kind=kind_noahmp) :: DepthYTmp ! temporary depth Y [m] + real(kind=kind_noahmp) :: DepthYPrev ! previous depth Y [m] + real(kind=kind_noahmp) :: DepthYInit ! initial depth Y [m] + real(kind=kind_noahmp) :: TmpVar1 ! temporary variable + real(kind=kind_noahmp) :: Error ! allowed error + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + DepthSoilLayer => noahmp%config%domain%DepthSoilLayer ,& ! in, depth [m] of layer-bottom from soil surface + OptDynVicInfiltration => noahmp%config%nmlist%OptDynVicInfiltration ,& ! in, options for infiltration in dynamic VIC runoff scheme + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! in, total soil moisture [m3/m3] + SoilSfcInflowMean => noahmp%water%flux%SoilSfcInflowMean ,& ! in, mean water input on soil surface [m/s] + SoilMoistureSat => noahmp%water%param%SoilMoistureSat ,& ! in, saturated value of soil moisture [m3/m3] + InfilHeteroDynVic => noahmp%water%param%InfilHeteroDynVic ,& ! in, Dynamic VIC heterogeniety parameter for infiltration + InfilFacDynVic => noahmp%water%param%InfilFacDynVic ,& ! in, Dynamic VIC model infiltration parameter + RunoffSurface => noahmp%water%flux%RunoffSurface ,& ! out, surface runoff [m/s] + InfilRateSfc => noahmp%water%flux%InfilRateSfc & ! out, infiltration rate at surface [m/s] + ) +! ---------------------------------------------------------------------- + + ! initialization + WaterDepthTop = 0.0 + WaterDepthSatTop = 0.0 + InfilExpB = 1.0 + WaterInSoilSfc = 0.0 + WaterDepthMax = 0.0 + WaterDepthInit = 0.0 + RunoffSatExcess = 0.0 + RunoffInfilExcess = 0.0 + InfilTmp = 0.0 + RunoffSurface = 0.0 + InfilRateSfc = 0.0 + NumIter = 20 + Error = 1.388889E-07 * TimeStep ! 0.5 mm per hour time step + InfilExpB = InfilHeteroDynVic + + do IndIter = 1, NumSoilLayer-2 + WaterDepthTop = WaterDepthTop + (SoilMoisture(IndIter) * (-1.0) * DepthSoilLayer(IndIter)) ! actual moisture in top layers, [m] + WaterDepthSatTop = WaterDepthSatTop + (SoilMoistureSat(IndIter) * (-1.0) * DepthSoilLayer(IndIter)) ! maximum moisture in top layers, [m] + enddo + if ( WaterDepthTop > WaterDepthSatTop ) WaterDepthTop = WaterDepthSatTop + + WaterInSoilSfc = SoilSfcInflowMean * TimeStep ! precipitation depth, [m] + WaterDepthMax = WaterDepthSatTop * (InfilFacDynVic + 1.0) ! maximum infiltration capacity [m], Eq.14 + WaterDepthInit = WaterDepthMax * (1.0 - (1.0 - (WaterDepthTop/WaterDepthSatTop)**(1.0/(1.0+InfilFacDynVic)))) ! infiltration capacity, [m] in Eq.1 + !WaterDepthMax = CAP_minf ; WaterDepthInit = A + IndInfilMax = 0 + + ! compute surface infiltration + if ( OptDynVicInfiltration == 1 ) then + call SoilWaterInfilPhilip(noahmp, TimeStep, IndInfilMax, InfilRateAcc, InfilSfcTmp) + else if ( OptDynVicInfiltration == 2 ) then + call SoilWaterInfilGreenAmpt(noahmp, IndInfilMax, InfilRateAcc, InfilSfcTmp) + else if ( OptDynVicInfiltration == 3 ) then + call SoilWaterInfilSmithParlange(noahmp, IndInfilMax, InfilRateAcc, InfilSfcTmp) + endif + + ! I_MM = InfilSfcTmp; I_M = InfilSfcMax + InfilSfcMax = (InfilExpB + 1.0) * InfilSfcTmp + if ( WaterInSoilSfc <= 0.0 ) then + RunoffSatExcess = 0.0 + RunoffInfilExcess = 0.0 + InfilTmp = 0.0 + goto 2001 + else + if ( (WaterDepthTop >= WaterDepthSatTop) .and. (WaterDepthInit >= WaterDepthMax) ) then + WaterDepthTop = WaterDepthSatTop + WaterDepthInit = WaterDepthMax + RunoffSatExcess = WaterInSoilSfc + RunoffInfilExcess = 0.0 + InfilTmp = 0.0 + goto 2001 + else + WaterDepthInit = WaterDepthMax * (1.0-(1.0-(WaterDepthTop/WaterDepthSatTop)**(1.0/(1.0+InfilFacDynVic)))) + if ( (WaterInSoilSfc+WaterDepthInit) > WaterDepthMax ) then + if ( (InfilSfcMax*TimeStep) >= WaterInSoilSfc) then + DepthYTmp = WaterDepthMax - WaterDepthInit + RunoffSatExcTmp = 0.0 + call RunoffSatExcessDynamicVic(noahmp,WaterDepthInit,WaterDepthMax,DepthYTmp,RunoffSatExcTmp) + TmpVar1 = WaterDepthMax - WaterDepthInit - RunoffSatExcTmp - (InfilSfcTmp*TimeStep) * & + (1.0-(1.0-((WaterInSoilSfc-RunoffSatExcTmp)/(InfilSfcMax*TimeStep))**(InfilExpB+1.0))) + if ( TmpVar1 <= 0.0 ) then + DepthYTmp = WaterDepthMax - WaterDepthInit + InfilTmp = WaterDepthSatTop - WaterDepthTop + RunoffSatExcess = WaterInSoilSfc - InfilTmp + RunoffInfilExcess = 0.0 + WaterDepthTop = WaterDepthSatTop + WaterDepthInit = WaterDepthMax + goto 2001 + else + DepthYTmp = 0.0 + do IndIter = 1, NumIter ! loop : iteration 1 + DepthYPrev = DepthYTmp + RunoffSatExcTmp = 0.0 + call RunoffSatExcessDynamicVic(noahmp,WaterDepthInit,WaterDepthMax,DepthYTmp,RunoffSatExcTmp) + DepthYTmp = RunoffSatExcTmp + ((InfilSfcTmp*TimeStep) * & + (1.0-(1.0-((WaterInSoilSfc-RunoffSatExcTmp)/(InfilSfcMax*TimeStep))**(InfilExpB+1.0)))) + if ( (abs(DepthYTmp-DepthYPrev) <= Error) .or. (IndIter == NumIter) ) then + goto 1003 + endif + enddo + endif + else + RunoffSatExcTmp = 0.0 + call RunoffSatExcessDynamicVic(noahmp,WaterDepthInit,WaterDepthMax,DepthYTmp,RunoffSatExcTmp) + if ( (RunoffSatExcTmp+(InfilSfcMax*TimeStep)) <= WaterInSoilSfc ) then + if ( (WaterDepthMax-WaterDepthInit-RunoffSatExcTmp-(InfilSfcMax*TimeStep)) <= 0.0 ) then + DepthYTmp = WaterDepthMax - WaterDepthInit + InfilTmp = WaterDepthSatTop - WaterDepthTop + RunoffSatExcess = WaterInSoilSfc - InfilTmp + RunoffInfilExcess = 0.0 + WaterDepthTop = WaterDepthSatTop + WaterDepthInit = WaterDepthMax + goto 2001 + else + DepthYTmp = 0.0 + do IndIter = 1, NumIter ! loop : iteration 2 + DepthYPrev = DepthYTmp + RunoffSatExcTmp = 0.0 + call RunoffSatExcessDynamicVic(noahmp,WaterDepthInit,WaterDepthMax,DepthYTmp,RunoffSatExcTmp) + DepthYTmp = RunoffSatExcTmp + (InfilSfcTmp*TimeStep) + if ( (abs(DepthYTmp-DepthYPrev) <= Error) .or. (IndIter == NumIter) ) then + goto 1003 + endif + enddo + endif + else + DepthYTmp = WaterInSoilSfc / 2.0 + do IndIter = 1, NumIter ! loop : iteration 3_0 + DepthYPrev = DepthYTmp + RunoffSatExcTmp = 0.0 + call RunoffSatExcessDynamicVic(noahmp,WaterDepthInit,WaterDepthMax,DepthYTmp,RunoffSatExcTmp) + DepthYTmp = DepthYTmp - RunoffSatExcTmp - (InfilSfcTmp*TimeStep) + WaterInSoilSfc + if ( DepthYTmp <= 0.0 ) DepthYTmp = 0.0 + if ( DepthYTmp >= WaterInSoilSfc ) DepthYTmp = WaterInSoilSfc + if ( (abs(DepthYTmp-DepthYPrev) <= Error) .or. (IndIter == NumIter) ) then + DepthYInit = DepthYTmp + exit + endif + enddo + do IndIter = 1, NumIter ! loop : iteration 3 + DepthYPrev = DepthYTmp + RunoffSatExcTmp = 0.0 + RunoffInfExcTmp = 0.0 + call RunoffSatExcessDynamicVic(noahmp,WaterDepthInit,WaterDepthMax,DepthYTmp,RunoffSatExcTmp) + call RunoffInfilExcessDynamicVic(DepthYTmp,DepthYInit,RunoffSatExcTmp,InfilSfcMax,& + InfilSfcTmp,TimeStep,WaterInSoilSfc,InfilExpB,RunoffInfExcTmp) + DepthYTmp = WaterInSoilSfc - RunoffInfExcTmp + if ( (abs(DepthYTmp-DepthYPrev) <= Error) .or. (IndIter == NumIter) ) then + goto 1003 + endif + enddo +1003 if ( DepthYTmp <= 0.0 ) DepthYTmp = 0.0 + if ( DepthYTmp >= WaterInSoilSfc ) DepthYTmp = WaterInSoilSfc + call RunoffSatExcessDynamicVic(noahmp,WaterDepthInit,WaterDepthMax,DepthYTmp,RunoffSatExcTmp1) + RunoffSatExcess = RunoffSatExcTmp1 + RunoffInfilExcess = WaterInSoilSfc - DepthYTmp + InfilTmp = DepthYTmp - RunoffSatExcess + WaterDepthTop = WaterDepthTop + InfilTmp + DepthYTmp = WaterDepthInit + DepthYTmp + if ( WaterDepthTop <= 0.0 ) WaterDepthTop = 0.0 + if ( WaterDepthTop >= WaterDepthSatTop ) WaterDepthTop = WaterDepthSatTop + WaterDepthInit = WaterDepthMax * (1.0-(1.0-(WaterDepthTop/WaterDepthSatTop)**(1.0/(1.0+InfilFacDynVic)))) + goto 2001 + endif + endif + else + if ( (InfilSfcMax*TimeStep) >= WaterInSoilSfc) then + DepthYTmp = WaterInSoilSfc / 2.0 + do IndIter = 1, NumIter ! iteration 1 + DepthYPrev = DepthYTmp + RunoffSatExcTmp = 0.0 + call RunoffSatExcessDynamicVic(noahmp,WaterDepthInit,WaterDepthMax,DepthYTmp,RunoffSatExcTmp) + DepthYTmp = RunoffSatExcTmp + ((InfilSfcTmp*TimeStep) * & + (1.0-(1.0-((WaterInSoilSfc-RunoffSatExcTmp)/(InfilSfcMax*TimeStep))**(InfilExpB+1.0)))) + if ( (abs(DepthYTmp-DepthYPrev) <= Error) .or. (IndIter == NumIter) ) then + goto 1004 + endif + enddo + else + RunoffSatExcTmp = 0.0 + call RunoffSatExcessDynamicVic(noahmp,WaterDepthInit,WaterDepthMax,DepthYTmp,RunoffSatExcTmp) + if ( (RunoffSatExcTmp+(InfilSfcMax*TimeStep)) <= WaterInSoilSfc ) then + DepthYTmp = WaterInSoilSfc / 2.0 + do IndIter = 1, NumIter ! iteration 2 + DepthYPrev = DepthYTmp + RunoffSatExcTmp = 0.0 + call RunoffSatExcessDynamicVic(noahmp,WaterDepthInit,WaterDepthMax,DepthYTmp,RunoffSatExcTmp) + DepthYTmp = RunoffSatExcTmp+(InfilSfcTmp*TimeStep) + if ( (abs(DepthYTmp-DepthYPrev) <= Error) .or. (IndIter == NumIter) ) then + goto 1004 + endif + enddo + else + DepthYTmp = 0.0 + do IndIter = 1, NumIter ! iteration 3_0 + DepthYPrev = DepthYTmp + RunoffSatExcTmp = 0.0 + call RunoffSatExcessDynamicVic(noahmp,WaterDepthInit,WaterDepthMax,DepthYTmp,RunoffSatExcTmp) + DepthYTmp = (WaterInSoilSfc - (InfilSfcMax*TimeStep)) + DepthYTmp - RunoffSatExcTmp + if ( DepthYTmp <= 0.0 ) DepthYTmp = 0.0 + if ( DepthYTmp >= WaterInSoilSfc ) DepthYTmp = WaterInSoilSfc + RunoffSatExcTmp = 0.0 + call RunoffSatExcessDynamicVic(noahmp,WaterDepthInit,WaterDepthMax,DepthYTmp,RunoffSatExcTmp) + if ( (abs(RunoffSatExcTmp+(InfilSfcMax*TimeStep)-WaterInSoilSfc) <= Error) .or. (IndIter == NumIter) ) then + DepthYInit = DepthYTmp + exit + endif + enddo + do IndIter = 1, NumIter ! iteration 3 + DepthYPrev = DepthYTmp + RunoffSatExcTmp = 0.0 + RunoffInfExcTmp = 0.0 + call RunoffSatExcessDynamicVic(noahmp,WaterDepthInit,WaterDepthMax,DepthYTmp,RunoffSatExcTmp) + call RunoffInfilExcessDynamicVic(DepthYTmp,DepthYInit,RunoffSatExcTmp,InfilSfcMax,& + InfilSfcTmp,TimeStep,WaterInSoilSfc,InfilExpB,RunoffInfExcTmp) + DepthYTmp = WaterInSoilSfc - RunoffInfExcTmp + if ( (abs(DepthYTmp-DepthYPrev) <= Error) .or. (IndIter == NumIter) ) then + goto 1004 + endif + enddo + endif + endif +1004 if ( DepthYTmp <= 0.0 ) DepthYTmp = 0.0 + if ( DepthYTmp >= WaterInSoilSfc ) DepthYTmp = WaterInSoilSfc + RunoffSatExcTmp1 = 0.0 + call RunoffSatExcessDynamicVic(noahmp,WaterDepthInit,WaterDepthMax,DepthYTmp,RunoffSatExcTmp1) + RunoffSatExcess = RunoffSatExcTmp1 + RunoffInfilExcess = WaterInSoilSfc - DepthYTmp + InfilTmp = DepthYTmp - RunoffSatExcess + WaterDepthTop = WaterDepthTop + InfilTmp + if ( WaterDepthTop <= 0.0 ) WaterDepthTop = 0.0 + if ( WaterDepthTop >= WaterDepthSatTop ) WaterDepthTop = WaterDepthSatTop + WaterDepthInit = WaterDepthMax * (1.0-(1.0-(WaterDepthTop/WaterDepthSatTop)**(1.0/(1.0+InfilFacDynVic)))) + endif + endif + endif + +2001 RunoffSurface = (RunoffSatExcess + RunoffInfilExcess) / TimeStep + RunoffSurface = min(RunoffSurface, SoilSfcInflowMean) + RunoffSurface = max(RunoffSurface, 0.0) + InfilRateSfc = SoilSfcInflowMean - RunoffSurface + + end associate + + end subroutine RunoffSurfaceDynamicVic + +end module RunoffSurfaceDynamicVicMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/RunoffSurfaceExcessDynamicVicMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/RunoffSurfaceExcessDynamicVicMod.F90 new file mode 100644 index 0000000000..910a86f277 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/RunoffSurfaceExcessDynamicVicMod.F90 @@ -0,0 +1,88 @@ +module RunoffSurfaceExcessDynamicVicMod + +!!! Compute infiltration and saturation excess runoff for dyanmic VIC runoff scheme + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine RunoffSatExcessDynamicVic(noahmp, WaterDepthInit, WaterDepthMax, DepthYTmp, RunoffSatExcess) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: RR1 for saturation excess runoff +! Original code: Prasanth Valayamkunnath +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + +! IN & OUT variabls + type(noahmp_type) , intent(inout) :: noahmp + real(kind=kind_noahmp), intent(in) :: WaterDepthInit ! initial water depth [m] + real(kind=kind_noahmp), intent(in) :: WaterDepthMax ! maximum water depth [m] + real(kind=kind_noahmp), intent(in) :: DepthYTmp ! initial depth Y [m] + real(kind=kind_noahmp), intent(out) :: RunoffSatExcess ! saturation excess runoff [m/s] + +! local variable + real(kind=kind_noahmp) :: WaterTableDepth ! water table depth [m] + +! ------------------------------------------------------------------ + associate( & + InfilFacDynVic => noahmp%water%param%InfilFacDynVic & ! in, DVIC model infiltration parameter + ) +! ------------------------------------------------------------------ + + WaterTableDepth = WaterDepthInit + DepthYTmp + if ( WaterTableDepth > WaterDepthMax ) WaterTableDepth = WaterDepthMax + + ! Saturation excess runoff , Eq 5. + RunoffSatExcess = DepthYTmp - ((WaterDepthMax/(InfilFacDynVic+1.0)) * & + (((1.0 - (WaterDepthInit/WaterDepthMax))**(InfilFacDynVic+1.0)) & + - ((1.0 - (WaterTableDepth/WaterDepthMax))**(InfilFacDynVic+1.0)))) + + if ( RunoffSatExcess < 0.0 ) RunoffSatExcess = 0.0 + + end associate + + end subroutine RunoffSatExcessDynamicVic + + + subroutine RunoffInfilExcessDynamicVic(DepthYTmp, DepthYInit, RunoffSatExcess, InfilRateMax, & + InfilRateSfc, TimeStep, WaterInSoilSfc, InfilExpB, RunoffInfilExcess) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: RRunoffInfilExcess for infiltration excess runoff +! Original code: Prasanth Valayamkunnath +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + +! IN & OUT variabls + real(kind=kind_noahmp), intent(in) :: DepthYTmp ! initial depth Y [m] + real(kind=kind_noahmp), intent(in) :: DepthYInit ! initial depth Y [m] + real(kind=kind_noahmp), intent(in) :: RunoffSatExcess ! saturation excess runoff [m/s] + real(kind=kind_noahmp), intent(in) :: InfilRateMax ! maximum infiltration rate [m/s] + real(kind=kind_noahmp), intent(in) :: InfilRateSfc ! surface infiltration rate [m/s] + real(kind=kind_noahmp), intent(in) :: TimeStep ! timestep (may not be the same as model timestep) + real(kind=kind_noahmp), intent(in) :: WaterInSoilSfc ! water input on soil surface [m] + real(kind=kind_noahmp), intent(in) :: InfilExpB ! B parameter for infiltration scaling curve + real(kind=kind_noahmp), intent(out) :: RunoffInfilExcess ! infiltration excess runoff [m/s] +! ---------------------------------------------------------------------- + + if ( DepthYTmp >= DepthYInit ) then + RunoffInfilExcess = WaterInSoilSfc - RunoffSatExcess - (InfilRateMax * TimeStep * & + (1.0-((1.0-(WaterInSoilSfc-RunoffSatExcess)/(InfilRateMax*TimeStep))**(InfilExpB+1.0)))) + else + RunoffInfilExcess = WaterInSoilSfc - RunoffSatExcess - (InfilRateMax*TimeStep) + endif + + if ( RunoffInfilExcess < 0.0) RunoffInfilExcess =0.0 + + end subroutine RunoffInfilExcessDynamicVic + +end module RunoffSurfaceExcessDynamicVicMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/RunoffSurfaceFreeDrainMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/RunoffSurfaceFreeDrainMod.F90 new file mode 100644 index 0000000000..e2e28450e7 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/RunoffSurfaceFreeDrainMod.F90 @@ -0,0 +1,132 @@ +module RunoffSurfaceFreeDrainMod + +!!! Calculate inflitration rate at soil surface and surface runoff for free drainage scheme + + use Machine + use NoahmpVarType + use ConstantDefineMod + use SoilHydraulicPropertyMod, only : SoilDiffusivityConductivityOpt2 + + implicit none + +contains + + subroutine RunoffSurfaceFreeDrain(noahmp, TimeStep) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: INFIL +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + +! IN & OUT variabls + type(noahmp_type) , intent(inout) :: noahmp + real(kind=kind_noahmp), intent(in) :: TimeStep ! timestep (may not be the same as model timestep) + +! local variable + integer :: IndSoilFrz ! number of interaction + integer :: LoopInd1, LoopInd2, LoopInd3 ! do-loop index + integer, parameter :: FrzSoilFac = 3 ! frozen soil pre-factor + real(kind=kind_noahmp) :: FracVoidRem ! remaining fraction + real(kind=kind_noahmp) :: SoilWatHoldMaxRem ! remaining accumulated maximum holdable soil water [m] + real(kind=kind_noahmp) :: WaterInSfc ! surface in water [m] + real(kind=kind_noahmp) :: TimeStepDay ! time indices + real(kind=kind_noahmp) :: SoilWatHoldMaxAcc ! accumulated maximum holdable soil water [m] + real(kind=kind_noahmp) :: SoilIceWatTmp ! maximum soil ice water [m] + real(kind=kind_noahmp) :: SoilImpervFrac ! impervious fraction due to frozen soil + real(kind=kind_noahmp) :: IndAcc ! accumulation index + real(kind=kind_noahmp) :: SoilIceCoeff ! soil ice coefficient + real(kind=kind_noahmp) :: SoilWatDiffusivity ! soil water diffusivity [m2/s] + real(kind=kind_noahmp) :: SoilWatConductivity ! soil water conductivity [m/s] + real(kind=kind_noahmp) :: SoilWatHoldCap ! soil moisture holding capacity [m3/m3] + real(kind=kind_noahmp) :: InfilRateMax ! maximum infiltration rate [m/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilWatMaxHold ! maximum soil water that can hold [m] + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + DepthSoilLayer => noahmp%config%domain%DepthSoilLayer ,& ! in, depth [m] of layer-bottom from soil surface + FlagUrban => noahmp%config%domain%FlagUrban ,& ! in, logical flag for urban grid + SoilLiqWater => noahmp%water%state%SoilLiqWater ,& ! in, soil water content [m3/m3] + SoilIce => noahmp%water%state%SoilIce ,& ! in, soil ice content [m3/m3] + SoilIceMax => noahmp%water%state%SoilIceMax ,& ! in, maximum soil ice content [m3/m3] + SoilSfcInflowMean => noahmp%water%flux%SoilSfcInflowMean ,& ! in, water input on soil surface [m/s] + SoilMoistureSat => noahmp%water%param%SoilMoistureSat ,& ! in, saturated value of soil moisture [m3/m3] + SoilMoistureWilt => noahmp%water%param%SoilMoistureWilt ,& ! in, wilting point soil moisture [m3/m3] + SoilInfilMaxCoeff => noahmp%water%param%SoilInfilMaxCoeff ,& ! in, parameter to calculate maximum infiltration rate + SoilImpervFracCoeff => noahmp%water%param%SoilImpervFracCoeff ,& ! in, parameter to calculate frozen soil impermeable fraction + RunoffSurface => noahmp%water%flux%RunoffSurface ,& ! out, surface runoff [m/s] + InfilRateSfc => noahmp%water%flux%InfilRateSfc & ! out, infiltration rate at surface [m/s] + ) +! ---------------------------------------------------------------------- + + ! initialize + if (.not. allocated(SoilWatMaxHold)) allocate(SoilWatMaxHold(1:NumSoilLayer)) + SoilWatMaxHold(1:NumSoilLayer) = 0.0 + + ! start infiltration for free drainage scheme + if ( SoilSfcInflowMean > 0.0 ) then + + TimeStepDay = TimeStep / 86400.0 + SoilWatHoldCap = SoilMoistureSat(1) - SoilMoistureWilt(1) + + ! compute maximum infiltration rate + SoilWatMaxHold(1) = -DepthSoilLayer(1) * SoilWatHoldCap + SoilIceWatTmp = -DepthSoilLayer(1) * SoilIce(1) + SoilWatMaxHold(1) = SoilWatMaxHold(1) * (1.0-(SoilLiqWater(1)+SoilIce(1)-SoilMoistureWilt(1)) / SoilWatHoldCap) + SoilWatHoldMaxAcc = SoilWatMaxHold(1) + do LoopInd3 = 2, NumSoilLayer + SoilIceWatTmp = SoilIceWatTmp + (DepthSoilLayer(LoopInd3-1) - DepthSoilLayer(LoopInd3))*SoilIce(LoopInd3) + SoilWatMaxHold(LoopInd3) = (DepthSoilLayer(LoopInd3-1) - DepthSoilLayer(LoopInd3)) * SoilWatHoldCap + SoilWatMaxHold(LoopInd3) = SoilWatMaxHold(LoopInd3) * (1.0 - (SoilLiqWater(LoopInd3) + SoilIce(LoopInd3) - & + SoilMoistureWilt(LoopInd3)) / SoilWatHoldCap) + SoilWatHoldMaxAcc = SoilWatHoldMaxAcc + SoilWatMaxHold(LoopInd3) + enddo + FracVoidRem = 1.0 - exp(-1.0 * SoilInfilMaxCoeff * TimeStepDay) + SoilWatHoldMaxRem = SoilWatHoldMaxAcc * FracVoidRem + WaterInSfc = max(0.0, SoilSfcInflowMean * TimeStep) + InfilRateMax = (WaterInSfc * (SoilWatHoldMaxRem/(WaterInSfc + SoilWatHoldMaxRem))) / TimeStep + + ! impermeable fraction due to frozen soil + SoilImpervFrac = 1.0 + if ( SoilIceWatTmp > 1.0e-2 ) then + SoilIceCoeff = FrzSoilFac * SoilImpervFracCoeff / SoilIceWatTmp + IndAcc = 1.0 + IndSoilFrz = FrzSoilFac - 1 + do LoopInd1 = 1, IndSoilFrz + LoopInd3 = 1 + do LoopInd2 = LoopInd1+1, IndSoilFrz + LoopInd3 = LoopInd3 * LoopInd2 + enddo + IndAcc = IndAcc + (SoilIceCoeff ** (FrzSoilFac-LoopInd1)) / float(LoopInd3) + enddo + SoilImpervFrac = 1.0 - exp(-SoilIceCoeff) * IndAcc + endif + + ! correction of infiltration limitation + InfilRateMax = InfilRateMax * SoilImpervFrac + ! jref for urban areas + ! if ( FlagUrban .eqv. .true. ) InfilRateMax == InfilRateMax * 0.05 + + ! soil hydraulic conductivity and diffusivity + call SoilDiffusivityConductivityOpt2(noahmp, SoilWatDiffusivity, SoilWatConductivity, SoilLiqWater(1), SoilIceMax, 1) + + InfilRateMax = max(InfilRateMax, SoilWatConductivity) + InfilRateMax = min(InfilRateMax, WaterInSfc/TimeStep) + + ! compute surface runoff and infiltration rate + RunoffSurface = max(0.0, SoilSfcInflowMean-InfilRateMax) + InfilRateSfc = SoilSfcInflowMean - RunoffSurface + + endif ! SoilSfcInflowMean > 0.0 + + ! deallocate local arrays to avoid memory leaks + deallocate(SoilWatMaxHold) + + end associate + + end subroutine RunoffSurfaceFreeDrain + +end module RunoffSurfaceFreeDrainMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/RunoffSurfaceTopModelEquiMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/RunoffSurfaceTopModelEquiMod.F90 new file mode 100644 index 0000000000..3e314225d9 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/RunoffSurfaceTopModelEquiMod.F90 @@ -0,0 +1,54 @@ +module RunoffSurfaceTopModelEquiMod + +!!! Calculate surface runoff based on TOPMODEL with equilibrium water table (Niu et al., 2005) + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine RunoffSurfaceTopModelEqui(noahmp) + +! ------------------------ Code history -------------------------------------------------- +! Originally embeded in SOILWATER subroutine instead of as a separate subroutine +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! -------------------------------------------------------------------- + associate( & + SoilSfcInflowMean => noahmp%water%flux%SoilSfcInflowMean ,& ! in, mean water input on soil surface [m/s] + RunoffDecayFac => noahmp%water%param%RunoffDecayFac ,& ! in, runoff decay factor [1/m] + SoilSfcSatFracMax => noahmp%water%param%SoilSfcSatFracMax ,& ! in, maximum surface saturated fraction (global mean) + SoilImpervFrac => noahmp%water%state%SoilImpervFrac ,& ! in, impervious fraction due to frozen soil + WaterTableDepth => noahmp%water%state%WaterTableDepth ,& ! in, water table depth [m] + SoilSaturateFrac => noahmp%water%state%SoilSaturateFrac ,& ! out, fractional saturated area for soil moisture + RunoffSurface => noahmp%water%flux%RunoffSurface ,& ! out, surface runoff [m/s] + InfilRateSfc => noahmp%water%flux%InfilRateSfc & ! out, infiltration rate at surface [m/s] + ) +! ---------------------------------------------------------------------- + + ! set up key parameter + RunoffDecayFac = 2.0 + + ! compute saturated area fraction + SoilSaturateFrac = SoilSfcSatFracMax * exp(-0.5 * RunoffDecayFac * WaterTableDepth) + + ! compute surface runoff and infiltration m/s + if ( SoilSfcInflowMean > 0.0 ) then + RunoffSurface = SoilSfcInflowMean * ((1.0-SoilImpervFrac(1)) * SoilSaturateFrac + SoilImpervFrac(1)) + InfilRateSfc = SoilSfcInflowMean - RunoffSurface + endif + + end associate + + end subroutine RunoffSurfaceTopModelEqui + +end module RunoffSurfaceTopModelEquiMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/RunoffSurfaceTopModelGrdMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/RunoffSurfaceTopModelGrdMod.F90 new file mode 100644 index 0000000000..b7d65aa0d6 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/RunoffSurfaceTopModelGrdMod.F90 @@ -0,0 +1,57 @@ +module RunoffSurfaceTopModelGrdMod + +!!! Calculate surface runoff based on TOPMODEL with groundwater scheme (Niu et al., 2007) + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine RunoffSurfaceTopModelGrd(noahmp) + +! ------------------------ Code history -------------------------------------------------- +! Originally embeded in SOILWATER subroutine instead of as a separate subroutine +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! -------------------------------------------------------------------- + associate( & + SoilSfcInflowMean => noahmp%water%flux%SoilSfcInflowMean ,& ! in, mean water input on soil surface [m/s] + RunoffDecayFac => noahmp%water%param%RunoffDecayFac ,& ! in, runoff decay factor [1/m] + SoilSfcSatFracMax => noahmp%water%param%SoilSfcSatFracMax ,& ! in, maximum surface saturated fraction (global mean) + SoilExpCoeffB => noahmp%water%param%SoilExpCoeffB ,& ! in, soil B parameter + SoilImpervFrac => noahmp%water%state%SoilImpervFrac ,& ! in, impervious fraction due to frozen soil + WaterTableDepth => noahmp%water%state%WaterTableDepth ,& ! in, water table depth [m] + SoilSaturateFrac => noahmp%water%state%SoilSaturateFrac ,& ! out, fractional saturated area for soil moisture + RunoffSurface => noahmp%water%flux%RunoffSurface ,& ! out, surface runoff [m/s] + InfilRateSfc => noahmp%water%flux%InfilRateSfc & ! out, infiltration rate at surface [m/s] + ) +! ---------------------------------------------------------------------- + + ! set up key parameter + !RunoffDecayFac = 6.0 + RunoffDecayFac = SoilExpCoeffB(1) / 3.0 ! calibratable, GY Niu's update 2022 + + ! compute saturated area fraction + !SoilSaturateFrac = SoilSfcSatFracMax * exp(-0.5 * RunoffDecayFac * (WaterTableDepth-2.0)) + SoilSaturateFrac = SoilSfcSatFracMax * exp(-0.5 * RunoffDecayFac * WaterTableDepth) ! GY Niu's update 2022 + + ! compute surface runoff and infiltration m/s + if ( SoilSfcInflowMean > 0.0 ) then + RunoffSurface = SoilSfcInflowMean * ((1.0-SoilImpervFrac(1)) * SoilSaturateFrac + SoilImpervFrac(1)) + InfilRateSfc = SoilSfcInflowMean - RunoffSurface + endif + + end associate + + end subroutine RunoffSurfaceTopModelGrd + +end module RunoffSurfaceTopModelGrdMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/RunoffSurfaceTopModelMmfMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/RunoffSurfaceTopModelMmfMod.F90 new file mode 100644 index 0000000000..7bdb97b8d5 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/RunoffSurfaceTopModelMmfMod.F90 @@ -0,0 +1,54 @@ +module RunoffSurfaceTopModelMmfMod + +!!! Calculate surface runoff based on TOPMODEL with MMF groundwater scheme + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine RunoffSurfaceTopModelMMF(noahmp) + +! ------------------------ Code history -------------------------------------------------- +! Originally embeded in SOILWATER subroutine instead of as a separate subroutine +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! -------------------------------------------------------------------- + associate( & + SoilSfcInflowMean => noahmp%water%flux%SoilSfcInflowMean ,& ! in, mean water input on soil surface [m/s] + RunoffDecayFac => noahmp%water%param%RunoffDecayFac ,& ! in, runoff decay factor [1/m] + SoilSfcSatFracMax => noahmp%water%param%SoilSfcSatFracMax ,& ! in, maximum surface saturated fraction (global mean) + SoilImpervFrac => noahmp%water%state%SoilImpervFrac ,& ! in, impervious fraction due to frozen soil + WaterTableDepth => noahmp%water%state%WaterTableDepth ,& ! in, water table depth [m] + SoilSaturateFrac => noahmp%water%state%SoilSaturateFrac ,& ! out, fractional saturated area for soil moisture + RunoffSurface => noahmp%water%flux%RunoffSurface ,& ! out, surface runoff [m/s] + InfilRateSfc => noahmp%water%flux%InfilRateSfc & ! out, infiltration rate at surface [m/s] + ) +! ---------------------------------------------------------------------- + + ! set up key parameter + RunoffDecayFac = 6.0 + + ! compute saturated area fraction + SoilSaturateFrac = SoilSfcSatFracMax * exp(-0.5 * RunoffDecayFac * max(-2.0-WaterTableDepth,0.0)) + + ! compute surface runoff and infiltration m/s + if ( SoilSfcInflowMean > 0.0 ) then + RunoffSurface = SoilSfcInflowMean * ((1.0-SoilImpervFrac(1)) * SoilSaturateFrac + SoilImpervFrac(1)) + InfilRateSfc = SoilSfcInflowMean - RunoffSurface + endif + + end associate + + end subroutine RunoffSurfaceTopModelMMF + +end module RunoffSurfaceTopModelMmfMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/RunoffSurfaceVicMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/RunoffSurfaceVicMod.F90 new file mode 100644 index 0000000000..3e29ca1644 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/RunoffSurfaceVicMod.F90 @@ -0,0 +1,100 @@ +module RunoffSurfaceVicMod + +!!! Compute saturated area, surface infiltration, and surface runoff based on VIC runoff scheme +!!! This scheme is adopted from VIC model + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine RunoffSurfaceVIC(noahmp, TimeStep) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: COMPUTE_VIC_SURFRUNOFF +! Original code: Prasanth Valayamkunnath +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + +! IN & OUT variabls + type(noahmp_type) , intent(inout) :: noahmp + real(kind=kind_noahmp), intent(in) :: TimeStep ! timestep (may not be the same as model timestep) + +! local variable + integer :: LoopInd ! do-loop index + real(kind=kind_noahmp) :: InfilExpFac ! infitration exponential factor + real(kind=kind_noahmp) :: WaterDepthInit ! initial water depth [m] + real(kind=kind_noahmp) :: WaterDepthMax ! Maximum water depth [m] + real(kind=kind_noahmp) :: InfilVarTmp ! temporary infiltration variable + real(kind=kind_noahmp) :: SoilMoistTop ! top layer soil moisture [m] + real(kind=kind_noahmp) :: SoilMoistTopMax ! top layer max soil moisture [m] + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + DepthSoilLayer => noahmp%config%domain%DepthSoilLayer ,& ! in, depth [m] of layer-bottom from soil surface + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! in, total soil moisture [m3/m3] + SoilSfcInflowMean => noahmp%water%flux%SoilSfcInflowMean ,& ! in, mean water input on soil surface [m/s] + SoilMoistureSat => noahmp%water%param%SoilMoistureSat ,& ! in, saturated value of soil moisture [m3/m3] + InfilFacVic => noahmp%water%param%InfilFacVic ,& ! in, VIC model infiltration parameter + RunoffSurface => noahmp%water%flux%RunoffSurface ,& ! out, surface runoff [m/s] + InfilRateSfc => noahmp%water%flux%InfilRateSfc ,& ! out, infiltration rate at surface [m/s] + SoilSaturateFrac => noahmp%water%state%SoilSaturateFrac & ! out, fractional saturated area for soil moisture + ) +! ---------------------------------------------------------------------- + + ! Initialization + InfilExpFac = 0.0 + SoilSaturateFrac = 0.0 + WaterDepthMax = 0.0 + WaterDepthInit = 0.0 + InfilVarTmp = 0.0 + SoilMoistTop = 0.0 + SoilMoistTopMax = 0.0 + RunoffSurface = 0.0 + InfilRateSfc = 0.0 + + do LoopInd = 1, NumSoilLayer-2 + SoilMoistTop = SoilMoistTop + SoilMoisture(LoopInd) * (-1.0) * DepthSoilLayer(LoopInd) + SoilMoistTopMax = SoilMoistTopMax + SoilMoistureSat(LoopInd) * (-1.0) * DepthSoilLayer(LoopInd) + enddo + + ! fractional saturated area from soil moisture + InfilExpFac = InfilFacVic / ( 1.0 + InfilFacVic ) + SoilSaturateFrac = 1.0 - (max(0.0, (1.0-(SoilMoistTop/SoilMoistTopMax))))**InfilExpFac + SoilSaturateFrac = max(0.0, SoilSaturateFrac) + SoilSaturateFrac = min(1.0, SoilSaturateFrac) + + ! Infiltration for the previous time-step soil moisture based on SoilSaturateFrac + WaterDepthMax = (1.0 + InfilFacVic) * SoilMoistTopMax + WaterDepthInit = WaterDepthMax * (1.0 - (1.0 - SoilSaturateFrac)**(1.0/InfilFacVic)) + + ! Solve for surface runoff + if ( SoilSfcInflowMean == 0.0 ) then + RunoffSurface = 0.0 + else if ( WaterDepthMax == 0.0 ) then + RunoffSurface = SoilSfcInflowMean * TimeStep + else if ( (WaterDepthInit + (SoilSfcInflowMean*TimeStep)) > WaterDepthMax ) then + RunoffSurface = SoilSfcInflowMean * TimeStep - SoilMoistTopMax + SoilMoistTop + else + InfilVarTmp = 1.0 - ((WaterDepthInit + (SoilSfcInflowMean * TimeStep) ) / WaterDepthMax) + RunoffSurface = SoilSfcInflowMean * TimeStep - SoilMoistTopMax + SoilMoistTop + & + SoilMoistTopMax * (InfilVarTmp**(1.0+InfilFacVic)) + endif + + RunoffSurface = RunoffSurface / TimeStep + if ( RunoffSurface < 0.0 ) RunoffSurface = 0.0 + if ( RunoffSurface > SoilSfcInflowMean) RunoffSurface = SoilSfcInflowMean + + InfilRateSfc = SoilSfcInflowMean - RunoffSurface + + end associate + + end subroutine RunoffSurfaceVIC + +end module RunoffSurfaceVicMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/RunoffSurfaceXinAnJiangMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/RunoffSurfaceXinAnJiangMod.F90 new file mode 100644 index 0000000000..b067be4fe4 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/RunoffSurfaceXinAnJiangMod.F90 @@ -0,0 +1,110 @@ +module RunoffSurfaceXinAnJiangMod + +!!! Compute surface infiltration rate and surface runoff based on XinAnJiang runoff scheme +!!! Reference: Knoben, W. J., et al., (2019): Modular Assessment of Rainfall-Runoff Models +!!! Toolbox (MARRMoT) v1.2 an open-source, extendable framework providing implementations +!!! of 46 conceptual hydrologic models as continuous state-space formulations. + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine RunoffSurfaceXinAnJiang(noahmp, TimeStep) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: COMPUTE_XAJ_SURFRUNOFF +! Original code: Prasanth Valayamkunnath +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + +! IN & OUT variables + type(noahmp_type) , intent(inout) :: noahmp + real(kind=kind_noahmp), intent(in) :: TimeStep ! timestep (may not be the same as model timestep) + +! local variable + integer :: LoopInd ! do-loop index + real(kind=kind_noahmp) :: SoilWaterTmp ! temporary soil water [m] + real(kind=kind_noahmp) :: SoilWaterMax ! maximum soil water [m] + real(kind=kind_noahmp) :: SoilWaterFree ! free soil water [m] + real(kind=kind_noahmp) :: SoilWaterFreeMax ! maximum free soil water [m] + real(kind=kind_noahmp) :: RunoffSfcImp ! impervious surface runoff [m] + real(kind=kind_noahmp) :: RunoffSfcPerv ! pervious surface runoff [m] + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + DepthSoilLayer => noahmp%config%domain%DepthSoilLayer ,& ! in, depth [m] of layer-bottom from soil surface + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! in, total soil moisture [m3/m3] + SoilImpervFrac => noahmp%water%state%SoilImpervFrac ,& ! in, fraction of imperviousness due to frozen soil + SoilSfcInflowMean => noahmp%water%flux%SoilSfcInflowMean ,& ! in, mean water input on soil surface [m/s] + SoilMoistureSat => noahmp%water%param%SoilMoistureSat ,& ! in, saturated value of soil moisture [m3/m3] + SoilMoistureFieldCap => noahmp%water%param%SoilMoistureFieldCap ,& ! in, reference soil moisture (field capacity) [m3/m3] + TensionWatDistrInfl => noahmp%water%param%TensionWatDistrInfl ,& ! in, Tension water distribution inflection parameter + TensionWatDistrShp => noahmp%water%param%TensionWatDistrShp ,& ! in, Tension water distribution shape parameter + FreeWatDistrShp => noahmp%water%param%FreeWatDistrShp ,& ! in, Free water distribution shape parameter + RunoffSurface => noahmp%water%flux%RunoffSurface ,& ! out, surface runoff [m/s] + InfilRateSfc => noahmp%water%flux%InfilRateSfc & ! out, infiltration rate at surface [m/s] + ) +! ---------------------------------------------------------------------- + + ! initialization + SoilWaterTmp = 0.0 + SoilWaterMax = 0.0 + SoilWaterFree = 0.0 + SoilWaterFreeMax = 0.0 + RunoffSfcImp = 0.0 + RunoffSfcPerv = 0.0 + RunoffSurface = 0.0 + InfilRateSfc = 0.0 + + do LoopInd = 1, NumSoilLayer-2 + if ( (SoilMoisture(LoopInd)-SoilMoistureFieldCap(LoopInd)) > 0.0 ) then ! soil moisture greater than field capacity + SoilWaterFree = SoilWaterFree + & + (SoilMoisture(LoopInd)-SoilMoistureFieldCap(LoopInd)) * (-1.0) * DepthSoilLayer(LoopInd) + SoilWaterTmp = SoilWaterTmp + SoilMoistureFieldCap(LoopInd) * (-1.0) * DepthSoilLayer(LoopInd) + else + SoilWaterTmp = SoilWaterTmp + SoilMoisture(LoopInd) * (-1.0) * DepthSoilLayer(LoopInd) + endif + SoilWaterMax = SoilWaterMax + SoilMoistureFieldCap(LoopInd) * (-1.0) * DepthSoilLayer(LoopInd) + SoilWaterFreeMax = SoilWaterFreeMax + & + (SoilMoistureSat(LoopInd)-SoilMoistureFieldCap(LoopInd)) * (-1.0) * DepthSoilLayer(LoopInd) + enddo + SoilWaterTmp = min(SoilWaterTmp, SoilWaterMax) ! tension water [m] + SoilWaterFree = min(SoilWaterFree, SoilWaterFreeMax) ! free water [m] + + ! impervious surface runoff R_IMP + RunoffSfcImp = SoilImpervFrac(1) * SoilSfcInflowMean * TimeStep + + ! solve pervious surface runoff (m) based on Eq. (310) + if ( (SoilWaterTmp/SoilWaterMax) <= (0.5-TensionWatDistrInfl) ) then + RunoffSfcPerv = (1.0-SoilImpervFrac(1)) * SoilSfcInflowMean * TimeStep * & + ((0.5-TensionWatDistrInfl)**(1.0-TensionWatDistrShp)) * & + ((SoilWaterTmp/SoilWaterMax)**TensionWatDistrShp) + else + RunoffSfcPerv = (1.0-SoilImpervFrac(1)) * SoilSfcInflowMean * TimeStep * & + (1.0-(((0.5+TensionWatDistrInfl)**(1.0-TensionWatDistrShp)) * & + ((1.0-(SoilWaterTmp/SoilWaterMax))**TensionWatDistrShp))) + endif + + ! estimate surface runoff based on Eq. (313) + if ( SoilSfcInflowMean == 0.0 ) then + RunoffSurface = 0.0 + else + RunoffSurface = RunoffSfcPerv * (1.0-((1.0-(SoilWaterFree/SoilWaterFreeMax))**FreeWatDistrShp)) + RunoffSfcImp + endif + RunoffSurface = RunoffSurface / TimeStep + RunoffSurface = max(0.0,RunoffSurface) + RunoffSurface = min(SoilSfcInflowMean, RunoffSurface) + InfilRateSfc = SoilSfcInflowMean - RunoffSurface + + end associate + + end subroutine RunoffSurfaceXinAnJiang + +end module RunoffSurfaceXinAnJiangMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/ShallowWaterTableMmfMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/ShallowWaterTableMmfMod.F90 new file mode 100644 index 0000000000..32c1b70aaf --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/ShallowWaterTableMmfMod.F90 @@ -0,0 +1,176 @@ +module ShallowWaterTableMmfMod + +!!! Diagnoses water table depth and computes recharge when the water table is +!!! within the resolved soil layers, according to the Miguez-Macho&Fan scheme + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine ShallowWaterTableMMF(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: SHALLOWWATERTABLE +! Original code: Miguez-Macho&Fan (Miguez-Macho et al 2007, Fan et al 2007) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: LoopInd ! do-loop index + integer :: IndAbvWatTbl ! layer index above water table layer + integer :: IndWatTbl ! layer index where the water table layer is + real(kind=kind_noahmp) :: WatTblDepthOld ! old water table depth + real(kind=kind_noahmp) :: ThicknessUpLy ! upper layer thickness + real(kind=kind_noahmp) :: SoilMoistDeep ! deep layer soil moisture + real(kind=kind_noahmp), allocatable, dimension(:) :: DepthSoilLayer0 ! temporary soil depth + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + SoilTimeStep => noahmp%config%domain%SoilTimeStep ,& ! in, noahmp soil timestep [s] + DepthSoilLayer => noahmp%config%domain%DepthSoilLayer ,& ! in, depth of soil layer-bottom [m] + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! in, thickness of snow/soil layers [m] + SoilMoistureEqui => noahmp%water%state%SoilMoistureEqui ,& ! in, equilibrium soil water content [m3/m3] + SoilMoistureSat => noahmp%water%param%SoilMoistureSat ,& ! in, saturated value of soil moisture [m3/m3] + SoilMatPotentialSat => noahmp%water%param%SoilMatPotentialSat ,& ! in, saturated soil matric potential [m] + SoilExpCoeffB => noahmp%water%param%SoilExpCoeffB ,& ! in, soil B parameter + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! inout, total soil water content [m3/m3] + WaterTableDepth => noahmp%water%state%WaterTableDepth ,& ! inout, water table depth [m] + SoilMoistureToWT => noahmp%water%state%SoilMoistureToWT ,& ! inout, soil moisture between bottom of soil & water table + DrainSoilBot => noahmp%water%flux%DrainSoilBot ,& ! inout, soil bottom drainage [m/s] + RechargeGwShallowWT => noahmp%water%state%RechargeGwShallowWT & ! out, groundwater recharge (net vertical flux across water table), positive up + ) +! ---------------------------------------------------------------------- + + ! initialization + if (.not. allocated(DepthSoilLayer0)) allocate(DepthSoilLayer0(0:NumSoilLayer)) + DepthSoilLayer0(1:NumSoilLayer) = DepthSoilLayer(1:NumSoilLayer) + DepthSoilLayer0(0) = 0.0 + + ! find the layer where the water table is + do LoopInd = NumSoilLayer, 1, -1 + if ( (WaterTableDepth+1.0e-6) < DepthSoilLayer0(LoopInd) ) exit + enddo + IndAbvWatTbl = LoopInd + + IndWatTbl = IndAbvWatTbl + 1 ! layer where the water table is + if ( IndWatTbl <= NumSoilLayer ) then ! water table depth in the resolved layers + WatTblDepthOld = WaterTableDepth + if ( SoilMoisture(IndWatTbl) > SoilMoistureEqui(IndWatTbl) ) then + if ( SoilMoisture(IndWatTbl) == SoilMoistureSat(IndWatTbl) ) then ! wtd went to the layer above + WaterTableDepth = DepthSoilLayer0(IndAbvWatTbl) + RechargeGwShallowWT = -(WatTblDepthOld - WaterTableDepth) * & + (SoilMoistureSat(IndWatTbl) - SoilMoistureEqui(IndWatTbl)) + IndAbvWatTbl = IndAbvWatTbl-1 + IndWatTbl = IndWatTbl-1 + if ( IndWatTbl >= 1 ) then + if ( SoilMoisture(IndWatTbl) > SoilMoistureEqui(IndWatTbl) ) then + WatTblDepthOld = WaterTableDepth + WaterTableDepth = min((SoilMoisture(IndWatTbl)*ThicknessSnowSoilLayer(IndWatTbl) - & + SoilMoistureEqui(IndWatTbl)*DepthSoilLayer0(IndAbvWatTbl) + & + SoilMoistureSat(IndWatTbl)*DepthSoilLayer0(IndWatTbl)) / & + (SoilMoistureSat(IndWatTbl)-SoilMoistureEqui(IndWatTbl)), & + DepthSoilLayer0(IndAbvWatTbl) ) + RechargeGwShallowWT = RechargeGwShallowWT - (WatTblDepthOld-WaterTableDepth) * & + (SoilMoistureSat(IndWatTbl)-SoilMoistureEqui(IndWatTbl)) + endif + endif + else ! water table depth stays in the layer + WaterTableDepth = min((SoilMoisture(IndWatTbl)*ThicknessSnowSoilLayer(IndWatTbl) - & + SoilMoistureEqui(IndWatTbl)*DepthSoilLayer0(IndAbvWatTbl) + & + SoilMoistureSat(IndWatTbl)*DepthSoilLayer0(IndWatTbl) ) / & + (SoilMoistureSat(IndWatTbl)-SoilMoistureEqui(IndWatTbl)), & + DepthSoilLayer0(IndAbvWatTbl)) + RechargeGwShallowWT = -(WatTblDepthOld-WaterTableDepth) * & + (SoilMoistureSat(IndWatTbl) - SoilMoistureEqui(IndWatTbl)) + endif + else ! water table depth has gone down to the layer below + WaterTableDepth = DepthSoilLayer0(IndWatTbl) + RechargeGwShallowWT = -(WatTblDepthOld-WaterTableDepth) * & + (SoilMoistureSat(IndWatTbl) - SoilMoistureEqui(IndWatTbl)) + IndWatTbl = IndWatTbl + 1 + IndAbvWatTbl = IndAbvWatTbl + 1 + ! water table depth crossed to the layer below. Now adjust it there + if ( IndWatTbl <= NumSoilLayer ) then + WatTblDepthOld = WaterTableDepth + if ( SoilMoisture(IndWatTbl) > SoilMoistureEqui(IndWatTbl) ) then + WaterTableDepth = min((SoilMoisture(IndWatTbl)*ThicknessSnowSoilLayer(IndWatTbl) - & + SoilMoistureEqui(IndWatTbl)*DepthSoilLayer0(IndAbvWatTbl) + & + SoilMoistureSat(IndWatTbl)*DepthSoilLayer0(IndWatTbl) ) / & + (SoilMoistureSat(IndWatTbl)-SoilMoistureEqui(IndWatTbl)), & + DepthSoilLayer0(IndAbvWatTbl)) + else + WaterTableDepth = DepthSoilLayer0(IndWatTbl) + endif + RechargeGwShallowWT = RechargeGwShallowWT - (WatTblDepthOld-WaterTableDepth) * & + (SoilMoistureSat(IndWatTbl) - SoilMoistureEqui(IndWatTbl)) + else + WatTblDepthOld = WaterTableDepth + ! restore smoi to equilibrium value with water from the ficticious layer below + ! SoilMoistureToWT = SoilMoistureToWT - (SoilMoistureEqui(NumSoilLayer)-SoilMoisture(NumSoilLayer)) + ! DrainSoilBot = DrainSoilBot - 1000 * & + ! (SoilMoistureEqui(NumSoilLayer) - SoilMoisture(NumSoilLayer)) * & + ! ThicknessSnowSoilLayer(NumSoilLayer) / SoilTimeStep + ! SoilMoisture(NumSoilLayer) = SoilMoistureEqui(NumSoilLayer) + + ! adjust water table depth in the ficticious layer below + SoilMoistDeep = SoilMoistureSat(NumSoilLayer) * (-SoilMatPotentialSat(NumSoilLayer) / & + (-SoilMatPotentialSat(NumSoilLayer) - ThicknessSnowSoilLayer(NumSoilLayer)))** & + (1.0/SoilExpCoeffB(NumSoilLayer)) + WaterTableDepth = min((SoilMoistureToWT * ThicknessSnowSoilLayer(NumSoilLayer) - & + SoilMoistDeep * DepthSoilLayer0(NumSoilLayer) + & + SoilMoistureSat(NumSoilLayer) * (DepthSoilLayer0(NumSoilLayer) - & + ThicknessSnowSoilLayer(NumSoilLayer))) / & + (SoilMoistureSat(NumSoilLayer)-SoilMoistDeep), DepthSoilLayer0(NumSoilLayer)) + RechargeGwShallowWT = RechargeGwShallowWT - (WatTblDepthOld-WaterTableDepth) * & + (SoilMoistureSat(NumSoilLayer) - SoilMoistDeep) + endif + endif + else if ( WaterTableDepth >= (DepthSoilLayer0(NumSoilLayer)-ThicknessSnowSoilLayer(NumSoilLayer)) ) then + ! if water table depth was already below the bottom of the resolved soil crust + WatTblDepthOld = WaterTableDepth + SoilMoistDeep = SoilMoistureSat(NumSoilLayer) * (-SoilMatPotentialSat(NumSoilLayer) / & + (-SoilMatPotentialSat(NumSoilLayer) - ThicknessSnowSoilLayer(NumSoilLayer)))** & + (1.0/SoilExpCoeffB(NumSoilLayer)) + if ( SoilMoistureToWT > SoilMoistDeep ) then + WaterTableDepth = min((SoilMoistureToWT * ThicknessSnowSoilLayer(NumSoilLayer) - & + SoilMoistDeep * DepthSoilLayer0(NumSoilLayer) + & + SoilMoistureSat(NumSoilLayer) * (DepthSoilLayer0(NumSoilLayer) - & + ThicknessSnowSoilLayer(NumSoilLayer))) / & + (SoilMoistureSat(NumSoilLayer)-SoilMoistDeep), DepthSoilLayer0(NumSoilLayer)) + RechargeGwShallowWT = -(WatTblDepthOld-WaterTableDepth) * (SoilMoistureSat(NumSoilLayer)-SoilMoistDeep) + else + RechargeGwShallowWT = -(WatTblDepthOld - (DepthSoilLayer0(NumSoilLayer)-ThicknessSnowSoilLayer(NumSoilLayer))) * & + (SoilMoistureSat(NumSoilLayer) - SoilMoistDeep) + WatTblDepthOld = DepthSoilLayer0(NumSoilLayer) - ThicknessSnowSoilLayer(NumSoilLayer) + ! and now even further down + ThicknessUpLy = (SoilMoistDeep - SoilMoistureToWT) * ThicknessSnowSoilLayer(NumSoilLayer) / & + (SoilMoistureSat(NumSoilLayer) - SoilMoistDeep) + WaterTableDepth = WatTblDepthOld - ThicknessUpLy + RechargeGwShallowWT = RechargeGwShallowWT - (SoilMoistureSat(NumSoilLayer)-SoilMoistDeep) * ThicknessUpLy + SoilMoistureToWT = SoilMoistDeep + endif + endif + + if ( (IndAbvWatTbl < NumSoilLayer) .and. (IndAbvWatTbl > 0) ) then + SoilMoistureToWT = SoilMoistureSat(IndAbvWatTbl) + else if ( (IndAbvWatTbl < NumSoilLayer) .and. (IndAbvWatTbl <= 0) ) then + SoilMoistureToWT = SoilMoistureSat(1) + endif + + ! deallocate local arrays to avoid memory leaks + deallocate(DepthSoilLayer0) + + end associate + + end subroutine ShallowWaterTableMMF + +end module ShallowWaterTableMmfMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SnowAgingBatsMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SnowAgingBatsMod.F90 new file mode 100644 index 0000000000..c883c1ef6c --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SnowAgingBatsMod.F90 @@ -0,0 +1,74 @@ +module SnowAgingBatsMod + +!!! Estimate snow age based on BATS snow albedo scheme for use in BATS snow albedo calculation +!!! Reference: Yang et al. (1997) J.of Climate + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine SnowAgingBats(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: SNOW_AGE +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + real(kind=kind_noahmp) :: SnowAgeFacTot ! total aging effects + real(kind=kind_noahmp) :: SnowAgeVapEff ! effects of grain growth due to vapor diffusion + real(kind=kind_noahmp) :: SnowAgeFrzEff ! effects of grain growth at freezing of melt water + real(kind=kind_noahmp) :: SnowAgeSootEff ! effects of soot + real(kind=kind_noahmp) :: SnowAgeChg ! nondimensional snow age change + real(kind=kind_noahmp) :: SnowAgeTmp ! temporary nondimensional snow age + real(kind=kind_noahmp) :: SnowFreshFac ! fresh snowfall factor + real(kind=kind_noahmp) :: SnowAgeTimeFac ! snow aging time factor + real(kind=kind_noahmp) :: SnowGrowVapExp ! snow vapor diffusion growth exponential factor + +! -------------------------------------------------------------------- + associate( & + MainTimeStep => noahmp%config%domain%MainTimeStep ,& ! in, main noahmp timestep [s] + SnowMassFullCoverOld => noahmp%water%param%SnowMassFullCoverOld ,& ! in, new snow mass to fully cover old snow [mm] + SnowAgeFacBats => noahmp%energy%param%SnowAgeFacBats ,& ! in, snow aging parameter + SnowGrowVapFacBats => noahmp%energy%param%SnowGrowVapFacBats ,& ! in, vapor diffusion snow growth factor + SnowGrowFrzFacBats => noahmp%energy%param%SnowGrowFrzFacBats ,& ! in, extra snow growth factor near freezing + SnowSootFacBats => noahmp%energy%param%SnowSootFacBats ,& ! in, dirt and soot effect factor + TemperatureGrd => noahmp%energy%state%TemperatureGrd ,& ! in, ground temperature [K] + SnowWaterEquiv => noahmp%water%state%SnowWaterEquiv ,& ! in, snow water equivalent [mm] + SnowWaterEquivPrev => noahmp%water%state%SnowWaterEquivPrev ,& ! in, snow water equivalent at previous time step [mm] + SnowAgeNondim => noahmp%energy%state%SnowAgeNondim ,& ! inout, non-dimensional snow age + SnowAgeFac => noahmp%energy%state%SnowAgeFac & ! out, snow age factor + ) +! ---------------------------------------------------------------------- + + if ( SnowWaterEquiv <= 0.0 ) then + SnowAgeNondim = 0.0 + else + SnowAgeTimeFac = MainTimeStep / SnowAgeFacBats + SnowGrowVapExp = SnowGrowVapFacBats * (1.0/ConstFreezePoint - 1.0/TemperatureGrd) + SnowAgeVapEff = exp(SnowGrowVapExp) + SnowAgeFrzEff = exp(amin1(0.0, SnowGrowFrzFacBats*SnowGrowVapExp)) + SnowAgeSootEff = SnowSootFacBats + SnowAgeFacTot = SnowAgeVapEff + SnowAgeFrzEff + SnowAgeSootEff + SnowAgeChg = SnowAgeTimeFac * SnowAgeFacTot + SnowFreshFac = amax1(0.0, SnowWaterEquiv-SnowWaterEquivPrev) / SnowMassFullCoverOld + SnowAgeTmp = (SnowAgeNondim + SnowAgeChg) * (1.0 - SnowFreshFac) + SnowAgeNondim = amax1(0.0, SnowAgeTmp) + endif + + SnowAgeFac = SnowAgeNondim / (SnowAgeNondim + 1.0) + + end associate + + end subroutine SnowAgingBats + +end module SnowAgingBatsMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SnowAlbedoBatsMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SnowAlbedoBatsMod.F90 new file mode 100644 index 0000000000..9ab51bc5b7 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SnowAlbedoBatsMod.F90 @@ -0,0 +1,68 @@ +module SnowAlbedoBatsMod + +!!! Compute snow albedo based on BATS scheme (Yang et al. (1997) J.of Climate) + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine SnowAlbedoBats(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: SNOWALB_BATS +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + real(kind=kind_noahmp) :: ZenithAngFac ! solar zenith angle correction factor + real(kind=kind_noahmp) :: ZenithAngFacTmp ! temperary zenith angle correction factor + real(kind=kind_noahmp) :: SolarAngleFac2 ! 2.0 * SolarAngleFac + real(kind=kind_noahmp) :: SolarAngleFac1 ! 1 / SolarAngleFac + real(kind=kind_noahmp) :: SolarAngleFac ! adjustable solar zenith angle factor + +! -------------------------------------------------------------------- + associate( & + NumSwRadBand => noahmp%config%domain%NumSwRadBand ,& ! in, number of solar radiation wave bands + CosSolarZenithAngle => noahmp%config%domain%CosSolarZenithAngle ,& ! in, cosine solar zenith angle + SolarZenithAdjBats => noahmp%energy%param%SolarZenithAdjBats ,& ! in, zenith angle snow albedo adjustment + FreshSnoAlbVisBats => noahmp%energy%param%FreshSnoAlbVisBats ,& ! in, new snow visible albedo + FreshSnoAlbNirBats => noahmp%energy%param%FreshSnoAlbNirBats ,& ! in, new snow NIR albedo + SnoAgeFacDifVisBats => noahmp%energy%param%SnoAgeFacDifVisBats ,& ! in, age factor for diffuse visible snow albedo + SnoAgeFacDifNirBats => noahmp%energy%param%SnoAgeFacDifNirBats ,& ! in, age factor for diffuse NIR snow albedo + SzaFacDirVisBats => noahmp%energy%param%SzaFacDirVisBats ,& ! in, cosz factor for direct visible snow albedo + SzaFacDirNirBats => noahmp%energy%param%SzaFacDirNirBats ,& ! in, cosz factor for direct NIR snow albedo + SnowAgeFac => noahmp%energy%state%SnowAgeFac ,& ! in, snow age factor + AlbedoSnowDir => noahmp%energy%state%AlbedoSnowDir ,& ! out, snow albedo for direct(1=vis, 2=nir) + AlbedoSnowDif => noahmp%energy%state%AlbedoSnowDif & ! out, snow albedo for diffuse(1=vis, 2=nir) + ) +! ---------------------------------------------------------------------- + + ! initialization + AlbedoSnowDir(1:NumSwRadBand) = 0.0 + AlbedoSnowDif(1:NumSwRadBand) = 0.0 + + ! when CosSolarZenithAngle > 0 + SolarAngleFac = SolarZenithAdjBats + SolarAngleFac1 = 1.0 / SolarAngleFac + SolarAngleFac2 = 2.0 * SolarAngleFac + ZenithAngFacTmp = (1.0 + SolarAngleFac1) / (1.0 + SolarAngleFac2*CosSolarZenithAngle) - SolarAngleFac1 + ZenithAngFac = amax1(ZenithAngFacTmp, 0.0) + AlbedoSnowDif(1) = FreshSnoAlbVisBats * (1.0 - SnoAgeFacDifVisBats * SnowAgeFac) + AlbedoSnowDif(2) = FreshSnoAlbNirBats * (1.0 - SnoAgeFacDifNirBats * SnowAgeFac) + AlbedoSnowDir(1) = AlbedoSnowDif(1) + SzaFacDirVisBats * ZenithAngFac * (1.0 - AlbedoSnowDif(1)) + AlbedoSnowDir(2) = AlbedoSnowDif(2) + SzaFacDirNirBats * ZenithAngFac * (1.0 - AlbedoSnowDif(2)) + + end associate + + end subroutine SnowAlbedoBats + +end module SnowAlbedoBatsMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SnowAlbedoClassMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SnowAlbedoClassMod.F90 new file mode 100644 index 0000000000..06185e9d6d --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SnowAlbedoClassMod.F90 @@ -0,0 +1,68 @@ +module SnowAlbedoClassMod + +!!! Compute snow albedo based on the CLASS scheme (Verseghy, 1991) + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine SnowAlbedoClass(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: SNOWALB_CLASS +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + real(kind=kind_noahmp) :: SnowAlbedoTmp ! temporary snow albedo + +! -------------------------------------------------------------------- + associate( & + NumSwRadBand => noahmp%config%domain%NumSwRadBand ,& ! in, number of solar radiation wave bands + MainTimeStep => noahmp%config%domain%MainTimeStep ,& ! in, noahmp main time step [s] + SnowfallGround => noahmp%water%flux%SnowfallGround ,& ! in, snowfall at ground [mm/s] + SnowMassFullCoverOld => noahmp%water%param%SnowMassFullCoverOld ,& ! in, new snow mass to fully cover old snow [mm] + SnowAlbRefClass => noahmp%energy%param%SnowAlbRefClass ,& ! in, reference snow albedo in CLASS scheme + SnowAgeFacClass => noahmp%energy%param%SnowAgeFacClass ,& ! in, snow aging e-folding time [s] + SnowAlbFreshClass => noahmp%energy%param%SnowAlbFreshClass ,& ! in, fresh snow albedo + AlbedoSnowPrev => noahmp%energy%state%AlbedoSnowPrev ,& ! in, snow albedo at last time step + AlbedoSnowDir => noahmp%energy%state%AlbedoSnowDir ,& ! out, snow albedo for direct (1=vis, 2=nir) + AlbedoSnowDif => noahmp%energy%state%AlbedoSnowDif & ! out, snow albedo for diffuse (1=vis, 2=nir) + ) +! ---------------------------------------------------------------------- + + ! initialization + AlbedoSnowDir(1:NumSwRadBand) = 0.0 + AlbedoSnowDif(1:NumSwRadBand) = 0.0 + + ! when CosSolarZenithAngle > 0 + SnowAlbedoTmp = SnowAlbRefClass + (AlbedoSnowPrev-SnowAlbRefClass) * exp(-0.01*MainTimeStep/SnowAgeFacClass) + + ! 1 mm fresh snow(SWE) -- 10mm snow depth, assumed the fresh snow density 100kg/m3 + ! here assume 1cm snow depth will fully cover the old snow + if ( SnowfallGround > 0.0 ) then + SnowAlbedoTmp = SnowAlbedoTmp + min(SnowfallGround, SnowMassFullCoverOld/MainTimeStep) * & + (SnowAlbFreshClass-SnowAlbedoTmp) / (SnowMassFullCoverOld/MainTimeStep) + endif + + AlbedoSnowDif(1) = SnowAlbedoTmp + AlbedoSnowDif(2) = SnowAlbedoTmp + AlbedoSnowDir(1) = SnowAlbedoTmp + AlbedoSnowDir(2) = SnowAlbedoTmp + + AlbedoSnowPrev = SnowAlbedoTmp + + end associate + + end subroutine SnowAlbedoClass + +end module SnowAlbedoClassMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SnowCoverGlacierMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SnowCoverGlacierMod.F90 new file mode 100644 index 0000000000..9d0b58f123 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SnowCoverGlacierMod.F90 @@ -0,0 +1,41 @@ +module SnowCoverGlacierMod + +!!! Compute glacier ground snow cover fraction + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine SnowCoverGlacier(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: None (embedded in RADIATION_GLACIER subroutine) +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + +! -------------------------------------------------------------------- + associate( & + SnowWaterEquiv => noahmp%water%state%SnowWaterEquiv ,& ! in, snow water equivalent [mm] + SnowCoverFrac => noahmp%water%state%SnowCoverFrac & ! out, snow cover fraction + ) +! ---------------------------------------------------------------------- + + SnowCoverFrac = 0.0 + if ( SnowWaterEquiv > 0.0 ) SnowCoverFrac = 1.0 + + end associate + + end subroutine SnowCoverGlacier + +end module SnowCoverGlacierMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SnowCoverGroundNiu07Mod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SnowCoverGroundNiu07Mod.F90 new file mode 100644 index 0000000000..78456dee97 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SnowCoverGroundNiu07Mod.F90 @@ -0,0 +1,51 @@ +module SnowCoverGroundNiu07Mod + +!!! Compute ground snow cover fraction based on Niu and Yang (2007, JGR) scheme + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine SnowCoverGroundNiu07(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: None (embedded in ENERGY subroutine) +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + real(kind=kind_noahmp) :: SnowDensBulk ! bulk density of snow [Kg/m3] + real(kind=kind_noahmp) :: MeltFac ! melting factor for snow cover frac + +! -------------------------------------------------------------------- + associate( & + SnowMeltFac => noahmp%water%param%SnowMeltFac ,& ! in, snowmelt m parameter + SnowCoverFac => noahmp%water%param%SnowCoverFac ,& ! in, snow cover factor [m] + SnowDepth => noahmp%water%state%SnowDepth ,& ! in, snow depth [m] + SnowWaterEquiv => noahmp%water%state%SnowWaterEquiv ,& ! in, snow water equivalent [mm] + SnowCoverFrac => noahmp%water%state%SnowCoverFrac & ! out, snow cover fraction + ) +! ---------------------------------------------------------------------- + + SnowCoverFrac = 0.0 + if ( SnowDepth > 0.0 ) then + SnowDensBulk = SnowWaterEquiv / SnowDepth + MeltFac = (SnowDensBulk / 100.0)**SnowMeltFac + !SnowCoverFrac = tanh( SnowDepth /(2.5 * Z0 * MeltFac)) + SnowCoverFrac = tanh( SnowDepth /(SnowCoverFac * MeltFac)) ! C.He: bring hard-coded 2.5*z0 to MPTABLE + endif + + end associate + + end subroutine SnowCoverGroundNiu07 + +end module SnowCoverGroundNiu07Mod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SnowLayerCombineMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SnowLayerCombineMod.F90 new file mode 100644 index 0000000000..909542f2b5 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SnowLayerCombineMod.F90 @@ -0,0 +1,185 @@ +module SnowLayerCombineMod + +!!! Snowpack layer combination process +!!! Update snow ice, snow water, snow thickness, snow temperature + + use Machine + use NoahmpVarType + use ConstantDefineMod + use SnowLayerWaterComboMod, only: SnowLayerWaterCombo + + implicit none + +contains + + subroutine SnowLayerCombine(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: COMBINE +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: I,J,K,L ! node indices + integer :: NumSnowLayerOld ! number of snow layer + integer :: IndLayer ! node index + integer :: IndNeighbor ! adjacent node selected for combination + real(kind=kind_noahmp) :: SnowIceTmp ! total ice mass in snow + real(kind=kind_noahmp) :: SnowLiqTmp ! total liquid water in snow + real(kind=kind_noahmp) :: SnowThickMin(3) ! minimum thickness of each snow layer + data SnowThickMin /0.025, 0.025, 0.1/ ! MB: change limit + !data SnowThickMin /0.045, 0.05, 0.2/ + +! -------------------------------------------------------------------- + associate( & + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg ,& ! inout, actual number of snow layers (negative) + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! inout, thickness of snow/soil layers [m] + SnowDepth => noahmp%water%state%SnowDepth ,& ! inout, snow depth [m] + SnowWaterEquiv => noahmp%water%state%SnowWaterEquiv ,& ! inout, snow water equivalent [mm] + SnowIce => noahmp%water%state%SnowIce ,& ! inout, snow layer ice [mm] + SnowLiqWater => noahmp%water%state%SnowLiqWater ,& ! inout, snow layer liquid water [mm] + SoilLiqWater => noahmp%water%state%SoilLiqWater ,& ! inout, soil liquid moisture [m3/m3] + SoilIce => noahmp%water%state%SoilIce ,& ! inout, soil ice moisture [m3/m3] + TemperatureSoilSnow => noahmp%energy%state%TemperatureSoilSnow ,& ! inout, snow and soil layer temperature [K] + PondSfcThinSnwComb => noahmp%water%state%PondSfcThinSnwComb ,& ! out, surface ponding [mm] from liquid in thin snow layer combination + PondSfcThinSnwTrans => noahmp%water%state%PondSfcThinSnwTrans & ! out, surface ponding [mm] from thin snow liquid during transition from multilayer to no layer + ) +! ---------------------------------------------------------------------- + +! check and combine small ice content layer + NumSnowLayerOld = NumSnowLayerNeg + + do J = NumSnowLayerOld+1,0 + if ( SnowIce(J) <= 0.1 ) then + if ( J /= 0 ) then + SnowLiqWater(J+1) = SnowLiqWater(J+1) + SnowLiqWater(J) + SnowIce(J+1) = SnowIce(J+1) + SnowIce(J) + ThicknessSnowSoilLayer(J+1) = ThicknessSnowSoilLayer(J+1) + ThicknessSnowSoilLayer(J) + else + if ( NumSnowLayerNeg < -1 ) then ! MB/KM: change to NumSnowLayerNeg + SnowLiqWater(J-1) = SnowLiqWater(J-1) + SnowLiqWater(J) + SnowIce(J-1) = SnowIce(J-1) + SnowIce(J) + ThicknessSnowSoilLayer(J-1) = ThicknessSnowSoilLayer(J-1) + ThicknessSnowSoilLayer(J) + else + if ( SnowIce(J) >= 0.0 ) then + PondSfcThinSnwComb = SnowLiqWater(J) ! NumSnowLayerNeg WILL GET SET TO ZERO BELOW; PondSfcThinSnwComb WILL GET + SnowWaterEquiv = SnowIce(J) ! ADDED TO PONDING FROM PHASECHANGE PONDING SHOULD BE + SnowDepth = ThicknessSnowSoilLayer(J) ! ZERO HERE BECAUSE IT WAS CALCULATED FOR THIN SNOW + else ! SnowIce OVER-SUBLIMATED EARLIER + PondSfcThinSnwComb = SnowLiqWater(J) + SnowIce(J) + if ( PondSfcThinSnwComb < 0.0 ) then ! IF SnowIce AND SnowLiqWater SUBLIMATES REMOVE FROM SOIL + SoilIce(1) = SoilIce(1) + PondSfcThinSnwComb/(ThicknessSnowSoilLayer(1)*1000.0) ! negative SoilIce from oversublimation is adjusted below + PondSfcThinSnwComb = 0.0 + endif + SnowWaterEquiv = 0.0 + SnowDepth = 0.0 + endif ! if(SnowIce(J) >= 0.0) + SnowLiqWater(J) = 0.0 + SnowIce(J) = 0.0 + ThicknessSnowSoilLayer(J) = 0.0 + endif ! if(NumSnowLayerOld < -1) + + !SoilLiqWater(1) = SoilLiqWater(1) + SnowLiqWater(J)/(ThicknessSnowSoilLayer(1)*1000.0) + !SoilIce(1) = SoilIce(1) + SnowIce(J)/(ThicknessSnowSoilLayer(1)*1000.0) + endif ! if(J /= 0) + + ! shift all elements above this down by one. + if ( (J > NumSnowLayerNeg+1) .and. (NumSnowLayerNeg < -1) ) then + do I = J, NumSnowLayerNeg+2, -1 + TemperatureSoilSnow(I) = TemperatureSoilSnow(I-1) + SnowLiqWater(I) = SnowLiqWater(I-1) + SnowIce(I) = SnowIce(I-1) + ThicknessSnowSoilLayer(I) = ThicknessSnowSoilLayer(I-1) + enddo + endif + NumSnowLayerNeg = NumSnowLayerNeg + 1 + + endif ! if(SnowIce(J) <= 0.1) + enddo ! do J + +! to conserve water in case of too large surface sublimation + if ( SoilIce(1) < 0.0) then + SoilLiqWater(1) = SoilLiqWater(1) + SoilIce(1) + SoilIce(1) = 0.0 + endif + + if ( NumSnowLayerNeg ==0 ) return ! MB: get out if no longer multi-layer + + SnowWaterEquiv = 0.0 + SnowDepth = 0.0 + SnowIceTmp = 0.0 + SnowLiqTmp = 0.0 + + do J = NumSnowLayerNeg+1, 0 + SnowWaterEquiv = SnowWaterEquiv + SnowIce(J) + SnowLiqWater(J) + SnowDepth = SnowDepth + ThicknessSnowSoilLayer(J) + SnowIceTmp = SnowIceTmp + SnowIce(J) + SnowLiqTmp = SnowLiqTmp + SnowLiqWater(J) + enddo + +! check the snow depth - all snow gone, the liquid water assumes ponding on soil surface. + !if ( (SnowDepth < 0.05) .and. (NumSnowLayerNeg < 0) ) then + if ( (SnowDepth < 0.025) .and. (NumSnowLayerNeg < 0) ) then ! MB: change limit + NumSnowLayerNeg = 0 + SnowWaterEquiv = SnowIceTmp + PondSfcThinSnwTrans = SnowLiqTmp ! LIMIT OF NumSnowLayerNeg < 0 MEANS INPUT PONDING + if ( SnowWaterEquiv <= 0.0 ) SnowDepth = 0.0 ! SHOULD BE ZERO; SEE ABOVE + endif + +! check the snow depth - snow layers combined + if ( NumSnowLayerNeg < -1 ) then + NumSnowLayerOld = NumSnowLayerNeg + IndLayer = 1 + do I = NumSnowLayerOld+1, 0 + if ( ThicknessSnowSoilLayer(I) < SnowThickMin(IndLayer) ) then + if ( I == NumSnowLayerNeg+1 ) then + IndNeighbor = I + 1 + else if ( I == 0 ) then + IndNeighbor = I - 1 + else + IndNeighbor = I + 1 + if ( (ThicknessSnowSoilLayer(I-1)+ThicknessSnowSoilLayer(I)) < & + (ThicknessSnowSoilLayer(I+1)+ThicknessSnowSoilLayer(I)) ) IndNeighbor = I-1 + endif + ! Node l and j are combined and stored as node j. + if ( IndNeighbor > I ) then + J = IndNeighbor + L = I + else + J = I + L = IndNeighbor + endif + + ! update combined snow water & temperature + call SnowLayerWaterCombo(ThicknessSnowSoilLayer(J), SnowLiqWater(J), SnowIce(J), TemperatureSoilSnow(J), & + ThicknessSnowSoilLayer(L), SnowLiqWater(L), SnowIce(L), TemperatureSoilSnow(L) ) + + ! Now shift all elements above this down one. + if ( (J-1) > (NumSnowLayerNeg+1) ) then + do K = J-1, NumSnowLayerNeg+2, -1 + TemperatureSoilSnow(K) = TemperatureSoilSnow(K-1) + SnowIce(K) = SnowIce(K-1) + SnowLiqWater(K) = SnowLiqWater(K-1) + ThicknessSnowSoilLayer(K) = ThicknessSnowSoilLayer(K-1) + enddo + endif + ! Decrease the number of snow layers + NumSnowLayerNeg = NumSnowLayerNeg + 1 + if ( NumSnowLayerNeg >= -1 ) Exit + else + ! The layer thickness is greater than the prescribed minimum value + IndLayer = IndLayer + 1 + endif + enddo + endif + + end associate + + end subroutine SnowLayerCombine + +end module SnowLayerCombineMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SnowLayerDivideMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SnowLayerDivideMod.F90 new file mode 100644 index 0000000000..6254978a41 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SnowLayerDivideMod.F90 @@ -0,0 +1,160 @@ +module SnowLayerDivideMod + +!!! Snowpack layer division process +!!! Update snow ice, snow water, snow thickness, snow temperature + + use Machine + use NoahmpVarType + use ConstantDefineMod + use SnowLayerWaterComboMod, only: SnowLayerWaterCombo + + implicit none + +contains + + subroutine SnowLayerDivide(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: DIVIDE +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: LoopInd ! snow layer loop index + integer :: NumSnowLayerTmp ! number of snow layer top to bottom + real(kind=kind_noahmp) :: SnowThickCombTmp ! thickness of the combined [m] + real(kind=kind_noahmp) :: SnowIceExtra ! extra snow ice to be divided compared to allowed layer thickness + real(kind=kind_noahmp) :: SnowLiqExtra ! extra snow liquid water to be divided compared to allowed layer thickness + real(kind=kind_noahmp) :: SnowFracExtra ! fraction of extra snow to be divided compared to allowed layer thickness + real(kind=kind_noahmp) :: SnowTempGrad ! temperature gradient between two snow layers + real(kind=kind_noahmp), allocatable, dimension(:) :: SnowThickTmp ! snow layer thickness [m] + real(kind=kind_noahmp), allocatable, dimension(:) :: SnowIceTmp ! partial volume of ice [m3/m3] + real(kind=kind_noahmp), allocatable, dimension(:) :: SnowLiqTmp ! partial volume of liquid water [m3/m3] + real(kind=kind_noahmp), allocatable, dimension(:) :: TemperatureSnowTmp ! node temperature [K] + +! -------------------------------------------------------------------- + associate( & + NumSnowLayerMax => noahmp%config%domain%NumSnowLayerMax ,& ! in, maximum number of snow layers + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg ,& ! inout, actual number of snow layers (negative) + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! inout, thickness of snow/soil layers [m] + TemperatureSoilSnow => noahmp%energy%state%TemperatureSoilSnow ,& ! inout, snow and soil layer temperature [K] + SnowIce => noahmp%water%state%SnowIce ,& ! inout, snow layer ice [mm] + SnowLiqWater => noahmp%water%state%SnowLiqWater & ! inout, snow layer liquid water [mm] + ) +! ---------------------------------------------------------------------- + + ! initialization + if (.not. allocated(SnowIceTmp) ) allocate(SnowIceTmp (1:NumSnowLayerMax)) + if (.not. allocated(SnowLiqTmp) ) allocate(SnowLiqTmp (1:NumSnowLayerMax)) + if (.not. allocated(TemperatureSnowTmp)) allocate(TemperatureSnowTmp(1:NumSnowLayerMax)) + if (.not. allocated(SnowThickTmp) ) allocate(SnowThickTmp (1:NumSnowLayerMax)) + SnowIceTmp (:) = 0.0 + SnowLiqTmp (:) = 0.0 + TemperatureSnowTmp(:) = 0.0 + SnowThickTmp (:) = 0.0 + + do LoopInd = 1, NumSnowLayerMax + if ( LoopInd <= abs(NumSnowLayerNeg) ) then + SnowThickTmp(LoopInd) = ThicknessSnowSoilLayer(LoopInd+NumSnowLayerNeg) + SnowIceTmp(LoopInd) = SnowIce(LoopInd+NumSnowLayerNeg) + SnowLiqTmp(LoopInd) = SnowLiqWater(LoopInd+NumSnowLayerNeg) + TemperatureSnowTmp(LoopInd) = TemperatureSoilSnow(LoopInd+NumSnowLayerNeg) + endif + enddo + + ! start snow layer division + NumSnowLayerTmp = abs(NumSnowLayerNeg) + + if ( NumSnowLayerTmp == 1 ) then + ! Specify a new snow layer + if ( SnowThickTmp(1) > 0.05 ) then + NumSnowLayerTmp = 2 + SnowThickTmp(1) = SnowThickTmp(1)/2.0 + SnowIceTmp(1) = SnowIceTmp(1)/2.0 + SnowLiqTmp(1) = SnowLiqTmp(1)/2.0 + SnowThickTmp(2) = SnowThickTmp(1) + SnowIceTmp(2) = SnowIceTmp(1) + SnowLiqTmp(2) = SnowLiqTmp(1) + TemperatureSnowTmp(2) = TemperatureSnowTmp(1) + endif + endif + + if ( NumSnowLayerTmp > 1 ) then + if ( SnowThickTmp(1) > 0.05 ) then ! maximum allowed thickness (5cm) for top snow layer + SnowThickCombTmp = SnowThickTmp(1) - 0.05 + SnowFracExtra = SnowThickCombTmp / SnowThickTmp(1) + SnowIceExtra = SnowFracExtra * SnowIceTmp(1) + SnowLiqExtra = SnowFracExtra * SnowLiqTmp(1) + SnowFracExtra = 0.05 / SnowThickTmp(1) + SnowIceTmp(1) = SnowFracExtra*SnowIceTmp(1) + SnowLiqTmp(1) = SnowFracExtra*SnowLiqTmp(1) + SnowThickTmp(1) = 0.05 + + ! update combined snow water & temperature + call SnowLayerWaterCombo(SnowThickTmp(2), SnowLiqTmp(2), SnowIceTmp(2), TemperatureSnowTmp(2), & + SnowThickCombTmp, SnowLiqExtra, SnowIceExtra, TemperatureSnowTmp(1)) + + ! subdivide a new layer, maximum allowed thickness (20cm) for second snow layer + if ( (NumSnowLayerTmp <= 2) .and. (SnowThickTmp(2) > 0.20) ) then ! MB: change limit + !if ( (NumSnowLayerTmp <= 2) .and. (SnowThickTmp(2) > 0.10) ) then + NumSnowLayerTmp = 3 + SnowTempGrad = (TemperatureSnowTmp(1) - TemperatureSnowTmp(2)) / & + ((SnowThickTmp(1)+SnowThickTmp(2)) / 2.0) + SnowThickTmp(2) = SnowThickTmp(2) / 2.0 + SnowIceTmp(2) = SnowIceTmp(2) / 2.0 + SnowLiqTmp(2) = SnowLiqTmp(2) / 2.0 + SnowThickTmp(3) = SnowThickTmp(2) + SnowIceTmp(3) = SnowIceTmp(2) + SnowLiqTmp(3) = SnowLiqTmp(2) + TemperatureSnowTmp(3) = TemperatureSnowTmp(2) - SnowTempGrad * SnowThickTmp(2) / 2.0 + if ( TemperatureSnowTmp(3) >= ConstFreezePoint ) then + TemperatureSnowTmp(3) = TemperatureSnowTmp(2) + else + TemperatureSnowTmp(2) = TemperatureSnowTmp(2) + SnowTempGrad * SnowThickTmp(2) / 2.0 + endif + endif + endif ! if(SnowThickTmp(1) > 0.05) + endif ! if (NumSnowLayerTmp > 1) + + if ( NumSnowLayerTmp > 2 ) then + if ( SnowThickTmp(2) > 0.2 ) then + SnowThickCombTmp = SnowThickTmp(2) - 0.2 + SnowFracExtra = SnowThickCombTmp / SnowThickTmp(2) + SnowIceExtra = SnowFracExtra * SnowIceTmp(2) + SnowLiqExtra = SnowFracExtra * SnowLiqTmp(2) + SnowFracExtra = 0.2 / SnowThickTmp(2) + SnowIceTmp(2) = SnowFracExtra * SnowIceTmp(2) + SnowLiqTmp(2) = SnowFracExtra * SnowLiqTmp(2) + SnowThickTmp(2) = 0.2 + + ! update combined snow water & temperature + call SnowLayerWaterCombo(SnowThickTmp(3), SnowLiqTmp(3), SnowIceTmp(3), TemperatureSnowTmp(3), & + SnowThickCombTmp, SnowLiqExtra, SnowIceExtra, TemperatureSnowTmp(2)) + endif + endif + + NumSnowLayerNeg = -NumSnowLayerTmp + + do LoopInd = NumSnowLayerNeg+1, 0 + ThicknessSnowSoilLayer(LoopInd) = SnowThickTmp(LoopInd-NumSnowLayerNeg) + SnowIce(LoopInd) = SnowIceTmp(LoopInd-NumSnowLayerNeg) + SnowLiqWater(LoopInd) = SnowLiqTmp(LoopInd-NumSnowLayerNeg) + TemperatureSoilSnow(LoopInd) = TemperatureSnowTmp(LoopInd-NumSnowLayerNeg) + enddo + + ! deallocate local arrays to avoid memory leaks + deallocate(SnowIceTmp ) + deallocate(SnowLiqTmp ) + deallocate(TemperatureSnowTmp) + deallocate(SnowThickTmp ) + + end associate + + end subroutine SnowLayerDivide + +end module SnowLayerDivideMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SnowLayerWaterComboMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SnowLayerWaterComboMod.F90 new file mode 100644 index 0000000000..37c48d3d11 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SnowLayerWaterComboMod.F90 @@ -0,0 +1,70 @@ +module SnowLayerWaterComboMod + +!!! Update snow water and temperature for combined snowpack layer + + use Machine + use ConstantDefineMod + + implicit none + +contains + + subroutine SnowLayerWaterCombo(ThickLayer1, LiqLayer1, IceLayer1, TempLayer1, & + ThickLayer2, LiqLayer2, IceLayer2, TempLayer2) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: COMBO +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + +! IN and OUT variables + real(kind=kind_noahmp), intent(in) :: ThickLayer2 ! nodal thickness of 2 elements being combined [m] + real(kind=kind_noahmp), intent(in) :: LiqLayer2 ! liquid water of element 2 [kg/m2] + real(kind=kind_noahmp), intent(in) :: IceLayer2 ! ice of element 2 [kg/m2] + real(kind=kind_noahmp), intent(in) :: TempLayer2 ! nodal temperature of element 2 [K] + real(kind=kind_noahmp), intent(inout) :: ThickLayer1 ! nodal thickness of 1 elements being combined [m] + real(kind=kind_noahmp), intent(inout) :: LiqLayer1 ! liquid water of element 1 + real(kind=kind_noahmp), intent(inout) :: IceLayer1 ! ice of element 1 [kg/m2] + real(kind=kind_noahmp), intent(inout) :: TempLayer1 ! node temperature of element 1 [K] + +! local variable + real(kind=kind_noahmp) :: ThickLayerComb ! total thickness of nodes 1 and 2 + real(kind=kind_noahmp) :: LiqLayerComb ! combined liquid water [kg/m2] + real(kind=kind_noahmp) :: IceLayerComb ! combined ice [kg/m2] + real(kind=kind_noahmp) :: TempLayerComb ! combined node temperature [K] + real(kind=kind_noahmp) :: EnthLayer1 ! enthalpy of element 1 [J/m2] + real(kind=kind_noahmp) :: EnthLayer2 ! enthalpy of element 2 [J/m2] + real(kind=kind_noahmp) :: EnthLayerComb ! combined enthalpy [J/m2] + +! ---------------------------------------------------------------------- + + ThickLayerComb = ThickLayer1 + ThickLayer2 + IceLayerComb = IceLayer1 + IceLayer2 + LiqLayerComb = LiqLayer1 + LiqLayer2 + EnthLayer1 = (ConstHeatCapacIce*IceLayer1 + ConstHeatCapacWater*LiqLayer1) * & + (TempLayer1-ConstFreezePoint) + ConstLatHeatFusion*LiqLayer1 + EnthLayer2 = (ConstHeatCapacIce*IceLayer2 + ConstHeatCapacWater*LiqLayer2) * & + (TempLayer2-ConstFreezePoint) + ConstLatHeatFusion*LiqLayer2 + + EnthLayerComb = EnthLayer1 + EnthLayer2 + if ( EnthLayerComb < 0.0 ) then + TempLayerComb = ConstFreezePoint + EnthLayerComb / & + (ConstHeatCapacIce*IceLayerComb + ConstHeatCapacWater*LiqLayerComb) + else if ( EnthLayerComb <= (ConstLatHeatFusion*LiqLayerComb) ) then + TempLayerComb = ConstFreezePoint + else + TempLayerComb = ConstFreezePoint + (EnthLayerComb-ConstLatHeatFusion*LiqLayerComb) / & + (ConstHeatCapacIce*IceLayerComb + ConstHeatCapacWater*LiqLayerComb) + endif + + ThickLayer1 = ThickLayerComb + IceLayer1 = IceLayerComb + LiqLayer1 = LiqLayerComb + TempLayer1 = TempLayerComb + + end subroutine SnowLayerWaterCombo + +end module SnowLayerWaterComboMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SnowThermalPropertyMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SnowThermalPropertyMod.F90 new file mode 100644 index 0000000000..6e6db9a7ef --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SnowThermalPropertyMod.F90 @@ -0,0 +1,85 @@ +module SnowThermalPropertyMod + +!!! Compute snowpack thermal conductivity and volumetric specific heat + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine SnowThermalProperty(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: CSNOW +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: LoopInd ! loop index + real(kind=kind_noahmp), allocatable, dimension(:) :: SnowDensBulk ! bulk density of snow [kg/m3] + +! -------------------------------------------------------------------- + associate( & + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg ,& ! in, actual number of snow layers (negative) + NumSnowLayerMax => noahmp%config%domain%NumSnowLayerMax ,& ! in, maximum number of snow layers + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! in, thickness of snow/soil layers [m] + OptSnowThermConduct => noahmp%config%nmlist%OptSnowThermConduct ,& ! in, options for snow thermal conductivity schemes + SnowIce => noahmp%water%state%SnowIce ,& ! in, snow layer ice [mm] + SnowLiqWater => noahmp%water%state%SnowLiqWater ,& ! in, snow layer liquid water [mm] + SnowIceVol => noahmp%water%state%SnowIceVol ,& ! out, partial volume of snow ice [m3/m3] + SnowLiqWaterVol => noahmp%water%state%SnowLiqWaterVol ,& ! out, partial volume of snow liquid water [m3/m3] + SnowEffPorosity => noahmp%water%state%SnowEffPorosity ,& ! out, snow effective porosity [m3/m3] + HeatCapacVolSnow => noahmp%energy%state%HeatCapacVolSnow ,& ! out, snow layer volumetric specific heat [J/m3/K] + ThermConductSnow => noahmp%energy%state%ThermConductSnow & ! out, snow layer thermal conductivity [W/m/K] + ) +! ---------------------------------------------------------------------- + + ! initialization + if (.not. allocated(SnowDensBulk)) allocate(SnowDensBulk(-NumSnowLayerMax+1:0)) + SnowDensBulk = 0.0 + + ! effective porosity of snow + do LoopInd = NumSnowLayerNeg+1, 0 + SnowIceVol(LoopInd) = min(1.0, SnowIce(LoopInd)/(ThicknessSnowSoilLayer(LoopInd)*ConstDensityIce)) + SnowEffPorosity(LoopInd) = 1.0 - SnowIceVol(LoopInd) + SnowLiqWaterVol(LoopInd) = min(SnowEffPorosity(LoopInd), & + SnowLiqWater(LoopInd)/(ThicknessSnowSoilLayer(LoopInd)*ConstDensityWater)) + enddo + + ! thermal capacity of snow + do LoopInd = NumSnowLayerNeg+1, 0 + SnowDensBulk(LoopInd) = (SnowIce(LoopInd) + SnowLiqWater(LoopInd)) / ThicknessSnowSoilLayer(LoopInd) + HeatCapacVolSnow(LoopInd) = ConstHeatCapacIce*SnowIceVol(LoopInd) + ConstHeatCapacWater*SnowLiqWaterVol(LoopInd) + !HeatCapacVolSnow(LoopInd) = 0.525e06 ! constant + enddo + + ! thermal conductivity of snow + do LoopInd = NumSnowLayerNeg+1, 0 + if (OptSnowThermConduct == 1) & + ThermConductSnow(LoopInd) = 3.2217e-6 * SnowDensBulk(LoopInd)**2.0 ! Stieglitz(yen,1965) + if (OptSnowThermConduct == 2) & + ThermConductSnow(LoopInd) = 2e-2 + 2.5e-6*SnowDensBulk(LoopInd)*SnowDensBulk(LoopInd) ! Anderson, 1976 + if (OptSnowThermConduct == 3) & + ThermConductSnow(LoopInd) = 0.35 ! constant + if (OptSnowThermConduct == 4) & + ThermConductSnow(LoopInd) = 2.576e-6 * SnowDensBulk(LoopInd)**2.0 + 0.074 ! Verseghy (1991) + if (OptSnowThermConduct == 5) & + ThermConductSnow(LoopInd) = 2.22 * (SnowDensBulk(LoopInd)/1000.0)**1.88 ! Douvill(Yen, 1981) + enddo + + ! deallocate local arrays to avoid memory leaks + deallocate(SnowDensBulk) + + end associate + + end subroutine SnowThermalProperty + +end module SnowThermalPropertyMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SnowWaterMainGlacierMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SnowWaterMainGlacierMod.F90 new file mode 100644 index 0000000000..0fac6ec051 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SnowWaterMainGlacierMod.F90 @@ -0,0 +1,141 @@ +module SnowWaterMainGlacierMod + +!!! Main glacier snow water module including all snowpack processes +!!! Snowfall -> Snowpack compaction -> Snow layer combination -> Snow layer division -> Snow Hydrology + + use Machine + use NoahmpVarType + use ConstantDefineMod + use SnowfallBelowCanopyMod, only : SnowfallAfterCanopyIntercept + use SnowpackCompactionMod, only : SnowpackCompaction + use SnowLayerCombineMod, only : SnowLayerCombine + use SnowLayerDivideMod, only : SnowLayerDivide + use SnowpackHydrologyGlacierMod, only : SnowpackHydrologyGlacier + + implicit none + +contains + + subroutine SnowWaterMainGlacier(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: SNOWWATER_GLACIER +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variables + integer :: LoopInd ! do loop/array indices + real(kind=kind_noahmp) :: SnowDensBulk ! bulk density of snow [kg/m3] + +! -------------------------------------------------------------------- + associate( & + NumSnowLayerMax => noahmp%config%domain%NumSnowLayerMax ,& ! in, maximum number of snow layers + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + MainTimeStep => noahmp%config%domain%MainTimeStep ,& ! in, noahmp main time step [s] + DepthSoilLayer => noahmp%config%domain%DepthSoilLayer ,& ! in, depth [m] of layer-bottom from soil surface + SnoWatEqvMaxGlacier => noahmp%water%param%SnoWatEqvMaxGlacier ,& ! in, Maximum SWE allowed at glaciers [mm] + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! inout, thickness of snow/soil layers [m] + DepthSnowSoilLayer => noahmp%config%domain%DepthSnowSoilLayer ,& ! inout, depth of snow/soil layer-bottom [m] + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg ,& ! inout, actual number of snow layers (negative) + SnowDepth => noahmp%water%state%SnowDepth ,& ! inout, snow depth [m] + SnowWaterEquiv => noahmp%water%state%SnowWaterEquiv ,& ! inout, snow water equivalent [mm] + SnowIce => noahmp%water%state%SnowIce ,& ! inout, snow layer ice [mm] + SnowLiqWater => noahmp%water%state%SnowLiqWater ,& ! inout, snow layer liquid water [mm] + TemperatureSoilSnow => noahmp%energy%state%TemperatureSoilSnow ,& ! inout, snow and soil layer temperature [K] + GlacierExcessFlow => noahmp%water%flux%GlacierExcessFlow ,& ! out, glacier excess flow [mm/s] + PondSfcThinSnwComb => noahmp%water%state%PondSfcThinSnwComb ,& ! out, surface ponding [mm] from liquid in thin snow layer combination + PondSfcThinSnwTrans => noahmp%water%state%PondSfcThinSnwTrans & ! out, surface ponding [mm] from thin snow liquid during transition from multilayer to no layer + ) +! ---------------------------------------------------------------------- + + ! initialize out-only variables + GlacierExcessFlow = 0.0 + PondSfcThinSnwComb = 0.0 + PondSfcThinSnwTrans = 0.0 + + ! snowfall + call SnowfallAfterCanopyIntercept(noahmp) + + ! do following snow layer compaction, combination, and division only for multi-layer snowpack + + ! snowpack compaction + if ( NumSnowLayerNeg < 0 ) call SnowpackCompaction(noahmp) + + ! snow layer combination + if ( NumSnowLayerNeg < 0 ) call SnowLayerCombine(noahmp) + + ! snow layer division + if ( NumSnowLayerNeg < 0 ) call SnowLayerDivide(noahmp) + + ! snow hydrology for all snow cases + call SnowpackHydrologyGlacier(noahmp) + + ! set empty snow layer properties to zero + do LoopInd = -NumSnowLayerMax+1, NumSnowLayerNeg + SnowIce(LoopInd) = 0.0 + SnowLiqWater(LoopInd) = 0.0 + TemperatureSoilSnow(LoopInd) = 0.0 + ThicknessSnowSoilLayer(LoopInd) = 0.0 + DepthSnowSoilLayer(LoopInd) = 0.0 + enddo + + ! to obtain equilibrium state of snow in glacier region + if ( SnowWaterEquiv > SnoWatEqvMaxGlacier ) then + SnowDensBulk = SnowIce(0) / ThicknessSnowSoilLayer(0) + GlacierExcessFlow = SnowWaterEquiv - SnoWatEqvMaxGlacier + SnowIce(0) = SnowIce(0) - GlacierExcessFlow + ThicknessSnowSoilLayer(0) = ThicknessSnowSoilLayer(0) - GlacierExcessFlow / SnowDensBulk + GlacierExcessFlow = GlacierExcessFlow / MainTimeStep + endif + + ! sum up snow mass for layered snow + if ( NumSnowLayerNeg < 0 ) then ! MB: only do for multi-layer + SnowWaterEquiv = 0.0 + do LoopInd = NumSnowLayerNeg+1, 0 + SnowWaterEquiv = SnowWaterEquiv + SnowIce(LoopInd) + SnowLiqWater(LoopInd) + enddo + endif + + ! Reset DepthSnowSoilLayer and ThicknessSnowSoilLayer + do LoopInd = NumSnowLayerNeg+1, 0 + ThicknessSnowSoilLayer(LoopInd) = -ThicknessSnowSoilLayer(LoopInd) + enddo + + ThicknessSnowSoilLayer(1) = DepthSoilLayer(1) + do LoopInd = 2, NumSoilLayer + ThicknessSnowSoilLayer(LoopInd) = DepthSoilLayer(LoopInd) - DepthSoilLayer(LoopInd-1) + enddo + + DepthSnowSoilLayer(NumSnowLayerNeg+1) = ThicknessSnowSoilLayer(NumSnowLayerNeg+1) + do LoopInd = NumSnowLayerNeg+2, NumSoilLayer + DepthSnowSoilLayer(LoopInd) = DepthSnowSoilLayer(LoopInd-1) + ThicknessSnowSoilLayer(LoopInd) + enddo + + do LoopInd = NumSnowLayerNeg+1, NumSoilLayer + ThicknessSnowSoilLayer(LoopInd) = -ThicknessSnowSoilLayer(LoopInd) + enddo + + ! Update SnowDepth for multi-layer snow + if ( NumSnowLayerNeg < 0 ) then + SnowDepth = 0.0 + do LoopInd = NumSnowLayerNeg+1, 0 + SnowDepth = SnowDepth + ThicknessSnowSoilLayer(LoopInd) + enddo + endif + + ! update snow quantity + if ( (SnowDepth <= 1.0e-6) .or. (SnowWaterEquiv <= 1.0e-6) ) then + SnowDepth = 0.0 + SnowWaterEquiv = 0.0 + endif + + end associate + + end subroutine SnowWaterMainGlacier + +end module SnowWaterMainGlacierMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SnowWaterMainMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SnowWaterMainMod.F90 new file mode 100644 index 0000000000..2e3e7f00a6 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SnowWaterMainMod.F90 @@ -0,0 +1,141 @@ +module SnowWaterMainMod + +!!! Main snow water module including all snowpack processes +!!! Snowfall -> Snowpack compaction -> Snow layer combination -> Snow layer division -> Snow Hydrology + + use Machine + use NoahmpVarType + use ConstantDefineMod + use SnowfallBelowCanopyMod, only : SnowfallAfterCanopyIntercept + use SnowpackCompactionMod, only : SnowpackCompaction + use SnowLayerCombineMod, only : SnowLayerCombine + use SnowLayerDivideMod, only : SnowLayerDivide + use SnowpackHydrologyMod, only : SnowpackHydrology + + implicit none + +contains + + subroutine SnowWaterMain(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: SNOWWATER +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: LoopInd ! do loop/array indices + real(kind=kind_noahmp) :: SnowDensBulk ! bulk density of snow [kg/m3] + +! -------------------------------------------------------------------- + associate( & + NumSnowLayerMax => noahmp%config%domain%NumSnowLayerMax ,& ! in, maximum number of snow layers + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + MainTimeStep => noahmp%config%domain%MainTimeStep ,& ! in, noahmp main time step [s] + DepthSoilLayer => noahmp%config%domain%DepthSoilLayer ,& ! in, depth [m] of layer-bottom from soil surface + SnoWatEqvMaxGlacier => noahmp%water%param%SnoWatEqvMaxGlacier ,& ! in, Maximum SWE allowed at glaciers [mm] + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! inout, thickness of snow/soil layers [m] + DepthSnowSoilLayer => noahmp%config%domain%DepthSnowSoilLayer ,& ! inout, depth of snow/soil layer-bottom [m] + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg ,& ! inout, actual number of snow layers (negative) + SnowDepth => noahmp%water%state%SnowDepth ,& ! inout, snow depth [m] + SnowWaterEquiv => noahmp%water%state%SnowWaterEquiv ,& ! inout, snow water equivalent [mm] + SnowIce => noahmp%water%state%SnowIce ,& ! inout, snow layer ice [mm] + SnowLiqWater => noahmp%water%state%SnowLiqWater ,& ! inout, snow layer liquid water [mm] + TemperatureSoilSnow => noahmp%energy%state%TemperatureSoilSnow ,& ! inout, snow and soil layer temperature [K] + GlacierExcessFlow => noahmp%water%flux%GlacierExcessFlow ,& ! out, glacier snow excess flow [mm/s] + PondSfcThinSnwComb => noahmp%water%state%PondSfcThinSnwComb ,& ! out, surface ponding [mm] from liquid in thin snow layer combination + PondSfcThinSnwTrans => noahmp%water%state%PondSfcThinSnwTrans & ! out, surface ponding [mm] from thin snow liquid during transition from multilayer to no layer + ) +! ---------------------------------------------------------------------- + + ! initialize out-only variables + GlacierExcessFlow = 0.0 + PondSfcThinSnwComb = 0.0 + PondSfcThinSnwTrans = 0.0 + + ! snowfall after canopy interception + call SnowfallAfterCanopyIntercept(noahmp) + + ! do following snow layer compaction, combination, and division only for multi-layer snowpack + + ! snowpack compaction + if ( NumSnowLayerNeg < 0 ) call SnowpackCompaction(noahmp) + + ! snow layer combination + if ( NumSnowLayerNeg < 0 ) call SnowLayerCombine(noahmp) + + ! snow layer division + if ( NumSnowLayerNeg < 0 ) call SnowLayerDivide(noahmp) + + ! snow hydrology for all snow cases + call SnowpackHydrology(noahmp) + + ! set empty snow layer properties to zero + do LoopInd = -NumSnowLayerMax+1, NumSnowLayerNeg + SnowIce(LoopInd) = 0.0 + SnowLiqWater(LoopInd) = 0.0 + TemperatureSoilSnow(LoopInd) = 0.0 + ThicknessSnowSoilLayer(LoopInd) = 0.0 + DepthSnowSoilLayer(LoopInd) = 0.0 + enddo + + ! to obtain equilibrium state of snow in glacier region + if ( SnowWaterEquiv > SnoWatEqvMaxGlacier ) then + SnowDensBulk = SnowIce(0) / ThicknessSnowSoilLayer(0) + GlacierExcessFlow = SnowWaterEquiv - SnoWatEqvMaxGlacier + SnowIce(0) = SnowIce(0) - GlacierExcessFlow + ThicknessSnowSoilLayer(0) = ThicknessSnowSoilLayer(0) - GlacierExcessFlow / SnowDensBulk + GlacierExcessFlow = GlacierExcessFlow / MainTimeStep + endif + + ! sum up snow mass for layered snow + if ( NumSnowLayerNeg < 0 ) then ! MB: only do for multi-layer + SnowWaterEquiv = 0.0 + do LoopInd = NumSnowLayerNeg+1, 0 + SnowWaterEquiv = SnowWaterEquiv + SnowIce(LoopInd) + SnowLiqWater(LoopInd) + enddo + endif + + ! Reset DepthSnowSoilLayer and ThicknessSnowSoilLayer + do LoopInd = NumSnowLayerNeg+1, 0 + ThicknessSnowSoilLayer(LoopInd) = -ThicknessSnowSoilLayer(LoopInd) + enddo + + ThicknessSnowSoilLayer(1) = DepthSoilLayer(1) + do LoopInd = 2, NumSoilLayer + ThicknessSnowSoilLayer(LoopInd) = DepthSoilLayer(LoopInd) - DepthSoilLayer(LoopInd-1) + enddo + + DepthSnowSoilLayer(NumSnowLayerNeg+1) = ThicknessSnowSoilLayer(NumSnowLayerNeg+1) + do LoopInd = NumSnowLayerNeg+2, NumSoilLayer + DepthSnowSoilLayer(LoopInd) = DepthSnowSoilLayer(LoopInd-1) + ThicknessSnowSoilLayer(LoopInd) + enddo + + do LoopInd = NumSnowLayerNeg+1, NumSoilLayer + ThicknessSnowSoilLayer(LoopInd) = -ThicknessSnowSoilLayer(LoopInd) + enddo + + ! Update SnowDepth for multi-layer snow + if ( NumSnowLayerNeg < 0 ) then + SnowDepth = 0.0 + do LoopInd = NumSnowLayerNeg+1, 0 + SnowDepth = SnowDepth + ThicknessSnowSoilLayer(LoopInd) + enddo + endif + + ! update snow quantity + if ( (SnowDepth <= 1.0e-6) .or. (SnowWaterEquiv <= 1.0e-6) ) then + SnowDepth = 0.0 + SnowWaterEquiv = 0.0 + endif + + end associate + + end subroutine SnowWaterMain + +end module SnowWaterMainMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SnowfallBelowCanopyMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SnowfallBelowCanopyMod.F90 new file mode 100644 index 0000000000..5d37a407d6 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SnowfallBelowCanopyMod.F90 @@ -0,0 +1,78 @@ +module SnowfallBelowCanopyMod + +!!! Snowfall process after canopy interception +!!! Update snow water equivalent and snow depth + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine SnowfallAfterCanopyIntercept(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: SNOWFALL +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: IndNewSnowLayer ! 0-no new layers, 1-creating new layers + +! -------------------------------------------------------------------- + associate( & + MainTimeStep => noahmp%config%domain%MainTimeStep ,& ! in, noahmp main time step [s] + SnowfallGround => noahmp%water%flux%SnowfallGround ,& ! in, snowfall rate at ground [mm/s] + SnowDepthIncr => noahmp%water%flux%SnowDepthIncr ,& ! in, snow depth increasing rate [m/s] due to snowfall + TemperatureAirRefHeight => noahmp%forcing%TemperatureAirRefHeight ,& ! in, air temperature [K] at reference height + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg ,& ! inout, actual number of snow layers (negative) + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! inout, thickness of snow/soil layers [m] + SnowDepth => noahmp%water%state%SnowDepth ,& ! inout, snow depth [m] + SnowWaterEquiv => noahmp%water%state%SnowWaterEquiv ,& ! inout, snow water equivalent [mm] + SnowIce => noahmp%water%state%SnowIce ,& ! inout, snow layer ice [mm] + SnowLiqWater => noahmp%water%state%SnowLiqWater ,& ! inout, snow layer liquid water [mm] + TemperatureSoilSnow => noahmp%energy%state%TemperatureSoilSnow & ! inout, snow and soil layer temperature [K] + ) +! ---------------------------------------------------------------------- + + IndNewSnowLayer = 0 + + ! shallow snow / no layer + if ( (NumSnowLayerNeg == 0) .and. (SnowfallGround > 0.0) ) then + SnowDepth = SnowDepth + SnowDepthIncr * MainTimeStep + SnowWaterEquiv = SnowWaterEquiv + SnowfallGround * MainTimeStep + endif + + ! creating a new layer + !if ( (NumSnowLayerNeg == 0) .and. (SnowfallGround > 0.0) .and. (SnowDepth >= 0.05) ) then + !if ( (NumSnowLayerNeg == 0) .and. (SnowfallGround > 0.0) .and. (SnowDepth >= 0.025) ) then !MB: change limit + ! C.He: remove SnowfallGround > 0.0 to allow adjusting snow layer number based on SnowDepth when no snowfall + if ( (NumSnowLayerNeg == 0) .and. (SnowDepth >= 0.025) ) then + NumSnowLayerNeg = -1 + IndNewSnowLayer = 1 + ThicknessSnowSoilLayer(0) = SnowDepth + SnowDepth = 0.0 + TemperatureSoilSnow(0) = min(273.16, TemperatureAirRefHeight) ! temporary setup + SnowIce(0) = SnowWaterEquiv + SnowLiqWater(0) = 0.0 + endif + + ! snow with layers + if ( (NumSnowLayerNeg < 0) .and. (IndNewSnowLayer == 0) .and. (SnowfallGround > 0.0) ) then + SnowIce(NumSnowLayerNeg+1) = SnowIce(NumSnowLayerNeg+1) + SnowfallGround * MainTimeStep + ThicknessSnowSoilLayer(NumSnowLayerNeg+1) = ThicknessSnowSoilLayer(NumSnowLayerNeg+1) + & + SnowDepthIncr * MainTimeStep + endif + + end associate + + end subroutine SnowfallAfterCanopyIntercept + +end module SnowfallBelowCanopyMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SnowpackCompactionMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SnowpackCompactionMod.F90 new file mode 100644 index 0000000000..05d59b0d7b --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SnowpackCompactionMod.F90 @@ -0,0 +1,126 @@ +module SnowpackCompactionMod + +!!! Snowpack compaction process +!!! Update snow depth via compaction due to destructive metamorphism, overburden, & melt + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine SnowpackCompaction(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: COMPACT +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: LoopInd ! snow layer loop index + real(kind=kind_noahmp) :: SnowBurden ! pressure of overlying snow [kg/m2] + real(kind=kind_noahmp) :: SnowCompactAgeExpFac ! EXPF=exp(-c4*(273.15-TemperatureSoilSnow)) + real(kind=kind_noahmp) :: TempDiff ! ConstFreezePoint - TemperatureSoilSnow[K] + real(kind=kind_noahmp) :: SnowVoid ! void (1 - SnowIce - SnowLiqWater) + real(kind=kind_noahmp) :: SnowWatTotTmp ! water mass (ice + liquid) [kg/m2] + real(kind=kind_noahmp) :: SnowIceDens ! partial density of ice [kg/m3] + +! -------------------------------------------------------------------- + associate( & + MainTimeStep => noahmp%config%domain%MainTimeStep ,& ! in, noahmp main time step [s] + TemperatureSoilSnow => noahmp%energy%state%TemperatureSoilSnow ,& ! in, snow and soil layer temperature [K] + SnowIce => noahmp%water%state%SnowIce ,& ! in, snow layer ice [mm] + SnowLiqWater => noahmp%water%state%SnowLiqWater ,& ! in, snow layer liquid water [mm] + IndexPhaseChange => noahmp%water%state%IndexPhaseChange ,& ! in, phase change index [0-none;1-melt;2-refreeze] + SnowIceFracPrev => noahmp%water%state%SnowIceFracPrev ,& ! in, ice fraction in snow layers at previous timestep + SnowCompactBurdenFac => noahmp%water%param%SnowCompactBurdenFac ,& ! in, snow overburden compaction parameter [m3/kg] + SnowCompactAgingFac1 => noahmp%water%param%SnowCompactAgingFac1 ,& ! in, snow desctructive metamorphism compaction factor1 [1/s] + SnowCompactAgingFac2 => noahmp%water%param%SnowCompactAgingFac2 ,& ! in, snow desctructive metamorphism compaction factor2 [1/k] + SnowCompactAgingFac3 => noahmp%water%param%SnowCompactAgingFac3 ,& ! in, snow desctructive metamorphism compaction factor3 + SnowCompactAgingMax => noahmp%water%param%SnowCompactAgingMax ,& ! in, maximum destructive metamorphism compaction [kg/m3] + SnowViscosityCoeff => noahmp%water%param%SnowViscosityCoeff ,& ! in, snow viscosity coeff [kg s/m2],Anderson1979:0.52e6~1.38e6 + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg ,& ! inout, actual number of snow layers (negative) + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! inout, thickness of snow/soil layers [m] + CompactionSnowAging => noahmp%water%flux%CompactionSnowAging ,& ! out, rate of compaction due to destructive metamorphism [1/s] + CompactionSnowBurden => noahmp%water%flux%CompactionSnowBurden ,& ! out, rate of compaction of snowpack due to overburden [1/s] + CompactionSnowMelt => noahmp%water%flux%CompactionSnowMelt ,& ! out, rate of compaction of snowpack due to melt [1/s] + CompactionSnowTot => noahmp%water%flux%CompactionSnowTot ,& ! out, change in fractional-thickness due to compaction [1/s] + SnowIceFrac => noahmp%water%state%SnowIceFrac & ! out, fraction of ice in snow layers at current time step + ) +! ---------------------------------------------------------------------- + +! initialization for out-only variables + CompactionSnowAging(:) = 0.0 + CompactionSnowBurden(:) = 0.0 + CompactionSnowMelt(:) = 0.0 + CompactionSnowTot(:) = 0.0 + SnowIceFrac(:) = 0.0 + +! start snow compaction + SnowBurden = 0.0 + do LoopInd = NumSnowLayerNeg+1, 0 + + SnowWatTotTmp = SnowIce(LoopInd) + SnowLiqWater(LoopInd) + SnowIceFrac(LoopInd) = SnowIce(LoopInd) / SnowWatTotTmp + SnowVoid = 1.0 - (SnowIce(LoopInd)/ConstDensityIce + SnowLiqWater(LoopInd)/ConstDensityWater) / & + ThicknessSnowSoilLayer(LoopInd) + + ! Allow compaction only for non-saturated node and higher ice lens node. + if ( (SnowVoid > 0.001) .and. (SnowIce(LoopInd) > 0.1) ) then + SnowIceDens = SnowIce(LoopInd) / ThicknessSnowSoilLayer(LoopInd) + TempDiff = max(0.0, ConstFreezePoint-TemperatureSoilSnow(LoopInd)) + + ! Settling/compaction as a result of destructive metamorphism + SnowCompactAgeExpFac = exp(-SnowCompactAgingFac2 * TempDiff) + CompactionSnowAging(LoopInd) = -SnowCompactAgingFac1 * SnowCompactAgeExpFac + if ( SnowIceDens > SnowCompactAgingMax ) & + CompactionSnowAging(LoopInd) = CompactionSnowAging(LoopInd) * exp(-46.0e-3*(SnowIceDens-SnowCompactAgingMax)) + if ( SnowLiqWater(LoopInd) > (0.01*ThicknessSnowSoilLayer(LoopInd)) ) & + CompactionSnowAging(LoopInd) = CompactionSnowAging(LoopInd) * SnowCompactAgingFac3 ! Liquid water term + + ! Compaction due to overburden + CompactionSnowBurden(LoopInd) = -(SnowBurden + 0.5*SnowWatTotTmp) * & + exp(-0.08*TempDiff-SnowCompactBurdenFac*SnowIceDens) / SnowViscosityCoeff ! 0.5*SnowWatTotTmp -> self-burden + + ! Compaction occurring during melt + if ( IndexPhaseChange(LoopInd) == 1 ) then + CompactionSnowMelt(LoopInd) = max(0.0, (SnowIceFracPrev(LoopInd)-SnowIceFrac(LoopInd)) / & + max(1.0e-6, SnowIceFracPrev(LoopInd))) + CompactionSnowMelt(LoopInd) = -CompactionSnowMelt(LoopInd) / MainTimeStep ! sometimes too large + else + CompactionSnowMelt(LoopInd) = 0.0 + endif + + ! Time rate of fractional change in snow thickness (units of s-1) + CompactionSnowTot(LoopInd) = (CompactionSnowAging(LoopInd) + CompactionSnowBurden(LoopInd) + & + CompactionSnowMelt(LoopInd) ) * MainTimeStep + CompactionSnowTot(LoopInd) = max(-0.5, CompactionSnowTot(LoopInd)) + + ! The change in DZ due to compaction + ThicknessSnowSoilLayer(LoopInd) = ThicknessSnowSoilLayer(LoopInd) * (1.0 + CompactionSnowTot(LoopInd)) + ThicknessSnowSoilLayer(LoopInd) = max(ThicknessSnowSoilLayer(LoopInd), & + SnowIce(LoopInd)/ConstDensityIce + SnowLiqWater(LoopInd)/ConstDensityWater) + + ! Constrain snow density to a reasonable range (50~500 kg/m3) + ThicknessSnowSoilLayer(LoopInd) = min( max( ThicknessSnowSoilLayer(LoopInd),& + (SnowIce(LoopInd)+SnowLiqWater(LoopInd))/500.0 ), & + (SnowIce(LoopInd)+SnowLiqWater(LoopInd))/50.0 ) + endif + + ! Pressure of overlying snow + SnowBurden = SnowBurden + SnowWatTotTmp + + enddo + + end associate + + end subroutine SnowpackCompaction + +end module SnowpackCompactionMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SnowpackHydrologyGlacierMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SnowpackHydrologyGlacierMod.F90 new file mode 100644 index 0000000000..dc702ceaba --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SnowpackHydrologyGlacierMod.F90 @@ -0,0 +1,169 @@ +module SnowpackHydrologyGlacierMod + +!!! Snowpack hydrology processes (sublimation/frost, evaporation/dew, meltwater) +!!! Update snowpack ice and liquid water content + + use Machine + use NoahmpVarType + use ConstantDefineMod + use SnowLayerCombineMod, only : SnowLayerCombine + + implicit none + +contains + + subroutine SnowpackHydrologyGlacier(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: SNOWH2O_GLACIER +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variables + integer :: LoopInd ! do loop/array indices + real(kind=kind_noahmp) :: InflowSnowLayer ! water flow into each snow layer (mm/s) + real(kind=kind_noahmp) :: OutflowSnowLayer ! water flow out of each snow layer (mm/s) + real(kind=kind_noahmp) :: SnowIceTmp ! ice mass after minus sublimation + real(kind=kind_noahmp) :: SnowWaterRatio ! ratio of SWE after frost & sublimation to original SWE + real(kind=kind_noahmp) :: SnowWaterTmp ! temporary SWE + real(kind=kind_noahmp), allocatable, dimension(:) :: SnowLiqVol ! partial volume of liquid water in layer + real(kind=kind_noahmp), allocatable, dimension(:) :: SnowIceVol ! partial volume of ice lens in layer + +! -------------------------------------------------------------------- + associate( & + OptGlacierTreatment => noahmp%config%nmlist%OptGlacierTreatment ,& ! in, option for glacier treatment + NumSnowLayerMax => noahmp%config%domain%NumSnowLayerMax ,& ! in, maximum number of snow layers + MainTimeStep => noahmp%config%domain%MainTimeStep ,& ! in, noahmp main time step [s] + HeatSensibleSfc => noahmp%energy%flux%HeatSensibleSfc ,& ! in, total sensible heat [W/m2] (+ to atm) + FrostSnowSfcIce => noahmp%water%flux%FrostSnowSfcIce ,& ! in, snow surface frost rate [mm/s] + SublimSnowSfcIce => noahmp%water%flux%SublimSnowSfcIce ,& ! in, snow surface sublimation rate [mm/s] + RainfallGround => noahmp%water%flux%RainfallGround ,& ! in, ground surface rain rate [mm/s] + SnowLiqFracMax => noahmp%water%param%SnowLiqFracMax ,& ! in, maximum liquid water fraction in snow + SnowLiqHoldCap => noahmp%water%param%SnowLiqHoldCap ,& ! in, liquid water holding capacity for snowpack [m3/m3] + SnowLiqReleaseFac => noahmp%water%param%SnowLiqReleaseFac ,& ! in, snowpack water release timescale factor [1/s] + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg ,& ! inout, actual number of snow layers (negative) + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! inout, thickness of snow/soil layers [m] + SnowDepth => noahmp%water%state%SnowDepth ,& ! inout, snow depth [m] + SnowWaterEquiv => noahmp%water%state%SnowWaterEquiv ,& ! inout, snow water equivalent [mm] + SnowIce => noahmp%water%state%SnowIce ,& ! inout, snow layer ice [mm] + SnowLiqWater => noahmp%water%state%SnowLiqWater ,& ! inout, snow layer liquid water [mm] + SoilLiqWater => noahmp%water%state%SoilLiqWater ,& ! inout, soil liquid moisture [m3/m3] + SoilIce => noahmp%water%state%SoilIce ,& ! inout, soil ice moisture [m3/m3] + SnowEffPorosity => noahmp%water%state%SnowEffPorosity ,& ! out, snow effective porosity [m3/m3] + SnowBotOutflow => noahmp%water%flux%SnowBotOutflow & ! out, total water (snowmelt + rain through pack) out of snowpack bottom [mm/s] + ) +! ---------------------------------------------------------------------- + + ! initialization + if (.not. allocated(SnowLiqVol)) allocate(SnowLiqVol(-NumSnowLayerMax+1:0)) + if (.not. allocated(SnowIceVol)) allocate(SnowIceVol(-NumSnowLayerMax+1:0)) + SnowLiqVol(:) = 0.0 + SnowIceVol(:) = 0.0 + SnowEffPorosity(:) = 0.0 + SnowBotOutflow = 0.0 + InflowSnowLayer = 0.0 + OutflowSnowLayer = 0.0 + + ! for the case when SnowWaterEquiv becomes '0' after 'COMBINE' + if ( SnowWaterEquiv == 0.0 ) then + if ( OptGlacierTreatment == 1 ) then + SoilIce(1) = SoilIce(1) + (FrostSnowSfcIce-SublimSnowSfcIce) * MainTimeStep / & + (ThicknessSnowSoilLayer(1)*1000.0) ! Barlage: SoilLiqWater->SoilIce v3.6 + elseif ( OptGlacierTreatment == 2 ) then + HeatSensibleSfc = HeatSensibleSfc - (FrostSnowSfcIce - SublimSnowSfcIce) * ConstLatHeatSublim + FrostSnowSfcIce = 0.0 + SublimSnowSfcIce = 0.0 + endif + endif + + ! for shallow snow without a layer + ! snow surface sublimation may be larger than existing snow mass. To conserve water, + ! excessive sublimation is used to reduce soil water. Smaller time steps would tend to aviod this problem. + if ( (NumSnowLayerNeg == 0) .and. (SnowWaterEquiv > 0.0) ) then + if ( OptGlacierTreatment == 1 ) then + SnowWaterTmp = SnowWaterEquiv + SnowWaterEquiv = SnowWaterEquiv - SublimSnowSfcIce*MainTimeStep + FrostSnowSfcIce*MainTimeStep + SnowWaterRatio = SnowWaterEquiv / SnowWaterTmp + SnowDepth = max(0.0, SnowWaterRatio*SnowDepth) + SnowDepth = min(max(SnowDepth, SnowWaterEquiv/500.0), SnowWaterEquiv/50.0) ! limit adjustment to a reasonable density + elseif ( OptGlacierTreatment == 2 ) then + HeatSensibleSfc = HeatSensibleSfc - (FrostSnowSfcIce - SublimSnowSfcIce) * ConstLatHeatSublim + FrostSnowSfcIce = 0.0 + SublimSnowSfcIce = 0.0 + endif + if ( SnowWaterEquiv < 0.0 ) then + SoilIce(1) = SoilIce(1) + SnowWaterEquiv / (ThicknessSnowSoilLayer(1)*1000.0) + SnowWaterEquiv = 0.0 + SnowDepth = 0.0 + endif + if ( SoilIce(1) < 0.0 ) then + SoilLiqWater(1) = SoilLiqWater(1) + SoilIce(1) + SoilIce(1) = 0.0 + endif + endif + + if ( (SnowDepth <= 1.0e-8) .or. (SnowWaterEquiv <= 1.0e-6) ) then + SnowDepth = 0.0 + SnowWaterEquiv = 0.0 + endif + + ! for multi-layer (>=1) snow + if ( NumSnowLayerNeg < 0 ) then + SnowIceTmp = SnowIce(NumSnowLayerNeg+1) - SublimSnowSfcIce*MainTimeStep + FrostSnowSfcIce*MainTimeStep + SnowIce(NumSnowLayerNeg+1) = SnowIceTmp + if ( (SnowIceTmp < 1.0e-6) .and. (NumSnowLayerNeg < 0) ) call SnowLayerCombine(noahmp) + if ( NumSnowLayerNeg < 0 ) then + SnowLiqWater(NumSnowLayerNeg+1) = SnowLiqWater(NumSnowLayerNeg+1) + RainfallGround * MainTimeStep + SnowLiqWater(NumSnowLayerNeg+1) = max(0.0, SnowLiqWater(NumSnowLayerNeg+1)) + endif + endif + + ! Porosity and partial volume + do LoopInd = NumSnowLayerNeg+1, 0 + SnowIceVol(LoopInd) = min(1.0, SnowIce(LoopInd)/(ThicknessSnowSoilLayer(LoopInd)*ConstDensityIce)) + SnowEffPorosity(LoopInd) = 1.0 - SnowIceVol(LoopInd) + enddo + + ! compute inter-layer snow water flow + do LoopInd = NumSnowLayerNeg+1, 0 + SnowLiqWater(LoopInd) = SnowLiqWater(LoopInd) + InflowSnowLayer + SnowLiqVol(LoopInd) = SnowLiqWater(LoopInd) / (ThicknessSnowSoilLayer(LoopInd)*ConstDensityWater) + OutflowSnowLayer = max(0.0, (SnowLiqVol(LoopInd) - SnowLiqHoldCap*SnowEffPorosity(LoopInd)) * & + ThicknessSnowSoilLayer(LoopInd)) + if ( LoopInd == 0 ) then + OutflowSnowLayer = max((SnowLiqVol(LoopInd)-SnowEffPorosity(LoopInd)) * ThicknessSnowSoilLayer(LoopInd), & + SnowLiqReleaseFac * MainTimeStep * OutflowSnowLayer) + endif + OutflowSnowLayer = OutflowSnowLayer * ConstDensityWater + SnowLiqWater(LoopInd) = SnowLiqWater(LoopInd) - OutflowSnowLayer + if ( ( SnowLiqWater(LoopInd) / (SnowIce(LoopInd)+SnowLiqWater(LoopInd)) ) > SnowLiqFracMax ) then + OutflowSnowLayer = OutflowSnowLayer + & + (SnowLiqWater(LoopInd) - SnowLiqFracMax/(1.0-SnowLiqFracMax) * SnowIce(LoopInd)) + SnowLiqWater(LoopInd) = SnowLiqFracMax / (1.0 - SnowLiqFracMax) * SnowIce(LoopInd) + endif + InflowSnowLayer = OutflowSnowLayer + enddo + + ! update snow depth + do LoopInd = NumSnowLayerNeg+1, 0 + ThicknessSnowSoilLayer(LoopInd) = max(ThicknessSnowSoilLayer(LoopInd), & + SnowLiqWater(LoopInd)/ConstDensityWater + SnowIce(LoopInd)/ConstDensityIce) + enddo + + ! Liquid water from snow bottom to soil (mm/s) + SnowBotOutflow = OutflowSnowLayer / MainTimeStep + + ! deallocate local arrays to avoid memory leaks + deallocate(SnowLiqVol) + deallocate(SnowIceVol) + + end associate + + end subroutine SnowpackHydrologyGlacier + +end module SnowpackHydrologyGlacierMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SnowpackHydrologyMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SnowpackHydrologyMod.F90 new file mode 100644 index 0000000000..8b3638d4e2 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SnowpackHydrologyMod.F90 @@ -0,0 +1,159 @@ +module SnowpackHydrologyMod + +!!! Snowpack hydrology processes (sublimation/frost, evaporation/dew, meltwater) +!!! Update snowpack ice and liquid water content + + use Machine + use NoahmpVarType + use ConstantDefineMod + use SnowLayerCombineMod, only : SnowLayerCombine + + implicit none + +contains + + subroutine SnowpackHydrology(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: SNOWH2O +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: LoopInd ! do loop/array indices + real(kind=kind_noahmp) :: InflowSnowLayer ! water flow into each snow layer [mm/s] + real(kind=kind_noahmp) :: OutflowSnowLayer ! water flow out of each snow layer [mm/s] + real(kind=kind_noahmp) :: SnowIceTmp ! ice mass after minus sublimation + real(kind=kind_noahmp) :: SnowWaterRatio ! ratio of SWE after frost & sublimation to original SWE + real(kind=kind_noahmp) :: SnowWaterTmp ! temporary SWE + real(kind=kind_noahmp), allocatable, dimension(:) :: SnowLiqVol ! partial volume of liquid water in layer + real(kind=kind_noahmp), allocatable, dimension(:) :: SnowIceVol ! partial volume of ice lens in layer + +! -------------------------------------------------------------------- + associate( & + NumSnowLayerMax => noahmp%config%domain%NumSnowLayerMax ,& ! in, maximum number of snow layers + MainTimeStep => noahmp%config%domain%MainTimeStep ,& ! in, noahmp main time step [s] + FrostSnowSfcIce => noahmp%water%flux%FrostSnowSfcIce ,& ! in, snow surface frost rate [mm/s] + SublimSnowSfcIce => noahmp%water%flux%SublimSnowSfcIce ,& ! in, snow surface sublimation rate [mm/s] + RainfallGround => noahmp%water%flux%RainfallGround ,& ! in, ground surface rain rate [mm/s] + SnowLiqFracMax => noahmp%water%param%SnowLiqFracMax ,& ! in, maximum liquid water fraction in snow + SnowLiqHoldCap => noahmp%water%param%SnowLiqHoldCap ,& ! in, liquid water holding capacity for snowpack [m3/m3] + SnowLiqReleaseFac => noahmp%water%param%SnowLiqReleaseFac ,& ! in, snowpack water release timescale factor [1/s] + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg ,& ! inout, actual number of snow layers (negative) + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! inout, thickness of snow/soil layers [m] + SnowDepth => noahmp%water%state%SnowDepth ,& ! inout, snow depth [m] + SnowWaterEquiv => noahmp%water%state%SnowWaterEquiv ,& ! inout, snow water equivalent [mm] + SnowIce => noahmp%water%state%SnowIce ,& ! inout, snow layer ice [mm] + SnowLiqWater => noahmp%water%state%SnowLiqWater ,& ! inout, snow layer liquid water [mm] + SoilLiqWater => noahmp%water%state%SoilLiqWater ,& ! inout, soil liquid moisture [m3/m3] + SoilIce => noahmp%water%state%SoilIce ,& ! inout, soil ice moisture [m3/m3] + SnowEffPorosity => noahmp%water%state%SnowEffPorosity ,& ! out, snow effective porosity [m3/m3] + SnowBotOutflow => noahmp%water%flux%SnowBotOutflow & ! out, total water (snowmelt + rain through pack) out of snowpack bottom [mm/s] + ) +! ---------------------------------------------------------------------- + + ! initialization + if (.not. allocated(SnowLiqVol)) allocate(SnowLiqVol(-NumSnowLayerMax+1:0)) + if (.not. allocated(SnowIceVol)) allocate(SnowIceVol(-NumSnowLayerMax+1:0)) + SnowLiqVol(:) = 0.0 + SnowIceVol(:) = 0.0 + SnowEffPorosity(:) = 0.0 + SnowBotOutflow = 0.0 + InflowSnowLayer = 0.0 + OutflowSnowLayer = 0.0 + + ! for the case when SnowWaterEquiv becomes '0' after 'COMBINE' + if ( SnowWaterEquiv == 0.0 ) then + SoilIce(1) = SoilIce(1) + (FrostSnowSfcIce-SublimSnowSfcIce) * MainTimeStep / & + (ThicknessSnowSoilLayer(1)*1000.0) ! Barlage: SoilLiqWater->SoilIce v3.6 + if ( SoilIce(1) < 0.0 ) then + SoilLiqWater(1) = SoilLiqWater(1) + SoilIce(1) + SoilIce(1) = 0.0 + endif + endif + + ! for shallow snow without a layer + ! snow surface sublimation may be larger than existing snow mass. To conserve water, + ! excessive sublimation is used to reduce soil water. Smaller time steps would tend to aviod this problem. + if ( (NumSnowLayerNeg == 0) .and. (SnowWaterEquiv > 0.0) ) then + SnowWaterTmp = SnowWaterEquiv + SnowWaterEquiv = SnowWaterEquiv - SublimSnowSfcIce*MainTimeStep + FrostSnowSfcIce*MainTimeStep + SnowWaterRatio = SnowWaterEquiv / SnowWaterTmp + SnowDepth = max(0.0, SnowWaterRatio*SnowDepth ) + SnowDepth = min(max(SnowDepth,SnowWaterEquiv/500.0), SnowWaterEquiv/50.0) ! limit adjustment to a reasonable density + if ( SnowWaterEquiv < 0.0 ) then + SoilIce(1) = SoilIce(1) + SnowWaterEquiv / (ThicknessSnowSoilLayer(1)*1000.0) + SnowWaterEquiv = 0.0 + SnowDepth = 0.0 + endif + if ( SoilIce(1) < 0.0 ) then + SoilLiqWater(1) = SoilLiqWater(1) + SoilIce(1) + SoilIce(1) = 0.0 + endif + endif + + if ( (SnowDepth <= 1.0e-8) .or. (SnowWaterEquiv <= 1.0e-6) ) then + SnowDepth = 0.0 + SnowWaterEquiv = 0.0 + endif + + ! for multi-layer (>=1) snow + if ( NumSnowLayerNeg < 0 ) then + SnowIceTmp = SnowIce(NumSnowLayerNeg+1) - SublimSnowSfcIce*MainTimeStep + FrostSnowSfcIce*MainTimeStep + SnowIce(NumSnowLayerNeg+1) = SnowIceTmp + if ( (SnowIceTmp < 1.0e-6) .and. (NumSnowLayerNeg < 0) ) call SnowLayerCombine(noahmp) + if ( NumSnowLayerNeg < 0 ) then + SnowLiqWater(NumSnowLayerNeg+1) = SnowLiqWater(NumSnowLayerNeg+1) + RainfallGround * MainTimeStep + SnowLiqWater(NumSnowLayerNeg+1) = max(0.0, SnowLiqWater(NumSnowLayerNeg+1)) + endif + endif + + ! Porosity and partial volume + do LoopInd = NumSnowLayerNeg+1, 0 + SnowIceVol(LoopInd) = min(1.0, SnowIce(LoopInd)/(ThicknessSnowSoilLayer(LoopInd)*ConstDensityIce)) + SnowEffPorosity(LoopInd) = 1.0 - SnowIceVol(LoopInd) + enddo + + ! compute inter-layer snow water flow + do LoopInd = NumSnowLayerNeg+1, 0 + SnowLiqWater(LoopInd) = SnowLiqWater(LoopInd) + InflowSnowLayer + SnowLiqVol(LoopInd) = SnowLiqWater(LoopInd) / (ThicknessSnowSoilLayer(LoopInd)*ConstDensityWater) + OutflowSnowLayer = max(0.0, (SnowLiqVol(LoopInd)-SnowLiqHoldCap*SnowEffPorosity(LoopInd)) * & + ThicknessSnowSoilLayer(LoopInd)) + if ( LoopInd == 0 ) then + OutflowSnowLayer = max((SnowLiqVol(LoopInd)-SnowEffPorosity(LoopInd)) * ThicknessSnowSoilLayer(LoopInd), & + SnowLiqReleaseFac * MainTimeStep * OutflowSnowLayer) + endif + OutflowSnowLayer = OutflowSnowLayer * ConstDensityWater + SnowLiqWater(LoopInd) = SnowLiqWater(LoopInd) - OutflowSnowLayer + if ( (SnowLiqWater(LoopInd)/(SnowIce(LoopInd)+SnowLiqWater(LoopInd))) > SnowLiqFracMax ) then + OutflowSnowLayer = OutflowSnowLayer + (SnowLiqWater(LoopInd) - & + SnowLiqFracMax / (1.0-SnowLiqFracMax) * SnowIce(LoopInd)) + SnowLiqWater(LoopInd) = SnowLiqFracMax / (1.0 - SnowLiqFracMax) * SnowIce(LoopInd) + endif + InflowSnowLayer = OutflowSnowLayer + enddo + + ! update snow depth + do LoopInd = NumSnowLayerNeg+1, 0 + ThicknessSnowSoilLayer(LoopInd) = max(ThicknessSnowSoilLayer(LoopInd), & + SnowLiqWater(LoopInd)/ConstDensityWater+SnowIce(LoopInd)/ConstDensityIce) + enddo + + ! Liquid water from snow bottom to soil [mm/s] + SnowBotOutflow = OutflowSnowLayer / MainTimeStep + + ! deallocate local arrays to avoid memory leaks + deallocate(SnowLiqVol) + deallocate(SnowIceVol) + + end associate + + end subroutine SnowpackHydrology + +end module SnowpackHydrologyMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SoilHydraulicPropertyMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SoilHydraulicPropertyMod.F90 new file mode 100644 index 0000000000..438624f5c0 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SoilHydraulicPropertyMod.F90 @@ -0,0 +1,118 @@ +module SoilHydraulicPropertyMod + +!!! Two methods for calculating soil water diffusivity and soil hydraulic conductivity +!!! Option 1: linear effects (more permeable, Niu and Yang,2006); Option 2: nonlinear effects (less permeable) + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine SoilDiffusivityConductivityOpt1(noahmp, SoilWatDiffusivity, SoilWatConductivity, & + SoilMoisture, SoilImpervFrac, IndLayer) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: WDFCND1 +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + +! IN and OUT variables + type(noahmp_type) , intent(inout) :: noahmp + integer , intent(in) :: IndLayer ! soil layer index + real(kind=kind_noahmp), intent(in) :: SoilMoisture ! soil moisture [m3/m3] + real(kind=kind_noahmp), intent(in) :: SoilImpervFrac ! impervious fraction due to frozen soil + real(kind=kind_noahmp), intent(out) :: SoilWatConductivity ! soil water conductivity [m/s] + real(kind=kind_noahmp), intent(out) :: SoilWatDiffusivity ! soil water diffusivity [m2/s] + +! local variable + real(kind=kind_noahmp) :: SoilExpTmp ! exponential local factor + real(kind=kind_noahmp) :: SoilPreFac ! pre-factor + +! -------------------------------------------------------------------- + associate( & + SoilMoistureSat => noahmp%water%param%SoilMoistureSat ,& ! in, saturated value of soil moisture [m3/m3] + SoilExpCoeffB => noahmp%water%param%SoilExpCoeffB ,& ! in, soil B parameter + SoilWatDiffusivitySat => noahmp%water%param%SoilWatDiffusivitySat ,& ! in, saturated soil hydraulic diffusivity [m2/s] + SoilWatConductivitySat => noahmp%water%param%SoilWatConductivitySat & ! in, saturated soil hydraulic conductivity [m/s] + ) +! ---------------------------------------------------------------------- + + SoilPreFac = max(0.01, SoilMoisture/SoilMoistureSat(IndLayer)) + + ! soil water diffusivity + SoilExpTmp = SoilExpCoeffB(IndLayer) + 2.0 + SoilWatDiffusivity = SoilWatDiffusivitySat(IndLayer) * SoilPreFac ** SoilExpTmp + SoilWatDiffusivity = SoilWatDiffusivity * (1.0 - SoilImpervFrac) + + ! soil hydraulic conductivity + SoilExpTmp = 2.0 * SoilExpCoeffB(IndLayer) + 3.0 + SoilWatConductivity = SoilWatConductivitySat(IndLayer) * SoilPreFac ** SoilExpTmp + SoilWatConductivity = SoilWatConductivity * (1.0 - SoilImpervFrac) + + end associate + + end subroutine SoilDiffusivityConductivityOpt1 + + + subroutine SoilDiffusivityConductivityOpt2(noahmp, SoilWatDiffusivity, SoilWatConductivity, & + SoilMoisture, SoilIce, IndLayer) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: WDFCND2 +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + +! IN and OUT variables + type(noahmp_type) , intent(inout) :: noahmp + integer , intent(in) :: IndLayer ! soil layer index + real(kind=kind_noahmp), intent(in) :: SoilMoisture ! soil moisture [m3/m3] + real(kind=kind_noahmp), intent(in) :: SoilIce ! soil ice content [m3/m3] + real(kind=kind_noahmp), intent(out) :: SoilWatConductivity ! soil water conductivity [m/s] + real(kind=kind_noahmp), intent(out) :: SoilWatDiffusivity ! soil water diffusivity [m2/s] + +! local variable + real(kind=kind_noahmp) :: SoilExpTmp ! exponential local factor + real(kind=kind_noahmp) :: SoilPreFac1 ! pre-factor + real(kind=kind_noahmp) :: SoilPreFac2 ! pre-factor + real(kind=kind_noahmp) :: SoilIceWgt ! weights + +! -------------------------------------------------------------------- + associate( & + SoilMoistureSat => noahmp%water%param%SoilMoistureSat ,& ! in, saturated value of soil moisture [m3/m3] + SoilExpCoeffB => noahmp%water%param%SoilExpCoeffB ,& ! in, soil B parameter + SoilWatDiffusivitySat => noahmp%water%param%SoilWatDiffusivitySat ,& ! in, saturated soil hydraulic diffusivity [m2/s] + SoilWatConductivitySat => noahmp%water%param%SoilWatConductivitySat & ! in, saturated soil hydraulic conductivity [m/s] + ) +! ---------------------------------------------------------------------- + + SoilPreFac1 = 0.05 / SoilMoistureSat(IndLayer) + SoilPreFac2 = max(0.01, SoilMoisture/SoilMoistureSat(IndLayer)) + SoilPreFac1 = min(SoilPreFac1, SoilPreFac2) + + ! soil water diffusivity + SoilExpTmp = SoilExpCoeffB(IndLayer) + 2.0 + SoilWatDiffusivity = SoilWatDiffusivitySat(IndLayer) * SoilPreFac2 ** SoilExpTmp + if ( SoilIce > 0.0 ) then + SoilIceWgt = 1.0 / (1.0 + (500.0 * SoilIce)**3.0) + SoilWatDiffusivity = SoilIceWgt * SoilWatDiffusivity + & + (1.0-SoilIceWgt) * SoilWatDiffusivitySat(IndLayer) * SoilPreFac1**SoilExpTmp + endif + + ! soil hydraulic conductivity + SoilExpTmp = 2.0 * SoilExpCoeffB(IndLayer) + 3.0 + SoilWatConductivity = SoilWatConductivitySat(IndLayer) * SoilPreFac2 ** SoilExpTmp + + end associate + + end subroutine SoilDiffusivityConductivityOpt2 + +end module SoilHydraulicPropertyMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SoilMoistureSolverMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SoilMoistureSolverMod.F90 new file mode 100644 index 0000000000..b7ac40166d --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SoilMoistureSolverMod.F90 @@ -0,0 +1,148 @@ +module SoilMoistureSolverMod + +!!! Compute soil moisture content using based on Richards diffusion & tri-diagonal matrix +!!! Dependent on the output from SoilWaterDiffusionRichards subroutine + + use Machine + use NoahmpVarType + use ConstantDefineMod + use MatrixSolverTriDiagonalMod, only : MatrixSolverTriDiagonal + + implicit none + +contains + + subroutine SoilMoistureSolver(noahmp, TimeStep, MatLeft1, MatLeft2, MatLeft3, MatRight) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: SSTEP +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + +! in & out variables + type(noahmp_type) , intent(inout) :: noahmp + real(kind=kind_noahmp), intent(in) :: TimeStep ! timestep (may not be the same as model timestep) + real(kind=kind_noahmp), allocatable, dimension(:), intent(inout) :: MatRight ! right-hand side term of the matrix + real(kind=kind_noahmp), allocatable, dimension(:), intent(inout) :: MatLeft1 ! left-hand side term of the matrix + real(kind=kind_noahmp), allocatable, dimension(:), intent(inout) :: MatLeft2 ! left-hand side term of the matrix + real(kind=kind_noahmp), allocatable, dimension(:), intent(inout) :: MatLeft3 ! left-hand side term of the matrix + +! local variable + integer :: LoopInd ! soil layer loop index + real(kind=kind_noahmp) :: WatDefiTmp ! temporary water deficiency + real(kind=kind_noahmp), allocatable, dimension(:) :: MatRightTmp ! temporary MatRight matrix coefficient + real(kind=kind_noahmp), allocatable, dimension(:) :: MatLeft3Tmp ! temporary MatLeft3 matrix coefficient + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + DepthSoilLayer => noahmp%config%domain%DepthSoilLayer ,& ! in, depth [m] of layer-bottom from soil surface + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! in, thickness of snow/soil layers [m] + OptRunoffSubsurface => noahmp%config%nmlist%OptRunoffSubsurface ,& ! in, options for drainage and subsurface runoff + SoilMoistureSat => noahmp%water%param%SoilMoistureSat ,& ! in, saturated value of soil moisture [m3/m3] + WaterTableDepth => noahmp%water%state%WaterTableDepth ,& ! in, water table depth [m] + SoilIce => noahmp%water%state%SoilIce ,& ! in, soil ice content [m3/m3] + SoilLiqWater => noahmp%water%state%SoilLiqWater ,& ! inout, soil water content [m3/m3] + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! inout, total soil moisture [m3/m3] + SoilMoistureToWT => noahmp%water%state%SoilMoistureToWT ,& ! inout, soil moisture between bottom of soil & water table + RechargeGwDeepWT => noahmp%water%state%RechargeGwDeepWT ,& ! inout, recharge to or from the water table when deep [m] + DrainSoilBot => noahmp%water%flux%DrainSoilBot ,& ! inout, soil bottom drainage (m/s) + SoilEffPorosity => noahmp%water%state%SoilEffPorosity ,& ! out, soil effective porosity (m3/m3) + SoilSaturationExcess => noahmp%water%state%SoilSaturationExcess & ! out, saturation excess of the total soil [m] + ) +! ---------------------------------------------------------------------- + + ! initialization + if (.not. allocated(MatRightTmp)) allocate(MatRightTmp(1:NumSoilLayer)) + if (.not. allocated(MatLeft3Tmp)) allocate(MatLeft3Tmp(1:NumSoilLayer)) + MatRightTmp = 0.0 + MatLeft3Tmp = 0.0 + SoilSaturationExcess = 0.0 + SoilEffPorosity(:) = 0.0 + + ! update tri-diagonal matrix elements + do LoopInd = 1, NumSoilLayer + MatRight(LoopInd) = MatRight(LoopInd) * TimeStep + MatLeft1(LoopInd) = MatLeft1(LoopInd) * TimeStep + MatLeft2(LoopInd) = 1.0 + MatLeft2(LoopInd) * TimeStep + MatLeft3(LoopInd) = MatLeft3(LoopInd) * TimeStep + enddo + + ! copy values for input variables before calling rosr12 + do LoopInd = 1, NumSoilLayer + MatRightTmp(LoopInd) = MatRight(LoopInd) + MatLeft3Tmp(LoopInd) = MatLeft3(LoopInd) + enddo + + ! call ROSR12 to solve the tri-diagonal matrix + call MatrixSolverTriDiagonal(MatLeft3,MatLeft1,MatLeft2,MatLeft3Tmp,MatRightTmp,MatRight,1,NumSoilLayer,0) + + do LoopInd = 1, NumSoilLayer + SoilLiqWater(LoopInd) = SoilLiqWater(LoopInd) + MatLeft3(LoopInd) + enddo + + ! excessive water above saturation in a layer is moved to + ! its unsaturated layer like in a bucket + + ! for MMF scheme, there is soil moisture below NumSoilLayer, to the water table + if ( OptRunoffSubsurface == 5 ) then + ! update SoilMoistureToWT + if ( WaterTableDepth < (DepthSoilLayer(NumSoilLayer)-ThicknessSnowSoilLayer(NumSoilLayer)) ) then + ! accumulate soil drainage to update deep water table and soil moisture later + RechargeGwDeepWT = RechargeGwDeepWT + TimeStep * DrainSoilBot + else + SoilMoistureToWT = SoilMoistureToWT + & + TimeStep * DrainSoilBot / ThicknessSnowSoilLayer(NumSoilLayer) + SoilSaturationExcess = max((SoilMoistureToWT - SoilMoistureSat(NumSoilLayer)), 0.0) * & + ThicknessSnowSoilLayer(NumSoilLayer) + WatDefiTmp = max((1.0e-4 - SoilMoistureToWT), 0.0) * ThicknessSnowSoilLayer(NumSoilLayer) + SoilMoistureToWT = max(min(SoilMoistureToWT, SoilMoistureSat(NumSoilLayer)), 1.0e-4) + SoilLiqWater(NumSoilLayer) = SoilLiqWater(NumSoilLayer) + & + SoilSaturationExcess / ThicknessSnowSoilLayer(NumSoilLayer) + ! reduce fluxes at the bottom boundaries accordingly + DrainSoilBot = DrainSoilBot - SoilSaturationExcess/TimeStep + RechargeGwDeepWT = RechargeGwDeepWT - WatDefiTmp + endif + endif + + do LoopInd = NumSoilLayer, 2, -1 + SoilEffPorosity(LoopInd) = max(1.0e-4, (SoilMoistureSat(LoopInd) - SoilIce(LoopInd))) + SoilSaturationExcess = max((SoilLiqWater(LoopInd)-SoilEffPorosity(LoopInd)), 0.0) * & + ThicknessSnowSoilLayer(LoopInd) + SoilLiqWater(LoopInd) = min(SoilEffPorosity(LoopInd), SoilLiqWater(LoopInd) ) + SoilLiqWater(LoopInd-1) = SoilLiqWater(LoopInd-1) + SoilSaturationExcess / ThicknessSnowSoilLayer(LoopInd-1) + enddo + + SoilEffPorosity(1) = max(1.0e-4, (SoilMoistureSat(1)-SoilIce(1))) + SoilSaturationExcess = max((SoilLiqWater(1)-SoilEffPorosity(1)), 0.0) * ThicknessSnowSoilLayer(1) + SoilLiqWater(1) = min(SoilEffPorosity(1), SoilLiqWater(1)) + + if ( SoilSaturationExcess > 0.0 ) then + SoilLiqWater(2) = SoilLiqWater(2) + SoilSaturationExcess / ThicknessSnowSoilLayer(2) + do LoopInd = 2, NumSoilLayer-1 + SoilEffPorosity(LoopInd) = max(1.0e-4, (SoilMoistureSat(LoopInd) - SoilIce(LoopInd))) + SoilSaturationExcess = max((SoilLiqWater(LoopInd)-SoilEffPorosity(LoopInd)), 0.0) * & + ThicknessSnowSoilLayer(LoopInd) + SoilLiqWater(LoopInd) = min(SoilEffPorosity(LoopInd), SoilLiqWater(LoopInd)) + SoilLiqWater(LoopInd+1) = SoilLiqWater(LoopInd+1) + SoilSaturationExcess / ThicknessSnowSoilLayer(LoopInd+1) + enddo + SoilEffPorosity(NumSoilLayer) = max(1.0e-4, (SoilMoistureSat(NumSoilLayer) - SoilIce(NumSoilLayer))) + SoilSaturationExcess = max((SoilLiqWater(NumSoilLayer)-SoilEffPorosity(NumSoilLayer)), 0.0) * & + ThicknessSnowSoilLayer(NumSoilLayer) + SoilLiqWater(NumSoilLayer) = min(SoilEffPorosity(NumSoilLayer), SoilLiqWater(NumSoilLayer)) + endif + + SoilMoisture = SoilLiqWater + SoilIce + + ! deallocate local arrays to avoid memory leaks + deallocate(MatRightTmp) + deallocate(MatLeft3Tmp) + + end associate + + end subroutine SoilMoistureSolver + +end module SoilMoistureSolverMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SoilSnowTemperatureMainMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SoilSnowTemperatureMainMod.F90 new file mode 100644 index 0000000000..cf4a906b2a --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SoilSnowTemperatureMainMod.F90 @@ -0,0 +1,84 @@ +module SoilSnowTemperatureMainMod + +!!! Main module to compute snow (if exists) and soil layer temperature. +!!! Note that snow temperatures during melting season may exceed melting +!!! point but later in SoilSnowPhaseChange subroutine the snow +!!! temperatures are reset to melting point for melting snow. + + use Machine + use NoahmpVarType + use ConstantDefineMod + use SoilSnowTemperatureSolverMod, only : SoilSnowTemperatureSolver + use SoilSnowThermalDiffusionMod, only : SoilSnowThermalDiffusion + + implicit none + +contains + + subroutine SoilSnowTemperatureMain(noahmp) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: TSNOSOI +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + +! in & out variables + type(noahmp_type) , intent(inout) :: noahmp + +! local variable + real(kind=kind_noahmp), allocatable, dimension(:) :: MatRight ! right-hand side term of the matrix + real(kind=kind_noahmp), allocatable, dimension(:) :: MatLeft1 ! left-hand side term + real(kind=kind_noahmp), allocatable, dimension(:) :: MatLeft2 ! left-hand side term + real(kind=kind_noahmp), allocatable, dimension(:) :: MatLeft3 ! left-hand side term + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + NumSnowLayerMax => noahmp%config%domain%NumSnowLayerMax ,& ! in, maximum number of snow layers + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg ,& ! in, actual number of snow layers (negative) + SoilTimeStep => noahmp%config%domain%SoilTimeStep ,& ! in, noahmp soil process timestep [s] + DepthSoilTempBottom => noahmp%config%domain%DepthSoilTempBottom ,& ! in, depth [m] from soil surface for soil temp. lower boundary + SnowDepth => noahmp%water%state%SnowDepth ,& ! in, snow depth [m] + DepthSoilTempBotToSno => noahmp%energy%state%DepthSoilTempBotToSno ,& ! out, depth [m] of soil temp. lower boundary from snow surface + HeatFromSoilBot => noahmp%energy%flux%HeatFromSoilBot ,& ! out, energy influx from soil bottom during soil timestep [J/m2] + RadSwPenetrateGrd => noahmp%energy%flux%RadSwPenetrateGrd & ! out, light penetrating through soil/snow water [W/m2] + ) +! ---------------------------------------------------------------------- + + ! initialization + if (.not. allocated(MatRight)) allocate(MatRight(-NumSnowLayerMax+1:NumSoilLayer)) + if (.not. allocated(MatLeft1)) allocate(MatLeft1(-NumSnowLayerMax+1:NumSoilLayer)) + if (.not. allocated(MatLeft2)) allocate(MatLeft2(-NumSnowLayerMax+1:NumSoilLayer)) + if (.not. allocated(MatLeft3)) allocate(MatLeft3(-NumSnowLayerMax+1:NumSoilLayer)) + MatRight(:) = 0.0 + MatLeft1(:) = 0.0 + MatLeft2(:) = 0.0 + MatLeft3(:) = 0.0 + + ! compute solar penetration through water, needs more work + RadSwPenetrateGrd(NumSnowLayerNeg+1:NumSoilLayer) = 0.0 + + ! adjust DepthSoilTempBottom from soil surface to DepthSoilTempBotToSno from snow surface + DepthSoilTempBotToSno = DepthSoilTempBottom - SnowDepth + + ! compute soil temperatures + call SoilSnowThermalDiffusion(noahmp, MatLeft1, MatLeft2, MatLeft3, MatRight) + call SoilSnowTemperatureSolver(noahmp, SoilTimeStep, MatLeft1, MatLeft2, MatLeft3, MatRight) + + ! accumulate soil bottom flux for soil timestep + HeatFromSoilBot = HeatFromSoilBot * SoilTimeStep + + ! deallocate local arrays to avoid memory leaks + deallocate(MatRight) + deallocate(MatLeft1) + deallocate(MatLeft2) + deallocate(MatLeft3) + + end associate + + end subroutine SoilSnowTemperatureMain + +end module SoilSnowTemperatureMainMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SoilSnowTemperatureSolverMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SoilSnowTemperatureSolverMod.F90 new file mode 100644 index 0000000000..1a42889080 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SoilSnowTemperatureSolverMod.F90 @@ -0,0 +1,84 @@ +module SoilSnowTemperatureSolverMod + +!!! Compute soil and snow layer temperature using tri-diagonal matrix solution +!!! Dependent on the output from SoilSnowThermalDiffusion subroutine + + use Machine + use NoahmpVarType + use ConstantDefineMod + use MatrixSolverTriDiagonalMod, only : MatrixSolverTriDiagonal + + implicit none + +contains + + subroutine SoilSnowTemperatureSolver(noahmp, TimeStep, MatLeft1, MatLeft2, MatLeft3, MatRight) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: HSTEP +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + +! in & out variables + type(noahmp_type) , intent(inout) :: noahmp + real(kind=kind_noahmp), intent(in) :: TimeStep ! timestep (may not be the same as model timestep) + real(kind=kind_noahmp), allocatable, dimension(:), intent(inout) :: MatRight ! right-hand side term of the matrix + real(kind=kind_noahmp), allocatable, dimension(:), intent(inout) :: MatLeft1 ! left-hand side term of the matrix + real(kind=kind_noahmp), allocatable, dimension(:), intent(inout) :: MatLeft2 ! left-hand side term of the matrix + real(kind=kind_noahmp), allocatable, dimension(:), intent(inout) :: MatLeft3 ! left-hand side term of the matrix + +! local variable + integer :: LoopInd ! layer loop index + real(kind=kind_noahmp), allocatable, dimension(:) :: MatRightTmp ! temporary MatRight matrix coefficient + real(kind=kind_noahmp), allocatable, dimension(:) :: MatLeft3Tmp ! temporary MatLeft3 matrix coefficient + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + NumSnowLayerMax => noahmp%config%domain%NumSnowLayerMax ,& ! in, maximum number of snow layers + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg ,& ! in, actual number of snow layers (negative) + TemperatureSoilSnow => noahmp%energy%state%TemperatureSoilSnow & ! inout, snow and soil layer temperature [K] + ) +! ---------------------------------------------------------------------- + + ! initialization + if (.not. allocated(MatRightTmp)) allocate(MatRightTmp(-NumSnowLayerMax+1:NumSoilLayer)) + if (.not. allocated(MatLeft3Tmp)) allocate(MatLeft3Tmp(-NumSnowLayerMax+1:NumSoilLayer)) + MatRightTmp = 0.0 + MatLeft3Tmp = 0.0 + + ! update tri-diagonal matrix elements + do LoopInd = NumSnowLayerNeg+1, NumSoilLayer + MatRight(LoopInd) = MatRight(LoopInd) * TimeStep + MatLeft1(LoopInd) = MatLeft1(LoopInd) * TimeStep + MatLeft2(LoopInd) = 1.0 + MatLeft2(LoopInd) * TimeStep + MatLeft3(LoopInd) = MatLeft3(LoopInd) * TimeStep + enddo + + ! copy values for input variables before call to rosr12 + do LoopInd = NumSnowLayerNeg+1, NumSoilLayer + MatRightTmp(LoopInd) = MatRight(LoopInd) + MatLeft3Tmp(LoopInd) = MatLeft3(LoopInd) + enddo + + ! solve the tri-diagonal matrix equation + call MatrixSolverTriDiagonal(MatLeft3,MatLeft1,MatLeft2,MatLeft3Tmp,MatRightTmp,& + MatRight,NumSnowLayerNeg+1,NumSoilLayer,NumSnowLayerMax) + + ! update snow & soil temperature + do LoopInd = NumSnowLayerNeg+1, NumSoilLayer + TemperatureSoilSnow(LoopInd) = TemperatureSoilSnow(LoopInd) + MatLeft3(LoopInd) + enddo + + ! deallocate local arrays to avoid memory leaks + deallocate(MatRightTmp) + deallocate(MatLeft3Tmp) + + end associate + + end subroutine SoilSnowTemperatureSolver + +end module SoilSnowTemperatureSolverMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SoilSnowThermalDiffusionMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SoilSnowThermalDiffusionMod.F90 new file mode 100644 index 0000000000..9655b77d50 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SoilSnowThermalDiffusionMod.F90 @@ -0,0 +1,141 @@ +module SoilSnowThermalDiffusionMod + +!!! Solve soil and snow layer thermal diffusion +!!! Calculate the right hand side of the time tendency term of the soil +!!! and snow thermal diffusion equation. Currently snow and soil layers +!!! are coupled in solving the equations. Also compute/prepare the matrix +!!! coefficients for the tri-diagonal matrix of the implicit time scheme. + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine SoilSnowThermalDiffusion(noahmp, MatLeft1, MatLeft2, MatLeft3, MatRight) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: HRT +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + +! in & out variables + type(noahmp_type) , intent(inout) :: noahmp + real(kind=kind_noahmp), allocatable, dimension(:), intent(inout) :: MatRight ! right-hand side term of the matrix + real(kind=kind_noahmp), allocatable, dimension(:), intent(inout) :: MatLeft1 ! left-hand side term of the matrix + real(kind=kind_noahmp), allocatable, dimension(:), intent(inout) :: MatLeft2 ! left-hand side term of the matrix + real(kind=kind_noahmp), allocatable, dimension(:), intent(inout) :: MatLeft3 ! left-hand side term of the matrix + +! local variable + integer :: LoopInd ! loop index + real(kind=kind_noahmp) :: DepthSnowSoilTmp ! temporary snow/soil layer depth [m] + real(kind=kind_noahmp), allocatable, dimension(:) :: DepthSnowSoilInv ! inverse of snow/soil layer depth [1/m] + real(kind=kind_noahmp), allocatable, dimension(:) :: HeatCapacPerArea ! Heat capacity of soil/snow per area [J/m2/K] + real(kind=kind_noahmp), allocatable, dimension(:) :: TempGradDepth ! temperature gradient (derivative) with soil/snow depth [K/m] + real(kind=kind_noahmp), allocatable, dimension(:) :: EnergyExcess ! energy flux excess in soil/snow [W/m2] + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + NumSnowLayerMax => noahmp%config%domain%NumSnowLayerMax ,& ! in, maximum number of snow layers + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg ,& ! in, actual number of snow layers (negative) + DepthSnowSoilLayer => noahmp%config%domain%DepthSnowSoilLayer ,& ! in, depth of snow/soil layer-bottom [m] + OptSoilTemperatureBottom => noahmp%config%nmlist%OptSoilTemperatureBottom ,& ! in, options for lower boundary condition of soil temp. + OptSnowSoilTempTime => noahmp%config%nmlist%OptSnowSoilTempTime ,& ! in, options for snow/soil temperature time scheme + TemperatureSoilBottom => noahmp%forcing%TemperatureSoilBottom ,& ! in, bottom boundary soil temperature [K] + DepthSoilTempBotToSno => noahmp%energy%state%DepthSoilTempBotToSno ,& ! in, depth of lower boundary condition [m] from snow surface + TemperatureSoilSnow => noahmp%energy%state%TemperatureSoilSnow ,& ! in, snow and soil layer temperature [K] + ThermConductSoilSnow => noahmp%energy%state%ThermConductSoilSnow ,& ! in, thermal conductivity [W/m/K] for all soil & snow + HeatCapacSoilSnow => noahmp%energy%state%HeatCapacSoilSnow ,& ! in, heat capacity [J/m3/K] for all soil & snow + HeatGroundTotMean => noahmp%energy%flux%HeatGroundTotMean ,& ! in, total ground heat flux [W/m2] averaged during soil timestep + RadSwPenetrateGrd => noahmp%energy%flux%RadSwPenetrateGrd ,& ! in, light penetrating through soil/snow water [W/m2] + HeatFromSoilBot => noahmp%energy%flux%HeatFromSoilBot & ! out, energy influx from soil bottom [W/m2] + ) +! ---------------------------------------------------------------------- + + ! initialization + if (.not. allocated(DepthSnowSoilInv)) allocate(DepthSnowSoilInv(-NumSnowLayerMax+1:NumSoilLayer)) + if (.not. allocated(HeatCapacPerArea)) allocate(HeatCapacPerArea(-NumSnowLayerMax+1:NumSoilLayer)) + if (.not. allocated(TempGradDepth) ) allocate(TempGradDepth (-NumSnowLayerMax+1:NumSoilLayer)) + if (.not. allocated(EnergyExcess) ) allocate(EnergyExcess (-NumSnowLayerMax+1:NumSoilLayer)) + MatRight(:) = 0.0 + MatLeft1(:) = 0.0 + MatLeft2(:) = 0.0 + MatLeft3(:) = 0.0 + DepthSnowSoilInv(:) = 0.0 + HeatCapacPerArea(:) = 0.0 + TempGradDepth(:) = 0.0 + EnergyExcess(:) = 0.0 + + ! compute gradient and flux of soil/snow thermal diffusion + do LoopInd = NumSnowLayerNeg+1, NumSoilLayer + if ( LoopInd == (NumSnowLayerNeg+1) ) then + HeatCapacPerArea(LoopInd) = - DepthSnowSoilLayer(LoopInd) * HeatCapacSoilSnow(LoopInd) + DepthSnowSoilTmp = - DepthSnowSoilLayer(LoopInd+1) + DepthSnowSoilInv(LoopInd) = 2.0 / DepthSnowSoilTmp + TempGradDepth(LoopInd) = 2.0 * (TemperatureSoilSnow(LoopInd) - TemperatureSoilSnow(LoopInd+1)) / DepthSnowSoilTmp + EnergyExcess(LoopInd) = ThermConductSoilSnow(LoopInd) * TempGradDepth(LoopInd) - & + HeatGroundTotMean - RadSwPenetrateGrd(LoopInd) + elseif ( LoopInd < NumSoilLayer ) then + HeatCapacPerArea(LoopInd) = (DepthSnowSoilLayer(LoopInd-1) - DepthSnowSoilLayer(LoopInd)) * HeatCapacSoilSnow(LoopInd) + DepthSnowSoilTmp = DepthSnowSoilLayer(LoopInd-1) - DepthSnowSoilLayer(LoopInd+1) + DepthSnowSoilInv(LoopInd) = 2.0 / DepthSnowSoilTmp + TempGradDepth(LoopInd) = 2.0 * (TemperatureSoilSnow(LoopInd) - TemperatureSoilSnow(LoopInd+1)) / DepthSnowSoilTmp + EnergyExcess(LoopInd) = (ThermConductSoilSnow(LoopInd)*TempGradDepth(LoopInd) - & + ThermConductSoilSnow(LoopInd-1) * TempGradDepth(LoopInd-1) ) - RadSwPenetrateGrd(LoopInd) + elseif ( LoopInd == NumSoilLayer ) then + HeatCapacPerArea(LoopInd) = (DepthSnowSoilLayer(LoopInd-1) - DepthSnowSoilLayer(LoopInd)) * HeatCapacSoilSnow(LoopInd) + DepthSnowSoilTmp = DepthSnowSoilLayer(LoopInd-1) - DepthSnowSoilLayer(LoopInd) + if ( OptSoilTemperatureBottom == 1 ) then + HeatFromSoilBot = 0.0 + endif + if ( OptSoilTemperatureBottom == 2 ) then + TempGradDepth(LoopInd) = (TemperatureSoilSnow(LoopInd) - TemperatureSoilBottom) / & + (0.5*(DepthSnowSoilLayer(LoopInd-1)+DepthSnowSoilLayer(LoopInd)) - DepthSoilTempBotToSno) + HeatFromSoilBot = -ThermConductSoilSnow(LoopInd) * TempGradDepth(LoopInd) + endif + EnergyExcess(LoopInd) = (-HeatFromSoilBot - ThermConductSoilSnow(LoopInd-1) * TempGradDepth(LoopInd-1)) - & + RadSwPenetrateGrd(LoopInd) + endif + enddo + + ! prepare the matrix coefficients for the tri-diagonal matrix + do LoopInd = NumSnowLayerNeg+1, NumSoilLayer + if ( LoopInd == (NumSnowLayerNeg+1) ) then + MatLeft1(LoopInd) = 0.0 + MatLeft3(LoopInd) = - ThermConductSoilSnow(LoopInd) * DepthSnowSoilInv(LoopInd) / HeatCapacPerArea(LoopInd) + if ( (OptSnowSoilTempTime == 1) .or. (OptSnowSoilTempTime == 3) ) then + MatLeft2(LoopInd) = - MatLeft3(LoopInd) + endif + if ( OptSnowSoilTempTime == 2 ) then + MatLeft2(LoopInd) = - MatLeft3(LoopInd) + ThermConductSoilSnow(LoopInd) / & + (0.5*DepthSnowSoilLayer(LoopInd)*DepthSnowSoilLayer(LoopInd)*HeatCapacSoilSnow(LoopInd)) + endif + elseif ( LoopInd < NumSoilLayer ) then + MatLeft1(LoopInd) = - ThermConductSoilSnow(LoopInd-1) * DepthSnowSoilInv(LoopInd-1) / HeatCapacPerArea(LoopInd) + MatLeft3(LoopInd) = - ThermConductSoilSnow(LoopInd ) * DepthSnowSoilInv(LoopInd ) / HeatCapacPerArea(LoopInd) + MatLeft2(LoopInd) = - (MatLeft1(LoopInd) + MatLeft3 (LoopInd)) + elseif ( LoopInd == NumSoilLayer ) then + MatLeft1(LoopInd) = - ThermConductSoilSnow(LoopInd-1) * DepthSnowSoilInv(LoopInd-1) / HeatCapacPerArea(LoopInd) + MatLeft3(LoopInd) = 0.0 + MatLeft2(LoopInd) = - (MatLeft1(LoopInd) + MatLeft3(LoopInd)) + endif + MatRight(LoopInd) = EnergyExcess(LoopInd) / (-HeatCapacPerArea(LoopInd)) + enddo + + ! deallocate local arrays to avoid memory leaks + deallocate(DepthSnowSoilInv) + deallocate(HeatCapacPerArea) + deallocate(TempGradDepth ) + deallocate(EnergyExcess ) + + end associate + + end subroutine SoilSnowThermalDiffusion + +end module SoilSnowThermalDiffusionMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SoilSnowWaterPhaseChangeMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SoilSnowWaterPhaseChangeMod.F90 new file mode 100644 index 0000000000..fb8a202bc0 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SoilSnowWaterPhaseChangeMod.F90 @@ -0,0 +1,258 @@ +module SoilSnowWaterPhaseChangeMod + +!!! Compute the phase change (melting/freezing) of snow water and soil water + + use Machine + use NoahmpVarType + use ConstantDefineMod + use SoilWaterSupercoolKoren99Mod, only : SoilWaterSupercoolKoren99 + use SoilWaterSupercoolNiu06Mod, only : SoilWaterSupercoolNiu06 + + implicit none + +contains + + subroutine SoilSnowWaterPhaseChange(noahmp) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: PHASECHANGE +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + +! in & out variables + type(noahmp_type) , intent(inout) :: noahmp + +! local variable + integer :: LoopInd ! do loop index + real(kind=kind_noahmp) :: EnergyResLeft ! energy residual or loss after melting/freezing + real(kind=kind_noahmp) :: SnowWaterPrev ! old/previous snow water equivalent [kg/m2] + real(kind=kind_noahmp) :: SnowWaterRatio ! ratio of previous vs updated snow water equivalent + real(kind=kind_noahmp) :: HeatLhTotPhsChg ! total latent heat of phase change + real(kind=kind_noahmp), allocatable, dimension(:) :: EnergyRes ! energy residual [w/m2] + real(kind=kind_noahmp), allocatable, dimension(:) :: WaterPhaseChg ! melting or freezing water [kg/m2] + real(kind=kind_noahmp), allocatable, dimension(:) :: MassWatTotInit ! initial total water (ice + liq) mass + real(kind=kind_noahmp), allocatable, dimension(:) :: MassWatIceInit ! initial ice content + real(kind=kind_noahmp), allocatable, dimension(:) :: MassWatLiqInit ! initial liquid content + real(kind=kind_noahmp), allocatable, dimension(:) :: MassWatIceTmp ! soil/snow ice mass [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: MassWatLiqTmp ! soil/snow liquid water mass [mm] + +! -------------------------------------------------------------------- + associate( & + OptSoilSupercoolWater => noahmp%config%nmlist%OptSoilSupercoolWater ,& ! in, options for soil supercooled liquid water + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + NumSnowLayerMax => noahmp%config%domain%NumSnowLayerMax ,& ! in, maximum number of snow layers + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg ,& ! in, actual number of snow layers (negative) + MainTimeStep => noahmp%config%domain%MainTimeStep ,& ! in, main noahmp timestep [s] + SurfaceType => noahmp%config%domain%SurfaceType ,& ! in, surface type 1-soil; 2-lake + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! in, thickness of snow/soil layers [m] + SoilExpCoeffB => noahmp%water%param%SoilExpCoeffB ,& ! in, soil B parameter + SoilMatPotentialSat => noahmp%water%param%SoilMatPotentialSat ,& ! in, saturated soil matric potential [m] + SoilMoistureSat => noahmp%water%param%SoilMoistureSat ,& ! in, saturated value of soil moisture [m3/m3] + PhaseChgFacSoilSnow => noahmp%energy%state%PhaseChgFacSoilSnow ,& ! in, energy factor for soil & snow phase change + TemperatureSoilSnow => noahmp%energy%state%TemperatureSoilSnow ,& ! inout, snow and soil layer temperature [K] + SoilLiqWater => noahmp%water%state%SoilLiqWater ,& ! inout, soil water content [m3/m3] + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! inout, total soil moisture [m3/m3] + SnowIce => noahmp%water%state%SnowIce ,& ! inout, snow layer ice [mm] + SnowLiqWater => noahmp%water%state%SnowLiqWater ,& ! inout, snow layer liquid water [mm] + SnowDepth => noahmp%water%state%SnowDepth ,& ! inout, snow depth [m] + SnowWaterEquiv => noahmp%water%state%SnowWaterEquiv ,& ! inout, snow water equivalent [mm] + IndexPhaseChange => noahmp%water%state%IndexPhaseChange ,& ! out, phase change index [0-none;1-melt;2-refreeze] + SoilSupercoolWater => noahmp%water%state%SoilSupercoolWater ,& ! out, supercooled water in soil [kg/m2] + PondSfcThinSnwMelt => noahmp%water%state%PondSfcThinSnwMelt ,& ! out, surface ponding [mm] from melt when thin snow w/o layer + MeltGroundSnow => noahmp%water%flux%MeltGroundSnow & ! out, ground snowmelt rate [mm/s] + ) +! ---------------------------------------------------------------------- + + !--- Initialization + if (.not. allocated(EnergyRes) ) allocate(EnergyRes (-NumSnowLayerMax+1:NumSoilLayer)) + if (.not. allocated(WaterPhaseChg) ) allocate(WaterPhaseChg (-NumSnowLayerMax+1:NumSoilLayer)) + if (.not. allocated(MassWatTotInit)) allocate(MassWatTotInit(-NumSnowLayerMax+1:NumSoilLayer)) + if (.not. allocated(MassWatIceInit)) allocate(MassWatIceInit(-NumSnowLayerMax+1:NumSoilLayer)) + if (.not. allocated(MassWatLiqInit)) allocate(MassWatLiqInit(-NumSnowLayerMax+1:NumSoilLayer)) + if (.not. allocated(MassWatIceTmp) ) allocate(MassWatIceTmp (-NumSnowLayerMax+1:NumSoilLayer)) + if (.not. allocated(MassWatLiqTmp) ) allocate(MassWatLiqTmp (-NumSnowLayerMax+1:NumSoilLayer)) + EnergyRes = 0.0 + WaterPhaseChg = 0.0 + MassWatTotInit = 0.0 + MassWatIceInit = 0.0 + MassWatLiqInit = 0.0 + MassWatIceTmp = 0.0 + MassWatLiqTmp = 0.0 + MeltGroundSnow = 0.0 + PondSfcThinSnwMelt = 0.0 + HeatLhTotPhsChg = 0.0 + + ! supercooled water content + do LoopInd = -NumSnowLayerMax+1, NumSoilLayer + SoilSupercoolWater(LoopInd) = 0.0 + enddo + + ! snow layer water mass + do LoopInd = NumSnowLayerNeg+1, 0 + MassWatIceTmp(LoopInd) = SnowIce(LoopInd) + MassWatLiqTmp(LoopInd) = SnowLiqWater(LoopInd) + enddo + + ! soil layer water mass + do LoopInd = 1, NumSoilLayer + MassWatLiqTmp(LoopInd) = SoilLiqWater(LoopInd) * ThicknessSnowSoilLayer(LoopInd) * 1000.0 + MassWatIceTmp(LoopInd) = (SoilMoisture(LoopInd) - SoilLiqWater(LoopInd)) * ThicknessSnowSoilLayer(LoopInd) * 1000.0 + enddo + + ! other required variables + do LoopInd = NumSnowLayerNeg+1, NumSoilLayer + IndexPhaseChange(LoopInd) = 0 + EnergyRes(LoopInd) = 0.0 + WaterPhaseChg(LoopInd) = 0.0 + MassWatIceInit(LoopInd) = MassWatIceTmp(LoopInd) + MassWatLiqInit(LoopInd) = MassWatLiqTmp(LoopInd) + MassWatTotInit(LoopInd) = MassWatIceTmp(LoopInd) + MassWatLiqTmp(LoopInd) + enddo + + !--- compute soil supercool water content + if ( SurfaceType == 1 ) then ! land points + do LoopInd = 1, NumSoilLayer + if ( OptSoilSupercoolWater == 1 ) then + if ( TemperatureSoilSnow(LoopInd) < ConstFreezePoint ) then + call SoilWaterSupercoolNiu06(noahmp, LoopInd, SoilSupercoolWater(LoopInd),TemperatureSoilSnow(LoopInd)) + SoilSupercoolWater(LoopInd) = SoilSupercoolWater(LoopInd) * ThicknessSnowSoilLayer(LoopInd) * 1000.0 + endif + endif + if ( OptSoilSupercoolWater == 2 ) then + if ( TemperatureSoilSnow(LoopInd) < ConstFreezePoint ) then + call SoilWaterSupercoolKoren99(noahmp, LoopInd, SoilSupercoolWater(LoopInd), & + TemperatureSoilSnow(LoopInd), SoilMoisture(LoopInd), SoilLiqWater(LoopInd)) + SoilSupercoolWater(LoopInd) = SoilSupercoolWater(LoopInd) * ThicknessSnowSoilLayer(LoopInd) * 1000.0 + endif + endif + enddo + endif + + !--- determine melting or freezing state + do LoopInd = NumSnowLayerNeg+1, NumSoilLayer + if ( (MassWatIceTmp(LoopInd) > 0.0) .and. (TemperatureSoilSnow(LoopInd) >= ConstFreezePoint) ) then + IndexPhaseChange(LoopInd) = 1 ! melting + endif + if ( (MassWatLiqTmp(LoopInd) > SoilSupercoolWater(LoopInd)) .and. & + (TemperatureSoilSnow(LoopInd) < ConstFreezePoint) ) then + IndexPhaseChange(LoopInd) = 2 ! freezing + endif + ! If snow exists, but its thickness is not enough to create a layer + if ( (NumSnowLayerNeg == 0) .and. (SnowWaterEquiv > 0.0) .and. (LoopInd == 1) ) then + if ( TemperatureSoilSnow(LoopInd) >= ConstFreezePoint ) then + IndexPhaseChange(LoopInd) = 1 + endif + endif + enddo + + !--- Calculate the energy surplus and loss for melting and freezing + do LoopInd = NumSnowLayerNeg+1, NumSoilLayer + if ( IndexPhaseChange(LoopInd) > 0 ) then + EnergyRes(LoopInd) = (TemperatureSoilSnow(LoopInd)-ConstFreezePoint) / PhaseChgFacSoilSnow(LoopInd) + TemperatureSoilSnow(LoopInd) = ConstFreezePoint + endif + if ( (IndexPhaseChange(LoopInd) == 1) .and. (EnergyRes(LoopInd) < 0.0) ) then + EnergyRes(LoopInd) = 0.0 + IndexPhaseChange(LoopInd) = 0 + endif + if ( (IndexPhaseChange(LoopInd) == 2) .and. (EnergyRes(LoopInd) > 0.0) ) then + EnergyRes(LoopInd) = 0.0 + IndexPhaseChange(LoopInd) = 0 + endif + WaterPhaseChg(LoopInd) = EnergyRes(LoopInd) * MainTimeStep / ConstLatHeatFusion + enddo + + !--- The rate of melting for snow without a layer, needs more work. + if ( (NumSnowLayerNeg == 0) .and. (SnowWaterEquiv > 0.0) .and. (WaterPhaseChg(1) > 0.0) ) then + SnowWaterPrev = SnowWaterEquiv + SnowWaterEquiv = max(0.0, SnowWaterPrev-WaterPhaseChg(1)) + SnowWaterRatio = SnowWaterEquiv / SnowWaterPrev + SnowDepth = max(0.0, SnowWaterRatio*SnowDepth ) + SnowDepth = min(max(SnowDepth,SnowWaterEquiv/500.0), SnowWaterEquiv/50.0) ! limit adjustment to a reasonable density + EnergyResLeft = EnergyRes(1) - ConstLatHeatFusion * (SnowWaterPrev - SnowWaterEquiv) / MainTimeStep + if ( EnergyResLeft > 0.0 ) then + WaterPhaseChg(1) = EnergyResLeft * MainTimeStep / ConstLatHeatFusion + EnergyRes(1) = EnergyResLeft + else + WaterPhaseChg(1) = 0.0 + EnergyRes(1) = 0.0 + endif + MeltGroundSnow = max(0.0, (SnowWaterPrev-SnowWaterEquiv)) / MainTimeStep + HeatLhTotPhsChg = ConstLatHeatFusion * MeltGroundSnow + PondSfcThinSnwMelt = SnowWaterPrev - SnowWaterEquiv + endif + + ! The rate of melting and freezing for multi-layer snow and soil + do LoopInd = NumSnowLayerNeg+1, NumSoilLayer + if ( (IndexPhaseChange(LoopInd) > 0) .and. (abs(EnergyRes(LoopInd)) > 0.0) ) then + EnergyResLeft = 0.0 + if ( WaterPhaseChg(LoopInd) > 0.0 ) then + MassWatIceTmp(LoopInd) = max(0.0, MassWatIceInit(LoopInd)-WaterPhaseChg(LoopInd)) + EnergyResLeft = EnergyRes(LoopInd) - ConstLatHeatFusion * & + (MassWatIceInit(LoopInd) - MassWatIceTmp(LoopInd)) / MainTimeStep + elseif ( WaterPhaseChg(LoopInd) < 0.0 ) then + if ( LoopInd <= 0 ) then ! snow layer + MassWatIceTmp(LoopInd) = min(MassWatTotInit(LoopInd), MassWatIceInit(LoopInd)-WaterPhaseChg(LoopInd)) + else ! soil layer + if ( MassWatTotInit(LoopInd) < SoilSupercoolWater(LoopInd) ) then + MassWatIceTmp(LoopInd) = 0.0 + else + MassWatIceTmp(LoopInd) = min(MassWatTotInit(LoopInd)-SoilSupercoolWater(LoopInd), & + MassWatIceInit(LoopInd)-WaterPhaseChg(LoopInd)) + MassWatIceTmp(LoopInd) = max(MassWatIceTmp(LoopInd), 0.0) + endif + endif + EnergyResLeft = EnergyRes(LoopInd) - ConstLatHeatFusion * (MassWatIceInit(LoopInd) - & + MassWatIceTmp(LoopInd)) / MainTimeStep + endif + MassWatLiqTmp(LoopInd) = max(0.0, MassWatTotInit(LoopInd)-MassWatIceTmp(LoopInd)) ! update liquid water mass + + ! update soil/snow temperature and energy surplus/loss + if ( abs(EnergyResLeft) > 0.0 ) then + TemperatureSoilSnow(LoopInd) = TemperatureSoilSnow(LoopInd) + PhaseChgFacSoilSnow(LoopInd) * EnergyResLeft + if ( LoopInd <= 0 ) then ! snow + if ( (MassWatLiqTmp(LoopInd)*MassWatIceTmp(LoopInd)) > 0.0 ) & + TemperatureSoilSnow(LoopInd) = ConstFreezePoint + if ( MassWatIceTmp(LoopInd) == 0.0 ) then ! BARLAGE + TemperatureSoilSnow(LoopInd) = ConstFreezePoint + EnergyRes(LoopInd+1) = EnergyRes(LoopInd+1) + EnergyResLeft + WaterPhaseChg(LoopInd+1) = EnergyRes(LoopInd+1) * MainTimeStep / ConstLatHeatFusion + endif + endif + endif + HeatLhTotPhsChg = HeatLhTotPhsChg + ConstLatHeatFusion * & + (MassWatIceInit(LoopInd) - MassWatIceTmp(LoopInd)) / MainTimeStep + ! snow melting rate + if ( LoopInd < 1 ) then + MeltGroundSnow = MeltGroundSnow + max(0.0, (MassWatIceInit(LoopInd)-MassWatIceTmp(LoopInd))) / MainTimeStep + endif + endif + enddo + + !--- update snow and soil ice and liquid content + do LoopInd = NumSnowLayerNeg+1, 0 ! snow + SnowLiqWater(LoopInd) = MassWatLiqTmp(LoopInd) + SnowIce(LoopInd) = MassWatIceTmp(LoopInd) + enddo + do LoopInd = 1, NumSoilLayer ! soil + SoilLiqWater(LoopInd) = MassWatLiqTmp(LoopInd) / (1000.0 * ThicknessSnowSoilLayer(LoopInd)) + SoilMoisture(LoopInd) = (MassWatLiqTmp(LoopInd)+MassWatIceTmp(LoopInd)) / (1000.0*ThicknessSnowSoilLayer(LoopInd)) + enddo + + ! deallocate local arrays to avoid memory leaks + deallocate(EnergyRes ) + deallocate(WaterPhaseChg ) + deallocate(MassWatTotInit) + deallocate(MassWatIceInit) + deallocate(MassWatLiqInit) + deallocate(MassWatIceTmp ) + deallocate(MassWatLiqTmp ) + + end associate + + end subroutine SoilSnowWaterPhaseChange + +end module SoilSnowWaterPhaseChangeMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SoilThermalPropertyMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SoilThermalPropertyMod.F90 new file mode 100644 index 0000000000..dd38333c01 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SoilThermalPropertyMod.F90 @@ -0,0 +1,112 @@ +module SoilThermalPropertyMod + +!!! Compute soil thermal conductivity based on Peters-Lidard et al. (1998) + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine SoilThermalProperty(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: TDFCND +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! If the soil has any moisture content compute a partial sum/product +! otherwise use a constant value which works well with most soils +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: LoopInd ! loop index + real(kind=kind_noahmp) :: KerstenFac ! Kersten number + real(kind=kind_noahmp) :: SoilGamFac ! temporary soil GAMMD factor + real(kind=kind_noahmp) :: ThermConductSoilDry ! thermal conductivity for dry soil + real(kind=kind_noahmp) :: ThermConductSoilSat ! thermal conductivity for saturated soil + real(kind=kind_noahmp) :: ThermConductSolid ! thermal conductivity for the solids + real(kind=kind_noahmp) :: SoilSatRatio ! saturation ratio + real(kind=kind_noahmp) :: SoilWatFracSat ! saturated soil water fraction + real(kind=kind_noahmp) :: SoilWatFrac ! soil water fraction + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilIceTmp ! temporal soil ice + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + SoilMoistureSat => noahmp%water%param%SoilMoistureSat ,& ! in, saturated value of soil moisture [m3/m3] + SoilHeatCapacity => noahmp%energy%param%SoilHeatCapacity ,& ! in, soil volumetric specific heat [J/m3/K] + SoilQuartzFrac => noahmp%energy%param%SoilQuartzFrac ,& ! in, soil quartz content + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! in, total soil moisture [m3/m3] + SoilLiqWater => noahmp%water%state%SoilLiqWater ,& ! in, soil water content [m3/m3] + HeatCapacVolSoil => noahmp%energy%state%HeatCapacVolSoil ,& ! out, soil layer volumetric specific heat [J/m3/K] + ThermConductSoil => noahmp%energy%state%ThermConductSoil & ! out, soil layer thermal conductivity [W/m/K] + ) +! ---------------------------------------------------------------------- + + ! initiazliation + if (.not. allocated(SoilIceTmp)) allocate(SoilIceTmp(1:NumSoilLayer)) + SoilIceTmp(:) = 0.0 + + do LoopInd = 1, NumSoilLayer + + ! ==== soil heat capacity + SoilIceTmp(LoopInd) = SoilMoisture(LoopInd) - SoilLiqWater(LoopInd) + HeatCapacVolSoil(LoopInd) = SoilLiqWater(LoopInd) * ConstHeatCapacWater + & + (1.0 - SoilMoistureSat(LoopInd)) * SoilHeatCapacity + & + (SoilMoistureSat(LoopInd) - SoilMoisture(LoopInd)) * ConstHeatCapacAir + & + SoilIceTmp(LoopInd) * ConstHeatCapacIce + + ! ==== soil thermal conductivity + SoilSatRatio = SoilMoisture(LoopInd) / SoilMoistureSat(LoopInd) ! SATURATION RATIO + + ! UNFROZEN FRACTION (FROM 1., i.e., 100%LIQUID, TO 0. (100% FROZEN)) + ThermConductSolid = (ConstThermConductQuartz ** SoilQuartzFrac(LoopInd)) * & + (ConstThermConductSoilOth ** (1.0 - SoilQuartzFrac(LoopInd))) + + ! UNFROZEN VOLUME FOR SATURATION (POROSITY*SoilWatFrac) + SoilWatFrac = 1.0 ! Prevent divide by zero (suggested by D. Mocko) + if ( SoilMoisture(LoopInd) > 0.0 ) SoilWatFrac = SoilLiqWater(LoopInd) / SoilMoisture(LoopInd) + SoilWatFracSat = SoilWatFrac * SoilMoistureSat(LoopInd) + + ! SATURATED THERMAL CONDUCTIVITY + ThermConductSoilSat = ThermConductSolid ** (1.0-SoilMoistureSat(LoopInd)) * & + ConstThermConductIce ** (SoilMoistureSat(LoopInd)-SoilWatFracSat) * & + ConstThermConductWater ** (SoilWatFracSat) + + ! DRY THERMAL CONDUCTIVITY IN W.M-1.K-1 + SoilGamFac = (1.0 - SoilMoistureSat(LoopInd)) * 2700.0 + ThermConductSoilDry = (0.135 * SoilGamFac + 64.7) / (2700.0 - 0.947 * SoilGamFac) + + ! THE KERSTEN NUMBER KerstenFac + if ( (SoilLiqWater(LoopInd)+0.0005) < SoilMoisture(LoopInd) ) then ! FROZEN + KerstenFac = SoilSatRatio + else ! UNFROZEN + ! KERSTEN NUMBER (USING "FINE" FORMULA, VALID FOR SOILS CONTAINING AT + ! LEAST 5% OF PARTICLES WITH DIAMETER LESS THAN 2.E-6 METERS.) + ! (FOR "COARSE" FORMULA, SEE PETERS-LIDARD ET AL., 1998). + if ( SoilSatRatio > 0.1 ) then + KerstenFac = log10(SoilSatRatio) + 1.0 + else + KerstenFac = 0.0 + endif + endif + + ! THERMAL CONDUCTIVITY + ThermConductSoil(LoopInd) = KerstenFac*(ThermConductSoilSat-ThermConductSoilDry) + ThermConductSoilDry + + enddo ! LoopInd + + ! deallocate local arrays to avoid memory leaks + deallocate(SoilIceTmp) + + end associate + + end subroutine SoilThermalProperty + +end module SoilThermalPropertyMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SoilWaterDiffusionRichardsMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SoilWaterDiffusionRichardsMod.F90 new file mode 100644 index 0000000000..ebeaf64bf6 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SoilWaterDiffusionRichardsMod.F90 @@ -0,0 +1,180 @@ +module SoilWaterDiffusionRichardsMod + +!!! Solve Richards equation for soil water movement/diffusion +!!! Compute the right hand side of the time tendency term of the soil +!!! water diffusion equation. also to compute (prepare) the matrix +!!! coefficients for the tri-diagonal matrix of the implicit time scheme. + + use Machine + use NoahmpVarType + use ConstantDefineMod + use SoilHydraulicPropertyMod + + implicit none + +contains + + subroutine SoilWaterDiffusionRichards(noahmp, MatLeft1, MatLeft2, MatLeft3, MatRight) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: SRT +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + +! in & out variables + type(noahmp_type) , intent(inout) :: noahmp + real(kind=kind_noahmp), allocatable, dimension(:), intent(inout) :: MatRight ! right-hand side term of the matrix + real(kind=kind_noahmp), allocatable, dimension(:), intent(inout) :: MatLeft1 ! left-hand side term of the matrix + real(kind=kind_noahmp), allocatable, dimension(:), intent(inout) :: MatLeft2 ! left-hand side term of the matrix + real(kind=kind_noahmp), allocatable, dimension(:), intent(inout) :: MatLeft3 ! left-hand side term of the matrix + +! local variable + integer :: LoopInd ! loop index + real(kind=kind_noahmp) :: DepthSnowSoilTmp ! temporary snow/soil layer depth [m] + real(kind=kind_noahmp) :: SoilMoistTmpToWT ! temporary soil moisture between bottom of the soil and water table + real(kind=kind_noahmp) :: SoilMoistBotTmp ! temporary soil moisture below bottom to calculate flux + real(kind=kind_noahmp), allocatable, dimension(:) :: DepthSnowSoilInv ! inverse of snow/soil layer depth [1/m] + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilThickTmp ! temporary soil thickness + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilWaterGrad ! temporary soil moisture vertical gradient + real(kind=kind_noahmp), allocatable, dimension(:) :: WaterExcess ! temporary excess water flux + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilMoistureTmp ! temporary soil moisture + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + DepthSoilLayer => noahmp%config%domain%DepthSoilLayer ,& ! in, depth [m] of layer-bottom from soil surface + OptSoilPermeabilityFrozen => noahmp%config%nmlist%OptSoilPermeabilityFrozen ,& ! in, options for frozen soil permeability + OptRunoffSubsurface => noahmp%config%nmlist%OptRunoffSubsurface ,& ! in, options for drainage and subsurface runoff + SoilDrainSlope => noahmp%water%param%SoilDrainSlope ,& ! in, slope index for soil drainage + InfilRateSfc => noahmp%water%flux%InfilRateSfc ,& ! in, infiltration rate at surface [m/s] + EvapSoilSfcLiqMean => noahmp%water%flux%EvapSoilSfcLiqMean ,& ! in, mean evaporation from soil surface [m/s] + TranspWatLossSoilMean => noahmp%water%flux%TranspWatLossSoilMean ,& ! in, mean transpiration water loss from soil layers [m/s] + SoilLiqWater => noahmp%water%state%SoilLiqWater ,& ! in, soil water content [m3/m3] + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! in, total soil moisture [m3/m3] + WaterTableDepth => noahmp%water%state%WaterTableDepth ,& ! in, water table depth [m] + SoilImpervFrac => noahmp%water%state%SoilImpervFrac ,& ! in, fraction of imperviousness due to frozen soil + SoilImpervFracMax => noahmp%water%state%SoilImpervFracMax ,& ! in, maximum soil imperviousness fraction + SoilIceMax => noahmp%water%state%SoilIceMax ,& ! in, maximum soil ice content [m3/m3] + SoilMoistureToWT => noahmp%water%state%SoilMoistureToWT ,& ! in, soil moisture between bottom of the soil and the water table + SoilWatConductivity => noahmp%water%state%SoilWatConductivity ,& ! out, soil hydraulic conductivity [m/s] + SoilWatDiffusivity => noahmp%water%state%SoilWatDiffusivity ,& ! out, soil water diffusivity [m2/s] + DrainSoilBot => noahmp%water%flux%DrainSoilBot & ! out, soil bottom drainage [m/s] + ) +! ---------------------------------------------------------------------- + + ! initialization + if (.not. allocated(DepthSnowSoilInv)) allocate(DepthSnowSoilInv(1:NumSoilLayer)) + if (.not. allocated(SoilThickTmp) ) allocate(SoilThickTmp (1:NumSoilLayer)) + if (.not. allocated(SoilWaterGrad) ) allocate(SoilWaterGrad (1:NumSoilLayer)) + if (.not. allocated(WaterExcess) ) allocate(WaterExcess (1:NumSoilLayer)) + if (.not. allocated(SoilMoistureTmp) ) allocate(SoilMoistureTmp (1:NumSoilLayer)) + MatRight(:) = 0.0 + MatLeft1(:) = 0.0 + MatLeft2(:) = 0.0 + MatLeft3(:) = 0.0 + DepthSnowSoilInv(:) = 0.0 + SoilThickTmp(:) = 0.0 + SoilWaterGrad(:) = 0.0 + WaterExcess(:) = 0.0 + SoilMoistureTmp(:) = 0.0 + + ! compute soil hydraulic conductivity and diffusivity + if ( OptSoilPermeabilityFrozen == 1 ) then + do LoopInd = 1, NumSoilLayer + call SoilDiffusivityConductivityOpt1(noahmp,SoilWatDiffusivity(LoopInd),SoilWatConductivity(LoopInd),& + SoilMoisture(LoopInd),SoilImpervFrac(LoopInd),LoopInd) + SoilMoistureTmp(LoopInd) = SoilMoisture(LoopInd) + enddo + if ( OptRunoffSubsurface == 5 ) SoilMoistTmpToWT = SoilMoistureToWT + endif + + if ( OptSoilPermeabilityFrozen == 2 ) then + do LoopInd = 1, NumSoilLayer + call SoilDiffusivityConductivityOpt2(noahmp,SoilWatDiffusivity(LoopInd),SoilWatConductivity(LoopInd),& + SoilLiqWater(LoopInd),SoilIceMax,LoopInd) + SoilMoistureTmp(LoopInd) = SoilLiqWater(LoopInd) + enddo + if ( OptRunoffSubsurface == 5 ) & + SoilMoistTmpToWT = SoilMoistureToWT * SoilLiqWater(NumSoilLayer) / SoilMoisture(NumSoilLayer) !same liquid fraction as in the bottom layer + endif + + ! compute gradient and flux of soil water diffusion terms + do LoopInd = 1, NumSoilLayer + if ( LoopInd == 1 ) then + SoilThickTmp(LoopInd) = - DepthSoilLayer(LoopInd) + DepthSnowSoilTmp = - DepthSoilLayer(LoopInd+1) + DepthSnowSoilInv(LoopInd) = 2.0 / DepthSnowSoilTmp + SoilWaterGrad(LoopInd) = 2.0 * (SoilMoistureTmp(LoopInd)-SoilMoistureTmp(LoopInd+1)) / DepthSnowSoilTmp + WaterExcess(LoopInd) = SoilWatDiffusivity(LoopInd)*SoilWaterGrad(LoopInd) + SoilWatConductivity(LoopInd) - & + InfilRateSfc + TranspWatLossSoilMean(LoopInd) + EvapSoilSfcLiqMean + else if ( LoopInd < NumSoilLayer ) then + SoilThickTmp(LoopInd) = (DepthSoilLayer(LoopInd-1) - DepthSoilLayer(LoopInd)) + DepthSnowSoilTmp = (DepthSoilLayer(LoopInd-1) - DepthSoilLayer(LoopInd+1)) + DepthSnowSoilInv(LoopInd) = 2.0 / DepthSnowSoilTmp + SoilWaterGrad(LoopInd) = 2.0 * (SoilMoistureTmp(LoopInd) - SoilMoistureTmp(LoopInd+1)) / DepthSnowSoilTmp + WaterExcess(LoopInd) = SoilWatDiffusivity(LoopInd)*SoilWaterGrad(LoopInd) + SoilWatConductivity(LoopInd) - & + SoilWatDiffusivity(LoopInd-1)*SoilWaterGrad(LoopInd-1) - SoilWatConductivity(LoopInd-1) + & + TranspWatLossSoilMean(LoopInd) + else + SoilThickTmp(LoopInd) = (DepthSoilLayer(LoopInd-1) - DepthSoilLayer(LoopInd)) + if ( (OptRunoffSubsurface == 1) .or. (OptRunoffSubsurface == 2) ) then + DrainSoilBot = 0.0 + endif + if ( (OptRunoffSubsurface == 3) .or. (OptRunoffSubsurface == 6) .or. & + (OptRunoffSubsurface == 7) .or. (OptRunoffSubsurface == 8) ) then + DrainSoilBot = SoilDrainSlope * SoilWatConductivity(LoopInd) + endif + if ( OptRunoffSubsurface == 4 ) then + DrainSoilBot = (1.0 - SoilImpervFracMax) * SoilWatConductivity(LoopInd) + endif + if ( OptRunoffSubsurface == 5 ) then ! gmm new m-m&f water table dynamics formulation + DepthSnowSoilTmp = 2.0 * SoilThickTmp(LoopInd) + if ( WaterTableDepth < (DepthSoilLayer(NumSoilLayer)-SoilThickTmp(NumSoilLayer)) ) then + ! gmm interpolate from below, midway to the water table, + ! to the middle of the auxiliary layer below the soil bottom + SoilMoistBotTmp = SoilMoistureTmp(LoopInd) - (SoilMoistureTmp(LoopInd)-SoilMoistTmpToWT) * & + SoilThickTmp(LoopInd)*2.0 / (SoilThickTmp(LoopInd)+DepthSoilLayer(LoopInd)-WaterTableDepth) + else + SoilMoistBotTmp = SoilMoistTmpToWT + endif + SoilWaterGrad(LoopInd) = 2.0 * (SoilMoistureTmp(LoopInd) - SoilMoistBotTmp) / DepthSnowSoilTmp + DrainSoilBot = SoilWatDiffusivity(LoopInd) * SoilWaterGrad(LoopInd) + SoilWatConductivity(LoopInd) + endif + WaterExcess(LoopInd) = -(SoilWatDiffusivity(LoopInd-1)*SoilWaterGrad(LoopInd-1)) - SoilWatConductivity(LoopInd-1) + & + TranspWatLossSoilMean(LoopInd) + DrainSoilBot + endif + enddo + + ! prepare the matrix coefficients for the tri-diagonal matrix + do LoopInd = 1, NumSoilLayer + if ( LoopInd == 1 ) then + MatLeft1(LoopInd) = 0.0 + MatLeft2(LoopInd) = SoilWatDiffusivity(LoopInd ) * DepthSnowSoilInv(LoopInd ) / SoilThickTmp(LoopInd) + MatLeft3(LoopInd) = - MatLeft2(LoopInd) + else if ( LoopInd < NumSoilLayer ) then + MatLeft1(LoopInd) = - SoilWatDiffusivity(LoopInd-1) * DepthSnowSoilInv(LoopInd-1) / SoilThickTmp(LoopInd) + MatLeft3(LoopInd) = - SoilWatDiffusivity(LoopInd ) * DepthSnowSoilInv(LoopInd ) / SoilThickTmp(LoopInd) + MatLeft2(LoopInd) = - (MatLeft1(LoopInd) + MatLeft3(LoopInd)) + else + MatLeft1(LoopInd) = - SoilWatDiffusivity(LoopInd-1) * DepthSnowSoilInv(LoopInd-1) / SoilThickTmp(LoopInd) + MatLeft3(LoopInd) = 0.0 + MatLeft2(LoopInd) = - (MatLeft1(LoopInd) + MatLeft3(LoopInd)) + endif + MatRight(LoopInd) = WaterExcess(LoopInd) / (-SoilThickTmp(LoopInd)) + enddo + + ! deallocate local arrays to avoid memory leaks + deallocate(DepthSnowSoilInv) + deallocate(SoilThickTmp ) + deallocate(SoilWaterGrad ) + deallocate(WaterExcess ) + deallocate(SoilMoistureTmp ) + + end associate + + end subroutine SoilWaterDiffusionRichards + +end module SoilWaterDiffusionRichardsMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SoilWaterInfilGreenAmptMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SoilWaterInfilGreenAmptMod.F90 new file mode 100644 index 0000000000..c61793459f --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SoilWaterInfilGreenAmptMod.F90 @@ -0,0 +1,94 @@ +module SoilWaterInfilGreenAmptMod + +!!! Compute soil surface infiltration rate based on Green-Ampt equation +!!! We use its three parameter version of the smith-parlage equation, where gamma = 0, Eq 6.25 = Green-Ampt. +!!! Reference: Smith, R.E. (2002) Infiltration Theory for Hydrologic Applications, Water Resources Monograph + + use Machine + use NoahmpVarType + use ConstantDefineMod + use SoilHydraulicPropertyMod, only : SoilDiffusivityConductivityOpt2 + + implicit none + +contains + + subroutine SoilWaterInfilGreenAmpt(noahmp, IndInfilMax, InfilSfcAcc, InfilSfcTmp) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: GREEN_AMPT_INFIL +! Original code: Prasanth Valayamkunnath +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + +! in & out variabls + type(noahmp_type) , intent(inout) :: noahmp + integer , intent(in) :: IndInfilMax ! check for maximum infiltration at SoilMoistureWilt + real(kind=kind_noahmp), intent(inout) :: InfilSfcAcc ! accumulated infiltration rate [m/s] + real(kind=kind_noahmp), intent(out) :: InfilSfcTmp ! surface infiltration rate [m/s] + +! local variable + integer :: IndSoil ! soil layer index + real(kind=kind_noahmp) :: SoilWatDiffusivity ! soil water diffusivity [m2/s] + real(kind=kind_noahmp) :: SoilWatConductivity ! soil water conductivity[m/s] + real(kind=kind_noahmp) :: InfilFacTmp ! temporary infiltrability variable + +! -------------------------------------------------------------------- + associate( & + DepthSoilLayer => noahmp%config%domain%DepthSoilLayer ,& ! in, depth [m] of layer-bottom from soil surface + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! in, total soil moisture [m3/m3] + SoilIce => noahmp%water%state%SoilIce ,& ! in, soil ice content [m3/m3] + SoilSfcInflowMean => noahmp%water%flux%SoilSfcInflowMean ,& ! in, mean water input on soil surface [m/s] + SoilMoistureSat => noahmp%water%param%SoilMoistureSat ,& ! in, saturated value of soil moisture [m3/m3] + SoilMoistureWilt => noahmp%water%param%SoilMoistureWilt ,& ! in, wilting point soil moisture [m3/m3] + SoilWatConductivitySat => noahmp%water%param%SoilWatConductivitySat ,& ! in, saturated soil hydraulic conductivity [m/s] + InfilCapillaryDynVic => noahmp%water%param%InfilCapillaryDynVic & ! in, DVIC Mean Capillary Drive [m] for infiltration models + ) +! ---------------------------------------------------------------------- + + IndSoil = 1 + if ( IndInfilMax == 1 ) then + + ! estimate initial soil hydraulic conductivty (Ki in the equation) (m/s) + call SoilDiffusivityConductivityOpt2(noahmp, SoilWatDiffusivity, SoilWatConductivity, & + SoilMoistureWilt(IndSoil), 0.0, IndSoil) + + ! Maximum infiltrability based on the Eq. 6.25. (m/s) + InfilFacTmp = InfilCapillaryDynVic * (SoilMoistureSat(IndSoil) - SoilMoistureWilt(IndSoil)) * & + (-1.0) * DepthSoilLayer(IndSoil) + InfilSfcTmp = SoilWatConductivitySat(IndSoil) + & + ((InfilFacTmp/1.0e-05) * (SoilWatConductivitySat(IndSoil) - SoilWatConductivity)) + + !maximum infiltration rate at surface + if ( InfilSfcTmp < 0.0 ) InfilSfcTmp = SoilWatConductivity + + else + + ! estimate initial soil hydraulic conductivty (Ki in the equation) (m/s) + call SoilDiffusivityConductivityOpt2(noahmp, SoilWatDiffusivity, SoilWatConductivity, & + SoilMoisture(IndSoil), SoilIce(IndSoil), IndSoil) + + ! Maximum infiltrability based on the Eq. 6.25. (m/s) + InfilFacTmp = InfilCapillaryDynVic * max(0.0, (SoilMoistureSat(IndSoil) - SoilMoisture(IndSoil))) * & + (-1.0) * DepthSoilLayer(IndSoil) + InfilSfcTmp = SoilWatConductivitySat(IndSoil) + & + ((InfilFacTmp/InfilSfcAcc) * (SoilWatConductivitySat(IndSoil) - SoilWatConductivity)) + + ! infiltration rate at surface + if ( SoilWatConductivitySat(IndSoil) < SoilSfcInflowMean ) then + InfilSfcTmp = min(SoilSfcInflowMean, InfilSfcTmp) + else + InfilSfcTmp = SoilSfcInflowMean + endif + ! accumulated infiltration function + InfilSfcAcc = InfilSfcAcc + InfilSfcTmp + + endif + + end associate + + end subroutine SoilWaterInfilGreenAmpt + +end module SoilWaterInfilGreenAmptMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SoilWaterInfilPhilipMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SoilWaterInfilPhilipMod.F90 new file mode 100644 index 0000000000..9008f1caa2 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SoilWaterInfilPhilipMod.F90 @@ -0,0 +1,104 @@ +module SoilWaterInfilPhilipMod + +!!! Compute soil surface infiltration rate based on Philip's two parameter equation +!!! Reference: Valiantzas (2010): New linearized two-parameter infiltration equation +!!! for direct determination of conductivity and sorptivity, J. Hydrology. + + use Machine + use NoahmpVarType + use ConstantDefineMod + use SoilHydraulicPropertyMod, only : SoilDiffusivityConductivityOpt2 + + implicit none + +contains + + subroutine SoilWaterInfilPhilip(noahmp, TimeStep, IndInfilMax, InfilSfcAcc, InfilSfcTmp) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: PHILIP_INFIL +! Original code: Prasanth Valayamkunnath +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + +! in & out variabls + type(noahmp_type) , intent(inout) :: noahmp + integer , intent(in) :: IndInfilMax ! check for maximum infiltration at SoilMoistureWilt + real(kind=kind_noahmp), intent(in) :: TimeStep ! timestep (may not be the same as model timestep) + real(kind=kind_noahmp), intent(inout) :: InfilSfcAcc ! accumulated infiltration rate [m/s] + real(kind=kind_noahmp), intent(out) :: InfilSfcTmp ! surface infiltration rate [m/s] + +! local variable + integer :: IndSoil ! soil layer index + real(kind=kind_noahmp) :: SoilWatDiffusivity ! soil water diffusivity [m2/s] + real(kind=kind_noahmp) :: SoilWatConductivity ! soil water conductivity [m/s] + real(kind=kind_noahmp) :: SoilSorptivity ! sorptivity [m s^-1/2] + real(kind=kind_noahmp) :: SoilWatConductTmp ! intial hydraulic conductivity [m/s] + +! -------------------------------------------------------------------- + associate( & + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! in, total soil moisture [m3/m3] + SoilIce => noahmp%water%state%SoilIce ,& ! in, soil ice content [m3/m3] + SoilSfcInflowMean => noahmp%water%flux%SoilSfcInflowMean ,& ! in, mean water input on soil surface [m/s] + SoilMoistureSat => noahmp%water%param%SoilMoistureSat ,& ! in, saturated value of soil moisture [m3/m3] + SoilMoistureWilt => noahmp%water%param%SoilMoistureWilt ,& ! in, wilting point soil moisture [m3/m3] + SoilWatDiffusivitySat => noahmp%water%param%SoilWatDiffusivitySat ,& ! in, saturated soil hydraulic diffusivity [m2/s] + SoilWatConductivitySat => noahmp%water%param%SoilWatConductivitySat & ! in, saturated soil hydraulic conductivity [m/s] + ) +! ---------------------------------------------------------------------- + + IndSoil = 1 + if ( IndInfilMax == 1) then + + ! estimate initial soil hydraulic conductivty and diffusivity (Ki, D(theta) in the equation) + call SoilDiffusivityConductivityOpt2(noahmp, SoilWatDiffusivity, SoilWatConductivity, & + SoilMoistureWilt(IndSoil), 0.0, IndSoil) + + ! Sorptivity based on Eq. 10b from Kutílek, Miroslav, and Jana Valentová (1986) + ! Sorptivity approximations. Transport in Porous Media 1.1, 57-62. + SoilSorptivity = sqrt(2.0 * (SoilMoistureSat(IndSoil) - SoilMoistureWilt(IndSoil)) * & + (SoilWatDiffusivitySat(IndSoil) - SoilWatDiffusivity)) + + ! Parameter A in Eq. 9 of Valiantzas (2010) is given by + SoilWatConductTmp = min(SoilWatConductivity, (2.0/3.0)*SoilWatConductivitySat(IndSoil)) + SoilWatConductTmp = max(SoilWatConductTmp, (1.0/3.0)*SoilWatConductivitySat(IndSoil)) + + ! Maximun infiltration rate + InfilSfcTmp = (1.0/2.0) * SoilSorptivity * (TimeStep**(-1.0/2.0)) + SoilWatConductTmp + if ( InfilSfcTmp < 0.0) InfilSfcTmp = SoilWatConductivity + + else + + ! estimate initial soil hydraulic conductivty and diffusivity (Ki, D(theta) in the equation) + call SoilDiffusivityConductivityOpt2(noahmp, SoilWatDiffusivity, SoilWatConductivity, & + SoilMoisture(IndSoil), SoilIce(IndSoil), IndSoil) + + ! Sorptivity based on Eq. 10b from Kutílek, Miroslav, and Jana Valentová (1986) + ! Sorptivity approximations. Transport in Porous Media 1.1, 57-62. + SoilSorptivity = sqrt(2.0 * max(0.0, (SoilMoistureSat(IndSoil)-SoilMoisture(IndSoil))) * & + (SoilWatDiffusivitySat(IndSoil) - SoilWatDiffusivity)) + ! Parameter A in Eq. 9 of Valiantzas (2010) is given by + SoilWatConductTmp = min(SoilWatConductivity, (2.0/3.0)*SoilWatConductivitySat(IndSoil)) + SoilWatConductTmp = max(SoilWatConductTmp, (1.0/3.0)*SoilWatConductivitySat(IndSoil)) + + ! Maximun infiltration rate + InfilSfcTmp = (1.0/2.0) * SoilSorptivity * (TimeStep**(-1.0/2.0)) + SoilWatConductTmp + + ! infiltration rate at surface + if ( SoilWatConductivitySat(IndSoil) < SoilSfcInflowMean ) then + InfilSfcTmp = min(SoilSfcInflowMean, InfilSfcTmp) + else + InfilSfcTmp = SoilSfcInflowMean + endif + ! accumulated infiltration function + InfilSfcAcc = InfilSfcAcc + InfilSfcTmp + + endif + + end associate + + end subroutine SoilWaterInfilPhilip + +end module SoilWaterInfilPhilipMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SoilWaterInfilSmithParlangeMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SoilWaterInfilSmithParlangeMod.F90 new file mode 100644 index 0000000000..5d87dfe957 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SoilWaterInfilSmithParlangeMod.F90 @@ -0,0 +1,108 @@ +module SoilWaterInfilSmithParlangeMod + +!!! Compute soil surface infiltration rate based on Smith-Parlange equation +!!! Reference: Smith, R.E. (2002), Infiltration Theory for Hydrologic Applications + + use Machine + use NoahmpVarType + use ConstantDefineMod + use SoilHydraulicPropertyMod, only : SoilDiffusivityConductivityOpt2 + + implicit none + +contains + + subroutine SoilWaterInfilSmithParlange(noahmp, IndInfilMax, InfilSfcAcc, InfilSfcTmp) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: SMITH_PARLANGE_INFIL +! Original code: Prasanth Valayamkunnath +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + +! in & out variabls + type(noahmp_type) , intent(inout) :: noahmp + integer , intent(in) :: IndInfilMax ! check for maximum infiltration at SoilMoistureWilt + real(kind=kind_noahmp), intent(inout) :: InfilSfcAcc ! accumulated infiltration rate [m/s] + real(kind=kind_noahmp), intent(out) :: InfilSfcTmp ! surface infiltration rate [m/s] + +! local variables + integer :: IndSoil ! soil layer index + real(kind=kind_noahmp) :: SoilWatDiffusivity ! soil water diffusivity [m2/s] + real(kind=kind_noahmp) :: SoilWatConductivity ! soil water conductivity [m/s] + real(kind=kind_noahmp) :: InfilFacTmp ! temporary infiltrability variable + real(kind=kind_noahmp) :: WeighFac ! smith-parlang weighing parameter + +! -------------------------------------------------------------------- + associate( & + DepthSoilLayer => noahmp%config%domain%DepthSoilLayer ,& ! in, depth [m] of layer-bottom from soil surface + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! in, total soil moisture [m3/m3] + SoilIce => noahmp%water%state%SoilIce ,& ! in, soil ice content [m3/m3] + SoilSfcInflowMean => noahmp%water%flux%SoilSfcInflowMean ,& ! in, mean water input on soil surface [m/s] + SoilMoistureSat => noahmp%water%param%SoilMoistureSat ,& ! in, saturated value of soil moisture [m3/m3] + SoilMoistureWilt => noahmp%water%param%SoilMoistureWilt ,& ! in, wilting point soil moisture [m3/m3] + SoilWatConductivitySat => noahmp%water%param%SoilWatConductivitySat ,& ! in, saturated soil hydraulic conductivity [m/s] + InfilCapillaryDynVic => noahmp%water%param%InfilCapillaryDynVic & ! in, DVIC Mean Capillary Drive [m] for infiltration models + ) +! ---------------------------------------------------------------------- + + ! smith-parlang weighing parameter, Gamma + WeighFac = 0.82 + IndSoil = 1 + + ! check whether we are estimating infiltration for current SoilMoisture or SoilMoistureWilt + if ( IndInfilMax == 1 ) then ! not active for now as the maximum infiltration is estimated based on table values + + ! estimate initial soil hydraulic conductivty (Ki in the equation) (m/s) + call SoilDiffusivityConductivityOpt2(noahmp, SoilWatDiffusivity, SoilWatConductivity, & + SoilMoistureWilt(IndSoil), 0.0, IndSoil) + + ! Maximum infiltrability based on the Eq. 6.25. (m/s) + InfilFacTmp = InfilCapillaryDynVic * (SoilMoistureSat(IndSoil) - SoilMoistureWilt(IndSoil)) * & + (-1.0) * DepthSoilLayer(IndSoil) + InfilSfcTmp = SoilWatConductivitySat(IndSoil) + (WeighFac*(SoilWatConductivitySat(IndSoil)-SoilWatConductivity) / & + (exp(WeighFac*1.0e-05/InfilFacTmp) - 1.0)) + + ! infiltration rate at surface + if ( SoilWatConductivitySat(IndSoil) < SoilSfcInflowMean ) then + InfilSfcTmp = min(SoilSfcInflowMean, InfilSfcTmp) + else + InfilSfcTmp = SoilSfcInflowMean + endif + if ( InfilSfcTmp < 0.0 ) InfilSfcTmp = SoilWatConductivity + + else + + ! estimate initial soil hydraulic conductivty (Ki in the equation) (m/s) + call SoilDiffusivityConductivityOpt2(noahmp, SoilWatDiffusivity, SoilWatConductivity, & + SoilMoisture(IndSoil), SoilIce(IndSoil), IndSoil) + + ! Maximum infiltrability based on the Eq. 6.25. (m/s) + InfilFacTmp = InfilCapillaryDynVic * max(0.0, (SoilMoistureSat(IndSoil) - SoilMoisture(IndSoil))) * & + (-1.0) * DepthSoilLayer(IndSoil) + if ( InfilFacTmp == 0.0 ) then ! infiltration at surface == saturated hydraulic conductivity + InfilSfcTmp = SoilWatConductivity + else + InfilSfcTmp = SoilWatConductivitySat(IndSoil) + (WeighFac*(SoilWatConductivitySat(IndSoil)-SoilWatConductivity) / & + (exp(WeighFac*InfilSfcAcc/InfilFacTmp) - 1.0)) + endif + + ! infiltration rate at surface + if ( SoilWatConductivitySat(IndSoil) < SoilSfcInflowMean ) then + InfilSfcTmp = min(SoilSfcInflowMean, InfilSfcTmp) + else + InfilSfcTmp = SoilSfcInflowMean + endif + + ! accumulated infiltration function + InfilSfcAcc = InfilSfcAcc + InfilSfcTmp + + endif + + end associate + + end subroutine SoilWaterInfilSmithParlange + +end module SoilWaterInfilSmithParlangeMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SoilWaterMainMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SoilWaterMainMod.F90 new file mode 100644 index 0000000000..a03a983b7a --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SoilWaterMainMod.F90 @@ -0,0 +1,270 @@ +module SoilWaterMainMod + +!!! Main soil water module including all soil water processes & update soil moisture +!!! surface runoff, infiltration, soil water diffusion, subsurface runoff, tile drainage + + use Machine + use NoahmpVarType + use ConstantDefineMod + use RunoffSurfaceTopModelGrdMod, only : RunoffSurfaceTopModelGrd + use RunoffSurfaceTopModelEquiMod, only : RunoffSurfaceTopModelEqui + use RunoffSurfaceFreeDrainMod, only : RunoffSurfaceFreeDrain + use RunoffSurfaceBatsMod, only : RunoffSurfaceBATS + use RunoffSurfaceTopModelMmfMod, only : RunoffSurfaceTopModelMMF + use RunoffSurfaceVicMod, only : RunoffSurfaceVIC + use RunoffSurfaceXinAnJiangMod, only : RunoffSurfaceXinAnJiang + use RunoffSurfaceDynamicVicMod, only : RunoffSurfaceDynamicVic + use RunoffSubSurfaceEquiWaterTableMod, only : RunoffSubSurfaceEquiWaterTable + use RunoffSubSurfaceGroundWaterMod, only : RunoffSubSurfaceGroundWater + use RunoffSubSurfaceDrainageMod, only : RunoffSubSurfaceDrainage + use RunoffSubSurfaceShallowMmfMod, only : RunoffSubSurfaceShallowWaterMMF + use SoilWaterDiffusionRichardsMod, only : SoilWaterDiffusionRichards + use SoilMoistureSolverMod, only : SoilMoistureSolver + use TileDrainageSimpleMod, only : TileDrainageSimple + use TileDrainageHooghoudtMod, only : TileDrainageHooghoudt + + implicit none + +contains + + subroutine SoilWaterMain(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: SOILWATER +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variables + integer :: LoopInd1, LoopInd2 ! loop index + integer :: IndIter ! iteration index + integer :: NumIterSoilWat ! iteration times soil moisture + real(kind=kind_noahmp) :: TimeStepFine ! fine time step [s] + real(kind=kind_noahmp) :: SoilSatExcAcc ! accumulation of soil saturation excess [m] + real(kind=kind_noahmp) :: SoilWatConductAcc ! sum of SoilWatConductivity*ThicknessSnowSoilLayer + real(kind=kind_noahmp) :: WaterRemove ! water mass removal [mm] + real(kind=kind_noahmp) :: SoilWatRem ! temporary remaining soil water [mm] + real(kind=kind_noahmp) :: SoilWaterMin ! minimum soil water [mm] + real(kind=kind_noahmp) :: DrainSoilBotAcc ! accumulated drainage water [mm] at fine time step + real(kind=kind_noahmp) :: RunoffSurfaceAcc ! accumulated surface runoff [mm] at fine time step + real(kind=kind_noahmp) :: InfilSfcAcc ! accumulated infiltration rate [m/s] + real(kind=kind_noahmp), parameter :: SoilImpPara = 4.0 ! soil impervious fraction parameter + real(kind=kind_noahmp), allocatable, dimension(:) :: MatRight ! right-hand side term of the matrix + real(kind=kind_noahmp), allocatable, dimension(:) :: MatLeft1 ! left-hand side term + real(kind=kind_noahmp), allocatable, dimension(:) :: MatLeft2 ! left-hand side term + real(kind=kind_noahmp), allocatable, dimension(:) :: MatLeft3 ! left-hand side term + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilLiqTmp ! temporary soil liquid water [mm] + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + SoilTimeStep => noahmp%config%domain%SoilTimeStep ,& ! in, noahmp soil time step [s] + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! in, thickness of snow/soil layers [m] + FlagUrban => noahmp%config%domain%FlagUrban ,& ! in, logical flag for urban grid + OptRunoffSurface => noahmp%config%nmlist%OptRunoffSurface ,& ! in, options for surface runoff + OptRunoffSubsurface => noahmp%config%nmlist%OptRunoffSubsurface ,& ! in, options for subsurface runoff + OptTileDrainage => noahmp%config%nmlist%OptTileDrainage ,& ! in, options for tile drainage + SoilIce => noahmp%water%state%SoilIce ,& ! in, soil ice content [m3/m3] + TileDrainFrac => noahmp%water%state%TileDrainFrac ,& ! in, tile drainage map (fraction) + SoilSfcInflowMean => noahmp%water%flux%SoilSfcInflowMean ,& ! in, mean water input on soil surface [m/s] + SoilMoistureSat => noahmp%water%param%SoilMoistureSat ,& ! in, saturated value of soil moisture [m3/m3] + SoilLiqWater => noahmp%water%state%SoilLiqWater ,& ! inout, soil water content [m3/m3] + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! inout, total soil water content [m3/m3] + RechargeGwDeepWT => noahmp%water%state%RechargeGwDeepWT ,& ! inout, recharge to or from the water table when deep [m] + DrainSoilBot => noahmp%water%flux%DrainSoilBot ,& ! out, soil bottom drainage [m/s] + RunoffSurface => noahmp%water%flux%RunoffSurface ,& ! out, surface runoff [mm per soil timestep] + RunoffSubsurface => noahmp%water%flux%RunoffSubsurface ,& ! out, subsurface runoff [mm per soil timestep] + InfilRateSfc => noahmp%water%flux%InfilRateSfc ,& ! out, infiltration rate at surface [m/s] + TileDrain => noahmp%water%flux%TileDrain ,& ! out, tile drainage [mm per soil timestep] + SoilImpervFracMax => noahmp%water%state%SoilImpervFracMax ,& ! out, maximum soil imperviousness fraction + SoilWatConductivity => noahmp%water%state%SoilWatConductivity ,& ! out, soil hydraulic conductivity [m/s] + SoilEffPorosity => noahmp%water%state%SoilEffPorosity ,& ! out, soil effective porosity [m3/m3] + SoilImpervFrac => noahmp%water%state%SoilImpervFrac ,& ! out, impervious fraction due to frozen soil + SoilIceFrac => noahmp%water%state%SoilIceFrac ,& ! out, ice fraction in frozen soil + SoilSaturationExcess => noahmp%water%state%SoilSaturationExcess ,& ! out, saturation excess of the total soil [m] + SoilIceMax => noahmp%water%state%SoilIceMax ,& ! out, maximum soil ice content [m3/m3] + SoilLiqWaterMin => noahmp%water%state%SoilLiqWaterMin & ! out, minimum soil liquid water content [m3/m3] + ) +! ---------------------------------------------------------------------- + + ! initialization + if (.not. allocated(MatRight) ) allocate(MatRight (1:NumSoilLayer)) + if (.not. allocated(MatLeft1) ) allocate(MatLeft1 (1:NumSoilLayer)) + if (.not. allocated(MatLeft2) ) allocate(MatLeft2 (1:NumSoilLayer)) + if (.not. allocated(MatLeft3) ) allocate(MatLeft3 (1:NumSoilLayer)) + if (.not. allocated(SoilLiqTmp)) allocate(SoilLiqTmp(1:NumSoilLayer)) + MatRight = 0.0 + MatLeft1 = 0.0 + MatLeft2 = 0.0 + MatLeft3 = 0.0 + SoilLiqTmp = 0.0 + RunoffSurface = 0.0 + RunoffSubsurface = 0.0 + InfilRateSfc = 0.0 + SoilSatExcAcc = 0.0 + InfilSfcAcc = 1.0e-06 + + ! for the case when snowmelt water is too large + do LoopInd1 = 1, NumSoilLayer + SoilEffPorosity(LoopInd1) = max(1.0e-4, (SoilMoistureSat(LoopInd1) - SoilIce(LoopInd1))) + SoilSatExcAcc = SoilSatExcAcc + max(0.0, SoilLiqWater(LoopInd1) - SoilEffPorosity(LoopInd1)) * & + ThicknessSnowSoilLayer(LoopInd1) + SoilLiqWater(LoopInd1) = min(SoilEffPorosity(LoopInd1), SoilLiqWater(LoopInd1)) + enddo + + ! impermeable fraction due to frozen soil + do LoopInd1 = 1, NumSoilLayer + SoilIceFrac(LoopInd1) = min(1.0, SoilIce(LoopInd1) / SoilMoistureSat(LoopInd1)) + SoilImpervFrac(LoopInd1) = max(0.0, exp(-SoilImpPara*(1.0-SoilIceFrac(LoopInd1))) - exp(-SoilImpPara)) / & + (1.0 - exp(-SoilImpPara)) + enddo + + ! maximum soil ice content and minimum liquid water of all layers + SoilIceMax = 0.0 + SoilImpervFracMax = 0.0 + SoilLiqWaterMin = SoilMoistureSat(1) + do LoopInd1 = 1, NumSoilLayer + if ( SoilIce(LoopInd1) > SoilIceMax ) SoilIceMax = SoilIce(LoopInd1) + if ( SoilImpervFrac(LoopInd1) > SoilImpervFracMax ) SoilImpervFracMax = SoilImpervFrac(LoopInd1) + if ( SoilLiqWater(LoopInd1) < SoilLiqWaterMin ) SoilLiqWaterMin = SoilLiqWater(LoopInd1) + enddo + + ! subsurface runoff for runoff scheme option 2 + if ( OptRunoffSubsurface == 2 ) call RunoffSubSurfaceEquiWaterTable(noahmp) + + ! jref impermable surface at urban + if ( FlagUrban .eqv. .true. ) SoilImpervFrac(1) = 0.95 + + ! surface runoff and infiltration rate using different schemes + if ( OptRunoffSurface == 1 ) call RunoffSurfaceTopModelGrd(noahmp) + if ( OptRunoffSurface == 2 ) call RunoffSurfaceTopModelEqui(noahmp) + if ( OptRunoffSurface == 3 ) call RunoffSurfaceFreeDrain(noahmp,SoilTimeStep) + if ( OptRunoffSurface == 4 ) call RunoffSurfaceBATS(noahmp) + if ( OptRunoffSurface == 5 ) call RunoffSurfaceTopModelMMF(noahmp) + if ( OptRunoffSurface == 6 ) call RunoffSurfaceVIC(noahmp,SoilTimeStep) + if ( OptRunoffSurface == 7 ) call RunoffSurfaceXinAnJiang(noahmp,SoilTimeStep) + if ( OptRunoffSurface == 8 ) call RunoffSurfaceDynamicVic(noahmp,SoilTimeStep,InfilSfcAcc) + + ! determine iteration times to solve soil water diffusion and moisture + NumIterSoilWat = 3 + if ( (InfilRateSfc*SoilTimeStep) > (ThicknessSnowSoilLayer(1)*SoilMoistureSat(1)) ) then + NumIterSoilWat = NumIterSoilWat*2 + endif + TimeStepFine = SoilTimeStep / NumIterSoilWat + + ! solve soil moisture + InfilSfcAcc = 1.0e-06 + DrainSoilBotAcc = 0.0 + RunoffSurfaceAcc = 0.0 + + do IndIter = 1, NumIterSoilWat + if ( SoilSfcInflowMean > 0.0 ) then + if ( OptRunoffSurface == 3 ) call RunoffSurfaceFreeDrain(noahmp,TimeStepFine) + if ( OptRunoffSurface == 6 ) call RunoffSurfaceVIC(noahmp,TimeStepFine) + if ( OptRunoffSurface == 7 ) call RunoffSurfaceXinAnJiang(noahmp,TimeStepFine) + if ( OptRunoffSurface == 8 ) call RunoffSurfaceDynamicVic(noahmp,TimeStepFine,InfilSfcAcc) + endif + call SoilWaterDiffusionRichards(noahmp, MatLeft1, MatLeft2, MatLeft3, MatRight) + call SoilMoistureSolver(noahmp, TimeStepFine, MatLeft1, MatLeft2, MatLeft3, MatRight) + SoilSatExcAcc = SoilSatExcAcc + SoilSaturationExcess + DrainSoilBotAcc = DrainSoilBotAcc + DrainSoilBot + RunoffSurfaceAcc = RunoffSurfaceAcc + RunoffSurface + enddo + + DrainSoilBot = DrainSoilBotAcc / NumIterSoilWat + RunoffSurface = RunoffSurfaceAcc / NumIterSoilWat + RunoffSurface = RunoffSurface * 1000.0 + SoilSatExcAcc * 1000.0 / SoilTimeStep ! m/s -> mm/s + DrainSoilBot = DrainSoilBot * 1000.0 ! m/s -> mm/s + + ! compute tile drainage ! pvk + if ( (OptTileDrainage == 1) .and. (TileDrainFrac > 0.3) .and. (OptRunoffSurface == 3) ) then + call TileDrainageSimple(noahmp) ! simple tile drainage + endif + if ( (OptTileDrainage == 2) .and. (TileDrainFrac > 0.1) .and. (OptRunoffSurface == 3) ) then + call TileDrainageHooghoudt(noahmp) ! Hooghoudt tile drain + END IF + + ! removal of soil water due to subsurface runoff (option 2) + if ( OptRunoffSubsurface == 2 ) then + SoilWatConductAcc = 0.0 + do LoopInd1 = 1, NumSoilLayer + SoilWatConductAcc = SoilWatConductAcc + SoilWatConductivity(LoopInd1) * ThicknessSnowSoilLayer(LoopInd1) + enddo + do LoopInd1 = 1, NumSoilLayer + WaterRemove = RunoffSubsurface * SoilTimeStep * & + (SoilWatConductivity(LoopInd1)*ThicknessSnowSoilLayer(LoopInd1)) / SoilWatConductAcc + SoilLiqWater(LoopInd1) = SoilLiqWater(LoopInd1) - WaterRemove / (ThicknessSnowSoilLayer(LoopInd1)*1000.0) + enddo + endif + + ! Limit SoilLiqTmp to be greater than or equal to watmin. + ! Get water needed to bring SoilLiqTmp equal SoilWaterMin from lower layer. + if ( OptRunoffSubsurface /= 1 ) then + do LoopInd2 = 1, NumSoilLayer + SoilLiqTmp(LoopInd2) = SoilLiqWater(LoopInd2) * ThicknessSnowSoilLayer(LoopInd2) * 1000.0 + enddo + + SoilWaterMin = 0.01 ! mm + do LoopInd2 = 1, NumSoilLayer-1 + if ( SoilLiqTmp(LoopInd2) < 0.0 ) then + SoilWatRem = SoilWaterMin - SoilLiqTmp(LoopInd2) + else + SoilWatRem = 0.0 + endif + SoilLiqTmp(LoopInd2 ) = SoilLiqTmp(LoopInd2 ) + SoilWatRem + SoilLiqTmp(LoopInd2+1) = SoilLiqTmp(LoopInd2+1) - SoilWatRem + enddo + LoopInd2 = NumSoilLayer + if ( SoilLiqTmp(LoopInd2) < SoilWaterMin ) then + SoilWatRem = SoilWaterMin - SoilLiqTmp(LoopInd2) + else + SoilWatRem = 0.0 + endif + SoilLiqTmp(LoopInd2) = SoilLiqTmp(LoopInd2) + SoilWatRem + RunoffSubsurface = RunoffSubsurface - SoilWatRem/SoilTimeStep + + if ( OptRunoffSubsurface == 5 ) RechargeGwDeepWT = RechargeGwDeepWT - SoilWatRem * 1.0e-3 + + do LoopInd2 = 1, NumSoilLayer + SoilLiqWater(LoopInd2) = SoilLiqTmp(LoopInd2) / (ThicknessSnowSoilLayer(LoopInd2)*1000.0) + enddo + endif ! OptRunoffSubsurface /= 1 + + ! compute groundwater and subsurface runoff + if ( OptRunoffSubsurface == 1 ) call RunoffSubSurfaceGroundWater(noahmp) + + ! compute subsurface runoff based on drainage rate + if ( (OptRunoffSubsurface == 3) .or. (OptRunoffSubsurface == 4) .or. (OptRunoffSubsurface == 6) .or. & + (OptRunoffSubsurface == 7) .or. (OptRunoffSubsurface == 8) ) then + call RunoffSubSurfaceDrainage(noahmp) + endif + + ! update soil moisture + do LoopInd2 = 1, NumSoilLayer + SoilMoisture(LoopInd2) = SoilLiqWater(LoopInd2) + SoilIce(LoopInd2) + enddo + + ! compute subsurface runoff and shallow water table for MMF scheme + if ( OptRunoffSubsurface == 5 ) call RunoffSubSurfaceShallowWaterMMF(noahmp) + + ! accumulated water flux over soil timestep [mm] + RunoffSurface = RunoffSurface * SoilTimeStep + RunoffSubsurface = RunoffSubsurface * SoilTimeStep + TileDrain = TileDrain * SoilTimeStep + + ! deallocate local arrays to avoid memory leaks + deallocate(MatRight ) + deallocate(MatLeft1 ) + deallocate(MatLeft2 ) + deallocate(MatLeft3 ) + deallocate(SoilLiqTmp) + + end associate + + end subroutine SoilWaterMain + +end module SoilWaterMainMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SoilWaterSupercoolKoren99Mod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SoilWaterSupercoolKoren99Mod.F90 new file mode 100644 index 0000000000..49f3dedbb2 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SoilWaterSupercoolKoren99Mod.F90 @@ -0,0 +1,127 @@ +module SoilWaterSupercoolKoren99Mod + +!!! Calculate amount of supercooled liquid soil water content if soil temperature < freezing point +!!! This uses Newton-type iteration to solve the nonlinear implicit equation +!!! Reference: Eqn.17 in Koren et al. 1999 JGR VOL 104(D16), 19569-19585 +!!! New version (June 2001): much faster and more accurate Newton iteration achieved by first +!!! taking log of Eqn above -- less than 4 (typically 1 or 2) iterations achieves convergence. +!!! Explicit 1-step solution option for special case of parameter CK=0, which reduces the +!!! original implicit equation to a simpler explicit form, known as "Flerchinger Eqn". Improved +!!! handling of solution in the limit of freezing point temperature. + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine SoilWaterSupercoolKoren99(noahmp, IndSoil, SoilWatSupercool, & + SoilTemperature, SoilMoisture, SoilLiqWater) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: FRH2O +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + +! in & out variables + type(noahmp_type) , intent(inout) :: noahmp + integer , intent(in ) :: IndSoil ! soil layer index + real(kind=kind_noahmp), intent(in ) :: SoilLiqWater ! soil liquid water content [m3/m3] + real(kind=kind_noahmp), intent(in ) :: SoilMoisture ! total soil moisture content [m3/m3] + real(kind=kind_noahmp), intent(in ) :: SoilTemperature ! soil temperature [K] + real(kind=kind_noahmp), intent(out ) :: SoilWatSupercool ! soil supercooled liquid water content [m3/m3] + +! local variable + integer :: NumIter ! number of iteration + integer :: IndCnt ! counting index + real(kind=kind_noahmp) :: SoilExpB ! temporary soil B parameter + real(kind=kind_noahmp) :: Denom ! temporary denominator variable + real(kind=kind_noahmp) :: DF ! temporary nominator variable + real(kind=kind_noahmp) :: SoilIceChg ! soil ice content change + real(kind=kind_noahmp) :: FlerFac ! factor in Flerchinger solution + real(kind=kind_noahmp) :: SoilIce ! soil ice content + real(kind=kind_noahmp) :: SoilIceTmp ! temporary soil ice content + real(kind=kind_noahmp), parameter :: CK = 8.0 ! parameter + real(kind=kind_noahmp), parameter :: SoilExpBMax = 5.5 ! limit of B soil parameter + real(kind=kind_noahmp), parameter :: ErrorThr = 0.005 ! error threshold + +! -------------------------------------------------------------------- + associate( & + SoilExpCoeffB => noahmp%water%param%SoilExpCoeffB ,& ! in, soil B parameter + SoilMatPotentialSat => noahmp%water%param%SoilMatPotentialSat ,& ! in, saturated soil matric potential [m] + SoilMoistureSat => noahmp%water%param%SoilMoistureSat & ! in, saturated value of soil moisture [m3/m3] + ) +! ---------------------------------------------------------------------- + + ! limit on parameter B: B < 5.5 (use parameter SoilExpBMax) + ! simulations showed if B > 5.5 unfrozen water content is + ! non-realistically high at very low temperatures + SoilExpB = SoilExpCoeffB(IndSoil) + + ! initializing iterations counter and interative solution flag + if ( SoilExpCoeffB(IndSoil) > SoilExpBMax ) SoilExpB = SoilExpBMax + NumIter = 0 + + ! if soil temperature not largely below freezing point, SoilLiqWater = SoilMoisture + IndCnt = 0 + if ( SoilTemperature > (ConstFreezePoint-1.0e-3) ) then + SoilWatSupercool = SoilMoisture + else ! frozen soil case + + !--- Option 1: iterated solution in Koren et al. 1999 JGR Eqn.17 + ! initial guess for SoilIce (frozen content) + if ( CK /= 0.0 ) then + SoilIce = SoilMoisture - SoilLiqWater + if ( SoilIce > (SoilMoisture-0.02) ) SoilIce = SoilMoisture - 0.02 ! keep within bounds + ! start the iterations + if ( SoilIce < 0.0 ) SoilIce = 0.0 +1001 Continue + if ( .not. ((NumIter < 10) .and. (IndCnt == 0)) ) goto 1002 + NumIter = NumIter +1 + DF = alog((SoilMatPotentialSat(IndSoil)*ConstGravityAcc/ConstLatHeatFusion) * & + ((1.0 + CK*SoilIce)**2.0) * (SoilMoistureSat(IndSoil)/(SoilMoisture - SoilIce))**SoilExpB) - & + alog(-(SoilTemperature - ConstFreezePoint) / SoilTemperature) + Denom = 2.0 * CK / (1.0 + CK * SoilIce) + SoilExpB / (SoilMoisture - SoilIce) + SoilIceTmp = SoilIce - DF / Denom + ! bounds useful for mathematical solution + if ( SoilIceTmp > (SoilMoisture-0.02) ) SoilIceTmp = SoilMoisture - 0.02 + if ( SoilIceTmp < 0.0 ) SoilIceTmp = 0.0 + SoilIceChg = abs(SoilIceTmp - SoilIce) ! mathematical solution bounds applied + ! if more than 10 iterations, use explicit method (CK=0 approx.) + ! when SoilIceChg <= ErrorThr, no more interations required. + SoilIce = SoilIceTmp + if ( SoilIceChg <= ErrorThr ) then + IndCnt = IndCnt +1 + endif + ! end of iteration + ! bounds applied within do-block are valid for physical solution + goto 1001 +1002 continue + SoilWatSupercool = SoilMoisture - SoilIce + endif + !--- End Option 1 + + !--- Option 2: explicit solution for Flerchinger Eq. i.e., CK=0 + ! in Koren et al. 1999 JGR Eqn. 17 + ! apply physical bounds to Flerchinger solution + if ( IndCnt == 0 ) then + print*, 'Flerchinger used in NEW version. Iterations=', NumIter + FlerFac = (((ConstLatHeatFusion / (ConstGravityAcc * (-SoilMatPotentialSat(IndSoil)))) * & + ((SoilTemperature-ConstFreezePoint) / SoilTemperature))**(-1.0/SoilExpB)) * SoilMoistureSat(IndSoil) + if ( FlerFac < 0.02 ) FlerFac = 0.02 + SoilWatSupercool = min(FlerFac, SoilMoisture) + endif + !--- End Option 2 + + endif + + end associate + + end subroutine SoilWaterSupercoolKoren99 + +end module SoilWaterSupercoolKoren99Mod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SoilWaterSupercoolNiu06Mod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SoilWaterSupercoolNiu06Mod.F90 new file mode 100644 index 0000000000..770d979169 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SoilWaterSupercoolNiu06Mod.F90 @@ -0,0 +1,48 @@ +module SoilWaterSupercoolNiu06Mod + +!!! Calculate amount of supercooled liquid soil water content if soil temperature < freezing point +!!! This solution does not use iteration (Niu and Yang, 2006 JHM). + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine SoilWaterSupercoolNiu06(noahmp, IndSoil, SoilWatSupercool, SoilTemperature) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: embedded in PHASECHANGE +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + +! in & out variables + type(noahmp_type) , intent(inout) :: noahmp + integer , intent(in ) :: IndSoil ! soil layer index + real(kind=kind_noahmp), intent(in ) :: SoilTemperature ! soil temperature [K] + real(kind=kind_noahmp), intent(out ) :: SoilWatSupercool ! soil supercooled liquid water content [m3/m3] + +! local variable + real(kind=kind_noahmp) :: SoilWatPotFrz ! frozen water potential [mm] + +! ----------------------------------------------------------------------------- + associate( & + SoilExpCoeffB => noahmp%water%param%SoilExpCoeffB ,& ! in, soil B parameter + SoilMatPotentialSat => noahmp%water%param%SoilMatPotentialSat ,& ! in, saturated soil matric potential [m] + SoilMoistureSat => noahmp%water%param%SoilMoistureSat & ! in, saturated value of soil moisture [m3/m3] + ) +! ----------------------------------------------------------------------------- + + SoilWatPotFrz = ConstLatHeatFusion * (ConstFreezePoint - SoilTemperature) / (ConstGravityAcc * SoilTemperature) + SoilWatSupercool = SoilMoistureSat(IndSoil) * (SoilWatPotFrz / SoilMatPotentialSat(IndSoil))**(-1.0/SoilExpCoeffB(IndSoil)) + + end associate + + end subroutine SoilWaterSupercoolNiu06 + +end module SoilWaterSupercoolNiu06Mod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SoilWaterTranspirationMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SoilWaterTranspirationMod.F90 new file mode 100644 index 0000000000..d5ef583af1 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SoilWaterTranspirationMod.F90 @@ -0,0 +1,91 @@ +module SoilWaterTranspirationMod + +!!! compute soil water transpiration factor that will be used for +!!! stomata resistance and evapotranspiration calculations + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine SoilWaterTranspiration(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: None (embedded in ENERGY subroutine) +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + +! in & out variables + type(noahmp_type), intent(inout) :: noahmp + +! local variables + integer :: IndSoil ! loop index + real(kind=kind_noahmp) :: SoilWetFac ! temporary variable + real(kind=kind_noahmp) :: MinThr ! minimum threshold to prevent divided by zero + +! -------------------------------------------------------------------- + associate( & + SurfaceType => noahmp%config%domain%SurfaceType ,& ! in, surface type 1-soil; 2-lake + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! in, thickness of snow/soil layers [m] + DepthSoilLayer => noahmp%config%domain%DepthSoilLayer ,& ! in, depth [m] of layer-bottom from soil surface + OptSoilWaterTranspiration => noahmp%config%nmlist%OptSoilWaterTranspiration ,& ! in, option for soil moisture factor for stomatal resistance & ET + NumSoilLayerRoot => noahmp%water%param%NumSoilLayerRoot ,& ! in, number of soil layers with root present + SoilMoistureWilt => noahmp%water%param%SoilMoistureWilt ,& ! in, wilting point soil moisture [m3/m3] + SoilMoistureFieldCap => noahmp%water%param%SoilMoistureFieldCap ,& ! in, reference soil moisture (field capacity) [m3/m3] + SoilMatPotentialWilt => noahmp%water%param%SoilMatPotentialWilt ,& ! in, soil metric potential for wilting point [m] + SoilMatPotentialSat => noahmp%water%param%SoilMatPotentialSat ,& ! in, saturated soil matric potential [m] + SoilMoistureSat => noahmp%water%param%SoilMoistureSat ,& ! in, saturated value of soil moisture [m3/m3] + SoilExpCoeffB => noahmp%water%param%SoilExpCoeffB ,& ! in, soil B parameter + SoilLiqWater => noahmp%water%state%SoilLiqWater ,& ! in, soil water content [m3/m3] + SoilTranspFac => noahmp%water%state%SoilTranspFac ,& ! out, soil water transpiration factor (0 to 1) + SoilTranspFacAcc => noahmp%water%state%SoilTranspFacAcc ,& ! out, accumulated soil water transpiration factor (0 to 1) + SoilMatPotential => noahmp%water%state%SoilMatPotential & ! out, soil matrix potential [m] + ) +! ---------------------------------------------------------------------- + + ! soil moisture factor controlling stomatal resistance and evapotranspiration + MinThr = 1.0e-6 + SoilTranspFacAcc = 0.0 + + ! only for soil point + if ( SurfaceType ==1 ) then + do IndSoil = 1, NumSoilLayerRoot + if ( OptSoilWaterTranspiration == 1 ) then ! Noah + SoilWetFac = (SoilLiqWater(IndSoil) - SoilMoistureWilt(IndSoil)) / & + (SoilMoistureFieldCap(IndSoil) - SoilMoistureWilt(IndSoil)) + endif + if ( OptSoilWaterTranspiration == 2 ) then ! CLM + SoilMatPotential(IndSoil) = max(SoilMatPotentialWilt, -SoilMatPotentialSat(IndSoil) * & + (max(0.01,SoilLiqWater(IndSoil))/SoilMoistureSat(IndSoil)) ** & + (-SoilExpCoeffB(IndSoil))) + SoilWetFac = (1.0 - SoilMatPotential(IndSoil)/SoilMatPotentialWilt) / & + (1.0 + SoilMatPotentialSat(IndSoil)/SoilMatPotentialWilt) + endif + if ( OptSoilWaterTranspiration == 3 ) then ! SSiB + SoilMatPotential(IndSoil) = max(SoilMatPotentialWilt, -SoilMatPotentialSat(IndSoil) * & + (max(0.01,SoilLiqWater(IndSoil))/SoilMoistureSat(IndSoil)) ** & + (-SoilExpCoeffB(IndSoil))) + SoilWetFac = 1.0 - exp(-5.8*(log(SoilMatPotentialWilt/SoilMatPotential(IndSoil)))) + endif + SoilWetFac = min(1.0, max(0.0,SoilWetFac)) + + SoilTranspFac(IndSoil) = max(MinThr, ThicknessSnowSoilLayer(IndSoil) / & + (-DepthSoilLayer(NumSoilLayerRoot)) * SoilWetFac) + SoilTranspFacAcc = SoilTranspFacAcc + SoilTranspFac(IndSoil) + enddo + + SoilTranspFacAcc = max(MinThr, SoilTranspFacAcc) + SoilTranspFac(1:NumSoilLayerRoot) = SoilTranspFac(1:NumSoilLayerRoot) / SoilTranspFacAcc + endif + + end associate + + end subroutine SoilWaterTranspiration + +end module SoilWaterTranspirationMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SurfaceAlbedoGlacierMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SurfaceAlbedoGlacierMod.F90 new file mode 100644 index 0000000000..515a22357a --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SurfaceAlbedoGlacierMod.F90 @@ -0,0 +1,79 @@ +module SurfaceAlbedoGlacierMod + +!!! Compute glacier surface albedo + + use Machine + use NoahmpVarType + use ConstantDefineMod + use SnowAgingBatsMod, only : SnowAgingBats + use SnowAlbedoBatsMod, only : SnowAlbedoBats + use SnowAlbedoClassMod, only : SnowAlbedoClass + use GroundAlbedoGlacierMod, only : GroundAlbedoGlacier + + implicit none + +contains + + subroutine SurfaceAlbedoGlacier(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: RADIATION_GLACIER +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: IndBand ! solar band index + +! -------------------------------------------------------------------- + associate( & + NumSwRadBand => noahmp%config%domain%NumSwRadBand ,& ! in, number of solar radiation wave bands + CosSolarZenithAngle => noahmp%config%domain%CosSolarZenithAngle ,& ! in, cosine solar zenith angle + OptSnowAlbedo => noahmp%config%nmlist%OptSnowAlbedo ,& ! in, options for ground snow surface albedo + AlbedoGrdDir => noahmp%energy%state%AlbedoGrdDir ,& ! out, ground albedo (direct beam: vis, nir) + AlbedoGrdDif => noahmp%energy%state%AlbedoGrdDif ,& ! out, ground albedo (diffuse: vis, nir) + AlbedoSnowDir => noahmp%energy%state%AlbedoSnowDir ,& ! out, snow albedo for direct(1=vis, 2=nir) + AlbedoSnowDif => noahmp%energy%state%AlbedoSnowDif ,& ! out, snow albedo for diffuse(1=vis, 2=nir) + AlbedoSfcDir => noahmp%energy%state%AlbedoSfcDir ,& ! out, surface albedo (direct) + AlbedoSfcDif => noahmp%energy%state%AlbedoSfcDif & ! out, surface albedo (diffuse) + ) +! ---------------------------------------------------------------------- + + ! initialization + do IndBand = 1, NumSwRadBand + AlbedoSfcDir (IndBand) = 0.0 + AlbedoSfcDif (IndBand) = 0.0 + AlbedoGrdDir (IndBand) = 0.0 + AlbedoGrdDif (IndBand) = 0.0 + AlbedoSnowDir(IndBand) = 0.0 + AlbedoSnowDif(IndBand) = 0.0 + enddo + + ! solar radiation process is only done if there is light + if ( CosSolarZenithAngle > 0 ) then + + ! snow aging + call SnowAgingBats(noahmp) + + ! snow albedo + if ( OptSnowAlbedo == 1 ) call SnowAlbedoBats(noahmp) + if ( OptSnowAlbedo == 2 ) call SnowAlbedoClass(noahmp) + + ! ground albedo + call GroundAlbedoGlacier(noahmp) + + ! surface albedo + AlbedoSfcDir = AlbedoGrdDir + AlbedoSfcDif = AlbedoGrdDif + + endif ! CosSolarZenithAngle > 0 + + end associate + + end subroutine SurfaceAlbedoGlacier + +end module SurfaceAlbedoGlacierMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SurfaceAlbedoMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SurfaceAlbedoMod.F90 new file mode 100644 index 0000000000..d8e4bf109e --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SurfaceAlbedoMod.F90 @@ -0,0 +1,159 @@ +module SurfaceAlbedoMod + +!!! Compute total surface albedo and vegetation radiative fluxes +!!! per unit incoming direct and diffuse radiation and sunlit fraction of canopy + + use Machine + use NoahmpVarType + use ConstantDefineMod + use SnowAgingBatsMod, only : SnowAgingBats + use SnowAlbedoBatsMod, only : SnowAlbedoBats + use SnowAlbedoClassMod, only : SnowAlbedoClass + use GroundAlbedoMod, only : GroundAlbedo + use CanopyRadiationTwoStreamMod, only : CanopyRadiationTwoStream + + implicit none + +contains + + subroutine SurfaceAlbedo(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: ALBEDO +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: IndBand ! waveband indices + integer :: IndDif ! direct beam: IndDif=0; diffuse: IndDif=1 + real(kind=kind_noahmp) :: LeafWgt ! fraction of LeafAreaIndex+StemAreaIndex that is LeafAreaIndex + real(kind=kind_noahmp) :: StemWgt ! fraction of LeafAreaIndex+StemAreaIndex that is StemAreaIndex + real(kind=kind_noahmp) :: MinThr ! prevents overflow for division by zero + real(kind=kind_noahmp) :: LightExtDir ! optical depth direct beam per unit leaf + stem area + +! -------------------------------------------------------------------- + associate( & + NumSwRadBand => noahmp%config%domain%NumSwRadBand ,& ! in, number of solar radiation wave bands + CosSolarZenithAngle => noahmp%config%domain%CosSolarZenithAngle ,& ! in, cosine solar zenith angle + OptSnowAlbedo => noahmp%config%nmlist%OptSnowAlbedo ,& ! in, options for ground snow surface albedo + ReflectanceLeaf => noahmp%energy%param%ReflectanceLeaf ,& ! in, leaf reflectance: 1=vis, 2=nir + ReflectanceStem => noahmp%energy%param%ReflectanceStem ,& ! in, stem reflectance: 1=vis, 2=nir + TransmittanceLeaf => noahmp%energy%param%TransmittanceLeaf ,& ! in, leaf transmittance: 1=vis, 2=nir + TransmittanceStem => noahmp%energy%param%TransmittanceStem ,& ! in, stem transmittance: 1=vis, 2=nir + LeafAreaIndEff => noahmp%energy%state%LeafAreaIndEff ,& ! in, leaf area index, after burying by snow + StemAreaIndEff => noahmp%energy%state%StemAreaIndEff ,& ! in, stem area index, after burying by snow + AlbedoGrdDir => noahmp%energy%state%AlbedoGrdDir ,& ! out, ground albedo (direct beam: vis, nir) + AlbedoGrdDif => noahmp%energy%state%AlbedoGrdDif ,& ! out, ground albedo (diffuse: vis, nir) + AlbedoSnowDir => noahmp%energy%state%AlbedoSnowDir ,& ! out, snow albedo for direct(1=vis, 2=nir) + AlbedoSnowDif => noahmp%energy%state%AlbedoSnowDif ,& ! out, snow albedo for diffuse(1=vis, 2=nir) + AlbedoSfcDir => noahmp%energy%state%AlbedoSfcDir ,& ! out, surface albedo (direct) + AlbedoSfcDif => noahmp%energy%state%AlbedoSfcDif ,& ! out, surface albedo (diffuse) + CanopySunlitFrac => noahmp%energy%state%CanopySunlitFrac ,& ! out, sunlit fraction of canopy + CanopyShadeFrac => noahmp%energy%state%CanopyShadeFrac ,& ! out, shaded fraction of canopy + LeafAreaIndSunlit => noahmp%energy%state%LeafAreaIndSunlit ,& ! out, sunlit leaf area + LeafAreaIndShade => noahmp%energy%state%LeafAreaIndShade ,& ! out, shaded leaf area + GapBtwCanopy => noahmp%energy%state%GapBtwCanopy ,& ! out, between canopy gap fraction for beam + GapInCanopy => noahmp%energy%state%GapInCanopy ,& ! out, within canopy gap fraction for beam + ReflectanceVeg => noahmp%energy%state%ReflectanceVeg ,& ! out, leaf/stem reflectance weighted by fraction LAI and SAI + TransmittanceVeg => noahmp%energy%state%TransmittanceVeg ,& ! out, leaf/stem transmittance weighted by fraction LAI and SAI + VegAreaIndEff => noahmp%energy%state%VegAreaIndEff ,& ! out, one-sided leaf+stem area index [m2/m2] + VegAreaProjDir => noahmp%energy%state%VegAreaProjDir ,& ! out, projected leaf+stem area in solar direction + RadSwAbsVegDir => noahmp%energy%flux%RadSwAbsVegDir ,& ! out, flux abs by veg (per unit direct flux) + RadSwAbsVegDif => noahmp%energy%flux%RadSwAbsVegDif ,& ! out, flux abs by veg (per unit diffuse flux) + RadSwDirTranGrdDir => noahmp%energy%flux%RadSwDirTranGrdDir ,& ! out, down direct flux below veg (per unit dir flux) + RadSwDifTranGrdDir => noahmp%energy%flux%RadSwDifTranGrdDir ,& ! out, down diffuse flux below veg (per unit dir flux) + RadSwDifTranGrdDif => noahmp%energy%flux%RadSwDifTranGrdDif ,& ! out, down diffuse flux below veg (per unit dif flux) + RadSwDirTranGrdDif => noahmp%energy%flux%RadSwDirTranGrdDif ,& ! out, down direct flux below veg per unit dif flux (= 0) + RadSwReflVegDir => noahmp%energy%flux%RadSwReflVegDir ,& ! out, flux reflected by veg layer (per unit direct flux) + RadSwReflVegDif => noahmp%energy%flux%RadSwReflVegDif ,& ! out, flux reflected by veg layer (per unit diffuse flux) + RadSwReflGrdDir => noahmp%energy%flux%RadSwReflGrdDir ,& ! out, flux reflected by ground (per unit direct flux) + RadSwReflGrdDif => noahmp%energy%flux%RadSwReflGrdDif & ! out, flux reflected by ground (per unit diffuse flux) + ) +! ---------------------------------------------------------------------- + + ! initialization + MinThr = 1.0e-06 + GapBtwCanopy = 0.0 + GapInCanopy = 0.0 + VegAreaProjDir = 0.0 + ReflectanceVeg = 0.0 + TransmittanceVeg = 0.0 + CanopySunlitFrac = 0.0 + do IndBand = 1, NumSwRadBand + AlbedoSfcDir (IndBand) = 0.0 + AlbedoSfcDif (IndBand) = 0.0 + AlbedoGrdDir (IndBand) = 0.0 + AlbedoGrdDif (IndBand) = 0.0 + AlbedoSnowDir (IndBand) = 0.0 + AlbedoSnowDif (IndBand) = 0.0 + RadSwAbsVegDir (IndBand) = 0.0 + RadSwAbsVegDif (IndBand) = 0.0 + RadSwDirTranGrdDir(IndBand) = 0.0 + RadSwDirTranGrdDif(IndBand) = 0.0 + RadSwDifTranGrdDir(IndBand) = 0.0 + RadSwDifTranGrdDif(IndBand) = 0.0 + RadSwReflVegDir (IndBand) = 0.0 + RadSwReflVegDif (IndBand) = 0.0 + RadSwReflGrdDir (IndBand) = 0.0 + RadSwReflGrdDif (IndBand) = 0.0 + enddo + VegAreaIndEff = LeafAreaIndEff + StemAreaIndEff + + ! solar radiation process is only done if there is light + if ( CosSolarZenithAngle > 0 ) then + + ! weight reflectance/transmittance by LeafAreaIndex and StemAreaIndex + LeafWgt = LeafAreaIndEff / max(VegAreaIndEff, MinThr) + StemWgt = StemAreaIndEff / max(VegAreaIndEff, MinThr) + do IndBand = 1, NumSwRadBand + ReflectanceVeg(IndBand) = max(ReflectanceLeaf(IndBand)*LeafWgt+ReflectanceStem(IndBand)*StemWgt, MinThr) + TransmittanceVeg(IndBand) = max(TransmittanceLeaf(IndBand)*LeafWgt+TransmittanceStem(IndBand)*StemWgt, MinThr) + enddo + + ! snow aging + call SnowAgingBats(noahmp) + + ! snow albedos + if ( OptSnowAlbedo == 1 ) call SnowAlbedoBats(noahmp) + if ( OptSnowAlbedo == 2 ) call SnowAlbedoClass(noahmp) + + ! ground surface albedo + call GroundAlbedo(noahmp) + + ! loop over shortwave bands to calculate surface albedos and solar + ! fluxes for unit incoming direct (IndDif=0) and diffuse flux (IndDif=1) + do IndBand = 1, NumSwRadBand + IndDif = 0 ! direct + call CanopyRadiationTwoStream(noahmp, IndBand, IndDif) + IndDif = 1 ! diffuse + call CanopyRadiationTwoStream(noahmp, IndBand, IndDif) + enddo + + ! sunlit fraction of canopy. set CanopySunlitFrac = 0 if CanopySunlitFrac < 0.01. + LightExtDir = VegAreaProjDir / CosSolarZenithAngle * sqrt(1.0-ReflectanceVeg(1)-TransmittanceVeg(1)) + CanopySunlitFrac = (1.0 - exp(-LightExtDir*VegAreaIndEff)) / max(LightExtDir*VegAreaIndEff, MinThr) + LightExtDir = CanopySunlitFrac + if ( LightExtDir < 0.01 ) then + LeafWgt = 0.0 + else + LeafWgt = LightExtDir + endif + CanopySunlitFrac = LeafWgt + + endif ! CosSolarZenithAngle > 0 + + ! shaded canopy fraction + CanopyShadeFrac = 1.0 - CanopySunlitFrac + LeafAreaIndSunlit = LeafAreaIndEff * CanopySunlitFrac + LeafAreaIndShade = LeafAreaIndEff * CanopyShadeFrac + + end associate + + end subroutine SurfaceAlbedo + +end module SurfaceAlbedoMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SurfaceEmissivityGlacierMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SurfaceEmissivityGlacierMod.F90 new file mode 100644 index 0000000000..374f999503 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SurfaceEmissivityGlacierMod.F90 @@ -0,0 +1,46 @@ +module SurfaceEmissivityGlacierMod + +!!! Compute glacier surface longwave emissivity + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine SurfaceEmissivityGlacier(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: None (embedded in ENERGY_GLACIER subroutine) +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + +! in & out variables + type(noahmp_type), intent(inout) :: noahmp + +! -------------------------------------------------------------------- + associate( & + EmissivitySnow => noahmp%energy%param%EmissivitySnow ,& ! in, snow emissivity + EmissivityIceSfc => noahmp%energy%param%EmissivityIceSfc ,& ! in, emissivity ice surface + SnowCoverFrac => noahmp%water%state%SnowCoverFrac ,& ! in, snow cover fraction + EmissivityGrd => noahmp%energy%state%EmissivityGrd ,& ! out, ground emissivity + EmissivitySfc => noahmp%energy%state%EmissivitySfc & ! out, surface emissivity + ) +! ---------------------------------------------------------------------- + + ! ground emissivity + EmissivityGrd = EmissivityIceSfc * (1.0 - SnowCoverFrac) + EmissivitySnow * SnowCoverFrac + + ! surface emissivity + EmissivitySfc = EmissivityGrd + + end associate + + end subroutine SurfaceEmissivityGlacier + +end module SurfaceEmissivityGlacierMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SurfaceEmissivityMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SurfaceEmissivityMod.F90 new file mode 100644 index 0000000000..1701a760bd --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SurfaceEmissivityMod.F90 @@ -0,0 +1,61 @@ +module SurfaceEmissivityMod + +!!! Compute ground, vegetation, and total surface longwave emissivity + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine SurfaceEmissivity(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: None (embedded in ENERGY subroutine) +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + +! in & out variables + type(noahmp_type), intent(inout) :: noahmp + +! -------------------------------------------------------------------- + associate( & + IndicatorIceSfc => noahmp%config%domain%IndicatorIceSfc ,& ! in, indicator for ice point: 1->seaice; -1->land ice; 0->soil + SurfaceType => noahmp%config%domain%SurfaceType ,& ! in, surface type 1-soil; 2-lake + EmissivitySnow => noahmp%energy%param%EmissivitySnow ,& ! in, snow emissivity + EmissivitySoilLake => noahmp%energy%param%EmissivitySoilLake ,& ! in, emissivity soil surface + EmissivityIceSfc => noahmp%energy%param%EmissivityIceSfc ,& ! in, emissivity ice surface + SnowCoverFrac => noahmp%water%state%SnowCoverFrac ,& ! in, snow cover fraction + LeafAreaIndEff => noahmp%energy%state%LeafAreaIndEff ,& ! in, leaf area index, after burying by snow + StemAreaIndEff => noahmp%energy%state%StemAreaIndEff ,& ! in, stem area index, after burying by snow + VegFrac => noahmp%energy%state%VegFrac ,& ! in, greeness vegetation fraction + EmissivityVeg => noahmp%energy%state%EmissivityVeg ,& ! out, vegetation emissivity + EmissivityGrd => noahmp%energy%state%EmissivityGrd ,& ! out, ground emissivity + EmissivitySfc => noahmp%energy%state%EmissivitySfc & ! out, surface emissivity + ) +! ---------------------------------------------------------------------- + + ! vegetation emissivity + EmissivityVeg = 1.0 - exp(-(LeafAreaIndEff + StemAreaIndEff) / 1.0) + + ! ground emissivity + if ( IndicatorIceSfc == 1 ) then + EmissivityGrd = EmissivityIceSfc * (1.0-SnowCoverFrac) + EmissivitySnow * SnowCoverFrac + else + EmissivityGrd = EmissivitySoilLake(SurfaceType) * (1.0-SnowCoverFrac) + EmissivitySnow * SnowCoverFrac + endif + + ! net surface emissivity + EmissivitySfc = VegFrac * (EmissivityGrd*(1-EmissivityVeg) + EmissivityVeg + & + EmissivityVeg*(1-EmissivityVeg)*(1-EmissivityGrd)) + (1-VegFrac) * EmissivityGrd + + end associate + + end subroutine SurfaceEmissivity + +end module SurfaceEmissivityMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SurfaceEnergyFluxBareGroundMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SurfaceEnergyFluxBareGroundMod.F90 new file mode 100644 index 0000000000..795af0443c --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SurfaceEnergyFluxBareGroundMod.F90 @@ -0,0 +1,227 @@ +module SurfaceEnergyFluxBareGroundMod + +!!! Compute surface energy fluxes and budget for bare ground +!!! Use newton-raphson iteration to solve for ground temperatures +!!! Surface energy balance (bare soil): +!!! Ground level: -RadSwAbsGrd - HeatPrecipAdvBareGrd + RadLwNetBareGrd + HeatSensibleBareGrd + HeatLatentBareGrd + HeatGroundBareGrd = 0 + + use Machine + use NoahmpVarType + use ConstantDefineMod + use VaporPressureSaturationMod, only : VaporPressureSaturation + use ResistanceBareGroundMostMod, only : ResistanceBareGroundMOST + use ResistanceBareGroundChen97Mod, only : ResistanceBareGroundChen97 + + implicit none + +contains + + subroutine SurfaceEnergyFluxBareGround(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: BARE_FLUX +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type) , intent(inout) :: noahmp + +! local variable + integer :: IndIter ! iteration index + integer :: MoStabParaSgn ! number of times MoStabParaBare changes sign + integer, parameter :: NumIter = 5 ! number of iterations for surface temperature + real(kind=kind_noahmp) :: TemperatureGrdChg ! change in ground temperature, last iteration [K] + real(kind=kind_noahmp) :: LwRadCoeff ! coefficients for LW radiation as function of ts**4 + real(kind=kind_noahmp) :: ShCoeff ! coefficients for sensible heat as function of ts + real(kind=kind_noahmp) :: LhCoeff ! coefficients for latent heat as function of ts + real(kind=kind_noahmp) :: GrdHeatCoeff ! coefficients for ground heat as function of ts + real(kind=kind_noahmp) :: ExchCoeffShTmp ! temporary sensible heat exchange coefficient [m/s] + real(kind=kind_noahmp) :: ExchCoeffMomTmp ! temporary momentum heat exchange coefficient [m/s] + real(kind=kind_noahmp) :: MoistureFluxSfc ! moisture flux + real(kind=kind_noahmp) :: VapPresSatWatTmp ! saturated vapor pressure for water [Pa] + real(kind=kind_noahmp) :: VapPresSatIceTmp ! saturated vapor pressure for ice [Pa] + real(kind=kind_noahmp) :: VapPresSatWatTmpD ! saturated vapor pressure gradient with ground temp. [Pa/K] for water + real(kind=kind_noahmp) :: VapPresSatIceTmpD ! saturated vapor pressure gradient with ground temp. [Pa/K] for ice + real(kind=kind_noahmp) :: FluxTotCoeff ! temporary total coefficients for all energy flux + real(kind=kind_noahmp) :: EnergyResTmp ! temporary energy residual + real(kind=kind_noahmp) :: HeatSensibleTmp ! temporary sensible heat flux [W/m2] + real(kind=kind_noahmp) :: TempTmp ! temporary temperature + real(kind=kind_noahmp) :: TempUnitConv ! Kelvin to degree Celsius with limit -50 to +50 +! local statement function + TempUnitConv(TempTmp) = min(50.0, max(-50.0, (TempTmp-ConstFreezePoint))) + +! -------------------------------------------------------------------- + associate( & + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg ,& ! in, actual number of snow layers (negative) + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! in, thickness of snow/soil layers [m] + FlagUrban => noahmp%config%domain%FlagUrban ,& ! in, logical flag for urban grid + OptSurfaceDrag => noahmp%config%nmlist%OptSurfaceDrag ,& ! in, options for surface layer drag/exchange coefficient + OptSnowSoilTempTime => noahmp%config%nmlist%OptSnowSoilTempTime ,& ! in, options for snow/soil temperature time scheme (only layer 1) + RadLwDownRefHeight => noahmp%forcing%RadLwDownRefHeight ,& ! in, downward longwave radiation [W/m2] at reference height + WindEastwardRefHeight => noahmp%forcing%WindEastwardRefHeight ,& ! in, wind speed [m/s] in eastward direction at reference height + WindNorthwardRefHeight => noahmp%forcing%WindNorthwardRefHeight ,& ! in, wind speed [m/s] in northward direction at reference height + TemperatureAirRefHeight => noahmp%forcing%TemperatureAirRefHeight ,& ! in, air temperature [K] at reference height + PressureAirRefHeight => noahmp%forcing%PressureAirRefHeight ,& ! in, air pressure [Pa] at surface reference height + ZilitinkevichCoeff => noahmp%energy%param%ZilitinkevichCoeff ,& ! in, Zilitinkevich Coefficient for exchange coefficient calculation + SnowDepth => noahmp%water%state%SnowDepth ,& ! in, snow depth [m] + SnowCoverFrac => noahmp%water%state%SnowCoverFrac ,& ! in, snow cover fraction + RadSwAbsGrd => noahmp%energy%flux%RadSwAbsGrd ,& ! in, solar radiation absorbed by ground [W/m2] + HeatPrecipAdvBareGrd => noahmp%energy%flux%HeatPrecipAdvBareGrd ,& ! in, precipitation advected heat - bare ground net [W/m2] + WindSpdRefHeight => noahmp%energy%state%WindSpdRefHeight ,& ! in, wind speed [m/s] at reference height + PressureVaporRefHeight => noahmp%energy%state%PressureVaporRefHeight ,& ! in, vapor pressure air [Pa] at reference height + SpecHumidityRefHeight => noahmp%forcing%SpecHumidityRefHeight ,& ! in, specific humidity [kg/kg] at reference height + DensityAirRefHeight => noahmp%energy%state%DensityAirRefHeight ,& ! in, density air [kg/m3] + RelHumidityGrd => noahmp%energy%state%RelHumidityGrd ,& ! in, raltive humidity in surface soil/snow air space + EmissivityGrd => noahmp%energy%state%EmissivityGrd ,& ! in, ground emissivity + TemperatureSoilSnow => noahmp%energy%state%TemperatureSoilSnow ,& ! in, snow and soil layer temperature [K] + ThermConductSoilSnow => noahmp%energy%state%ThermConductSoilSnow ,& ! in, thermal conductivity [W/m/K] for all soil & snow + ResistanceGrdEvap => noahmp%energy%state%ResistanceGrdEvap ,& ! in, ground surface resistance [s/m] to evaporation + RoughLenMomGrd => noahmp%energy%state%RoughLenMomGrd ,& ! in, roughness length, momentum, ground [m] + LatHeatVapGrd => noahmp%energy%state%LatHeatVapGrd ,& ! in, latent heat of vaporization/subli [J/kg], ground + PsychConstGrd => noahmp%energy%state%PsychConstGrd ,& ! in, psychrometric constant [Pa/K], ground + SpecHumiditySfc => noahmp%energy%state%SpecHumiditySfc ,& ! inout, specific humidity [kg/kg] at bare surface + TemperatureGrdBare => noahmp%energy%state%TemperatureGrdBare ,& ! inout, bare ground temperature (K) + ExchCoeffMomBare => noahmp%energy%state%ExchCoeffMomBare ,& ! inout, momentum exchange coeff [m/s)], above ZeroPlaneDisp, bare ground + ExchCoeffShBare => noahmp%energy%state%ExchCoeffShBare ,& ! inout, heat exchange coeff [m/s], above ZeroPlaneDisp, bare ground + WindStressEwBare => noahmp%energy%state%WindStressEwBare ,& ! out, wind stress: east-west [N/m2] bare ground + WindStressNsBare => noahmp%energy%state%WindStressNsBare ,& ! out, wind stress: north-south [N/m2] bare ground + TemperatureAir2mBare => noahmp%energy%state%TemperatureAir2mBare ,& ! out, 2 m height air temperature [K] bare ground + SpecHumidity2mBare => noahmp%energy%state%SpecHumidity2mBare ,& ! out, bare ground 2-m specific humidity [kg/kg] + ExchCoeffSh2mBare => noahmp%energy%state%ExchCoeffSh2mBare ,& ! out, bare ground 2-m sensible heat exchange coefficient [m/s] + FrictionVelBare => noahmp%energy%state%FrictionVelBare ,& ! out, friction velocity [m/s], vegetated + RoughLenShBareGrd => noahmp%energy%state%RoughLenShBareGrd ,& ! out, roughness length [m], sensible heat, bare ground + ResistanceLhBareGrd => noahmp%energy%state%ResistanceLhBareGrd ,& ! out, aerodynamic resistance for water vapor [s/m], bare ground + ResistanceShBareGrd => noahmp%energy%state%ResistanceShBareGrd ,& ! out, aerodynamic resistance for sensible heat [s/m], bare ground + ResistanceMomBareGrd => noahmp%energy%state%ResistanceMomBareGrd ,& ! out, aerodynamic resistance for momentum [s/m], bare ground + VapPresSatGrdBare => noahmp%energy%state%VapPresSatGrdBare ,& ! out, bare ground saturation vapor pressure [Pa] + VapPresSatGrdBareTempD => noahmp%energy%state%VapPresSatGrdBareTempD ,& ! out, bare ground d(VapPresSat)/dt [Pa/K] + MoStabParaBare => noahmp%energy%state%MoStabParaBare ,& ! out, Monin-Obukhov stability (z/L), above ZeroPlaneDisp, bare ground + MoStabCorrShBare2m => noahmp%energy%state%MoStabCorrShBare2m ,& ! out, M-O sen heat stability correction, 2m, bare ground + RadLwNetBareGrd => noahmp%energy%flux%RadLwNetBareGrd ,& ! out, net longwave rad [W/m2] bare ground (+ to atm) + HeatSensibleBareGrd => noahmp%energy%flux%HeatSensibleBareGrd ,& ! out, sensible heat flux [W/m2] bare ground (+ to atm) + HeatLatentBareGrd => noahmp%energy%flux%HeatLatentBareGrd ,& ! out, latent heat flux [W/m2] bare ground (+ to atm) + HeatGroundBareGrd => noahmp%energy%flux%HeatGroundBareGrd & ! out, bare ground heat flux [W/m2] (+ to soil/snow) + ) +! ---------------------------------------------------------------------- + + ! initialization (including variables that do not depend on stability iteration) + TemperatureGrdChg = 0.0 + MoStabParaBare = 0.0 + MoStabParaSgn = 0 + MoStabCorrShBare2m = 0.0 + MoistureFluxSfc = 0.0 + FrictionVelBare = 0.1 + HeatSensibleTmp = 0.0 + LwRadCoeff = EmissivityGrd * ConstStefanBoltzmann + GrdHeatCoeff = 2.0*ThermConductSoilSnow(NumSnowLayerNeg+1)/ThicknessSnowSoilLayer(NumSnowLayerNeg+1) + + ! begin stability iteration for ground temperature and flux + loop3: do IndIter = 1, NumIter + + ! ground roughness length + if ( IndIter == 1 ) then + RoughLenShBareGrd = RoughLenMomGrd + else + RoughLenShBareGrd = RoughLenMomGrd !* exp(-ZilitinkevichCoeff*0.4*258.2*sqrt(FrictionVelBare*RoughLenMomGrd)) + endif + + ! aerodyn resistances between reference heigths and d+z0v + if ( OptSurfaceDrag == 1 ) call ResistanceBareGroundMOST(noahmp, IndIter, HeatSensibleTmp, MoStabParaSgn) + if ( OptSurfaceDrag == 2 ) call ResistanceBareGroundChen97(noahmp, IndIter) + + ! conductance variables for diagnostics + ExchCoeffMomTmp = 1.0 / ResistanceMomBareGrd + ExchCoeffShTmp = 1.0 / ResistanceShBareGrd + + ! ES and d(ES)/dt evaluated at ground temperatue + TempTmp = TempUnitConv(TemperatureGrdBare) + call VaporPressureSaturation(TempTmp, VapPresSatWatTmp, VapPresSatIceTmp, VapPresSatWatTmpD, VapPresSatIceTmpD) + if ( TempTmp > 0.0 ) then + VapPresSatGrdBare = VapPresSatWatTmp + VapPresSatGrdBareTempD = VapPresSatWatTmpD + else + VapPresSatGrdBare = VapPresSatIceTmp + VapPresSatGrdBareTempD = VapPresSatIceTmpD + endif + + ! ground fluxes and temperature change + ShCoeff = DensityAirRefHeight * ConstHeatCapacAir / ResistanceShBareGrd + LhCoeff = DensityAirRefHeight * ConstHeatCapacAir / PsychConstGrd / (ResistanceGrdEvap+ResistanceLhBareGrd) + RadLwNetBareGrd = LwRadCoeff * TemperatureGrdBare**4 - EmissivityGrd * RadLwDownRefHeight + HeatSensibleBareGrd = ShCoeff * (TemperatureGrdBare - TemperatureAirRefHeight) + HeatLatentBareGrd = LhCoeff * (VapPresSatGrdBare*RelHumidityGrd - PressureVaporRefHeight) + HeatGroundBareGrd = GrdHeatCoeff * (TemperatureGrdBare - TemperatureSoilSnow(NumSnowLayerNeg+1)) + EnergyResTmp = RadSwAbsGrd - RadLwNetBareGrd - HeatSensibleBareGrd - HeatLatentBareGrd - & + HeatGroundBareGrd + HeatPrecipAdvBareGrd + FluxTotCoeff = 4.0*LwRadCoeff*TemperatureGrdBare**3 + ShCoeff + LhCoeff*VapPresSatGrdBareTempD + GrdHeatCoeff + TemperatureGrdChg = EnergyResTmp / FluxTotCoeff + RadLwNetBareGrd = RadLwNetBareGrd + 4.0 * LwRadCoeff * TemperatureGrdBare**3 * TemperatureGrdChg + HeatSensibleBareGrd = HeatSensibleBareGrd + ShCoeff * TemperatureGrdChg + HeatLatentBareGrd = HeatLatentBareGrd + LhCoeff * VapPresSatGrdBareTempD * TemperatureGrdChg + HeatGroundBareGrd = HeatGroundBareGrd + GrdHeatCoeff * TemperatureGrdChg + TemperatureGrdBare = TemperatureGrdBare + TemperatureGrdChg + + ! for computing M-O length + HeatSensibleTmp = ShCoeff * (TemperatureGrdBare - TemperatureAirRefHeight) + + ! update specific humidity + TempTmp = TempUnitConv(TemperatureGrdBare) + call VaporPressureSaturation(TempTmp, VapPresSatWatTmp, VapPresSatIceTmp, VapPresSatWatTmpD, VapPresSatIceTmpD) + if ( TempTmp > 0.0 ) then + VapPresSatGrdBare = VapPresSatWatTmp + else + VapPresSatGrdBare = VapPresSatIceTmp + endif + SpecHumiditySfc = 0.622 * (VapPresSatGrdBare*RelHumidityGrd) / & + (PressureAirRefHeight - 0.378 * (VapPresSatGrdBare*RelHumidityGrd)) + MoistureFluxSfc = (SpecHumiditySfc - SpecHumidityRefHeight) * LhCoeff * PsychConstGrd / ConstHeatCapacAir + + enddo loop3 ! end stability iteration + + ! if snow on ground and TemperatureGrdBare > freezing point: reset TemperatureGrdBare = freezing point. reevaluate ground fluxes. + if ( (OptSnowSoilTempTime == 1) .or. (OptSnowSoilTempTime == 3) ) then + if ( (SnowDepth > 0.05) .and. (TemperatureGrdBare > ConstFreezePoint) ) then + if ( OptSnowSoilTempTime == 1 ) & + TemperatureGrdBare = ConstFreezePoint + if ( OptSnowSoilTempTime == 3 ) & + TemperatureGrdBare = (1.0-SnowCoverFrac) * TemperatureGrdBare + SnowCoverFrac * ConstFreezePoint ! MB: allow TemperatureGrd>0C during melt v3.7 + + RadLwNetBareGrd = LwRadCoeff * TemperatureGrdBare**4 - EmissivityGrd * RadLwDownRefHeight + HeatSensibleBareGrd = ShCoeff * (TemperatureGrdBare - TemperatureAirRefHeight) + HeatLatentBareGrd = LhCoeff * (VapPresSatGrdBare*RelHumidityGrd - PressureVaporRefHeight) + HeatGroundBareGrd = RadSwAbsGrd + HeatPrecipAdvBareGrd - & + (RadLwNetBareGrd + HeatSensibleBareGrd + HeatLatentBareGrd) + endif + endif + + ! wind stresses + WindStressEwBare = -DensityAirRefHeight * ExchCoeffMomBare * WindSpdRefHeight * WindEastwardRefHeight + WindStressNsBare = -DensityAirRefHeight * ExchCoeffMomBare * WindSpdRefHeight * WindNorthwardRefHeight + + ! 2m air temperature + if ( (OptSurfaceDrag == 1) .or. (OptSurfaceDrag == 2) ) then + !ExchCoeffSh2mBare = FrictionVelBare * ConstVonKarman / log((2.0+RoughLenShBareGrd)/RoughLenShBareGrd) + ExchCoeffSh2mBare = FrictionVelBare * ConstVonKarman / & + (log((2.0+RoughLenShBareGrd)/RoughLenShBareGrd) - MoStabCorrShBare2m) + if ( ExchCoeffSh2mBare < 1.0e-5 ) then + TemperatureAir2mBare = TemperatureGrdBare + SpecHumidity2mBare = SpecHumiditySfc + else + TemperatureAir2mBare = TemperatureGrdBare - HeatSensibleBareGrd / & + (DensityAirRefHeight*ConstHeatCapacAir) * 1.0 / ExchCoeffSh2mBare + SpecHumidity2mBare = SpecHumiditySfc - HeatLatentBareGrd / & + (LatHeatVapGrd*DensityAirRefHeight) * (1.0/ExchCoeffSh2mBare + ResistanceGrdEvap) + endif + if ( FlagUrban .eqv. .true. ) SpecHumidity2mBare = SpecHumiditySfc + endif + + ! update ExchCoeffShBare + ExchCoeffShBare = ExchCoeffShTmp + + end associate + + end subroutine SurfaceEnergyFluxBareGround + +end module SurfaceEnergyFluxBareGroundMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SurfaceEnergyFluxGlacierMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SurfaceEnergyFluxGlacierMod.F90 new file mode 100644 index 0000000000..96dfd84a58 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SurfaceEnergyFluxGlacierMod.F90 @@ -0,0 +1,231 @@ +module SurfaceEnergyFluxGlacierMod + +!!! Compute surface energy fluxes and budget for bare ground (glacier) +!!! Use newton-raphson iteration to solve for ground temperatures +!!! Surface energy balance (bare soil): +!!! Ground level: -RadSwAbsGrd - HeatPrecipAdvBareGrd + RadLwNetBareGrd + HeatSensibleBareGrd + HeatLatentBareGrd + HeatGroundBareGrd = 0 + + use Machine + use NoahmpVarType + use ConstantDefineMod + use VaporPressureSaturationMod, only : VaporPressureSaturation + use ResistanceBareGroundMostMod, only : ResistanceBareGroundMOST + + implicit none + +contains + + subroutine SurfaceEnergyFluxGlacier(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: GLACIER_FLUX +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type) , intent(inout) :: noahmp + +! local variables + integer :: IndIter ! iteration index + integer :: MoStabParaSgn ! number of times MoStabParaBare changes sign + integer, parameter :: NumIter = 5 ! number of iterations for surface temperature + real(kind=kind_noahmp) :: TemperatureGrdChg ! change in ground temperature [K], last iteration + real(kind=kind_noahmp) :: LwRadCoeff ! coefficients for longwave radiation as function of ts**4 + real(kind=kind_noahmp) :: ShCoeff ! coefficients for sensible heat as function of ts + real(kind=kind_noahmp) :: LhCoeff ! coefficients for latent heat as function of ts + real(kind=kind_noahmp) :: GrdHeatCoeff ! coefficients for st as function of ts + real(kind=kind_noahmp) :: ExchCoeffShTmp ! temporary sensible heat exchange coefficient [m/s] + real(kind=kind_noahmp) :: ExchCoeffMomTmp ! temporary momentum heat exchange coefficient [m/s] + real(kind=kind_noahmp) :: MoistureFluxSfc ! moisture flux + real(kind=kind_noahmp) :: VapPresSatWatTmp ! saturated vapor pressure for water + real(kind=kind_noahmp) :: VapPresSatIceTmp ! saturated vapor pressure for ice + real(kind=kind_noahmp) :: VapPresSatWatTmpD ! saturated vapor pressure gradient with ground temp. [Pa/K] for water + real(kind=kind_noahmp) :: VapPresSatIceTmpD ! saturated vapor pressure gradient with ground temp. [Pa/K] for ice + real(kind=kind_noahmp) :: FluxTotCoeff ! temporary total coefficients for all energy flux + real(kind=kind_noahmp) :: EnergyResTmp ! temporary energy residual + real(kind=kind_noahmp) :: HeatSensibleTmp ! temporary sensible heat flux [W/m2] + real(kind=kind_noahmp) :: TempTmp ! temporary temperature + real(kind=kind_noahmp) :: TempUnitConv ! Kelvin to degree Celsius with limit -50 to +50 + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilIceTmp ! temporary glacier ice content [m3/m3] +! local statement function + TempUnitConv(TempTmp) = min(50.0, max(-50.0, (TempTmp-ConstFreezePoint))) + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of glacier/soil layers + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg ,& ! in, actual number of snow layers (negative) + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! in, thickness of snow/soil layers [m] + OptSnowSoilTempTime => noahmp%config%nmlist%OptSnowSoilTempTime ,& ! in, options for snow/soil temperature time scheme (only layer 1) + OptGlacierTreatment => noahmp%config%nmlist%OptGlacierTreatment ,& ! in, options for glacier treatment + RadLwDownRefHeight => noahmp%forcing%RadLwDownRefHeight ,& ! in, downward longwave radiation [W/m2] at reference height + WindEastwardRefHeight => noahmp%forcing%WindEastwardRefHeight ,& ! in, wind speed [m/s] in eastward direction at reference height + WindNorthwardRefHeight => noahmp%forcing%WindNorthwardRefHeight ,& ! in, wind speed [m/s] in northward direction at reference height + TemperatureAirRefHeight => noahmp%forcing%TemperatureAirRefHeight ,& ! in, air temperature [K] at reference height + PressureAirRefHeight => noahmp%forcing%PressureAirRefHeight ,& ! in, air pressure [Pa] at reference height + SnowDepth => noahmp%water%state%SnowDepth ,& ! in, snow depth [m] + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! in, total glacier/soil water content [m3/m3] + SoilLiqWater => noahmp%water%state%SoilLiqWater ,& ! in, glacier/soil water content [m3/m3] + RadSwAbsGrd => noahmp%energy%flux%RadSwAbsGrd ,& ! in, solar radiation absorbed by ground [W/m2] + HeatPrecipAdvBareGrd => noahmp%energy%flux%HeatPrecipAdvBareGrd ,& ! in, precipitation advected heat - bare ground net [W/m2] + WindSpdRefHeight => noahmp%energy%state%WindSpdRefHeight ,& ! in, wind speed [m/s] at reference height + PressureVaporRefHeight => noahmp%energy%state%PressureVaporRefHeight ,& ! in, vapor pressure air [Pa] at reference height + SpecHumidityRefHeight => noahmp%forcing%SpecHumidityRefHeight ,& ! in, specific humidity [kg/kg] at reference height + DensityAirRefHeight => noahmp%energy%state%DensityAirRefHeight ,& ! in, density air [kg/m3] + RelHumidityGrd => noahmp%energy%state%RelHumidityGrd ,& ! in, raltive humidity in surface soil/snow air space + EmissivityGrd => noahmp%energy%state%EmissivityGrd ,& ! in, ground emissivity + TemperatureSoilSnow => noahmp%energy%state%TemperatureSoilSnow ,& ! in, snow and soil layer temperature [K] + ThermConductSoilSnow => noahmp%energy%state%ThermConductSoilSnow ,& ! in, thermal conductivity [W/m/K] for all soil & snow + ResistanceGrdEvap => noahmp%energy%state%ResistanceGrdEvap ,& ! in, ground surface resistance [s/m] to evaporation + RoughLenMomGrd => noahmp%energy%state%RoughLenMomGrd ,& ! in, roughness length, momentum, ground [m] + LatHeatVapGrd => noahmp%energy%state%LatHeatVapGrd ,& ! in, latent heat of vaporization/subli [J/kg], ground + PsychConstGrd => noahmp%energy%state%PsychConstGrd ,& ! in, psychrometric constant [Pa/K], ground + SpecHumiditySfc => noahmp%energy%state%SpecHumiditySfc ,& ! inout, specific humidity at surface + TemperatureGrdBare => noahmp%energy%state%TemperatureGrdBare ,& ! inout, bare ground temperature [K] + ExchCoeffMomBare => noahmp%energy%state%ExchCoeffMomBare ,& ! inout, momentum exchange coeff [m/s], above ZeroPlaneDisp, bare ground + ExchCoeffShBare => noahmp%energy%state%ExchCoeffShBare ,& ! inout, heat exchange coeff [m/s], above ZeroPlaneDisp, bare ground + WindStressEwBare => noahmp%energy%state%WindStressEwBare ,& ! out, wind stress: east-west [N/m2] bare ground + WindStressNsBare => noahmp%energy%state%WindStressNsBare ,& ! out, wind stress: north-south [N/m2] bare ground + TemperatureAir2mBare => noahmp%energy%state%TemperatureAir2mBare ,& ! out, 2 m height air temperature [K] bare ground + SpecHumidity2mBare => noahmp%energy%state%SpecHumidity2mBare ,& ! out, bare ground 2-m specific humidity [kg/kg] + ExchCoeffSh2mBare => noahmp%energy%state%ExchCoeffSh2mBare ,& ! out, bare ground 2-m sensible heat exchange coefficient [m/s] + FrictionVelBare => noahmp%energy%state%FrictionVelBare ,& ! out, friction velocity [m/s], vegetated + RoughLenShBareGrd => noahmp%energy%state%RoughLenShBareGrd ,& ! out, roughness length [m], sensible heat, bare ground + ResistanceLhBareGrd => noahmp%energy%state%ResistanceLhBareGrd ,& ! out, aerodynamic resistance for water vapor [s/m], bare ground + ResistanceShBareGrd => noahmp%energy%state%ResistanceShBareGrd ,& ! out, aerodynamic resistance for sensible heat [s/m], bare ground + ResistanceMomBareGrd => noahmp%energy%state%ResistanceMomBareGrd ,& ! out, aerodynamic resistance for momentum [s/m], bare ground + VapPresSatGrdBare => noahmp%energy%state%VapPresSatGrdBare ,& ! out, bare ground saturation vapor pressure at TemperatureGrd [Pa] + VapPresSatGrdBareTempD => noahmp%energy%state%VapPresSatGrdBareTempD ,& ! out, bare ground d(VapPresSatGrdBare)/dt at TemperatureGrd [Pa/K] + MoStabParaBare => noahmp%energy%state%MoStabParaBare ,& ! out, Monin-Obukhov stability (z/L), above ZeroPlaneDisp, bare ground + MoStabCorrShBare2m => noahmp%energy%state%MoStabCorrShBare2m ,& ! out, M-O sen heat stability correction, 2m, bare ground + RadLwNetBareGrd => noahmp%energy%flux%RadLwNetBareGrd ,& ! out, net longwave rad [W/m2] bare ground (+ to atm) + HeatSensibleBareGrd => noahmp%energy%flux%HeatSensibleBareGrd ,& ! out, sensible heat flux [W/m2] bare ground (+ to atm) + HeatLatentBareGrd => noahmp%energy%flux%HeatLatentBareGrd ,& ! out, latent heat flux [W/m2] bare ground (+ to atm) + HeatGroundBareGrd => noahmp%energy%flux%HeatGroundBareGrd & ! out, bare ground heat flux [W/m2] (+ to soil/snow) + ) +! ---------------------------------------------------------------------- + + ! initialization (including variables that do not depend on stability iteration) + if (.not. allocated(SoilIceTmp)) allocate(SoilIceTmp(1:NumSoilLayer)) + SoilIceTmp = 0.0 + TemperatureGrdChg = 0.0 + MoStabParaBare = 0.0 + MoStabParaSgn = 0 + MoStabCorrShBare2m = 0.0 + HeatSensibleTmp = 0.0 + MoistureFluxSfc = 0.0 + FrictionVelBare = 0.1 + LwRadCoeff = EmissivityGrd * ConstStefanBoltzmann + GrdHeatCoeff = 2.0*ThermConductSoilSnow(NumSnowLayerNeg+1)/ThicknessSnowSoilLayer(NumSnowLayerNeg+1) + + ! begin stability iteration for ground temperature and flux + loop3: do IndIter = 1, NumIter + + ! ground roughness length + RoughLenShBareGrd = RoughLenMomGrd + + ! aerodyn resistances between heights reference height and d+z0v + call ResistanceBareGroundMOST(noahmp, IndIter, HeatSensibleTmp, MoStabParaSgn) + + ! conductance variables for diagnostics + ExchCoeffMomTmp = 1.0 / ResistanceMomBareGrd + ExchCoeffShTmp = 1.0 / ResistanceShBareGrd + + ! ES and d(ES)/dt evaluated at TemperatureGrd + TempTmp = TempUnitConv(TemperatureGrdBare) + call VaporPressureSaturation(TempTmp, VapPresSatWatTmp, VapPresSatIceTmp, VapPresSatWatTmpD, VapPresSatIceTmpD) + if ( TempTmp > 0.0 ) then + VapPresSatGrdBare = VapPresSatWatTmp + VapPresSatGrdBareTempD = VapPresSatWatTmpD + else + VapPresSatGrdBare = VapPresSatIceTmp + VapPresSatGrdBareTempD = VapPresSatIceTmpD + endif + + ! ground fluxes and temperature change + ShCoeff = DensityAirRefHeight * ConstHeatCapacAir / ResistanceShBareGrd + if ( (SnowDepth > 0.0) .or. (OptGlacierTreatment == 1) ) then + LhCoeff = DensityAirRefHeight * ConstHeatCapacAir / PsychConstGrd / (ResistanceGrdEvap+ResistanceLhBareGrd) + else + LhCoeff = 0.0 ! don't allow any sublimation of glacier in OptGlacierTreatment=2 + endif + RadLwNetBareGrd = LwRadCoeff * TemperatureGrdBare**4 - EmissivityGrd * RadLwDownRefHeight + HeatSensibleBareGrd = ShCoeff * (TemperatureGrdBare - TemperatureAirRefHeight) + HeatLatentBareGrd = LhCoeff * (VapPresSatGrdBare*RelHumidityGrd - PressureVaporRefHeight) + HeatGroundBareGrd = GrdHeatCoeff * (TemperatureGrdBare - TemperatureSoilSnow(NumSnowLayerNeg+1)) + EnergyResTmp = RadSwAbsGrd - RadLwNetBareGrd - HeatSensibleBareGrd - & + HeatLatentBareGrd - HeatGroundBareGrd + HeatPrecipAdvBareGrd + FluxTotCoeff = 4.0*LwRadCoeff*TemperatureGrdBare**3 + ShCoeff + LhCoeff*VapPresSatGrdBareTempD + GrdHeatCoeff + TemperatureGrdChg = EnergyResTmp / FluxTotCoeff + RadLwNetBareGrd = RadLwNetBareGrd + 4.0 * LwRadCoeff * TemperatureGrdBare**3 * TemperatureGrdChg + HeatSensibleBareGrd = HeatSensibleBareGrd + ShCoeff * TemperatureGrdChg + HeatLatentBareGrd = HeatLatentBareGrd + LhCoeff * VapPresSatGrdBareTempD * TemperatureGrdChg + HeatGroundBareGrd = HeatGroundBareGrd + GrdHeatCoeff * TemperatureGrdChg + TemperatureGrdBare = TemperatureGrdBare + TemperatureGrdChg ! update ground temperature + + ! for computing M-O length + HeatSensibleTmp = ShCoeff * (TemperatureGrdBare - TemperatureAirRefHeight) + + ! update specific humidity + TempTmp = TempUnitConv(TemperatureGrdBare) + call VaporPressureSaturation(TempTmp, VapPresSatWatTmp, VapPresSatIceTmp, VapPresSatWatTmpD, VapPresSatIceTmpD) + if ( TempTmp > 0.0 ) then + VapPresSatGrdBare = VapPresSatWatTmp + else + VapPresSatGrdBare = VapPresSatIceTmp + endif + SpecHumiditySfc = 0.622 * (VapPresSatGrdBare*RelHumidityGrd) / & + (PressureAirRefHeight - 0.378 * (VapPresSatGrdBare*RelHumidityGrd)) + MoistureFluxSfc = (SpecHumiditySfc - SpecHumidityRefHeight) * LhCoeff * PsychConstGrd / ConstHeatCapacAir + + enddo loop3 ! end stability iteration + + ! if snow on ground and TemperatureGrdBare > freezing point: reset TemperatureGrdBare = freezing point. reevaluate ground fluxes. + SoilIceTmp = SoilMoisture - SoilLiqWater + if ( (OptSnowSoilTempTime == 1) .or. (OptSnowSoilTempTime == 3) ) then + if ( (maxval(SoilIceTmp) > 0.0 .or. SnowDepth > 0.05) .and. & + (TemperatureGrdBare > ConstFreezePoint) .and. (OptGlacierTreatment == 1) ) then + TemperatureGrdBare = ConstFreezePoint + TempTmp = TempUnitConv(TemperatureGrdBare) ! MB: recalculate VapPresSatGrdBare + call VaporPressureSaturation(TempTmp, VapPresSatWatTmp, VapPresSatIceTmp, VapPresSatWatTmpD, VapPresSatIceTmpD) + VapPresSatGrdBare = VapPresSatIceTmp + SpecHumiditySfc = 0.622 * (VapPresSatGrdBare*RelHumidityGrd) / & + (PressureAirRefHeight - 0.378 * (VapPresSatGrdBare*RelHumidityGrd)) + MoistureFluxSfc = (SpecHumiditySfc - SpecHumidityRefHeight) * LhCoeff * PsychConstGrd / ConstHeatCapacAir + RadLwNetBareGrd = LwRadCoeff * TemperatureGrdBare**4 - EmissivityGrd * RadLwDownRefHeight + HeatSensibleBareGrd = ShCoeff * (TemperatureGrdBare - TemperatureAirRefHeight) + HeatLatentBareGrd = LhCoeff * (VapPresSatGrdBare*RelHumidityGrd - PressureVaporRefHeight) + HeatGroundBareGrd = RadSwAbsGrd + HeatPrecipAdvBareGrd - & + (RadLwNetBareGrd + HeatSensibleBareGrd + HeatLatentBareGrd) + endif + endif + + ! wind stresses + WindStressEwBare = -DensityAirRefHeight * ExchCoeffMomBare * WindSpdRefHeight * WindEastwardRefHeight + WindStressNsBare = -DensityAirRefHeight * ExchCoeffMomBare * WindSpdRefHeight * WindNorthwardRefHeight + + ! 2m air temperature + ExchCoeffSh2mBare = FrictionVelBare * ConstVonKarman / & + (log((2.0+RoughLenShBareGrd)/RoughLenShBareGrd) - MoStabCorrShBare2m) + if ( ExchCoeffSh2mBare < 1.0e-5 ) then + TemperatureAir2mBare = TemperatureGrdBare + SpecHumidity2mBare = SpecHumiditySfc + else + TemperatureAir2mBare = TemperatureGrdBare - HeatSensibleBareGrd / & + (DensityAirRefHeight*ConstHeatCapacAir) * 1.0 / ExchCoeffSh2mBare + SpecHumidity2mBare = SpecHumiditySfc - HeatLatentBareGrd / & + (LatHeatVapGrd*DensityAirRefHeight) * (1.0/ExchCoeffSh2mBare + ResistanceGrdEvap) + endif + + ! update ExchCoeffShBare + ExchCoeffShBare = ExchCoeffShTmp + + ! deallocate local arrays to avoid memory leaks + deallocate(SoilIceTmp) + + end associate + + end subroutine SurfaceEnergyFluxGlacier + +end module SurfaceEnergyFluxGlacierMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SurfaceEnergyFluxVegetatedMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SurfaceEnergyFluxVegetatedMod.F90 new file mode 100644 index 0000000000..1283553adc --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SurfaceEnergyFluxVegetatedMod.F90 @@ -0,0 +1,428 @@ +module SurfaceEnergyFluxVegetatedMod + +!!! Compute surface energy fluxes and budget for vegetated surface +!!! Use newton-raphson iteration to solve for vegetation and ground temperatures +!!! Surface energy balance: +!!! Canopy level: -RadSwAbsVeg - HeatPrecipAdvCanopy + RadLwNetCanopy + HeatSensibleCanopy + HeatLatentCanEvap + HeatLatentCanTransp + HeatCanStorageChg = 0 +!!! Ground level: -RadSwAbsGrd - HeatPrecipAdvVegGrd + RadLwNetVegGrd + HeatSensibleVegGrd + HeatLatentVegGrd + HeatGroundVegGrd = 0 + + use Machine + use NoahmpVarType + use ConstantDefineMod + use VaporPressureSaturationMod, only : VaporPressureSaturation + use ResistanceAboveCanopyMostMod, only : ResistanceAboveCanopyMOST + use ResistanceAboveCanopyChen97Mod, only : ResistanceAboveCanopyChen97 + use ResistanceLeafToGroundMod, only : ResistanceLeafToGround + use ResistanceCanopyStomataBallBerryMod, only : ResistanceCanopyStomataBallBerry + use ResistanceCanopyStomataJarvisMod, only : ResistanceCanopyStomataJarvis + + implicit none + +contains + + subroutine SurfaceEnergyFluxVegetated(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: VEGE_FLUX +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type) , intent(inout) :: noahmp + +! local variable + integer :: IndIter ! iteration index + integer :: LastIter ! Last iteration + integer :: MoStabParaSgn ! number of times MoStabParaAbvCan changes sign + integer :: IndexShade ! index for sunlit/shaded (0=sunlit;1=shaded) + integer, parameter :: NumIterC = 20 ! number of iterations for surface temperature (5~20) + integer, parameter :: NumIterG = 5 ! number of iterations for ground temperature (3~5) + real(kind=kind_noahmp) :: ExchCoeffShAbvCanTmp ! sensible heat conductance, canopy air to reference height air [m/s] + real(kind=kind_noahmp) :: TemperatureCanChg ! change in tv, last iteration [K] + real(kind=kind_noahmp) :: TemperatureGrdChg ! change in tg, last iteration [K] + real(kind=kind_noahmp) :: LwCoeffAir ! coefficients for longwave emission as function of ts**4 + real(kind=kind_noahmp) :: LwCoeffCan ! coefficients for longwave emission as function of ts**4 + real(kind=kind_noahmp) :: ShCoeff ! coefficients for sensible heat as function of ts + real(kind=kind_noahmp) :: LhCoeff ! coefficients for latent heat as function of ts + real(kind=kind_noahmp) :: GrdHeatCoeff ! coefficients for ground heat as function of ts + real(kind=kind_noahmp) :: TranspHeatCoeff ! coefficients for transpiration heat as function of ts + real(kind=kind_noahmp) :: TempShGhTmp ! partial temperature by sensible and ground heat + real(kind=kind_noahmp) :: ExchCoeffShFrac ! exchange coefficient fraction for sensible heat + real(kind=kind_noahmp) :: VapPresLhTot ! vapor pressure related to total latent heat + real(kind=kind_noahmp) :: ExchCoeffEtFrac ! exchange coefficient fraction for evapotranspiration heat + real(kind=kind_noahmp) :: VapPresSatWatTmp ! saturated vapor pressure for water + real(kind=kind_noahmp) :: VapPresSatIceTmp ! saturated vapor pressure for ice + real(kind=kind_noahmp) :: VapPresSatWatTmpD ! saturated vapor pressure gradient with ground temp. [Pa/K] for water + real(kind=kind_noahmp) :: VapPresSatIceTmpD ! saturated vapor pressure gradient with ground temp. [Pa/K] for ice + real(kind=kind_noahmp) :: FluxTotCoeff ! temporary total coefficients for all energy flux + real(kind=kind_noahmp) :: EnergyResTmp ! temporary energy residual + real(kind=kind_noahmp) :: ExchCoeffShLeafTmp ! sensible heat conductance, leaf surface to canopy air [m/s] + real(kind=kind_noahmp) :: ExchCoeffTot ! sum of conductances [m/s] + real(kind=kind_noahmp) :: ShCanTmp ! temporary sensible heat flux [W/m2] + real(kind=kind_noahmp) :: ShGrdTmp ! temporary sensible heat flux [W/m2] + real(kind=kind_noahmp) :: MoistureFluxSfc ! moisture flux + real(kind=kind_noahmp) :: VegAreaIndTmp ! total leaf area index + stem area index,effective + real(kind=kind_noahmp) :: LeafAreaIndSunEff ! sunlit leaf area index, one-sided [m2/m2],effective + real(kind=kind_noahmp) :: LeafAreaIndShdEff ! shaded leaf area index, one-sided [m2/m2],effective + real(kind=kind_noahmp) :: TempTmp ! temporary temperature + real(kind=kind_noahmp) :: TempUnitConv ! Kelvin to degree Celsius with limit -50 to +50 + real(kind=kind_noahmp) :: HeatCapacCan ! canopy heat capacity [J/m2/K] +! local statement function + TempUnitConv(TempTmp) = min(50.0, max(-50.0, (TempTmp - ConstFreezePoint))) + +! -------------------------------------------------------------------- + associate( & + MainTimeStep => noahmp%config%domain%MainTimeStep ,& ! in, main noahmp timestep [s] + GridIndexI => noahmp%config%domain%GridIndexI ,& ! in, grid index in x-direction + GridIndexJ => noahmp%config%domain%GridIndexJ ,& ! in, grid index in y-direction + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg ,& ! in, actual number of snow layers (negative) + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! in, thickness of snow/soil layers [m] + OptSurfaceDrag => noahmp%config%nmlist%OptSurfaceDrag ,& ! in, options for surface layer drag/exchange coefficient + OptStomataResistance => noahmp%config%nmlist%OptStomataResistance ,& ! in, options for canopy stomatal resistance + OptSnowSoilTempTime => noahmp%config%nmlist%OptSnowSoilTempTime ,& ! in, options for snow/soil temperature time scheme (only layer 1) + WindEastwardRefHeight => noahmp%forcing%WindEastwardRefHeight ,& ! in, wind speed [m/s] in eastward direction at reference height + WindNorthwardRefHeight => noahmp%forcing%WindNorthwardRefHeight ,& ! in, wind speed [m/s] in northward direction at reference height + RadLwDownRefHeight => noahmp%forcing%RadLwDownRefHeight ,& ! in, downward longwave radiation [W/m2] at reference height + TemperatureAirRefHeight => noahmp%forcing%TemperatureAirRefHeight ,& ! in, air temperature [K] at reference height + PressureAirRefHeight => noahmp%forcing%PressureAirRefHeight ,& ! in, air pressure [Pa] at reference height + PressureAirSurface => noahmp%forcing%PressureAirSurface ,& ! in, air pressure [Pa] at surface-atmos interface + SnowDepth => noahmp%water%state%SnowDepth ,& ! in, snow depth [m] + SnowCoverFrac => noahmp%water%state%SnowCoverFrac ,& ! in, snow cover fraction + CanopyWetFrac => noahmp%water%state%CanopyWetFrac ,& ! in, wetted or snowed fraction of the canopy + CanopyLiqWater => noahmp%water%state%CanopyLiqWater ,& ! in, canopy intercepted liquid water [mm] + CanopyIce => noahmp%water%state%CanopyIce ,& ! in, canopy intercepted ice [mm] + HeightCanopyTop => noahmp%energy%param%HeightCanopyTop ,& ! in, top of canopy [m] + ZilitinkevichCoeff => noahmp%energy%param%ZilitinkevichCoeff ,& ! in, Zilitinkevich Coefficient for exchange coefficient calculation + HeatCapacCanFac => noahmp%energy%param%HeatCapacCanFac ,& ! in, canopy biomass heat capacity parameter [m] + RadSwAbsVeg => noahmp%energy%flux%RadSwAbsVeg ,& ! in, solar radiation absorbed by vegetation [W/m2] + RadSwAbsGrd => noahmp%energy%flux%RadSwAbsGrd ,& ! in, solar radiation absorbed by ground [W/m2] + HeatPrecipAdvCanopy => noahmp%energy%flux%HeatPrecipAdvCanopy ,& ! in, precipitation advected heat - vegetation net [W/m2] + HeatPrecipAdvVegGrd => noahmp%energy%flux%HeatPrecipAdvVegGrd ,& ! in, precipitation advected heat - under canopy net [W/m2] + RefHeightAboveGrd => noahmp%energy%state%RefHeightAboveGrd ,& ! in, surface reference height [m] + VegFrac => noahmp%energy%state%VegFrac ,& ! in, greeness vegetation fraction + WindSpdRefHeight => noahmp%energy%state%WindSpdRefHeight ,& ! in, wind speed [m/s] at reference height + PressureVaporRefHeight => noahmp%energy%state%PressureVaporRefHeight ,& ! in, vapor pressure air [Pa] at reference height + SpecHumidityRefHeight => noahmp%forcing%SpecHumidityRefHeight ,& ! in, specific humidity [kg/kg] at reference height + DensityAirRefHeight => noahmp%energy%state%DensityAirRefHeight ,& ! in, density air [kg/m3] + VegAreaIndEff => noahmp%energy%state%VegAreaIndEff ,& ! in, one-sided leaf+stem area index [m2/m2] + LeafAreaIndSunlit => noahmp%energy%state%LeafAreaIndSunlit ,& ! in, sunlit leaf area index, one-sided [m2/m2] + LeafAreaIndShade => noahmp%energy%state%LeafAreaIndShade ,& ! in, shaded leaf area index, one-sided [m2/m2] + ZeroPlaneDispSfc => noahmp%energy%state%ZeroPlaneDispSfc ,& ! in, zero plane displacement [m] + RoughLenMomSfc => noahmp%energy%state%RoughLenMomSfc ,& ! in, roughness length [m], momentum, surface + RoughLenMomGrd => noahmp%energy%state%RoughLenMomGrd ,& ! in, roughness length [m], momentum, ground + EmissivityVeg => noahmp%energy%state%EmissivityVeg ,& ! in, vegetation emissivity + EmissivityGrd => noahmp%energy%state%EmissivityGrd ,& ! in, ground emissivity + TemperatureSoilSnow => noahmp%energy%state%TemperatureSoilSnow ,& ! in, snow and soil layer temperature [K] + ThermConductSoilSnow => noahmp%energy%state%ThermConductSoilSnow ,& ! in, thermal conductivity [W/m/K] for all soil & snow + ResistanceGrdEvap => noahmp%energy%state%ResistanceGrdEvap ,& ! in, ground surface resistance [s/m] to evaporation + PsychConstCanopy => noahmp%energy%state%PsychConstCanopy ,& ! in, psychrometric constant [Pa/K], canopy + LatHeatVapCanopy => noahmp%energy%state%LatHeatVapCanopy ,& ! in, latent heat of vaporization/subli [J/kg], canopy + PsychConstGrd => noahmp%energy%state%PsychConstGrd ,& ! in, psychrometric constant [Pa/K], ground + RelHumidityGrd => noahmp%energy%state%RelHumidityGrd ,& ! in, raltive humidity in surface soil/snow air space + SpecHumiditySfc => noahmp%energy%state%SpecHumiditySfc ,& ! inout, specific humidity at vegetated surface + PressureVaporCanAir => noahmp%energy%state%PressureVaporCanAir ,& ! inout, canopy air vapor pressure [Pa] + TemperatureCanopyAir => noahmp%energy%state%TemperatureCanopyAir ,& ! inout, canopy air temperature [K] + TemperatureCanopy => noahmp%energy%state%TemperatureCanopy ,& ! inout, vegetation temperature [K] + TemperatureGrdVeg => noahmp%energy%state%TemperatureGrdVeg ,& ! inout, vegetated ground (below-canopy) temperature [K] + ExchCoeffMomAbvCan => noahmp%energy%state%ExchCoeffMomAbvCan ,& ! inout, momentum exchange coeff [m/s], above ZeroPlaneDisp, vegetated + ExchCoeffShAbvCan => noahmp%energy%state%ExchCoeffShAbvCan ,& ! inout, heat exchange coeff [m/s], above ZeroPlaneDisp, vegetated + WindStressEwVeg => noahmp%energy%state%WindStressEwVeg ,& ! out, wind stress: east-west [N/m2] above canopy + WindStressNsVeg => noahmp%energy%state%WindStressNsVeg ,& ! out, wind stress: north-south [N/m2] above canopy + TemperatureAir2mVeg => noahmp%energy%state%TemperatureAir2mVeg ,& ! out, 2 m height air temperature [K], vegetated + ExchCoeffShLeaf => noahmp%energy%state%ExchCoeffShLeaf ,& ! out, sensible heat exchange coeff [m/s],leaf surface to canopy air + ExchCoeffShUndCan => noahmp%energy%state%ExchCoeffShUndCan ,& ! out, under canopy sensible heat exchange coefficient [m/s] + ExchCoeffSh2mVeg => noahmp%energy%state%ExchCoeffSh2mVeg ,& ! out, 2m sensible heat exchange coefficient [m/s] + SpecHumidity2mVeg => noahmp%energy%state%SpecHumidity2mVeg ,& ! out, specific humidity [kg/kg] at 2m vegetated + ResistanceStomataSunlit => noahmp%energy%state%ResistanceStomataSunlit ,& ! out, sunlit leaf stomatal resistance [s/m] + ResistanceStomataShade => noahmp%energy%state%ResistanceStomataShade ,& ! out, shaded leaf stomatal resistance [s/m] + FrictionVelVeg => noahmp%energy%state%FrictionVelVeg ,& ! out, friction velocity [m/s], vegetated + RoughLenShCanopy => noahmp%energy%state%RoughLenShCanopy ,& ! out, roughness length [m], sensible heat, vegetated + RoughLenShVegGrd => noahmp%energy%state%RoughLenShVegGrd ,& ! out, roughness length [m], sensible heat ground, below canopy + ResistanceLeafBoundary => noahmp%energy%state%ResistanceLeafBoundary ,& ! out, bulk leaf boundary layer resistance [s/m] + ResistanceShAbvCan => noahmp%energy%state%ResistanceShAbvCan ,& ! out, aerodynamic resistance for sensible heat [s/m], above canopy + ResistanceLhAbvCan => noahmp%energy%state%ResistanceLhAbvCan ,& ! out, aerodynamic resistance for water vapor [s/m], above canopy + ResistanceShUndCan => noahmp%energy%state%ResistanceShUndCan ,& ! out, ground aerodynamic resistance for sensible heat [s/m] + ResistanceLhUndCan => noahmp%energy%state%ResistanceLhUndCan ,& ! out, ground aerodynamic resistance for water vapor [s/m] + ExchCoeffLhAbvCan => noahmp%energy%state%ExchCoeffLhAbvCan ,& ! out, latent heat conductance, canopy air to reference height [m/s] + ExchCoeffLhTransp => noahmp%energy%state%ExchCoeffLhTransp ,& ! out, transpiration conductance, leaf to canopy air [m/s] + ExchCoeffLhEvap => noahmp%energy%state%ExchCoeffLhEvap ,& ! out, evaporation conductance, leaf to canopy air [m/s] + ExchCoeffLhUndCan => noahmp%energy%state%ExchCoeffLhUndCan ,& ! out, latent heat conductance, ground to canopy air [m/s] + VapPresSatCanopy => noahmp%energy%state%VapPresSatCanopy ,& ! out, saturation vapor pressure at TemperatureCanopy [Pa] + VapPresSatGrdVeg => noahmp%energy%state%VapPresSatGrdVeg ,& ! out, saturation vapor pressure at TemperatureGrd [Pa] + VapPresSatCanTempD => noahmp%energy%state%VapPresSatCanTempD ,& ! out, d(VapPresSatCanopy)/dt at TemperatureCanopy [Pa/K] + VapPresSatGrdVegTempD => noahmp%energy%state%VapPresSatGrdVegTempD ,& ! out, d(VapPresSatGrdVeg)/dt at TemperatureGrd [Pa/K] + CanopyHeight => noahmp%energy%state%CanopyHeight ,& ! out, canopy height [m] + WindSpdCanopyTop => noahmp%energy%state%WindSpdCanopyTop ,& ! out, wind speed at top of canopy [m/s] + MoStabParaAbvCan => noahmp%energy%state%MoStabParaAbvCan ,& ! out, Monin-Obukhov stability (z/L), above ZeroPlaneDispSfc, vegetated + MoStabCorrShVeg2m => noahmp%energy%state%MoStabCorrShVeg2m ,& ! out, M-O sen heat stability correction, 2m, vegetated + RadLwNetCanopy => noahmp%energy%flux%RadLwNetCanopy ,& ! out, canopy net longwave radiation [W/m2] (+ to atm) + HeatSensibleCanopy => noahmp%energy%flux%HeatSensibleCanopy ,& ! out, canopy sensible heat flux [W/m2] (+ to atm) + HeatLatentCanEvap => noahmp%energy%flux%HeatLatentCanEvap ,& ! out, canopy evaporation heat flux [W/m2] (+ to atm) + RadLwNetVegGrd => noahmp%energy%flux%RadLwNetVegGrd ,& ! out, ground net longwave radiation [W/m2] (+ to atm) + HeatSensibleVegGrd => noahmp%energy%flux%HeatSensibleVegGrd ,& ! out, vegetated ground sensible heat flux [W/m2] (+ to atm) + HeatLatentVegGrd => noahmp%energy%flux%HeatLatentVegGrd ,& ! out, ground evaporation heat flux [W/m2] (+ to atm) + HeatLatentCanTransp => noahmp%energy%flux%HeatLatentCanTransp ,& ! out, canopy transpiration heat flux [W/m2] (+ to atm) + HeatCanStorageChg => noahmp%energy%flux%HeatCanStorageChg ,& ! out, canopy heat storage change [W/m2] + HeatGroundVegGrd => noahmp%energy%flux%HeatGroundVegGrd & ! out, vegetated ground heat [W/m2] (+ to soil/snow) + ) +! ---------------------------------------------------------------------- + + ! initialization (including variables that do not depend on stability iteration) + LastIter = 0 + FrictionVelVeg = 0.1 + TemperatureCanChg = 0.0 + TemperatureGrdChg = 0.0 + MoStabParaAbvCan = 0.0 + MoStabParaSgn = 0 + MoStabCorrShVeg2m = 0.0 + ShGrdTmp = 0.0 + ShCanTmp = 0.0 + MoistureFluxSfc = 0.0 + ! limit LeafAreaIndex + VegAreaIndTmp = min(6.0, VegAreaIndEff) + LeafAreaIndSunEff = min(6.0, LeafAreaIndSunlit) + LeafAreaIndShdEff = min(6.0, LeafAreaIndShade) + + ! saturation vapor pressure at ground temperature + TempTmp = TempUnitConv(TemperatureGrdVeg) + call VaporPressureSaturation(TempTmp, VapPresSatWatTmp, VapPresSatIceTmp, VapPresSatWatTmpD, VapPresSatIceTmpD) + if ( TempTmp > 0.0 ) then + VapPresSatGrdVeg = VapPresSatWatTmp + else + VapPresSatGrdVeg = VapPresSatIceTmp + endif + + ! canopy height + CanopyHeight = HeightCanopyTop + ! wind speed at canopy height + !WindSpdCanopyTop = WindSpdRefHeight * log(CanopyHeight/RoughLenMomSfc) / log(RefHeightAboveGrd/RoughLenMomSfc) + WindSpdCanopyTop = WindSpdRefHeight * log((CanopyHeight - ZeroPlaneDispSfc + RoughLenMomSfc)/RoughLenMomSfc) / & + log(RefHeightAboveGrd/RoughLenMomSfc) ! MB: add ZeroPlaneDispSfc v3.7 + if ( (CanopyHeight-ZeroPlaneDispSfc) <= 0.0 ) then + print*, "CRITICAL PROBLEM: CanopyHeight <= ZeroPlaneDispSfc" + print*, "GridIndexI,GridIndexJ = ", GridIndexI, GridIndexJ + print*, "CanopyHeight = " , CanopyHeight + print*, "ZeroPlaneDispSfc = " , ZeroPlaneDispSfc + print*, "SnowDepth = " , SnowDepth + stop "Error: ZeroPlaneDisp problem in NoahMP LSM" + endif + + ! prepare for longwave rad. + LwCoeffAir = -EmissivityVeg * (1.0 + (1.0-EmissivityVeg)*(1.0-EmissivityGrd)) * RadLwDownRefHeight - & + EmissivityVeg * EmissivityGrd * ConstStefanBoltzmann * TemperatureGrdVeg**4 + LwCoeffCan = (2.0 - EmissivityVeg * (1.0-EmissivityGrd)) * EmissivityVeg * ConstStefanBoltzmann + + ! begin stability iteration for canopy temperature and flux + loop1: do IndIter = 1, NumIterC + + ! ground and surface roughness length + if ( IndIter == 1 ) then + RoughLenShCanopy = RoughLenMomSfc + RoughLenShVegGrd = RoughLenMomGrd + else + RoughLenShCanopy = RoughLenMomSfc !* exp(-ZilitinkevichCoeff*0.4*258.2*sqrt(FrictionVelVeg*RoughLenMomSfc)) + RoughLenShVegGrd = RoughLenMomGrd !* exp(-ZilitinkevichCoeff*0.4*258.2*sqrt(FrictionVelVeg*RoughLenMomGrd)) + endif + + ! aerodyn resistances between RefHeightAboveGrd and d+z0v + if ( OptSurfaceDrag == 1 ) call ResistanceAboveCanopyMOST(noahmp, IndIter, ShCanTmp, MoStabParaSgn) + if ( OptSurfaceDrag == 2 ) call ResistanceAboveCanopyChen97(noahmp, IndIter) + + ! aerodyn resistance between z0g and d+z0v, and leaf boundary layer resistance + call ResistanceLeafToGround(noahmp, IndIter, VegAreaIndTmp, ShGrdTmp) + + ! ES and d(ES)/dt evaluated at TemperatureCanopy + TempTmp = TempUnitConv(TemperatureCanopy) + call VaporPressureSaturation(TempTmp, VapPresSatWatTmp, VapPresSatIceTmp, VapPresSatWatTmpD, VapPresSatIceTmpD) + if ( TempTmp > 0.0 ) then + VapPresSatCanopy = VapPresSatWatTmp + VapPresSatCanTempD = VapPresSatWatTmpD + else + VapPresSatCanopy = VapPresSatIceTmp + VapPresSatCanTempD = VapPresSatIceTmpD + endif + + ! stomatal resistance + if ( IndIter == 1 ) then + if ( OptStomataResistance == 1 ) then ! Ball-Berry + IndexShade = 0 ! sunlit case + call ResistanceCanopyStomataBallBerry(noahmp, IndexShade) + IndexShade = 1 ! shaded case + call ResistanceCanopyStomataBallBerry(noahmp, IndexShade) + endif + if ( OptStomataResistance == 2 ) then ! Jarvis + IndexShade = 0 ! sunlit case + call ResistanceCanopyStomataJarvis(noahmp, IndexShade) + IndexShade = 1 ! shaded case + call ResistanceCanopyStomataJarvis(noahmp, IndexShade) + endif + endif + + ! sensible heat conductance and coeff above veg. + ExchCoeffShAbvCanTmp = 1.0 / ResistanceShAbvCan + ExchCoeffShLeafTmp = 2.0 * VegAreaIndTmp / ResistanceLeafBoundary + GrdHeatCoeff = 1.0 / ResistanceShUndCan + ExchCoeffTot = ExchCoeffShAbvCanTmp + ExchCoeffShLeafTmp + GrdHeatCoeff + TempShGhTmp = (TemperatureAirRefHeight*ExchCoeffShAbvCanTmp + TemperatureGrdVeg*GrdHeatCoeff) / ExchCoeffTot + ExchCoeffShFrac = ExchCoeffShLeafTmp / ExchCoeffTot + ShCoeff = (1.0 - ExchCoeffShFrac) * DensityAirRefHeight * ConstHeatCapacAir * ExchCoeffShLeafTmp + + ! latent heat conductance and coeff above veg. + ExchCoeffLhAbvCan = 1.0 / ResistanceLhAbvCan + ExchCoeffLhEvap = CanopyWetFrac * VegAreaIndTmp / ResistanceLeafBoundary + ExchCoeffLhTransp = (1.0 - CanopyWetFrac) * (LeafAreaIndSunEff/(ResistanceLeafBoundary+ResistanceStomataSunlit) + & + LeafAreaIndShdEff/(ResistanceLeafBoundary+ResistanceStomataShade)) + ExchCoeffLhUndCan = 1.0 / (ResistanceLhUndCan + ResistanceGrdEvap) + ExchCoeffTot = ExchCoeffLhAbvCan + ExchCoeffLhEvap + ExchCoeffLhTransp + ExchCoeffLhUndCan + VapPresLhTot = (PressureVaporRefHeight*ExchCoeffLhAbvCan + VapPresSatGrdVeg*ExchCoeffLhUndCan ) / ExchCoeffTot + ExchCoeffEtFrac = (ExchCoeffLhEvap + ExchCoeffLhTransp) / ExchCoeffTot + LhCoeff = (1.0 - ExchCoeffEtFrac) * ExchCoeffLhEvap * DensityAirRefHeight * & + ConstHeatCapacAir / PsychConstCanopy ! Barlage: change to vegetation v3.6 + TranspHeatCoeff = (1.0 - ExchCoeffEtFrac) * ExchCoeffLhTransp * DensityAirRefHeight * & + ConstHeatCapacAir / PsychConstCanopy + + ! evaluate surface fluxes with current temperature and solve for temperature change + TemperatureCanopyAir = TempShGhTmp + ExchCoeffShFrac * TemperatureCanopy ! canopy air T. + PressureVaporCanAir = VapPresLhTot + ExchCoeffEtFrac * VapPresSatCanopy ! canopy air e + RadLwNetCanopy = VegFrac * (LwCoeffAir + LwCoeffCan * TemperatureCanopy**4) + HeatSensibleCanopy = VegFrac * DensityAirRefHeight * ConstHeatCapacAir * & + ExchCoeffShLeafTmp * (TemperatureCanopy - TemperatureCanopyAir) + HeatLatentCanEvap = VegFrac * DensityAirRefHeight * ConstHeatCapacAir * ExchCoeffLhEvap * & + (VapPresSatCanopy - PressureVaporCanAir) / PsychConstCanopy ! Barlage: change to v in v3.6 + HeatLatentCanTransp = VegFrac * DensityAirRefHeight * ConstHeatCapacAir * ExchCoeffLhTransp * & + (VapPresSatCanopy - PressureVaporCanAir) / PsychConstCanopy + if ( TemperatureCanopy > ConstFreezePoint ) then + HeatLatentCanEvap = min(CanopyLiqWater*LatHeatVapCanopy/MainTimeStep, HeatLatentCanEvap) ! Barlage: add if block for canopy ice in v3.6 + else + HeatLatentCanEvap = min(CanopyIce*LatHeatVapCanopy/MainTimeStep, HeatLatentCanEvap) + endif + ! canopy heat capacity + HeatCapacCan = HeatCapacCanFac*VegAreaIndTmp*ConstHeatCapacWater + CanopyLiqWater*ConstHeatCapacWater/ConstDensityWater + & + CanopyIce*ConstHeatCapacIce/ConstDensityIce ! [J/m2/K] + ! compute vegetation temperature change + EnergyResTmp = RadSwAbsVeg - RadLwNetCanopy - HeatSensibleCanopy - & + HeatLatentCanEvap - HeatLatentCanTransp + HeatPrecipAdvCanopy + FluxTotCoeff = VegFrac * (4.0*LwCoeffCan*TemperatureCanopy**3 + ShCoeff + & + (LhCoeff+TranspHeatCoeff)*VapPresSatCanTempD + HeatCapacCan/MainTimeStep) ! volumetric heat capacity + TemperatureCanChg = EnergyResTmp / FluxTotCoeff + ! update fluxes with temperature change + RadLwNetCanopy = RadLwNetCanopy + VegFrac * 4.0 * LwCoeffCan * TemperatureCanopy**3 * TemperatureCanChg + HeatSensibleCanopy = HeatSensibleCanopy + VegFrac * ShCoeff * TemperatureCanChg + HeatLatentCanEvap = HeatLatentCanEvap + VegFrac * LhCoeff * VapPresSatCanTempD * TemperatureCanChg + HeatLatentCanTransp = HeatLatentCanTransp + VegFrac * TranspHeatCoeff * VapPresSatCanTempD * TemperatureCanChg + HeatCanStorageChg = VegFrac * HeatCapacCan / MainTimeStep * TemperatureCanChg ! canopy heat storage change [W/m2] + ! update vegetation temperature + TemperatureCanopy = TemperatureCanopy + TemperatureCanChg + !TemperatureCanopyAir = TempShGhTmp + ExchCoeffShFrac * TemperatureCanopy ! canopy air T; update here for consistency + + ! for computing M-O length in the next iteration + ShCanTmp = DensityAirRefHeight * ConstHeatCapacAir * (TemperatureCanopyAir-TemperatureAirRefHeight) / ResistanceShAbvCan + ShGrdTmp = DensityAirRefHeight * ConstHeatCapacAir * (TemperatureGrdVeg-TemperatureCanopyAir) / ResistanceShUndCan + + ! consistent specific humidity from canopy air vapor pressure + SpecHumiditySfc = (0.622 * PressureVaporCanAir) / (PressureAirRefHeight - 0.378 * PressureVaporCanAir) + if ( LastIter == 1 ) then + exit loop1 + endif + if ( (IndIter >= 5) .and. (abs(TemperatureCanChg) <= 0.01) .and. (LastIter == 0) ) then + LastIter = 1 + endif + enddo loop1 ! end stability iteration + + ! under-canopy fluxes and ground temperature + LwCoeffAir = -EmissivityGrd * (1.0 - EmissivityVeg) * RadLwDownRefHeight - & + EmissivityGrd * EmissivityVeg * ConstStefanBoltzmann * TemperatureCanopy**4 + LwCoeffCan = EmissivityGrd * ConstStefanBoltzmann + ShCoeff = DensityAirRefHeight * ConstHeatCapacAir / ResistanceShUndCan + LhCoeff = DensityAirRefHeight * ConstHeatCapacAir / (PsychConstGrd * (ResistanceLhUndCan+ResistanceGrdEvap)) ! Barlage: change to ground v3.6 + GrdHeatCoeff = 2.0 * ThermConductSoilSnow(NumSnowLayerNeg+1) / ThicknessSnowSoilLayer(NumSnowLayerNeg+1) + ! begin stability iteration + loop2: do IndIter = 1, NumIterG + TempTmp = TempUnitConv(TemperatureGrdVeg) + call VaporPressureSaturation(TempTmp, VapPresSatWatTmp, VapPresSatIceTmp, VapPresSatWatTmpD, VapPresSatIceTmpD) + if ( TempTmp > 0.0 ) then + VapPresSatGrdVeg = VapPresSatWatTmp + VapPresSatGrdVegTempD = VapPresSatWatTmpD + else + VapPresSatGrdVeg = VapPresSatIceTmp + VapPresSatGrdVegTempD = VapPresSatIceTmpD + endif + RadLwNetVegGrd = LwCoeffCan * TemperatureGrdVeg**4 + LwCoeffAir + HeatSensibleVegGrd = ShCoeff * (TemperatureGrdVeg - TemperatureCanopyAir) + HeatLatentVegGrd = LhCoeff * (VapPresSatGrdVeg*RelHumidityGrd - PressureVaporCanAir) + HeatGroundVegGrd = GrdHeatCoeff * (TemperatureGrdVeg - TemperatureSoilSnow(NumSnowLayerNeg+1)) + EnergyResTmp = RadSwAbsGrd - RadLwNetVegGrd - HeatSensibleVegGrd - & + HeatLatentVegGrd - HeatGroundVegGrd + HeatPrecipAdvVegGrd + FluxTotCoeff = 4.0 * LwCoeffCan * TemperatureGrdVeg**3 + ShCoeff + LhCoeff*VapPresSatGrdVegTempD + GrdHeatCoeff + TemperatureGrdChg = EnergyResTmp / FluxTotCoeff + RadLwNetVegGrd = RadLwNetVegGrd + 4.0 * LwCoeffCan * TemperatureGrdVeg**3 * TemperatureGrdChg + HeatSensibleVegGrd = HeatSensibleVegGrd + ShCoeff * TemperatureGrdChg + HeatLatentVegGrd = HeatLatentVegGrd + LhCoeff * VapPresSatGrdVegTempD * TemperatureGrdChg + HeatGroundVegGrd = HeatGroundVegGrd + GrdHeatCoeff * TemperatureGrdChg + TemperatureGrdVeg = TemperatureGrdVeg + TemperatureGrdChg + enddo loop2 + !TemperatureCanopyAir = (ExchCoeffShAbvCanTmp*TemperatureAirRefHeight + ExchCoeffShLeafTmp*TemperatureCanopy + & + ! GrdHeatCoeff*TemperatureGrdVeg)/(ExchCoeffShAbvCanTmp + ExchCoeffShLeafTmp + GrdHeatCoeff) + + ! if snow on ground and TemperatureGrdVeg > freezing point: reset TemperatureGrdVeg = freezing point. reevaluate ground fluxes. + if ( (OptSnowSoilTempTime == 1) .or. (OptSnowSoilTempTime == 3) ) then + if ( (SnowDepth > 0.05) .and. (TemperatureGrdVeg > ConstFreezePoint) ) then + if ( OptSnowSoilTempTime == 1 ) & + TemperatureGrdVeg = ConstFreezePoint + if ( OptSnowSoilTempTime == 3 ) & + TemperatureGrdVeg = (1.0 - SnowCoverFrac) * TemperatureGrdVeg + SnowCoverFrac * ConstFreezePoint ! MB: allow TemperatureGrdVeg>0C during melt v3.7 + + RadLwNetVegGrd = LwCoeffCan * TemperatureGrdVeg**4 - EmissivityGrd * (1.0-EmissivityVeg) * RadLwDownRefHeight - & + EmissivityGrd * EmissivityVeg * ConstStefanBoltzmann * TemperatureCanopy**4 + HeatSensibleVegGrd = ShCoeff * (TemperatureGrdVeg - TemperatureCanopyAir) + HeatLatentVegGrd = LhCoeff * (VapPresSatGrdVeg*RelHumidityGrd - PressureVaporCanAir) + HeatGroundVegGrd = RadSwAbsGrd + HeatPrecipAdvVegGrd - (RadLwNetVegGrd + HeatSensibleVegGrd + HeatLatentVegGrd) + endif + endif + + ! wind stresses + WindStressEwVeg = -DensityAirRefHeight * ExchCoeffMomAbvCan * WindSpdRefHeight * WindEastwardRefHeight + WindStressNsVeg = -DensityAirRefHeight * ExchCoeffMomAbvCan * WindSpdRefHeight * WindNorthwardRefHeight + + ! consistent vegetation air temperature and vapor pressure + ! since TemperatureGrdVeg is not consistent with the TemperatureCanopyAir/PressureVaporCanAir calculation. + !TemperatureCanopyAir = TemperatureAirRefHeight + (HeatSensibleVegGrd + HeatSensibleCanopy) / & + ! (DensityAirRefHeight*ConstHeatCapacAir*ExchCoeffShAbvCanTmp) + !TemperatureCanopyAir = TemperatureAirRefHeight + (HeatSensibleVegGrd * VegFrac + HeatSensibleCanopy) / & + ! (DensityAirRefHeight*ConstHeatCapacAir*ExchCoeffShAbvCanTmp) ! ground flux need fveg + !PressureVaporCanAir = PressureVaporRefHeight + (HeatLatentCanEvap+VegFrac*(HeatLatentCanTransp+HeatLatentVegGrd)) / & + ! (DensityAirRefHeight*ExchCoeffLhAbvCan*ConstHeatCapacAir/PsychConstGrd) + !MoistureFluxSfc = (SpecHumiditySfc - SpecHumidityRefHeight) * DensityAirRefHeight * ExchCoeffLhAbvCan !*ConstHeatCapacAir/PsychConstGrd + + ! 2m temperature over vegetation ( corrected for low LH exchange coeff values ) + if ( (OptSurfaceDrag == 1) .or. (OptSurfaceDrag == 2) ) then + !ExchCoeffSh2mVeg = FrictionVelVeg * 1.0 / ConstVonKarman * log((2.0+RoughLenShCanopy)/RoughLenShCanopy) + !ExchCoeffSh2mVeg = FrictionVelVeg * ConstVonKarman / log((2.0+RoughLenShCanopy)/RoughLenShCanopy) + ExchCoeffSh2mVeg = FrictionVelVeg * ConstVonKarman / (log((2.0+RoughLenShCanopy)/RoughLenShCanopy) - MoStabCorrShVeg2m) + if ( ExchCoeffSh2mVeg < 1.0e-5 ) then + TemperatureAir2mVeg = TemperatureCanopyAir + !SpecHumidity2mVeg = (PressureVaporCanAir*0.622/(PressureAirRefHeight - 0.378*PressureVaporCanAir)) + SpecHumidity2mVeg = SpecHumiditySfc + else + TemperatureAir2mVeg = TemperatureCanopyAir - (HeatSensibleVegGrd + HeatSensibleCanopy/VegFrac) / & + (DensityAirRefHeight * ConstHeatCapacAir) * 1.0 / ExchCoeffSh2mVeg + !SpecHumidity2mVeg = (PressureVaporCanAir*0.622/(PressureAirRefHeight - 0.378*PressureVaporCanAir)) - & + ! MoistureFluxSfc/(DensityAirRefHeight*FrictionVelVeg)* 1.0/ConstVonKarman * & + ! log((2.0+RoughLenShCanopy)/RoughLenShCanopy) + SpecHumidity2mVeg = SpecHumiditySfc - ((HeatLatentCanEvap+HeatLatentCanTransp)/VegFrac + HeatLatentVegGrd) / & + (LatHeatVapCanopy * DensityAirRefHeight) * 1.0 / ExchCoeffSh2mVeg + endif + endif + + ! update ExchCoeffSh for output + ExchCoeffShAbvCan = ExchCoeffShAbvCanTmp + ExchCoeffShLeaf = ExchCoeffShLeafTmp + ExchCoeffShUndCan = 1.0 / ResistanceShUndCan + + end associate + + end subroutine SurfaceEnergyFluxVegetated + +end module SurfaceEnergyFluxVegetatedMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SurfaceRadiationGlacierMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SurfaceRadiationGlacierMod.F90 new file mode 100644 index 0000000000..0d8e2bac71 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SurfaceRadiationGlacierMod.F90 @@ -0,0 +1,65 @@ +module SurfaceRadiationGlacierMod + +!!! Compute glacier surface radiative fluxes (absorption and reflection) + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine SurfaceRadiationGlacier(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: RADIATION_GLACIER +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: IndBand ! waveband indices (1=vis, 2=nir) + real(kind=kind_noahmp) :: RadSwAbsGrdTmp ! ground absorbed solar radiation [W/m2] + real(kind=kind_noahmp) :: RadSwReflGrdTmp ! ground reflected solar radiation [W/m2] + +! ----------------------------------------------------------------- + associate( & + NumSwRadBand => noahmp%config%domain%NumSwRadBand ,& ! in, number of solar radiation wave bands + RadSwDownDir => noahmp%energy%flux%RadSwDownDir ,& ! in, incoming direct solar radiation [W/m2] + RadSwDownDif => noahmp%energy%flux%RadSwDownDif ,& ! in, incoming diffuse solar radiation [W/m2] + AlbedoGrdDir => noahmp%energy%state%AlbedoGrdDir ,& ! in, ground albedo (direct beam: vis, nir) + AlbedoGrdDif => noahmp%energy%state%AlbedoGrdDif ,& ! in, ground albedo (diffuse: vis, nir) + RadSwAbsGrd => noahmp%energy%flux%RadSwAbsGrd ,& ! out, solar radiation absorbed by ground [W/m2] + RadSwAbsSfc => noahmp%energy%flux%RadSwAbsSfc ,& ! out, total absorbed solar radiation [W/m2] + RadSwReflSfc => noahmp%energy%flux%RadSwReflSfc & ! out, total reflected solar radiation [W/m2] + ) +! ---------------------------------------------------------------------- + + ! initialization + RadSwAbsGrd = 0.0 + RadSwAbsSfc = 0.0 + RadSwReflSfc = 0.0 + + do IndBand = 1, NumSwRadBand + ! solar radiation absorbed by glacier surface + RadSwAbsGrdTmp = RadSwDownDir(IndBand) * (1.0 - AlbedoGrdDir(IndBand)) + & + RadSwDownDif(IndBand) * (1.0 - AlbedoGrdDif(IndBand)) + RadSwAbsGrd = RadSwAbsGrd + RadSwAbsGrdTmp + RadSwAbsSfc = RadSwAbsSfc + RadSwAbsGrdTmp + + ! solar radiation reflected by glacier surface + RadSwReflGrdTmp = RadSwDownDir(IndBand) * AlbedoGrdDir(IndBand) + & + RadSwDownDif(IndBand) * AlbedoGrdDif(IndBand) + RadSwReflSfc = RadSwReflSfc + RadSwReflGrdTmp + enddo + + end associate + + end subroutine SurfaceRadiationGlacier + +end module SurfaceRadiationGlacierMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SurfaceRadiationMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SurfaceRadiationMod.F90 new file mode 100644 index 0000000000..bd9bbb4197 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SurfaceRadiationMod.F90 @@ -0,0 +1,137 @@ +module SurfaceRadiationMod + +!!! Compute surface (ground and vegetation) radiative fluxes (absorption and reflection) + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine SurfaceRadiation(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: SURRAD +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: IndBand ! waveband indices (1=vis, 2=nir) + real(kind=kind_noahmp) :: MinThr ! prevents overflow for division by zero + real(kind=kind_noahmp) :: RadSwAbsGrdTmp ! ground absorbed solar radiation [W/m2] + real(kind=kind_noahmp) :: RadSwReflSfcNir ! surface reflected solar radiation NIR [W/m2] + real(kind=kind_noahmp) :: RadSwReflSfcVis ! surface reflected solar radiation VIS [W/m2] + real(kind=kind_noahmp) :: LeafAreaIndFrac ! leaf area fraction of canopy + real(kind=kind_noahmp) :: RadSwTranGrdDir ! transmitted solar radiation at ground: direct [W/m2] + real(kind=kind_noahmp) :: RadSwTranGrdDif ! transmitted solar radiation at ground: diffuse [W/m2] + real(kind=kind_noahmp), allocatable, dimension(:) :: RadSwAbsCanDir ! direct beam absorbed by canopy [W/m2] + real(kind=kind_noahmp), allocatable, dimension(:) :: RadSwAbsCanDif ! diffuse radiation absorbed by canopy [W/m2] + +! -------------------------------------------------------------------- + associate( & + NumSwRadBand => noahmp%config%domain%NumSwRadBand ,& ! in, number of solar radiation wave bands + LeafAreaIndEff => noahmp%energy%state%LeafAreaIndEff ,& ! in, leaf area index, after burying by snow + VegAreaIndEff => noahmp%energy%state%VegAreaIndEff ,& ! in, one-sided leaf+stem area index [m2/m2] + CanopySunlitFrac => noahmp%energy%state%CanopySunlitFrac ,& ! in, sunlit fraction of canopy + CanopyShadeFrac => noahmp%energy%state%CanopyShadeFrac ,& ! in, shaded fraction of canopy + LeafAreaIndSunlit => noahmp%energy%state%LeafAreaIndSunlit ,& ! in, sunlit leaf area + LeafAreaIndShade => noahmp%energy%state%LeafAreaIndShade ,& ! in, shaded leaf area + RadSwDownDir => noahmp%energy%flux%RadSwDownDir ,& ! in, incoming direct solar radiation [W/m2] + RadSwDownDif => noahmp%energy%flux%RadSwDownDif ,& ! in, incoming diffuse solar radiation [W/m2] + RadSwAbsVegDir => noahmp%energy%flux%RadSwAbsVegDir ,& ! in, flux abs by veg (per unit direct flux) + RadSwAbsVegDif => noahmp%energy%flux%RadSwAbsVegDif ,& ! in, flux abs by veg (per unit diffuse flux) + RadSwDirTranGrdDir => noahmp%energy%flux%RadSwDirTranGrdDir ,& ! in, down direct flux below veg (per unit dir flux) + RadSwDifTranGrdDir => noahmp%energy%flux%RadSwDifTranGrdDir ,& ! in, down diffuse flux below veg (per unit dir flux) + RadSwDifTranGrdDif => noahmp%energy%flux%RadSwDifTranGrdDif ,& ! in, down diffuse flux below veg (per unit dif flux) + AlbedoGrdDir => noahmp%energy%state%AlbedoGrdDir ,& ! in, ground albedo (direct beam: vis, nir) + AlbedoGrdDif => noahmp%energy%state%AlbedoGrdDif ,& ! in, ground albedo (diffuse: vis, nir) + AlbedoSfcDir => noahmp%energy%state%AlbedoSfcDir ,& ! in, surface albedo (direct) + AlbedoSfcDif => noahmp%energy%state%AlbedoSfcDif ,& ! in, surface albedo (diffuse) + RadSwReflVegDir => noahmp%energy%flux%RadSwReflVegDir ,& ! in, flux reflected by veg layer (per unit direct flux) + RadSwReflVegDif => noahmp%energy%flux%RadSwReflVegDif ,& ! in, flux reflected by veg layer (per unit diffuse flux) + RadSwReflGrdDir => noahmp%energy%flux%RadSwReflGrdDir ,& ! in, flux reflected by ground (per unit direct flux) + RadSwReflGrdDif => noahmp%energy%flux%RadSwReflGrdDif ,& ! in, flux reflected by ground (per unit diffuse flux) + RadPhotoActAbsSunlit => noahmp%energy%flux%RadPhotoActAbsSunlit ,& ! out, average absorbed par for sunlit leaves [W/m2] + RadPhotoActAbsShade => noahmp%energy%flux%RadPhotoActAbsShade ,& ! out, average absorbed par for shaded leaves [W/m2] + RadSwAbsVeg => noahmp%energy%flux%RadSwAbsVeg ,& ! out, solar radiation absorbed by vegetation [W/m2] + RadSwAbsGrd => noahmp%energy%flux%RadSwAbsGrd ,& ! out, solar radiation absorbed by ground [W/m2] + RadSwAbsSfc => noahmp%energy%flux%RadSwAbsSfc ,& ! out, total absorbed solar radiation [W/m2] + RadSwReflSfc => noahmp%energy%flux%RadSwReflSfc ,& ! out, total reflected solar radiation [W/m2] + RadSwReflVeg => noahmp%energy%flux%RadSwReflVeg ,& ! out, reflected solar radiation by vegetation [W/m2] + RadSwReflGrd => noahmp%energy%flux%RadSwReflGrd & ! out, reflected solar radiation by ground [W/m2] + ) +! ---------------------------------------------------------------------- + + ! initialization + if (.not. allocated(RadSwAbsCanDir)) allocate(RadSwAbsCanDir(1:NumSwRadBand)) + if (.not. allocated(RadSwAbsCanDif)) allocate(RadSwAbsCanDif(1:NumSwRadBand)) + MinThr = 1.0e-6 + RadSwAbsCanDir = 0.0 + RadSwAbsCanDif = 0.0 + RadSwAbsGrd = 0.0 + RadSwAbsVeg = 0.0 + RadSwAbsSfc = 0.0 + RadSwReflSfc = 0.0 + RadSwReflVeg = 0.0 + RadSwReflGrd = 0.0 + RadPhotoActAbsSunlit = 0.0 + RadPhotoActAbsShade = 0.0 + + do IndBand = 1, NumSwRadBand + ! absorbed by canopy + RadSwAbsCanDir(IndBand) = RadSwDownDir(IndBand) * RadSwAbsVegDir(IndBand) + RadSwAbsCanDif(IndBand) = RadSwDownDif(IndBand) * RadSwAbsVegDif(IndBand) + RadSwAbsVeg = RadSwAbsVeg + RadSwAbsCanDir(IndBand) + RadSwAbsCanDif(IndBand) + RadSwAbsSfc = RadSwAbsSfc + RadSwAbsCanDir(IndBand) + RadSwAbsCanDif(IndBand) + ! transmitted solar fluxes incident on ground + RadSwTranGrdDir = RadSwDownDir(IndBand) * RadSwDirTranGrdDir(IndBand) + RadSwTranGrdDif = RadSwDownDir(IndBand) * RadSwDifTranGrdDir(IndBand) + & + RadSwDownDif(IndBand) * RadSwDifTranGrdDif(IndBand) + ! solar radiation absorbed by ground surface + RadSwAbsGrdTmp = RadSwTranGrdDir * (1.0 - AlbedoGrdDir(IndBand)) + & + RadSwTranGrdDif * (1.0 - AlbedoGrdDif(IndBand)) + RadSwAbsGrd = RadSwAbsGrd + RadSwAbsGrdTmp + RadSwAbsSfc = RadSwAbsSfc + RadSwAbsGrdTmp + enddo + + ! partition visible canopy absorption to sunlit and shaded fractions + ! to get average absorbed par for sunlit and shaded leaves + LeafAreaIndFrac = LeafAreaIndEff / max(VegAreaIndEff, MinThr) + if ( CanopySunlitFrac > 0.0 ) then + RadPhotoActAbsSunlit = (RadSwAbsCanDir(1) + CanopySunlitFrac * RadSwAbsCanDif(1)) * & + LeafAreaIndFrac / max(LeafAreaIndSunlit, MinThr) + RadPhotoActAbsShade = (CanopyShadeFrac * RadSwAbsCanDif(1)) * & + LeafAreaIndFrac / max(LeafAreaIndShade, MinThr) + else + RadPhotoActAbsSunlit = 0.0 + RadPhotoActAbsShade = (RadSwAbsCanDir(1) + RadSwAbsCanDif(1)) * & + LeafAreaIndFrac / max(LeafAreaIndShade, MinThr) + endif + + ! reflected solar radiation + RadSwReflSfcVis = AlbedoSfcDir(1) * RadSwDownDir(1) + AlbedoSfcDif(1) * RadSwDownDif(1) + RadSwReflSfcNir = AlbedoSfcDir(2) * RadSwDownDir(2) + AlbedoSfcDif(2) * RadSwDownDif(2) + RadSwReflSfc = RadSwReflSfcVis + RadSwReflSfcNir + + ! reflected solar radiation of veg. and ground (combined ground) + RadSwReflVeg = RadSwReflVegDir(1)*RadSwDownDir(1) + RadSwReflVegDif(1)*RadSwDownDif(1) + & + RadSwReflVegDir(2)*RadSwDownDir(2) + RadSwReflVegDif(2)*RadSwDownDif(2) + RadSwReflGrd = RadSwReflGrdDir(1)*RadSwDownDir(1) + RadSwReflGrdDif(1)*RadSwDownDif(1) + & + RadSwReflGrdDir(2)*RadSwDownDir(2) + RadSwReflGrdDif(2)*RadSwDownDif(2) + + ! deallocate local arrays to avoid memory leaks + deallocate(RadSwAbsCanDir) + deallocate(RadSwAbsCanDif) + + end associate + + end subroutine SurfaceRadiation + +end module SurfaceRadiationMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/TileDrainageEquiDepthMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/TileDrainageEquiDepthMod.F90 new file mode 100644 index 0000000000..df77856392 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/TileDrainageEquiDepthMod.F90 @@ -0,0 +1,69 @@ +module TileDrainageEquiDepthMod + +!!! Calculate tile drainage equivalent depth (currently used in Hooghoudt's scheme) + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine TileDrainageEquiDepth(DrainDepthToImp, DrainTubeDist, DrainTubeRadius, DrainWatHgtAbvImp) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: TD_EQUIVALENT_DEPTH +! Original code: P. Valayamkunnath (NCAR) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + +! in & out variables + real(kind=kind_noahmp), intent(in) :: DrainDepthToImp ! tile drainage depth to impermeable layer [m] + real(kind=kind_noahmp), intent(in) :: DrainTubeDist ! distance between two drain tubes or tiles [m] + real(kind=kind_noahmp), intent(in) :: DrainTubeRadius ! effective radius of drains [m] + real(kind=kind_noahmp), intent(out) :: DrainWatHgtAbvImp ! Height of water table in drain Above Impermeable Layer [m] + +! local variables + integer :: LoopInd ! loop index + real(kind=kind_noahmp) :: PiMath = 22.0/7.0 ! pi value + real(kind=kind_noahmp) :: DrainAspect ! temporary drain variable + real(kind=kind_noahmp) :: DrainFac ! temporary drain factor + real(kind=kind_noahmp) :: DrainExpFac ! temporary drain exponential factor + real(kind=kind_noahmp) :: DrainFacTmp ! temporary drain factor + +! ---------------------------------------------------------------------- + + ! initialization + DrainFac = 0.0 + DrainExpFac = 0.0 + DrainFacTmp = 0.0 + DrainAspect = (2.0 * PiMath * DrainDepthToImp) / DrainTubeDist + + ! compute tile drainage equivalent depth + if ( DrainAspect > 0.5 ) then + do LoopInd = 1, 45, 2 + DrainExpFac = exp(-2.0 * LoopInd * DrainAspect) + DrainFacTmp = (4.0 * DrainExpFac) / (LoopInd * (1.0-DrainExpFac)) + DrainFac = DrainFac + DrainFacTmp + if ( DrainFacTmp < 1.0e-6 ) then + DrainWatHgtAbvImp = ((PiMath*DrainTubeDist) / 8.0) / & + (log(DrainTubeDist/(PiMath*DrainTubeRadius)) + DrainFac) + exit + endif + enddo + elseif ( DrainAspect < 1.0e-8 ) then + DrainWatHgtAbvImp = DrainDepthToImp + else + DrainFac = ((PiMath*PiMath)/(4.0*DrainAspect)) + (log(DrainAspect/(2.0*PiMath))) + DrainWatHgtAbvImp = ((PiMath*DrainTubeDist) / 8.0) / & + (log(DrainTubeDist/(PiMath*DrainTubeRadius)) + DrainFac) + endif + + if ( (DrainWatHgtAbvImp < 0.0) .and. (LoopInd <= 2) ) DrainWatHgtAbvImp = DrainDepthToImp + + end subroutine TileDrainageEquiDepth + +end module TileDrainageEquiDepthMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/TileDrainageHooghoudtMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/TileDrainageHooghoudtMod.F90 new file mode 100644 index 0000000000..4642a590e1 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/TileDrainageHooghoudtMod.F90 @@ -0,0 +1,188 @@ +module TileDrainageHooghoudtMod + +!!! Calculate tile drainage discharge [mm] based on Hooghoudt's equation + + use Machine + use NoahmpVarType + use ConstantDefineMod + use TileDrainageEquiDepthMod, only : TileDrainageEquiDepth + use WaterTableDepthSearchMod, only : WaterTableDepthSearch + use WaterTableEquilibriumMod, only : WaterTableEquilibrium + + implicit none + +contains + + subroutine TileDrainageHooghoudt(noahmp) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: TILE_HOOGHOUDT +! Original code: P. Valayamkunnath (NCAR) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: IndSoil ! soil layer loop index + integer :: NumDrain ! number of drains + real(kind=kind_noahmp) :: ThickSatZoneTot ! total thickness of saturated zone + real(kind=kind_noahmp) :: LateralFlow ! lateral flow + real(kind=kind_noahmp) :: DepthToLayerTop ! depth to top of the layer + real(kind=kind_noahmp) :: WatTblTmp1 ! temporary water table variable + real(kind=kind_noahmp) :: WatTblTmp2 ! temporary water table variable + real(kind=kind_noahmp) :: LateralWatCondAve ! average lateral hydruaic conductivity + real(kind=kind_noahmp) :: DrainWatHgtAbvImp ! Height of water table in the drain Above Impermeable Layer + real(kind=kind_noahmp) :: DepthSfcToImp ! Effective Depth to impermeable layer from soil surface + real(kind=kind_noahmp) :: HgtDrnToWatTbl ! Effective Height between water level in drains to water table MiDpoint + real(kind=kind_noahmp) :: DrainCoeffTmp ! Drainage Coefficient + real(kind=kind_noahmp) :: TileDrainTmp ! temporary drainage discharge + real(kind=kind_noahmp) :: DrainDepthToImpTmp ! drain depth to impermeable layer + real(kind=kind_noahmp) :: WatExcFieldCapTot ! amount of water over field capacity + real(kind=kind_noahmp), allocatable, dimension(:) :: ThickSatZone ! thickness of saturated zone + real(kind=kind_noahmp), allocatable, dimension(:) :: LateralWatCondTmp ! lateral hydraulic ocnductivity kth layer + real(kind=kind_noahmp), allocatable, dimension(:) :: WatExcFieldCapTmp ! layer-wise amount of water over field capacity + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilLiqWaterAftDrain ! remaining water after tile drain + +! ---------------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + DepthSoilLayer => noahmp%config%domain%DepthSoilLayer ,& ! in, depth [m] of layer-bottom from soil surface + SoilTimeStep => noahmp%config%domain%SoilTimeStep ,& ! in, noahmp soil timestep [s] + GridSize => noahmp%config%domain%GridSize ,& ! in, noahmp model grid spacing [m] + ThicknessSoilLayer => noahmp%config%domain%ThicknessSoilLayer ,& ! in, soil layer thickness [m] + SoilMoistureFieldCap => noahmp%water%param%SoilMoistureFieldCap ,& ! in, reference soil moisture (field capacity) [m3/m3] + TileDrainCoeff => noahmp%water%param%TileDrainCoeff ,& ! in, drainage coefficent [m/day] + DrainDepthToImperv => noahmp%water%param%DrainDepthToImperv ,& ! in, Actual depth to impermeable layer from surface [m] + LateralWatCondFac => noahmp%water%param%LateralWatCondFac ,& ! in, multiplication factor to determine lateral hydraulic conductivity + TileDrainDepth => noahmp%water%param%TileDrainDepth ,& ! in, Depth of drain [m] + DrainTubeDist => noahmp%water%param%DrainTubeDist ,& ! in, distance between two drain tubes or tiles [m] + DrainTubeRadius => noahmp%water%param%DrainTubeRadius ,& ! in, effective radius of drains [m] + SoilWatConductivity => noahmp%water%state%SoilWatConductivity ,& ! in, soil hydraulic conductivity [m/s] + SoilIce => noahmp%water%state%SoilIce ,& ! in, soil ice content [m3/m3] + WaterTableHydro => noahmp%water%state%WaterTableHydro ,& ! in, water table depth estimated in WRF-Hydro fine grids [m] + SoilLiqWater => noahmp%water%state%SoilLiqWater ,& ! inout, soil water content [m3/m3] + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! inout, total soil moisture [m3/m3] + WaterTableDepth => noahmp%water%state%WaterTableDepth ,& ! inout, water table depth [m] + TileDrain => noahmp%water%flux%TileDrain & ! inout, tile drainage [mm/s] + ) +! ---------------------------------------------------------------------- + + ! initialization + if (.not. allocated(ThickSatZone) ) allocate(ThickSatZone (1:NumSoilLayer)) + if (.not. allocated(LateralWatCondTmp) ) allocate(LateralWatCondTmp (1:NumSoilLayer)) + if (.not. allocated(WatExcFieldCapTmp) ) allocate(WatExcFieldCapTmp (1:NumSoilLayer)) + if (.not. allocated(SoilLiqWaterAftDrain)) allocate(SoilLiqWaterAftDrain(1:NumSoilLayer)) + ThickSatZone = 0.0 + LateralWatCondTmp = 0.0 + WatExcFieldCapTmp = 0.0 + SoilLiqWaterAftDrain = 0.0 + DepthToLayerTop = 0.0 + LateralFlow = 0.0 + ThickSatZoneTot = 0.0 + DrainCoeffTmp = TileDrainCoeff * 1000.0 * SoilTimeStep / (24.0 * 3600.0) ! m per day to mm per timestep + + ! Thickness of soil layers + do IndSoil = 1, NumSoilLayer + if ( IndSoil == 1 ) then + ThicknessSoilLayer(IndSoil) = -1.0 * DepthSoilLayer(IndSoil) + else + ThicknessSoilLayer(IndSoil) = (DepthSoilLayer(IndSoil-1) - DepthSoilLayer(IndSoil)) + endif + enddo + +#ifdef WRF_HYDRO + ! Depth to water table from WRF-HYDRO, m + WatTblTmp2 = WaterTableHydro +#else + call WaterTableDepthSearch(noahmp) + !call WaterTableEquilibrium(noahmp) + WatTblTmp2 = WaterTableDepth +#endif + + if ( WatTblTmp2 > DrainDepthToImperv) WatTblTmp2 = DrainDepthToImperv + + ! Depth of saturated zone + do IndSoil = 1, NumSoilLayer + if ( WatTblTmp2 > (-1.0*DepthSoilLayer(IndSoil)) ) then + ThickSatZone(IndSoil) = 0.0 + else + ThickSatZone(IndSoil) = (-1.0 * DepthSoilLayer(IndSoil)) - WatTblTmp2 + WatTblTmp1 = (-1.0 * DepthSoilLayer(IndSoil)) - DepthToLayerTop + if ( ThickSatZone(IndSoil) > WatTblTmp1 ) ThickSatZone(IndSoil) = WatTblTmp1 + endif + DepthToLayerTop = -1.0 * DepthSoilLayer(IndSoil) + enddo + + ! amount of water over field capacity + WatExcFieldCapTot = 0.0 + do IndSoil = 1, NumSoilLayer + WatExcFieldCapTmp(IndSoil) = (SoilLiqWater(IndSoil) - (SoilMoistureFieldCap(IndSoil)-SoilIce(IndSoil))) * & + ThicknessSoilLayer(IndSoil) * 1000.0 + if ( WatExcFieldCapTmp(IndSoil) < 0.0 ) WatExcFieldCapTmp(IndSoil) = 0.0 + WatExcFieldCapTot = WatExcFieldCapTot + WatExcFieldCapTmp(IndSoil) + enddo + + ! lateral hydraulic conductivity and total lateral flow + do IndSoil = 1, NumSoilLayer + LateralWatCondTmp(IndSoil) = SoilWatConductivity(IndSoil) * LateralWatCondFac * SoilTimeStep ! m/s to m/timestep + LateralFlow = LateralFlow + (ThickSatZone(IndSoil) * LateralWatCondTmp(IndSoil)) + ThickSatZoneTot = ThickSatZoneTot + ThickSatZone(IndSoil) + enddo + if ( ThickSatZoneTot < 0.001 ) ThickSatZoneTot = 0.001 ! unit is m + if ( LateralFlow < 0.001 ) LateralFlow = 0.0 ! unit is m + LateralWatCondAve = LateralFlow / ThickSatZoneTot ! lateral hydraulic conductivity per timestep + DrainDepthToImpTmp = DrainDepthToImperv - TileDrainDepth + + call TileDrainageEquiDepth(DrainDepthToImpTmp, DrainTubeDist, DrainTubeRadius, DrainWatHgtAbvImp) + + DepthSfcToImp = DrainWatHgtAbvImp + TileDrainDepth + HgtDrnToWatTbl = TileDrainDepth - WatTblTmp2 + if ( HgtDrnToWatTbl <= 0.0 ) then + TileDrain = 0.0 + else + TileDrain = ((8.0*LateralWatCondAve*DrainWatHgtAbvImp*HgtDrnToWatTbl) + & + (4.0*LateralWatCondAve*HgtDrnToWatTbl*HgtDrnToWatTbl)) / (DrainTubeDist*DrainTubeDist) + endif + TileDrain = TileDrain * 1000.0 ! m per timestep to mm/timestep /one tile + if ( TileDrain <= 0.0 ) TileDrain = 0.0 + if ( TileDrain > DrainCoeffTmp ) TileDrain = DrainCoeffTmp + NumDrain = int(GridSize / DrainTubeDist) + TileDrain = TileDrain * NumDrain + if ( TileDrain > WatExcFieldCapTot ) TileDrain = WatExcFieldCapTot + + ! update soil moisture after drainage: moisture drains from top to bottom + TileDrainTmp = TileDrain + do IndSoil = 1, NumSoilLayer + if ( TileDrainTmp > 0.0) then + if ( (ThickSatZone(IndSoil) > 0.0) .and. (WatExcFieldCapTmp(IndSoil) > 0.0) ) then + SoilLiqWaterAftDrain(IndSoil) = WatExcFieldCapTmp(IndSoil) - TileDrainTmp ! remaining water after tile drain + if ( SoilLiqWaterAftDrain(IndSoil) > 0.0 ) then + SoilLiqWater(IndSoil) = (SoilMoistureFieldCap(IndSoil) - SoilIce(IndSoil)) + & + SoilLiqWaterAftDrain(IndSoil) / (ThicknessSoilLayer(IndSoil) * 1000.0) + SoilMoisture(IndSoil) = SoilLiqWater(IndSoil) + SoilIce(IndSoil) + exit + else + SoilLiqWater(IndSoil) = SoilMoistureFieldCap(IndSoil) - SoilIce(IndSoil) + SoilMoisture(IndSoil) = SoilLiqWater(IndSoil) + SoilIce (IndSoil) + TileDrainTmp = TileDrainTmp - WatExcFieldCapTmp(IndSoil) + endif + endif + endif + enddo + + TileDrain = TileDrain / SoilTimeStep ! mm/s + + ! deallocate local arrays to avoid memory leaks + deallocate(ThickSatZone ) + deallocate(LateralWatCondTmp ) + deallocate(WatExcFieldCapTmp ) + deallocate(SoilLiqWaterAftDrain) + + end associate + + end subroutine TileDrainageHooghoudt + +end module TileDrainageHooghoudtMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/TileDrainageSimpleMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/TileDrainageSimpleMod.F90 new file mode 100644 index 0000000000..d482a4dcb5 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/TileDrainageSimpleMod.F90 @@ -0,0 +1,213 @@ +module TileDrainageSimpleMod + +!!! Calculate tile drainage discharge [mm] based on simple model + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine TileDrainageSimple(noahmp) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: TILE_DRAIN +! Original code: P. Valayamkunnath (NCAR) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: IndSoil ! soil layer loop index + real(kind=kind_noahmp) :: DrainWatVolTot ! temporary variable for drainage volume [mm] + real(kind=kind_noahmp) :: DrainCoeffTmp ! temporary variable for drainage + real(kind=kind_noahmp) :: DrainWatTmp ! temporary variable for drainage + real(kind=kind_noahmp), allocatable, dimension(:) :: WatExcFieldCap ! temp variable for volume of water above field capacity + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilFieldCapLiq ! Available field capacity = field capacity - SoilIce [m3/m3] + real(kind=kind_noahmp), allocatable, dimension(:) :: DrainFracTmp ! tile drainage fraction + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + DepthSoilLayer => noahmp%config%domain%DepthSoilLayer ,& ! in, depth [m] of layer-bottom from soil surface + SoilTimeStep => noahmp%config%domain%SoilTimeStep ,& ! in, noahmp soil timestep [s] + ThicknessSoilLayer => noahmp%config%domain%ThicknessSoilLayer ,& ! in, soil layer thickness [m] + TileDrainCoeffSp => noahmp%water%param%TileDrainCoeffSp ,& ! in, drainage coefficient [mm/d] + DrainSoilLayerInd => noahmp%water%param%DrainSoilLayerInd ,& ! in, starting soil layer for drainage + TileDrainTubeDepth => noahmp%water%param%TileDrainTubeDepth ,& ! in, depth of drain tube from the soil surface + DrainFacSoilWat => noahmp%water%param%DrainFacSoilWat ,& ! in, drainage factor for soil moisture + SoilMoistureFieldCap => noahmp%water%param%SoilMoistureFieldCap ,& ! in, reference soil moisture (field capacity) [m3/m3] + SoilIce => noahmp%water%state%SoilIce ,& ! in, soil ice content [m3/m3] + SoilLiqWater => noahmp%water%state%SoilLiqWater ,& ! inout, soil water content [m3/m3] + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! inout, total soil moisture [m3/m3] + TileDrain => noahmp%water%flux%TileDrain & ! out, tile drainage [mm/s] + ) +! ---------------------------------------------------------------------- + + ! initialization + if (.not. allocated(DrainFracTmp) ) allocate(DrainFracTmp (1:NumSoilLayer)) + if (.not. allocated(SoilFieldCapLiq)) allocate(SoilFieldCapLiq(1:NumSoilLayer)) + if (.not. allocated(WatExcFieldCap) ) allocate(WatExcFieldCap (1:NumSoilLayer)) + DrainFracTmp = 0.0 + SoilFieldCapLiq = 0.0 + DrainWatVolTot = 0.0 + WatExcFieldCap = 0.0 + TileDrain = 0.0 + ThicknessSoilLayer = 0.0 + DrainWatTmp = 0.0 + DrainFracTmp = 0.0 + DrainCoeffTmp = TileDrainCoeffSp * SoilTimeStep / (24.0 * 3600.0) + + do IndSoil = 1, NumSoilLayer + if ( IndSoil == 1 ) then + ThicknessSoilLayer(IndSoil) = -1.0 * DepthSoilLayer(IndSoil) + else + ThicknessSoilLayer(IndSoil) = DepthSoilLayer(IndSoil-1) - DepthSoilLayer(IndSoil) + endif + enddo + if ( DrainSoilLayerInd == 0 ) then ! drainage from one specified layer in NoahmpTable.TBL + IndSoil = TileDrainTubeDepth + SoilFieldCapLiq(IndSoil) = SoilMoistureFieldCap(IndSoil) - SoilIce (IndSoil) + WatExcFieldCap(IndSoil) = (SoilLiqWater(IndSoil) - (DrainFacSoilWat*SoilFieldCapLiq(IndSoil))) * & + ThicknessSoilLayer(IndSoil) * 1000.0 ! mm + if ( WatExcFieldCap(IndSoil) > 0.0 ) then + if ( WatExcFieldCap(IndSoil) > DrainCoeffTmp ) WatExcFieldCap(IndSoil) = DrainCoeffTmp + DrainWatVolTot = DrainWatVolTot + WatExcFieldCap(IndSoil) + SoilLiqWater(IndSoil) = SoilLiqWater(IndSoil) - & + (WatExcFieldCap(IndSoil) / (ThicknessSoilLayer(IndSoil) * 1000.0)) + SoilMoisture(IndSoil) = SoilLiqWater(IndSoil) + SoilIce (IndSoil) + endif + else if ( DrainSoilLayerInd == 1 ) then + do IndSoil = 1, 2 + SoilFieldCapLiq(IndSoil) = SoilMoistureFieldCap(IndSoil) - SoilIce (IndSoil) + WatExcFieldCap(IndSoil) = (SoilLiqWater(IndSoil) - (DrainFacSoilWat*SoilFieldCapLiq(IndSoil))) * & + ThicknessSoilLayer(IndSoil) * 1000.0 ! mm + if ( WatExcFieldCap(IndSoil) < 0.0 ) WatExcFieldCap(IndSoil) = 0.0 + DrainWatTmp = DrainWatTmp + WatExcFieldCap(IndSoil) + enddo + do IndSoil = 1, 2 + if ( WatExcFieldCap(IndSoil) /= 0.0 ) then + DrainFracTmp(IndSoil) = WatExcFieldCap(IndSoil) / DrainWatTmp + endif + enddo + if ( DrainWatTmp > 0.0 ) then + if ( DrainWatTmp > DrainCoeffTmp ) DrainWatTmp = DrainCoeffTmp + DrainWatVolTot = DrainWatVolTot + DrainWatTmp + do IndSoil = 1, 2 + WatExcFieldCap(IndSoil) = DrainFracTmp(IndSoil) * DrainWatTmp + SoilLiqWater(IndSoil) = SoilLiqWater(IndSoil) - & + (WatExcFieldCap(IndSoil) / (ThicknessSoilLayer(IndSoil) * 1000.0)) + SoilMoisture(IndSoil) = SoilLiqWater(IndSoil) + SoilIce (IndSoil) + enddo + endif + else if ( DrainSoilLayerInd == 2 ) then + do IndSoil = 1, 3 + SoilFieldCapLiq(IndSoil) = SoilMoistureFieldCap(IndSoil) - SoilIce (IndSoil) + WatExcFieldCap(IndSoil) = (SoilLiqWater(IndSoil) - (DrainFacSoilWat*SoilFieldCapLiq(IndSoil))) * & + ThicknessSoilLayer(IndSoil) * 1000.0 + if ( WatExcFieldCap(IndSoil) < 0.0 ) WatExcFieldCap(IndSoil) = 0.0 + DrainWatTmp = DrainWatTmp + WatExcFieldCap(IndSoil) + enddo + do IndSoil = 1, 3 + if ( WatExcFieldCap(IndSoil) /= 0.0 ) then + DrainFracTmp(IndSoil) = WatExcFieldCap(IndSoil) / DrainWatTmp + endif + enddo + if ( DrainWatTmp > 0.0 ) then + if ( DrainWatTmp > DrainCoeffTmp ) DrainWatTmp = DrainCoeffTmp + DrainWatVolTot = DrainWatVolTot + DrainWatTmp + do IndSoil = 1, 3 + WatExcFieldCap(IndSoil) = DrainFracTmp(IndSoil) * DrainWatTmp + SoilLiqWater(IndSoil) = SoilLiqWater(IndSoil) - & + (WatExcFieldCap(IndSoil) / (ThicknessSoilLayer(IndSoil) * 1000.0)) + SoilMoisture(IndSoil) = SoilLiqWater(IndSoil) + SoilIce (IndSoil) + enddo + endif + else if ( DrainSoilLayerInd == 3 ) then + do IndSoil = 2, 3 + SoilFieldCapLiq(IndSoil) = SoilMoistureFieldCap(IndSoil) - SoilIce (IndSoil) + WatExcFieldCap(IndSoil) = (SoilLiqWater(IndSoil) - (DrainFacSoilWat*SoilFieldCapLiq(IndSoil))) * & + ThicknessSoilLayer(IndSoil) * 1000.0 + if ( WatExcFieldCap(IndSoil) < 0.0 ) WatExcFieldCap(IndSoil) = 0.0 + DrainWatTmp = DrainWatTmp + WatExcFieldCap(IndSoil) + enddo + do IndSoil = 2, 3 + if ( WatExcFieldCap(IndSoil) /= 0.0 ) then + DrainFracTmp(IndSoil) = WatExcFieldCap(IndSoil) / DrainWatTmp + endif + enddo + if ( DrainWatTmp > 0.0 ) then + if ( DrainWatTmp > DrainCoeffTmp ) DrainWatTmp = DrainCoeffTmp + DrainWatVolTot = DrainWatVolTot + DrainWatTmp + do IndSoil = 2, 3 + WatExcFieldCap(IndSoil) = DrainFracTmp(IndSoil) * DrainWatTmp + SoilLiqWater(IndSoil) = SoilLiqWater(IndSoil) - & + (WatExcFieldCap(IndSoil) / (ThicknessSoilLayer(IndSoil) * 1000.0)) + SoilMoisture(IndSoil) = SoilLiqWater(IndSoil) + SoilIce (IndSoil) + enddo + endif + else if ( DrainSoilLayerInd == 4 ) then + do IndSoil = 3, 4 + SoilFieldCapLiq(IndSoil) = SoilMoistureFieldCap(IndSoil) - SoilIce (IndSoil) + WatExcFieldCap(IndSoil) = (SoilLiqWater(IndSoil) - (DrainFacSoilWat*SoilFieldCapLiq(IndSoil))) * & + ThicknessSoilLayer(IndSoil) * 1000.0 + if ( WatExcFieldCap(IndSoil) < 0.0 ) WatExcFieldCap(IndSoil) = 0.0 + DrainWatTmp = DrainWatTmp + WatExcFieldCap(IndSoil) + enddo + do IndSoil = 3, 4 + if ( WatExcFieldCap(IndSoil) /= 0.0 ) then + DrainFracTmp(IndSoil) = WatExcFieldCap(IndSoil) / DrainWatTmp + endif + enddo + if ( DrainWatTmp > 0.0 ) then + if ( DrainWatTmp > DrainCoeffTmp ) DrainWatTmp = DrainCoeffTmp + DrainWatVolTot = DrainWatVolTot + DrainWatTmp + do IndSoil = 3, 4 + WatExcFieldCap(IndSoil) = DrainFracTmp(IndSoil) * DrainWatTmp + SoilLiqWater(IndSoil) = SoilLiqWater(IndSoil) - (WatExcFieldCap(IndSoil) / & + (ThicknessSoilLayer(IndSoil) * 1000.0)) + SoilMoisture(IndSoil) = SoilLiqWater(IndSoil) + SoilIce (IndSoil) + enddo + endif + else if ( DrainSoilLayerInd == 5 ) then ! from all the four layers + do IndSoil = 1, 4 + SoilFieldCapLiq(IndSoil) = SoilMoistureFieldCap(IndSoil) - SoilIce (IndSoil) + WatExcFieldCap(IndSoil) = (SoilLiqWater(IndSoil) - (DrainFacSoilWat*SoilFieldCapLiq(IndSoil))) * & + ThicknessSoilLayer(IndSoil) * 1000.0 + if ( WatExcFieldCap(IndSoil) < 0.0 ) WatExcFieldCap(IndSoil) = 0.0 + DrainWatTmp = DrainWatTmp + WatExcFieldCap(IndSoil) + enddo + do IndSoil = 1, 4 + if ( WatExcFieldCap(IndSoil) /= 0.0 ) then + DrainFracTmp(IndSoil) = WatExcFieldCap(IndSoil) / DrainWatTmp + endif + enddo + if ( DrainWatTmp > 0.0 ) then + if ( DrainWatTmp > DrainCoeffTmp ) DrainWatTmp = DrainCoeffTmp + DrainWatVolTot = DrainWatVolTot + DrainWatTmp + do IndSoil = 1, 4 + WatExcFieldCap(IndSoil) = DrainFracTmp(IndSoil) * DrainWatTmp + SoilLiqWater(IndSoil) = SoilLiqWater(IndSoil) - (WatExcFieldCap(IndSoil) / & + (ThicknessSoilLayer(IndSoil) * 1000.0)) + SoilMoisture(IndSoil) = SoilLiqWater(IndSoil) + SoilIce (IndSoil) + enddo + endif + endif + + TileDrain = DrainWatVolTot / SoilTimeStep + + ! deallocate local arrays to avoid memory leaks + deallocate(DrainFracTmp ) + deallocate(SoilFieldCapLiq) + deallocate(WatExcFieldCap ) + + end associate + + end subroutine TileDrainageSimple + +end module TileDrainageSimpleMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/VaporPressureSaturationMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/VaporPressureSaturationMod.F90 new file mode 100644 index 0000000000..09f761f973 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/VaporPressureSaturationMod.F90 @@ -0,0 +1,69 @@ +module VaporPressureSaturationMod + +!!! Calculate saturation vapor pressure and derivative with respect to temperature +!!! using polynomials; over water when t > 0C and over ice when t <= 0C + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine VaporPressureSaturation(T, VapPresSatWat, VapPresSatIce, VapPresSatWatD, VapPresSatIceD) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: ESAT +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + real(kind=kind_noahmp), intent(in) :: T ! air temperature [K] + real(kind=kind_noahmp), intent(out) :: VapPresSatWat ! saturation vapor pressure over water [Pa] + real(kind=kind_noahmp), intent(out) :: VapPresSatIce ! saturation vapor pressure over ice [Pa] + real(kind=kind_noahmp), intent(out) :: VapPresSatWatD ! d(ESAT)/dT over water [Pa/K] + real(kind=kind_noahmp), intent(out) :: VapPresSatIceD ! d(ESAT)/dT over ice [Pa/K] + +! local variable + real(kind=kind_noahmp), parameter :: A0 = 6.107799961 ! coefficients for ESAT over water + real(kind=kind_noahmp), parameter :: A1 = 4.436518521e-01 ! coefficients for ESAT over water + real(kind=kind_noahmp), parameter :: A2 = 1.428945805e-02 ! coefficients for ESAT over water + real(kind=kind_noahmp), parameter :: A3 = 2.650648471e-04 ! coefficients for ESAT over water + real(kind=kind_noahmp), parameter :: A4 = 3.031240396e-06 ! coefficients for ESAT over water + real(kind=kind_noahmp), parameter :: A5 = 2.034080948e-08 ! coefficients for ESAT over water + real(kind=kind_noahmp), parameter :: A6 = 6.136820929e-11 ! coefficients for ESAT over water + real(kind=kind_noahmp), parameter :: B0 = 6.109177956 ! coefficients for ESAT over ice + real(kind=kind_noahmp), parameter :: B1 = 5.034698970e-01 ! coefficients for ESAT over ice + real(kind=kind_noahmp), parameter :: B2 = 1.886013408e-02 ! coefficients for ESAT over ice + real(kind=kind_noahmp), parameter :: B3 = 4.176223716e-04 ! coefficients for ESAT over ice + real(kind=kind_noahmp), parameter :: B4 = 5.824720280e-06 ! coefficients for ESAT over ice + real(kind=kind_noahmp), parameter :: B5 = 4.838803174e-08 ! coefficients for ESAT over ice + real(kind=kind_noahmp), parameter :: B6 = 1.838826904e-10 ! coefficients for ESAT over ice + real(kind=kind_noahmp), parameter :: C0 = 4.438099984e-01 ! coefficients for d(ESAT)/dT over water + real(kind=kind_noahmp), parameter :: C1 = 2.857002636e-02 ! coefficients for d(ESAT)/dT over water + real(kind=kind_noahmp), parameter :: C2 = 7.938054040e-04 ! coefficients for d(ESAT)/dT over water + real(kind=kind_noahmp), parameter :: C3 = 1.215215065e-05 ! coefficients for d(ESAT)/dT over water + real(kind=kind_noahmp), parameter :: C4 = 1.036561403e-07 ! coefficients for d(ESAT)/dT over water + real(kind=kind_noahmp), parameter :: C5 = 3.532421810e-10 ! coefficients for d(ESAT)/dT over water + real(kind=kind_noahmp), parameter :: C6 = -7.090244804e-13 ! coefficients for d(ESAT)/dT over water + real(kind=kind_noahmp), parameter :: D0 = 5.030305237e-01 ! coefficients for d(ESAT)/dT over ice + real(kind=kind_noahmp), parameter :: D1 = 3.773255020e-02 ! coefficients for d(ESAT)/dT over ice + real(kind=kind_noahmp), parameter :: D2 = 1.267995369e-03 ! coefficients for d(ESAT)/dT over ice + real(kind=kind_noahmp), parameter :: D3 = 2.477563108e-05 ! coefficients for d(ESAT)/dT over ice + real(kind=kind_noahmp), parameter :: D4 = 3.005693132e-07 ! coefficients for d(ESAT)/dT over ice + real(kind=kind_noahmp), parameter :: D5 = 2.158542548e-09 ! coefficients for d(ESAT)/dT over ice + real(kind=kind_noahmp), parameter :: D6 = 7.131097725e-12 ! coefficients for d(ESAT)/dT over ice + +! ---------------------------------------------------------------------- + + VapPresSatWat = 100.0 * (A0 + T * (A1 + T * (A2 + T * (A3 + T * ( A4 + T * (A5 + T*A6) ) ) ) ) ) + VapPresSatIce = 100.0 * (B0 + T * (B1 + T * (B2 + T * (B3 + T * ( B4 + T * (B5 + T*B6) ) ) ) ) ) + VapPresSatWatD = 100.0 * (C0 + T * (C1 + T * (C2 + T * (C3 + T * ( C4 + T * (C5 + T*C6) ) ) ) ) ) + VapPresSatIceD = 100.0 * (D0 + T * (D1 + T * (D2 + T * (D3 + T * ( D4 + T * (D5 + T*D6) ) ) ) ) ) + + end subroutine VaporPressureSaturation + +end module VaporPressureSaturationMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/WaterMainGlacierMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/WaterMainGlacierMod.F90 new file mode 100644 index 0000000000..1b11f3cd32 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/WaterMainGlacierMod.F90 @@ -0,0 +1,158 @@ +module WaterMainGlacierMod + +!!! Main glacier water module including all water relevant processes +!!! snowpack water -> ice water -> runoff + + use Machine + use NoahmpVarType + use ConstantDefineMod + use SnowWaterMainGlacierMod, only : SnowWaterMainGlacier + + implicit none + +contains + + subroutine WaterMainGlacier(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: WATER_GLACIER +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: LoopInd ! loop index + real(kind=kind_noahmp) :: WatReplaceSublim ! replacement water due to sublimation of glacier + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilIceTmp ! temporary glacier ice content [m3/m3] + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilLiqWaterTmp ! temporary glacier liquid water content [m3/m3] + +! -------------------------------------------------------------------- + associate( & + OptGlacierTreatment => noahmp%config%nmlist%OptGlacierTreatment ,& ! in, option for glacier treatment + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + MainTimeStep => noahmp%config%domain%MainTimeStep ,& ! in, noahmp main time step [s] + GridIndexI => noahmp%config%domain%GridIndexI ,& ! in, grid index in x-direction + GridIndexJ => noahmp%config%domain%GridIndexJ ,& ! in, grid index in y-direction + VaporizeGrd => noahmp%water%flux%VaporizeGrd ,& ! in, ground vaporize rate total (evap+sublim) [mm/s] + CondenseVapGrd => noahmp%water%flux%CondenseVapGrd ,& ! in, ground vapor condense rate total (dew+frost) [mm/s] + RainfallGround => noahmp%water%flux%RainfallGround ,& ! in, ground surface rain rate [mm/s] + SnowfallGround => noahmp%water%flux%SnowfallGround ,& ! in, snowfall on the ground [mm/s] + SnowfallDensity => noahmp%water%state%SnowfallDensity ,& ! in, bulk density of snowfall [kg/m3] + LatHeatVapGrd => noahmp%energy%state%LatHeatVapGrd ,& ! in, latent heat of vaporization/subli [J/kg], ground + HeatLatentGrd => noahmp%energy%flux%HeatLatentGrd ,& ! inout, total ground latent heat [W/m2] (+ to atm) + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg ,& ! inout, actual number of snow layers (negative) + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! inout, thickness of snow/glacier layers [m] + SnowWaterEquiv => noahmp%water%state%SnowWaterEquiv ,& ! inout, snow water equivalent [mm] + SnowWaterEquivPrev => noahmp%water%state%SnowWaterEquivPrev ,& ! inout, snow water equivalent at last time step [mm] + SoilLiqWater => noahmp%water%state%SoilLiqWater ,& ! inout, glacier water content [m3/m3] + SoilIce => noahmp%water%state%SoilIce ,& ! inout, glacier ice moisture [m3/m3] + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! inout, total glacier water [m3/m3] + PondSfcThinSnwMelt => noahmp%water%state%PondSfcThinSnwMelt ,& ! inout, surface ponding [mm] from snowmelt when thin snow has no layer + WaterHeadSfc => noahmp%water%state%WaterHeadSfc ,& ! inout, surface water head [mm)] + SoilSfcInflow => noahmp%water%flux%SoilSfcInflow ,& ! inout, water input on glacier/soil surface [m/s] + FrostSnowSfcIce => noahmp%water%flux%FrostSnowSfcIce ,& ! inout, snow surface frost rate [mm/s] + SublimSnowSfcIce => noahmp%water%flux%SublimSnowSfcIce ,& ! inout, snow surface sublimation rate [mm/s] + GlacierExcessFlow => noahmp%water%flux%GlacierExcessFlow ,& ! inout, glacier snow excess flow [mm/s] + SnowDepthIncr => noahmp%water%flux%SnowDepthIncr ,& ! out, snow depth increasing rate [m/s] due to snowfall + EvapGroundNet => noahmp%water%flux%EvapGroundNet ,& ! out, net direct ground evaporation [mm/s] + RunoffSurface => noahmp%water%flux%RunoffSurface ,& ! out, surface runoff [mm/s] + RunoffSubsurface => noahmp%water%flux%RunoffSubsurface ,& ! out, subsurface runoff [mm/s] + SnowBotOutflow => noahmp%water%flux%SnowBotOutflow ,& ! out, total water (snowmelt + rain through pack) out of snowpack bottom [mm/s] + PondSfcThinSnwComb => noahmp%water%state%PondSfcThinSnwComb ,& ! out, surface ponding [mm] from liquid in thin snow layer combination + PondSfcThinSnwTrans => noahmp%water%state%PondSfcThinSnwTrans & ! out, surface ponding [mm] from thin snow liquid during transition from multilayer to no layer + ) +! ---------------------------------------------------------------------- + + ! initialize + if (.not. allocated(SoilIceTmp) ) allocate(SoilIceTmp (1:NumSoilLayer)) + if (.not. allocated(SoilLiqWaterTmp)) allocate(SoilLiqWaterTmp(1:NumSoilLayer)) + SoilIceTmp = 0.0 + SoilLiqWaterTmp = 0.0 + GlacierExcessFlow = 0.0 + RunoffSubsurface = 0.0 + RunoffSurface = 0.0 + SnowDepthIncr = 0.0 + + ! prepare for water process + SoilIce(:) = max(0.0, SoilMoisture(:)-SoilLiqWater(:)) + SoilIceTmp = SoilIce + SoilLiqWaterTmp = SoilLiqWater + SnowWaterEquivPrev = SnowWaterEquiv + + ! compute soil/snow surface evap/dew rate based on energy flux + VaporizeGrd = max(HeatLatentGrd/LatHeatVapGrd, 0.0) ! positive part of ground latent heat; Barlage change to ground v3.6 + CondenseVapGrd = abs(min(HeatLatentGrd/LatHeatVapGrd, 0.0)) ! negative part of ground latent heat + EvapGroundNet = VaporizeGrd - CondenseVapGrd + + ! snow height increase + SnowDepthIncr = SnowfallGround / SnowfallDensity + + ! ground sublimation and evaporation + SublimSnowSfcIce = VaporizeGrd + + ! ground frost and dew + FrostSnowSfcIce = CondenseVapGrd + + ! snowpack water processs + call SnowWaterMainGlacier(noahmp) + + ! total surface input water to glacier ice + SoilSfcInflow = (PondSfcThinSnwMelt + PondSfcThinSnwComb + PondSfcThinSnwTrans) / MainTimeStep * 0.001 ! convert units (mm/s -> m/s) + if ( NumSnowLayerNeg == 0 ) then + SoilSfcInflow = SoilSfcInflow + (SnowBotOutflow + RainfallGround) * 0.001 + else + SoilSfcInflow = SoilSfcInflow + SnowBotOutflow * 0.001 + endif +#ifdef WRF_HYDRO + SoilSfcInflow = SoilSfcInflow + WaterHeadSfc / MainTimeStep * 0.001 +#endif + + ! surface runoff + RunoffSurface = SoilSfcInflow * 1000.0 ! mm/s + + ! glacier ice water + if ( OptGlacierTreatment == 1 ) then + WatReplaceSublim = 0.0 + do LoopInd = 1, NumSoilLayer + WatReplaceSublim = WatReplaceSublim + ThicknessSnowSoilLayer(LoopInd)*(SoilIce(LoopInd) - & + SoilIceTmp(LoopInd) + SoilLiqWater(LoopInd) - SoilLiqWaterTmp(LoopInd)) + enddo + WatReplaceSublim = WatReplaceSublim * 1000.0 / MainTimeStep ! convert to [mm/s] + SoilIce = min(1.0, SoilIceTmp) + elseif ( OptGlacierTreatment == 2 ) then + SoilIce = 1.0 + endif + SoilLiqWater = 1.0 - SoilIce + + ! use RunoffSubsurface as a water balancer, GlacierExcessFlow is snow that disappears, WatReplaceSublim is + ! water from below that replaces glacier loss + if ( OptGlacierTreatment == 1 ) then + RunoffSubsurface = GlacierExcessFlow + WatReplaceSublim + elseif ( OptGlacierTreatment == 2 ) then + RunoffSubsurface = GlacierExcessFlow + VaporizeGrd = SublimSnowSfcIce + CondenseVapGrd = FrostSnowSfcIce + endif + + if ( OptGlacierTreatment == 2 ) then + EvapGroundNet = VaporizeGrd - CondenseVapGrd + HeatLatentGrd = EvapGroundNet * LatHeatVapGrd + endif + + if ( maxval(SoilIce) < 0.0001 ) then + write(*,*) "GLACIER HAS MELTED AT: ", GridIndexI, GridIndexJ, " ARE YOU SURE THIS SHOULD BE A GLACIER POINT?" + endif + + ! deallocate local arrays to avoid memory leaks + deallocate(SoilIceTmp ) + deallocate(SoilLiqWaterTmp) + + end associate + + end subroutine WaterMainGlacier + +end module WaterMainGlacierMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/WaterMainMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/WaterMainMod.F90 new file mode 100644 index 0000000000..d737e81e11 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/WaterMainMod.F90 @@ -0,0 +1,209 @@ +module WaterMainMod + +!!! Main water module including all water relevant processes +!!! canopy water -> snowpack water -> soil water -> ground water + + use Machine + use NoahmpVarType + use ConstantDefineMod + use CanopyHydrologyMod, only : CanopyHydrology + use SnowWaterMainMod, only : SnowWaterMain + use IrrigationFloodMod, only : IrrigationFlood + use IrrigationMicroMod, only : IrrigationMicro + use SoilWaterMainMod, only : SoilWaterMain + + implicit none + +contains + + subroutine WaterMain(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: WATER +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: LoopInd ! loop index + +! -------------------------------------------------------------------- + associate( & + MainTimeStep => noahmp%config%domain%MainTimeStep ,& ! in, noahmp main time step [s] + SoilTimeStep => noahmp%config%domain%SoilTimeStep ,& ! in, soil process timestep [s] + SurfaceType => noahmp%config%domain%SurfaceType ,& ! in, surface type 1-soil; 2-lake + FlagCropland => noahmp%config%domain%FlagCropland ,& ! in, flag to identify croplands + FlagUrban => noahmp%config%domain%FlagUrban ,& ! in, urban point flag + FlagSoilProcess => noahmp%config%domain%FlagSoilProcess ,& ! in, flag to calculate soil processes + NumSoilTimeStep => noahmp%config%domain%NumSoilTimeStep ,& ! in, number of timesteps for soil process calculation + VaporizeGrd => noahmp%water%flux%VaporizeGrd ,& ! in, ground vaporize rate total (evap+sublim) [mm/s] + CondenseVapGrd => noahmp%water%flux%CondenseVapGrd ,& ! in, ground vapor condense rate total (dew+frost) [mm/s] + RainfallGround => noahmp%water%flux%RainfallGround ,& ! in, ground surface rain rate [mm/s] + SoilTranspFac => noahmp%water%state%SoilTranspFac ,& ! in, soil water transpiration factor (0 to 1) + WaterStorageLakeMax => noahmp%water%param%WaterStorageLakeMax ,& ! in, maximum lake water storage [mm] + NumSoilLayerRoot => noahmp%water%param%NumSoilLayerRoot ,& ! in, number of soil layers with root present + FlagFrozenGround => noahmp%energy%state%FlagFrozenGround ,& ! in, frozen ground (logical) to define latent heat pathway + LatHeatVapGrd => noahmp%energy%state%LatHeatVapGrd ,& ! in, latent heat of vaporization/subli [J/kg], ground + DensityAirRefHeight => noahmp%energy%state%DensityAirRefHeight ,& ! in, density air [kg/m3] + ExchCoeffShSfc => noahmp%energy%state%ExchCoeffShSfc ,& ! in, exchange coefficient [m/s] for heat, surface, grid mean + SpecHumidityRefHeight => noahmp%forcing%SpecHumidityRefHeight ,& ! in, specific humidity [kg/kg] at reference height + HeatLatentGrd => noahmp%energy%flux%HeatLatentGrd ,& ! in, total ground latent heat [W/m2] (+ to atm) + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg ,& ! inout, actual number of snow layers (negative) + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! inout, thickness of snow/soil layers [m] + SnowWaterEquiv => noahmp%water%state%SnowWaterEquiv ,& ! inout, snow water equivalent [mm] + SnowWaterEquivPrev => noahmp%water%state%SnowWaterEquivPrev ,& ! inout, snow water equivalent at last time step [mm] + SoilLiqWater => noahmp%water%state%SoilLiqWater ,& ! inout, soil water content [m3/m3] + SoilIce => noahmp%water%state%SoilIce ,& ! inout, soil ice moisture [m3/m3] + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! inout, total soil moisture [m3/m3] + WaterStorageLake => noahmp%water%state%WaterStorageLake ,& ! inout, water storage in lake (can be negative) [mm] + PondSfcThinSnwMelt => noahmp%water%state%PondSfcThinSnwMelt ,& ! inout, surface ponding [mm] from snowmelt when thin snow has no layer + WaterHeadSfc => noahmp%water%state%WaterHeadSfc ,& ! inout, surface water head (mm) + IrrigationAmtFlood => noahmp%water%state%IrrigationAmtFlood ,& ! inout, flood irrigation water amount [m] + IrrigationAmtMicro => noahmp%water%state%IrrigationAmtMicro ,& ! inout, micro irrigation water amount [m] + SoilSfcInflow => noahmp%water%flux%SoilSfcInflow ,& ! inout, water input on soil surface [m/s] + EvapSoilSfcLiq => noahmp%water%flux%EvapSoilSfcLiq ,& ! inout, evaporation from soil surface [m/s] + DewSoilSfcLiq => noahmp%water%flux%DewSoilSfcLiq ,& ! inout, soil surface dew rate [mm/s] + FrostSnowSfcIce => noahmp%water%flux%FrostSnowSfcIce ,& ! inout, snow surface frost rate[mm/s] + SublimSnowSfcIce => noahmp%water%flux%SublimSnowSfcIce ,& ! inout, snow surface sublimation rate[mm/s] + TranspWatLossSoil => noahmp%water%flux%TranspWatLossSoil ,& ! inout, transpiration water loss from soil layers [m/s] + GlacierExcessFlow => noahmp%water%flux%GlacierExcessFlow ,& ! inout, glacier excess flow [mm/s] + SoilSfcInflowAcc => noahmp%water%flux%SoilSfcInflowAcc ,& ! inout, accumulated water flux into soil during soil timestep [m/s * dt_soil/dt_main] + EvapSoilSfcLiqAcc => noahmp%water%flux%EvapSoilSfcLiqAcc ,& ! inout, accumulated soil surface evaporation during soil timestep [m/s * dt_soil/dt_main] + TranspWatLossSoilAcc => noahmp%water%flux%TranspWatLossSoilAcc ,& ! inout, accumualted transpiration water loss during soil timestep [m/s * dt_soil/dt_main] + SpecHumidity2mBare => noahmp%energy%state%SpecHumidity2mBare ,& ! out, bare ground 2-m specific humidity [kg/kg] + SpecHumiditySfc => noahmp%energy%state%SpecHumiditySfc ,& ! out, specific humidity at surface [kg/kg] + EvapGroundNet => noahmp%water%flux%EvapGroundNet ,& ! out, net ground (soil/snow) evaporation [mm/s] + Transpiration => noahmp%water%flux%Transpiration ,& ! out, transpiration rate [mm/s] + EvapCanopyNet => noahmp%water%flux%EvapCanopyNet ,& ! out, evaporation of intercepted water [mm/s] + RunoffSurface => noahmp%water%flux%RunoffSurface ,& ! out, surface runoff [mm/dt_soil] per soil timestep + RunoffSubsurface => noahmp%water%flux%RunoffSubsurface ,& ! out, subsurface runoff [mm/dt_soil] per soil timestep + TileDrain => noahmp%water%flux%TileDrain ,& ! out, tile drainage per soil timestep [mm/dt_soil] + SnowBotOutflow => noahmp%water%flux%SnowBotOutflow ,& ! out, total water (snowmelt+rain through pack) out of snow bottom [mm/s] + WaterToAtmosTotal => noahmp%water%flux%WaterToAtmosTotal ,& ! out, total water vapor flux to atmosphere [mm/s] + SoilSfcInflowMean => noahmp%water%flux%SoilSfcInflowMean ,& ! out, mean water flux into soil during soil timestep [m/s] + EvapSoilSfcLiqMean => noahmp%water%flux%EvapSoilSfcLiqMean ,& ! out, mean soil surface evaporation during soil timestep [m/s] + TranspWatLossSoilMean => noahmp%water%flux%TranspWatLossSoilMean ,& ! out, mean transpiration water loss during soil timestep [m/s] + PondSfcThinSnwComb => noahmp%water%state%PondSfcThinSnwComb ,& ! out, surface ponding [mm] from liquid in thin snow layer combination + PondSfcThinSnwTrans => noahmp%water%state%PondSfcThinSnwTrans & ! out, surface ponding [mm] from thin snow liquid during transition from multilayer to no layer + ) +! ---------------------------------------------------------------------- + + ! initialize + TranspWatLossSoil = 0.0 + GlacierExcessFlow = 0.0 + RunoffSubsurface = 0.0 + RunoffSurface = 0.0 + SoilSfcInflow = 0.0 + TileDrain = 0.0 + + ! prepare for water process + SoilIce(:) = max(0.0, SoilMoisture(:)-SoilLiqWater(:)) + SnowWaterEquivPrev = SnowWaterEquiv + ! compute soil/snow surface evap/dew rate based on energy flux + VaporizeGrd = max(HeatLatentGrd/LatHeatVapGrd, 0.0) ! positive part of ground latent heat; Barlage change to ground v3.6 + CondenseVapGrd = abs(min(HeatLatentGrd/LatHeatVapGrd, 0.0)) ! negative part of ground latent heat + EvapGroundNet = VaporizeGrd - CondenseVapGrd + + ! canopy-intercepted snowfall/rainfall, drips, and throughfall + call CanopyHydrology(noahmp) + + ! ground sublimation and evaporation + SublimSnowSfcIce = 0.0 + if ( SnowWaterEquiv > 0.0 ) then + SublimSnowSfcIce = min(VaporizeGrd, SnowWaterEquiv/MainTimeStep) + endif + EvapSoilSfcLiq = VaporizeGrd - SublimSnowSfcIce + + ! ground frost and dew + FrostSnowSfcIce = 0.0 + if ( SnowWaterEquiv > 0.0 ) then + FrostSnowSfcIce = CondenseVapGrd + endif + DewSoilSfcLiq = CondenseVapGrd - FrostSnowSfcIce + + ! snowpack water processs + call SnowWaterMain(noahmp) + + ! treat frozen ground/soil + if ( FlagFrozenGround .eqv. .true. ) then + SoilIce(1) = SoilIce(1) + (DewSoilSfcLiq-EvapSoilSfcLiq) * MainTimeStep / & + (ThicknessSnowSoilLayer(1)*1000.0) + DewSoilSfcLiq = 0.0 + EvapSoilSfcLiq = 0.0 + if ( SoilIce(1) < 0.0 ) then + SoilLiqWater(1) = SoilLiqWater(1) + SoilIce(1) + SoilIce(1) = 0.0 + endif + SoilMoisture(1) = SoilLiqWater(1) + SoilIce(1) + endif + EvapSoilSfcLiq = EvapSoilSfcLiq * 0.001 ! mm/s -> m/s + + ! transpiration mm/s -> m/s + do LoopInd = 1, NumSoilLayerRoot + TranspWatLossSoil(LoopInd) = Transpiration * SoilTranspFac(LoopInd) * 0.001 + enddo + + ! total surface input water to soil mm/s -> m/s + SoilSfcInflow = (PondSfcThinSnwMelt + PondSfcThinSnwComb + PondSfcThinSnwTrans) / & + MainTimeStep * 0.001 ! convert units (mm/s -> m/s) + if ( NumSnowLayerNeg == 0 ) then + SoilSfcInflow = SoilSfcInflow + (SnowBotOutflow + DewSoilSfcLiq + RainfallGround) * 0.001 + else + SoilSfcInflow = SoilSfcInflow + (SnowBotOutflow + DewSoilSfcLiq) * 0.001 + endif + +#ifdef WRF_HYDRO + SoilSfcInflow = SoilSfcInflow + WaterHeadSfc / MainTimeStep * 0.001 +#endif + + ! calculate soil process only at soil timestep + SoilSfcInflowAcc = SoilSfcInflowAcc + SoilSfcInflow + EvapSoilSfcLiqAcc = EvapSoilSfcLiqAcc + EvapSoilSfcLiq + TranspWatLossSoilAcc = TranspWatLossSoilAcc + TranspWatLossSoil + + ! start soil water processes + if ( FlagSoilProcess .eqv. .true. ) then + + ! irrigation: call flood irrigation and add to SoilSfcInflowAcc + if ( (FlagCropland .eqv. .true.) .and. (IrrigationAmtFlood > 0.0) ) call IrrigationFlood(noahmp) + + ! irrigation: call micro irrigation assuming we implement drip in first layer + ! of the Noah-MP. Change layer 1 moisture wrt to MI rate + if ( (FlagCropland .eqv. .true.) .and. (IrrigationAmtMicro > 0.0) ) call IrrigationMicro(noahmp) + + ! compute mean water flux during soil timestep + SoilSfcInflowMean = SoilSfcInflowAcc / NumSoilTimeStep + EvapSoilSfcLiqMean = EvapSoilSfcLiqAcc / NumSoilTimeStep + TranspWatLossSoilMean = TranspWatLossSoilAcc / NumSoilTimeStep + + ! lake/soil water balances + if ( SurfaceType == 2 ) then ! lake + RunoffSurface = 0.0 + if ( WaterStorageLake >= WaterStorageLakeMax ) RunoffSurface = SoilSfcInflowMean*1000.0*SoilTimeStep ! mm per soil timestep + WaterStorageLake = WaterStorageLake + (SoilSfcInflowMean-EvapSoilSfcLiqMean)*1000.0*SoilTimeStep - RunoffSurface ! mm per soil timestep + else ! soil + ! soil water processes (including Top model groundwater and shallow water MMF groundwater) + call SoilWaterMain(noahmp) + endif + + endif ! FlagSoilProcess soil timestep + + ! merge excess glacier snow flow to subsurface runoff + RunoffSubsurface = RunoffSubsurface + GlacierExcessFlow * MainTimeStep ! mm per soil timestep + + ! update surface water vapor flux ! urban - jref + WaterToAtmosTotal = Transpiration + EvapCanopyNet + EvapGroundNet + if ( (FlagUrban .eqv. .true.) ) then + SpecHumiditySfc = WaterToAtmosTotal / (DensityAirRefHeight*ExchCoeffShSfc) + SpecHumidityRefHeight + SpecHumidity2mBare = SpecHumiditySfc + endif + + end associate + + end subroutine WaterMain + +end module WaterMainMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/WaterTableDepthSearchMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/WaterTableDepthSearchMod.F90 new file mode 100644 index 0000000000..5f396bc90c --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/WaterTableDepthSearchMod.F90 @@ -0,0 +1,77 @@ +module WaterTableDepthSearchMod + +!!! Calculate/search water table depth as on WRF-Hydro/NWM + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine WaterTableDepthSearch(noahmp) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: TD_FINDZWAT +! Original code: P. Valayamkunnath (NCAR) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + +! in & out variables + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: IndSoil ! loop index + integer :: IndSatLayer ! check saturated layer + real(kind=kind_noahmp) :: WaterAvailTmp ! temporary available water + real(kind=kind_noahmp) :: WaterTableDepthTmp ! temporary water table depth [m] + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + DepthSoilLayer => noahmp%config%domain%DepthSoilLayer ,& ! in, depth [m] of layer-bottom from soil surface + ThicknessSoilLayer => noahmp%config%domain%ThicknessSoilLayer ,& ! in, soil layer thickness [m] + SoilMoistureFieldCap => noahmp%water%param%SoilMoistureFieldCap ,& ! in, reference soil moisture (field capacity) [m3/m3] + SoilMoistureWilt => noahmp%water%param%SoilMoistureWilt ,& ! in, wilting point soil moisture [m3/m3] + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! inout, total soil moisture [m3/m3] + WaterTableDepth => noahmp%water%state%WaterTableDepth & ! out, water table depth [m] + ) +! ---------------------------------------------------------------------- + + ! initialization + IndSatLayer = 0 ! indicator for sat. layers + WaterAvailTmp = 0.0 ! set water avail for subsfc rtng = 0. + + ! calculate/search for water table depth + do IndSoil = NumSoilLayer, 1, -1 + if ( (SoilMoisture(IndSoil) >= SoilMoistureFieldCap(IndSoil)) .and. & + (SoilMoistureFieldCap(IndSoil) > SoilMoistureWilt(IndSoil)) ) then + if ( (IndSatLayer == (IndSoil+1)) .or. (IndSoil == NumSoilLayer) ) IndSatLayer = IndSoil + endif + enddo + + if ( IndSatLayer /= 0 ) then + if ( IndSatLayer /= 1 ) then ! soil column is partially sat. + WaterTableDepthTmp = -DepthSoilLayer(IndSatLayer-1) + else ! soil column is fully saturated to sfc. + WaterTableDepthTmp = 0.0 + endif + do IndSoil = IndSatLayer, NumSoilLayer + WaterAvailTmp = WaterAvailTmp + & + (SoilMoisture(IndSoil) - SoilMoistureFieldCap(IndSoil)) * ThicknessSoilLayer(IndSoil) + enddo + else ! no saturated layers... + WaterTableDepthTmp = -DepthSoilLayer(NumSoilLayer) + IndSatLayer = NumSoilLayer + 1 + endif + + WaterTableDepth = WaterTableDepthTmp + + end associate + + end subroutine WaterTableDepthSearch + +end module WaterTableDepthSearchMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/WaterTableEquilibriumMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/WaterTableEquilibriumMod.F90 new file mode 100644 index 0000000000..932b94a123 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/WaterTableEquilibriumMod.F90 @@ -0,0 +1,76 @@ +module WaterTableEquilibriumMod + +!!! Calculate equilibrium water table depth (Niu et al., 2005) + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine WaterTableEquilibrium(noahmp) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: ZWTEQ +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: IndSoil ! do-loop index + integer, parameter :: NumSoilFineLy = 100 ! no. of fine soil layers of 6m soil + real(kind=kind_noahmp) :: WatDeficitCoarse ! water deficit from coarse (4-L) soil moisture profile + real(kind=kind_noahmp) :: WatDeficitFine ! water deficit from fine (100-L) soil moisture profile + real(kind=kind_noahmp) :: ThickSoilFineLy ! layer thickness of the 100-L soil layers to 6.0 m + real(kind=kind_noahmp) :: TmpVar ! temporary variable + real(kind=kind_noahmp), dimension(1:NumSoilFineLy) :: DepthSoilFineLy ! layer-bottom depth of the 100-L soil layers to 6.0 m + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + DepthSoilLayer => noahmp%config%domain%DepthSoilLayer ,& ! in, depth [m] of layer-bottom from soil surface + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! in, thickness of snow/soil layers [m] + SoilLiqWater => noahmp%water%state%SoilLiqWater ,& ! in, soil water content [m3/m3] + SoilMoistureSat => noahmp%water%param%SoilMoistureSat ,& ! in, saturated value of soil moisture [m3/m3] + SoilMatPotentialSat => noahmp%water%param%SoilMatPotentialSat ,& ! in, saturated soil matric potential [m] + SoilExpCoeffB => noahmp%water%param%SoilExpCoeffB ,& ! in, soil B parameter + WaterTableDepth => noahmp%water%state%WaterTableDepth & ! out, water table depth [m] + ) +! ---------------------------------------------------------------------- + + DepthSoilFineLy(1:NumSoilFineLy) = 0.0 + WatDeficitCoarse = 0.0 + do IndSoil = 1, NumSoilLayer + WatDeficitCoarse = WatDeficitCoarse + (SoilMoistureSat(1) - SoilLiqWater(IndSoil)) * & + ThicknessSnowSoilLayer(IndSoil) ! [m] + enddo + + ThickSoilFineLy = 3.0 * (-DepthSoilLayer(NumSoilLayer)) / NumSoilFineLy + do IndSoil = 1, NumSoilFineLy + DepthSoilFineLy(IndSoil) = float(IndSoil) * ThickSoilFineLy + enddo + + WaterTableDepth = -3.0 * DepthSoilLayer(NumSoilLayer) - 0.001 ! initial value [m] + + WatDeficitFine = 0.0 + do IndSoil = 1, NumSoilFineLy + TmpVar = 1.0 + (WaterTableDepth - DepthSoilFineLy(IndSoil)) / SoilMatPotentialSat(1) + WatDeficitFine = WatDeficitFine + SoilMoistureSat(1) * & + (1.0 - TmpVar**(-1.0/SoilExpCoeffB(1))) * ThickSoilFineLy + if ( abs(WatDeficitFine-WatDeficitCoarse) <= 0.01 ) then + WaterTableDepth = DepthSoilFineLy(IndSoil) + exit + endif + enddo + + end associate + + end subroutine WaterTableEquilibrium + +end module WaterTableEquilibriumMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/WaterVarInitMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/WaterVarInitMod.F90 new file mode 100644 index 0000000000..a03d8b4f3c --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/WaterVarInitMod.F90 @@ -0,0 +1,310 @@ +module WaterVarInitMod + +!!! Initialize column (1-D) Noah-MP water variables +!!! Water variables should be first defined in WaterVarType.F90 + +! ------------------------ Code history ----------------------------------- +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + use Machine + use NoahmpVarType + + implicit none + +contains + +!=== initialize with default values + subroutine WaterVarInitDefault(noahmp) + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + + associate( & + NumSnowLayerMax => noahmp%config%domain%NumSnowLayerMax ,& + NumSoilLayer => noahmp%config%domain%NumSoilLayer & + ) + + ! water state variables + noahmp%water%state%IrrigationCntSprinkler = undefined_int + noahmp%water%state%IrrigationCntMicro = undefined_int + noahmp%water%state%IrrigationCntFlood = undefined_int + noahmp%water%state%IrrigationFracFlood = undefined_real + noahmp%water%state%IrrigationAmtFlood = undefined_real + noahmp%water%state%IrrigationFracMicro = undefined_real + noahmp%water%state%IrrigationAmtMicro = undefined_real + noahmp%water%state%IrrigationFracSprinkler = undefined_real + noahmp%water%state%IrrigationAmtSprinkler = undefined_real + noahmp%water%state%IrrigationFracGrid = undefined_real + noahmp%water%state%CanopyLiqWater = undefined_real + noahmp%water%state%CanopyIce = undefined_real + noahmp%water%state%CanopyTotalWater = undefined_real + noahmp%water%state%CanopyWetFrac = undefined_real + noahmp%water%state%CanopyIceMax = undefined_real + noahmp%water%state%CanopyLiqWaterMax = undefined_real + noahmp%water%state%SnowfallDensity = undefined_real + noahmp%water%state%SnowDepth = undefined_real + noahmp%water%state%SnowWaterEquiv = undefined_real + noahmp%water%state%SnowWaterEquivPrev = undefined_real + noahmp%water%state%SnowCoverFrac = undefined_real + noahmp%water%state%PondSfcThinSnwMelt = undefined_real + noahmp%water%state%PondSfcThinSnwComb = undefined_real + noahmp%water%state%PondSfcThinSnwTrans = undefined_real + noahmp%water%state%SoilIceMax = undefined_real + noahmp%water%state%SoilLiqWaterMin = undefined_real + noahmp%water%state%SoilSaturateFrac = undefined_real + noahmp%water%state%SoilImpervFracMax = undefined_real + noahmp%water%state%SoilMoistureToWT = undefined_real + noahmp%water%state%SoilTranspFacAcc = undefined_real + noahmp%water%state%SoilWaterRootZone = undefined_real + noahmp%water%state%SoilWaterStress = undefined_real + noahmp%water%state%SoilSaturationExcess = undefined_real + noahmp%water%state%RechargeGwDeepWT = undefined_real + noahmp%water%state%RechargeGwShallowWT = undefined_real + noahmp%water%state%WaterTableHydro = undefined_real + noahmp%water%state%WaterTableDepth = undefined_real + noahmp%water%state%WaterStorageAquifer = undefined_real + noahmp%water%state%WaterStorageSoilAqf = undefined_real + noahmp%water%state%WaterStorageLake = undefined_real + noahmp%water%state%WaterStorageTotBeg = undefined_real + noahmp%water%state%WaterBalanceError = undefined_real + noahmp%water%state%WaterStorageTotEnd = undefined_real + noahmp%water%state%WaterHeadSfc = undefined_real + noahmp%water%state%PrecipAreaFrac = undefined_real + noahmp%water%state%TileDrainFrac = undefined_real + noahmp%water%state%FrozenPrecipFrac = undefined_real + + if ( .not. allocated(noahmp%water%state%IndexPhaseChange) ) & + allocate( noahmp%water%state%IndexPhaseChange(-NumSnowLayerMax+1:NumSoilLayer) ) + if ( .not. allocated(noahmp%water%state%SoilSupercoolWater) ) & + allocate( noahmp%water%state%SoilSupercoolWater(-NumSnowLayerMax+1:NumSoilLayer) ) + if ( .not. allocated(noahmp%water%state%SnowIce) ) & + allocate( noahmp%water%state%SnowIce(-NumSnowLayerMax+1:0) ) + if ( .not. allocated(noahmp%water%state%SnowLiqWater) ) & + allocate( noahmp%water%state%SnowLiqWater(-NumSnowLayerMax+1:0) ) + if ( .not. allocated(noahmp%water%state%SnowIceVol) ) & + allocate( noahmp%water%state%SnowIceVol(-NumSnowLayerMax+1:0) ) + if ( .not. allocated(noahmp%water%state%SnowLiqWaterVol) ) & + allocate( noahmp%water%state%SnowLiqWaterVol(-NumSnowLayerMax+1:0) ) + if ( .not. allocated(noahmp%water%state%SnowIceFracPrev) ) & + allocate( noahmp%water%state%SnowIceFracPrev(-NumSnowLayerMax+1:0) ) + if ( .not. allocated(noahmp%water%state%SnowIceFrac) ) & + allocate( noahmp%water%state%SnowIceFrac(-NumSnowLayerMax+1:0) ) + if ( .not. allocated(noahmp%water%state%SnowEffPorosity) ) & + allocate( noahmp%water%state%SnowEffPorosity(-NumSnowLayerMax+1:0) ) + if ( .not. allocated(noahmp%water%state%SoilLiqWater) ) & + allocate( noahmp%water%state%SoilLiqWater(1:NumSoilLayer) ) + if ( .not. allocated(noahmp%water%state%SoilIce) ) & + allocate( noahmp%water%state%SoilIce(1:NumSoilLayer) ) + if ( .not. allocated(noahmp%water%state%SoilMoisture) ) & + allocate( noahmp%water%state%SoilMoisture(1:NumSoilLayer) ) + if ( .not. allocated(noahmp%water%state%SoilImpervFrac) ) & + allocate( noahmp%water%state%SoilImpervFrac(1:NumSoilLayer) ) + if ( .not. allocated(noahmp%water%state%SoilWatConductivity) ) & + allocate( noahmp%water%state%SoilWatConductivity(1:NumSoilLayer) ) + if ( .not. allocated(noahmp%water%state%SoilWatDiffusivity) ) & + allocate( noahmp%water%state%SoilWatDiffusivity(1:NumSoilLayer) ) + if ( .not. allocated(noahmp%water%state%SoilEffPorosity) ) & + allocate( noahmp%water%state%SoilEffPorosity(1:NumSoilLayer) ) + if ( .not. allocated(noahmp%water%state%SoilIceFrac) ) & + allocate( noahmp%water%state%SoilIceFrac(1:NumSoilLayer) ) + if ( .not. allocated(noahmp%water%state%SoilMoistureEqui) ) & + allocate( noahmp%water%state%SoilMoistureEqui(1:NumSoilLayer) ) + if ( .not. allocated(noahmp%water%state%SoilTranspFac) ) & + allocate( noahmp%water%state%SoilTranspFac(1:NumSoilLayer) ) + if ( .not. allocated(noahmp%water%state%SoilMatPotential) ) & + allocate( noahmp%water%state%SoilMatPotential(1:NumSoilLayer) ) + + noahmp%water%state%IndexPhaseChange (:) = undefined_int + noahmp%water%state%SoilSupercoolWater (:) = undefined_real + noahmp%water%state%SnowIce (:) = undefined_real + noahmp%water%state%SnowLiqWater (:) = undefined_real + noahmp%water%state%SnowIceVol (:) = undefined_real + noahmp%water%state%SnowLiqWaterVol (:) = undefined_real + noahmp%water%state%SnowIceFracPrev (:) = undefined_real + noahmp%water%state%SnowIceFrac (:) = undefined_real + noahmp%water%state%SoilIceFrac (:) = undefined_real + noahmp%water%state%SnowEffPorosity (:) = undefined_real + noahmp%water%state%SoilLiqWater (:) = undefined_real + noahmp%water%state%SoilIce (:) = undefined_real + noahmp%water%state%SoilMoisture (:) = undefined_real + noahmp%water%state%SoilImpervFrac (:) = undefined_real + noahmp%water%state%SoilWatConductivity(:) = undefined_real + noahmp%water%state%SoilWatDiffusivity (:) = undefined_real + noahmp%water%state%SoilEffPorosity (:) = undefined_real + noahmp%water%state%SoilMoistureEqui (:) = undefined_real + noahmp%water%state%SoilTranspFac (:) = undefined_real + noahmp%water%state%SoilMatPotential (:) = undefined_real + + ! water flux variables + noahmp%water%flux%PrecipTotRefHeight = undefined_real + noahmp%water%flux%RainfallRefHeight = undefined_real + noahmp%water%flux%SnowfallRefHeight = undefined_real + noahmp%water%flux%PrecipConvTotRefHeight = undefined_real + noahmp%water%flux%PrecipLargeSclRefHeight = undefined_real + noahmp%water%flux%EvapCanopyNet = undefined_real + noahmp%water%flux%Transpiration = undefined_real + noahmp%water%flux%EvapCanopyLiq = undefined_real + noahmp%water%flux%DewCanopyLiq = undefined_real + noahmp%water%flux%FrostCanopyIce = undefined_real + noahmp%water%flux%SublimCanopyIce = undefined_real + noahmp%water%flux%MeltCanopyIce = undefined_real + noahmp%water%flux%FreezeCanopyLiq = undefined_real + noahmp%water%flux%SnowfallGround = undefined_real + noahmp%water%flux%SnowDepthIncr = undefined_real + noahmp%water%flux%FrostSnowSfcIce = undefined_real + noahmp%water%flux%SublimSnowSfcIce = undefined_real + noahmp%water%flux%RainfallGround = undefined_real + noahmp%water%flux%SnowBotOutflow = undefined_real + noahmp%water%flux%GlacierExcessFlow = undefined_real + noahmp%water%flux%SoilSfcInflow = undefined_real + noahmp%water%flux%RunoffSurface = undefined_real + noahmp%water%flux%RunoffSubsurface = undefined_real + noahmp%water%flux%InfilRateSfc = undefined_real + noahmp%water%flux%EvapSoilSfcLiq = undefined_real + noahmp%water%flux%DrainSoilBot = undefined_real + noahmp%water%flux%RechargeGw = undefined_real + noahmp%water%flux%DischargeGw = undefined_real + noahmp%water%flux%VaporizeGrd = undefined_real + noahmp%water%flux%CondenseVapGrd = undefined_real + noahmp%water%flux%DewSoilSfcLiq = undefined_real + noahmp%water%flux%InterceptCanopyRain = undefined_real + noahmp%water%flux%DripCanopyRain = undefined_real + noahmp%water%flux%ThroughfallRain = undefined_real + noahmp%water%flux%InterceptCanopySnow = undefined_real + noahmp%water%flux%DripCanopySnow = undefined_real + noahmp%water%flux%ThroughfallSnow = undefined_real + noahmp%water%flux%EvapGroundNet = undefined_real + noahmp%water%flux%MeltGroundSnow = undefined_real + noahmp%water%flux%WaterToAtmosTotal = undefined_real + noahmp%water%flux%EvapSoilSfcLiqAcc = undefined_real + noahmp%water%flux%SoilSfcInflowAcc = undefined_real + noahmp%water%flux%SfcWaterTotChgAcc = undefined_real + noahmp%water%flux%PrecipTotAcc = undefined_real + noahmp%water%flux%EvapCanopyNetAcc = undefined_real + noahmp%water%flux%TranspirationAcc = undefined_real + noahmp%water%flux%EvapGroundNetAcc = undefined_real + noahmp%water%flux%EvapSoilSfcLiqMean = undefined_real + noahmp%water%flux%SoilSfcInflowMean = undefined_real + noahmp%water%flux%IrrigationRateFlood = 0.0 + noahmp%water%flux%IrrigationRateMicro = 0.0 + noahmp%water%flux%IrrigationRateSprinkler = 0.0 + noahmp%water%flux%IrriEvapLossSprinkler = 0.0 + noahmp%water%flux%EvapIrriSprinkler = 0.0 + noahmp%water%flux%TileDrain = 0.0 + + if ( .not. allocated(noahmp%water%flux%CompactionSnowAging) ) & + allocate( noahmp%water%flux%CompactionSnowAging(-NumSnowLayerMax+1:0) ) + if ( .not. allocated(noahmp%water%flux%CompactionSnowBurden) ) & + allocate( noahmp%water%flux%CompactionSnowBurden(-NumSnowLayerMax+1:0) ) + if ( .not. allocated(noahmp%water%flux%CompactionSnowMelt) ) & + allocate( noahmp%water%flux%CompactionSnowMelt(-NumSnowLayerMax+1:0) ) + if ( .not. allocated(noahmp%water%flux%CompactionSnowTot) ) & + allocate( noahmp%water%flux%CompactionSnowTot(-NumSnowLayerMax+1:0) ) + if ( .not. allocated(noahmp%water%flux%TranspWatLossSoil) ) & + allocate( noahmp%water%flux%TranspWatLossSoil(1:NumSoilLayer) ) + if ( .not. allocated(noahmp%water%flux%TranspWatLossSoilAcc) ) & + allocate( noahmp%water%flux%TranspWatLossSoilAcc(1:NumSoilLayer) ) + if ( .not. allocated(noahmp%water%flux%TranspWatLossSoilMean) ) & + allocate( noahmp%water%flux%TranspWatLossSoilMean(1:NumSoilLayer) ) + + noahmp%water%flux%CompactionSnowAging (:) = undefined_real + noahmp%water%flux%CompactionSnowBurden (:) = undefined_real + noahmp%water%flux%CompactionSnowMelt (:) = undefined_real + noahmp%water%flux%CompactionSnowTot (:) = undefined_real + noahmp%water%flux%TranspWatLossSoil (:) = undefined_real + noahmp%water%flux%TranspWatLossSoilAcc (:) = undefined_real + noahmp%water%flux%TranspWatLossSoilMean(:) = undefined_real + + ! water parameter variables + noahmp%water%param%DrainSoilLayerInd = undefined_int + noahmp%water%param%TileDrainTubeDepth = undefined_int + noahmp%water%param%NumSoilLayerRoot = undefined_int + noahmp%water%param%IrriStopDayBfHarvest = undefined_int + noahmp%water%param%CanopyLiqHoldCap = undefined_real + noahmp%water%param%SnowCompactBurdenFac = undefined_real + noahmp%water%param%SnowCompactAgingFac1 = undefined_real + noahmp%water%param%SnowCompactAgingFac2 = undefined_real + noahmp%water%param%SnowCompactAgingFac3 = undefined_real + noahmp%water%param%SnowCompactAgingMax = undefined_real + noahmp%water%param%SnowViscosityCoeff = undefined_real + noahmp%water%param%SnowLiqFracMax = undefined_real + noahmp%water%param%SnowLiqHoldCap = undefined_real + noahmp%water%param%SnowLiqReleaseFac = undefined_real + noahmp%water%param%IrriFloodRateFac = undefined_real + noahmp%water%param%IrriMicroRate = undefined_real + noahmp%water%param%SoilInfilMaxCoeff = undefined_real + noahmp%water%param%SoilImpervFracCoeff = undefined_real + noahmp%water%param%InfilFacVic = undefined_real + noahmp%water%param%TensionWatDistrInfl = undefined_real + noahmp%water%param%TensionWatDistrShp = undefined_real + noahmp%water%param%FreeWatDistrShp = undefined_real + noahmp%water%param%InfilHeteroDynVic = undefined_real + noahmp%water%param%InfilCapillaryDynVic = undefined_real + noahmp%water%param%InfilFacDynVic = undefined_real + noahmp%water%param%SoilDrainSlope = undefined_real + noahmp%water%param%TileDrainCoeffSp = undefined_real + noahmp%water%param%DrainFacSoilWat = undefined_real + noahmp%water%param%TileDrainCoeff = undefined_real + noahmp%water%param%DrainDepthToImperv = undefined_real + noahmp%water%param%LateralWatCondFac = undefined_real + noahmp%water%param%TileDrainDepth = undefined_real + noahmp%water%param%DrainTubeDist = undefined_real + noahmp%water%param%DrainTubeRadius = undefined_real + noahmp%water%param%DrainWatDepToImperv = undefined_real + noahmp%water%param%RunoffDecayFac = undefined_real + noahmp%water%param%BaseflowCoeff = undefined_real + noahmp%water%param%GridTopoIndex = undefined_real + noahmp%water%param%SoilSfcSatFracMax = undefined_real + noahmp%water%param%SpecYieldGw = undefined_real + noahmp%water%param%MicroPoreContent = undefined_real + noahmp%water%param%WaterStorageLakeMax = undefined_real + noahmp%water%param%SnoWatEqvMaxGlacier = undefined_real + noahmp%water%param%SoilConductivityRef = undefined_real + noahmp%water%param%SoilInfilFacRef = undefined_real + noahmp%water%param%GroundFrzCoeff = undefined_real + noahmp%water%param%IrriTriggerLaiMin = undefined_real + noahmp%water%param%SoilWatDeficitAllow = undefined_real + noahmp%water%param%IrriFloodLossFrac = undefined_real + noahmp%water%param%IrriSprinklerRate = undefined_real + noahmp%water%param%IrriFracThreshold = undefined_real + noahmp%water%param%IrriStopPrecipThr = undefined_real + noahmp%water%param%SnowfallDensityMax = undefined_real + noahmp%water%param%SnowMassFullCoverOld = undefined_real + noahmp%water%param%SoilMatPotentialWilt = undefined_real + noahmp%water%param%SnowMeltFac = undefined_real + noahmp%water%param%SnowCoverFac = undefined_real + + if ( .not. allocated(noahmp%water%param%SoilMoistureSat) ) & + allocate( noahmp%water%param%SoilMoistureSat(1:NumSoilLayer) ) + if ( .not. allocated(noahmp%water%param%SoilMoistureWilt) ) & + allocate( noahmp%water%param%SoilMoistureWilt(1:NumSoilLayer) ) + if ( .not. allocated(noahmp%water%param%SoilMoistureFieldCap) ) & + allocate( noahmp%water%param%SoilMoistureFieldCap(1:NumSoilLayer) ) + if ( .not. allocated(noahmp%water%param%SoilMoistureDry) ) & + allocate( noahmp%water%param%SoilMoistureDry(1:NumSoilLayer) ) + if ( .not. allocated(noahmp%water%param%SoilWatDiffusivitySat) ) & + allocate( noahmp%water%param%SoilWatDiffusivitySat(1:NumSoilLayer) ) + if ( .not. allocated(noahmp%water%param%SoilWatConductivitySat) ) & + allocate( noahmp%water%param%SoilWatConductivitySat(1:NumSoilLayer) ) + if ( .not. allocated(noahmp%water%param%SoilExpCoeffB) ) & + allocate( noahmp%water%param%SoilExpCoeffB(1:NumSoilLayer) ) + if ( .not. allocated(noahmp%water%param%SoilMatPotentialSat) ) & + allocate( noahmp%water%param%SoilMatPotentialSat(1:NumSoilLayer) ) + + noahmp%water%param%SoilMoistureSat (:) = undefined_real + noahmp%water%param%SoilMoistureWilt (:) = undefined_real + noahmp%water%param%SoilMoistureFieldCap (:) = undefined_real + noahmp%water%param%SoilMoistureDry (:) = undefined_real + noahmp%water%param%SoilWatDiffusivitySat (:) = undefined_real + noahmp%water%param%SoilWatConductivitySat(:) = undefined_real + noahmp%water%param%SoilExpCoeffB (:) = undefined_real + noahmp%water%param%SoilMatPotentialSat (:) = undefined_real + + end associate + + end subroutine WaterVarInitDefault + +end module WaterVarInitMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/WaterVarType.F90 b/src/core_atmosphere/physics/physics_noahmp/src/WaterVarType.F90 new file mode 100644 index 0000000000..2d2f913240 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/WaterVarType.F90 @@ -0,0 +1,244 @@ +module WaterVarType + +!!! Define column (1-D) Noah-MP Water variables +!!! Water variable initialization is done in WaterVarInitMod.F90 + +! ------------------------ Code history ----------------------------------- +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + use Machine + + implicit none + save + private + +!=== define "flux" sub-type of water (water%flux%variable) + type :: flux_type + + real(kind=kind_noahmp) :: RainfallRefHeight ! liquid rainfall rate [mm/s] at reference height + real(kind=kind_noahmp) :: SnowfallRefHeight ! snowfall rate [mm/s] at reference height + real(kind=kind_noahmp) :: PrecipTotRefHeight ! total precipitation [mm/s] at reference height + real(kind=kind_noahmp) :: PrecipConvTotRefHeight ! total convective precipitation [mm/s] at reference height + real(kind=kind_noahmp) :: PrecipLargeSclRefHeight ! large-scale precipitation [mm/s] at reference height + real(kind=kind_noahmp) :: EvapCanopyNet ! net evaporation of canopy intercepted total water [mm/s] + real(kind=kind_noahmp) :: Transpiration ! transpiration rate [mm/s] + real(kind=kind_noahmp) :: EvapCanopyLiq ! canopy liquid water evaporation rate [mm/s] + real(kind=kind_noahmp) :: DewCanopyLiq ! canopy water dew rate [mm/s] + real(kind=kind_noahmp) :: FrostCanopyIce ! canopy ice frost rate [mm/s] + real(kind=kind_noahmp) :: SublimCanopyIce ! canopy ice sublimation rate [mm/s] + real(kind=kind_noahmp) :: MeltCanopyIce ! canopy ice melting rate [mm/s] + real(kind=kind_noahmp) :: FreezeCanopyLiq ! canopy water freezing rate [mm/s] + real(kind=kind_noahmp) :: SnowfallGround ! snowfall on the ground (below canopy) [mm/s] + real(kind=kind_noahmp) :: SnowDepthIncr ! snow depth increasing rate [m/s] due to snowfall + real(kind=kind_noahmp) :: FrostSnowSfcIce ! snow surface ice frost rate[mm/s] + real(kind=kind_noahmp) :: SublimSnowSfcIce ! snow surface ice sublimation rate[mm/s] + real(kind=kind_noahmp) :: RainfallGround ! ground surface rain rate [mm/s] + real(kind=kind_noahmp) :: SnowBotOutflow ! total water (snowmelt + rain through pack) out of snowpack bottom [mm/s] + real(kind=kind_noahmp) :: GlacierExcessFlow ! glacier excess flow [mm/s] + real(kind=kind_noahmp) :: IrrigationRateFlood ! flood irrigation water rate [m/timestep] + real(kind=kind_noahmp) :: IrrigationRateMicro ! micro irrigation water rate [m/timestep] + real(kind=kind_noahmp) :: IrrigationRateSprinkler ! sprinkler irrigation water rate [m/timestep] + real(kind=kind_noahmp) :: IrriEvapLossSprinkler ! loss of irrigation water to evaporation,sprinkler [m/timestep] + real(kind=kind_noahmp) :: SoilSfcInflow ! water input on soil surface [m/s] + real(kind=kind_noahmp) :: RunoffSurface ! surface runoff [mm/s] + real(kind=kind_noahmp) :: RunoffSubsurface ! subsurface runoff [mm/s] + real(kind=kind_noahmp) :: InfilRateSfc ! infiltration rate at surface [m/s] + real(kind=kind_noahmp) :: EvapSoilSfcLiq ! soil surface water evaporation [m/s] + real(kind=kind_noahmp) :: DrainSoilBot ! soil bottom drainage [mm/s] + real(kind=kind_noahmp) :: TileDrain ! tile drainage [mm/s] + real(kind=kind_noahmp) :: RechargeGw ! groundwater recharge rate [mm/s] + real(kind=kind_noahmp) :: DischargeGw ! groundwater discharge rate [mm/s] + real(kind=kind_noahmp) :: VaporizeGrd ! ground vaporize rate total (evap+sublim) [mm/s] + real(kind=kind_noahmp) :: CondenseVapGrd ! ground vapor condense rate total (dew+frost) [mm/s] + real(kind=kind_noahmp) :: DewSoilSfcLiq ! soil surface water dew rate [mm/s] + real(kind=kind_noahmp) :: EvapIrriSprinkler ! evaporation of irrigation water, sprinkler [mm/s] + real(kind=kind_noahmp) :: InterceptCanopyRain ! interception rate for rain [mm/s] + real(kind=kind_noahmp) :: DripCanopyRain ! drip rate for intercepted rain [mm/s] + real(kind=kind_noahmp) :: ThroughfallRain ! throughfall for rain [mm/s] + real(kind=kind_noahmp) :: InterceptCanopySnow ! interception (loading) rate for snowfall [mm/s] + real(kind=kind_noahmp) :: DripCanopySnow ! drip (unloading) rate for intercepted snow [mm/s] + real(kind=kind_noahmp) :: ThroughfallSnow ! throughfall of snowfall [mm/s] + real(kind=kind_noahmp) :: EvapGroundNet ! net ground (soil/snow) evaporation [mm/s] + real(kind=kind_noahmp) :: MeltGroundSnow ! ground snow melting rate [mm/s] + real(kind=kind_noahmp) :: WaterToAtmosTotal ! total surface water vapor flux to atmosphere [mm/s] + real(kind=kind_noahmp) :: EvapSoilSfcLiqAcc ! accumulated soil surface water evaporation per soil timestep [m/s * dt_soil/dt_main] + real(kind=kind_noahmp) :: SoilSfcInflowAcc ! accumulated water input on soil surface per soil timestep [m/s * dt_soil/dt_main] + real(kind=kind_noahmp) :: SfcWaterTotChgAcc ! accumulated snow,soil,canopy water change per soil timestep [mm] + real(kind=kind_noahmp) :: PrecipTotAcc ! accumulated precipitation per soil timestep [mm] + real(kind=kind_noahmp) :: EvapCanopyNetAcc ! accumulated net evaporation of canopy intercepted water per soil timestep [mm] + real(kind=kind_noahmp) :: TranspirationAcc ! accumulated transpiration per soil timestep [mm] + real(kind=kind_noahmp) :: EvapGroundNetAcc ! accumulated net ground (soil/snow) evaporation per soil timestep [mm] + real(kind=kind_noahmp) :: EvapSoilSfcLiqMean ! mean soil surface water evaporation during soil timestep [m/s] + real(kind=kind_noahmp) :: SoilSfcInflowMean ! mean water input on soil surface during soil timestep [m/s] + + real(kind=kind_noahmp), allocatable, dimension(:) :: TranspWatLossSoil ! transpiration water loss from soil layers [m/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: TranspWatLossSoilAcc ! accumulated transpiration water loss from soil per soil timestep [m/s * dt_soil/dt_main] + real(kind=kind_noahmp), allocatable, dimension(:) :: TranspWatLossSoilMean ! mean transpiration water loss from soil during soil timestep [m/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: CompactionSnowAging ! rate of snow compaction due to destructive metamorphism/aging [1/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: CompactionSnowBurden ! rate of snow compaction due to overburden [1/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: CompactionSnowMelt ! rate of snow compaction due to melt [1/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: CompactionSnowTot ! rate of total snow compaction [fraction/timestep] + + end type flux_type + + +!=== define "state" sub-type of water (water%state%variable) + type :: state_type + + integer :: IrrigationCntSprinkler ! irrigation event number, Sprinkler + integer :: IrrigationCntMicro ! irrigation event number, Micro + integer :: IrrigationCntFlood ! irrigation event number, Flood + real(kind=kind_noahmp) :: CanopyTotalWater ! total (liquid+ice) canopy intercepted water [mm] + real(kind=kind_noahmp) :: CanopyWetFrac ! wetted or snowed fraction of the canopy + real(kind=kind_noahmp) :: SnowfallDensity ! bulk density of snowfall (kg/m3) + real(kind=kind_noahmp) :: CanopyLiqWater ! intercepted canopy liquid water [mm] + real(kind=kind_noahmp) :: CanopyIce ! intercepted canopy ice [mm] + real(kind=kind_noahmp) :: CanopyIceMax ! canopy capacity for snow interception [mm] + real(kind=kind_noahmp) :: CanopyLiqWaterMax ! canopy capacity for rain interception [mm] + real(kind=kind_noahmp) :: SnowDepth ! snow depth [m] + real(kind=kind_noahmp) :: SnowWaterEquiv ! snow water equivalent (ice+liquid) [mm] + real(kind=kind_noahmp) :: SnowWaterEquivPrev ! snow water equivalent at previous time step (mm) + real(kind=kind_noahmp) :: PondSfcThinSnwMelt ! surface ponding [mm] from snowmelt when snow has no layer + real(kind=kind_noahmp) :: PondSfcThinSnwComb ! surface ponding [mm] from liquid in thin snow layer combination + real(kind=kind_noahmp) :: PondSfcThinSnwTrans ! surface ponding [mm] from thin snow liquid during transition from multilayer to no layer + real(kind=kind_noahmp) :: IrrigationFracFlood ! fraction of grid under flood irrigation (0 to 1) + real(kind=kind_noahmp) :: IrrigationAmtFlood ! flood irrigation water amount [m] + real(kind=kind_noahmp) :: IrrigationFracMicro ! fraction of grid under micro irrigation (0 to 1) + real(kind=kind_noahmp) :: IrrigationAmtMicro ! micro irrigation water amount [m] + real(kind=kind_noahmp) :: IrrigationFracSprinkler ! fraction of grid under sprinkler irrigation (0 to 1) + real(kind=kind_noahmp) :: IrrigationAmtSprinkler ! sprinkler irrigation water amount [m] + real(kind=kind_noahmp) :: WaterTableDepth ! water table depth [m] + real(kind=kind_noahmp) :: SoilIceMax ! maximum soil ice content [m3/m3] + real(kind=kind_noahmp) :: SoilLiqWaterMin ! minimum soil liquid water content [m3/m3] + real(kind=kind_noahmp) :: SoilSaturateFrac ! fractional saturated area for soil moisture + real(kind=kind_noahmp) :: SoilImpervFracMax ! maximum soil imperviousness fraction + real(kind=kind_noahmp) :: SoilMoistureToWT ! soil moisture between bottom of the soil and the water table + real(kind=kind_noahmp) :: RechargeGwDeepWT ! groundwater recharge to or from the water table when deep [m] + real(kind=kind_noahmp) :: RechargeGwShallowWT ! groundwater recharge to or from shallow water table [m] + real(kind=kind_noahmp) :: SoilSaturationExcess ! saturation excess of the total soil [m] + real(kind=kind_noahmp) :: WaterTableHydro ! water table depth estimated in WRF-Hydro fine grids [m] + real(kind=kind_noahmp) :: TileDrainFrac ! tile drainage fraction + real(kind=kind_noahmp) :: WaterStorageAquifer ! water storage in aquifer [mm] + real(kind=kind_noahmp) :: WaterStorageSoilAqf ! water storage in aquifer + saturated soil [mm] + real(kind=kind_noahmp) :: WaterStorageLake ! water storage in lake (can be negative) [mm] + real(kind=kind_noahmp) :: WaterHeadSfc ! surface water head [mm] + real(kind=kind_noahmp) :: IrrigationFracGrid ! total irrigation fraction from input for a grid + real(kind=kind_noahmp) :: PrecipAreaFrac ! fraction of the gridcell that receives precipitation + real(kind=kind_noahmp) :: SnowCoverFrac ! snow cover fraction + real(kind=kind_noahmp) :: SoilTranspFacAcc ! accumulated soil water transpiration factor (0 to 1) + real(kind=kind_noahmp) :: FrozenPrecipFrac ! fraction of frozen precip in total precipitation + real(kind=kind_noahmp) :: SoilWaterRootZone ! root zone soil water + real(kind=kind_noahmp) :: SoilWaterStress ! soil water stress + real(kind=kind_noahmp) :: WaterStorageTotBeg ! total water storage [mm] at the begining before NoahMP process + real(kind=kind_noahmp) :: WaterBalanceError ! water balance error [mm] + real(kind=kind_noahmp) :: WaterStorageTotEnd ! total water storage [mm] at the end of NoahMP process + + integer , allocatable, dimension(:) :: IndexPhaseChange ! phase change index (0-none;1-melt;2-refreeze) + real(kind=kind_noahmp), allocatable, dimension(:) :: SnowIce ! snow layer ice [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: SnowLiqWater ! snow layer liquid water [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: SnowIceFracPrev ! ice fraction in snow layers at previous timestep + real(kind=kind_noahmp), allocatable, dimension(:) :: SnowIceFrac ! ice fraction in snow layers at current timestep + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilIceFrac ! ice fraction in soil layers at current timestep + real(kind=kind_noahmp), allocatable, dimension(:) :: SnowEffPorosity ! snow effective porosity [m3/m3] + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilLiqWater ! soil liquid moisture [m3/m3] + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilIce ! soil ice moisture [m3/m3] + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilMoisture ! total soil moisture [m3/m3] + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilImpervFrac ! fraction of imperviousness due to frozen soil + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilWatConductivity ! soil hydraulic/water conductivity [m/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilWatDiffusivity ! soil water diffusivity [m2/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilEffPorosity ! soil effective porosity [m3/m3] + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilMoistureEqui ! equilibrium soil water content [m3/m3] + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilTranspFac ! soil water transpiration factor (0 to 1) + real(kind=kind_noahmp), allocatable, dimension(:) :: SnowIceVol ! partial volume of snow ice [m3/m3] + real(kind=kind_noahmp), allocatable, dimension(:) :: SnowLiqWaterVol ! partial volume of snow liquid water [m3/m3] + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilSupercoolWater ! supercooled water in soil [kg/m2] + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilMatPotential ! soil matric potential [m] + + end type state_type + + +!=== define "parameter" sub-type of water (water%param%variable) + type :: parameter_type + + integer :: DrainSoilLayerInd ! starting soil layer for drainage + integer :: TileDrainTubeDepth ! depth [m] of drain tube from the soil surface for simple scheme + integer :: NumSoilLayerRoot ! number of soil layers with root present + integer :: IrriStopDayBfHarvest ! number of days before harvest date to stop irrigation + real(kind=kind_noahmp) :: CanopyLiqHoldCap ! maximum canopy intercepted liquid water per unit veg area index [mm] + real(kind=kind_noahmp) :: SnowCompactBurdenFac ! overburden snow compaction parameter [m3/kg] + real(kind=kind_noahmp) :: SnowCompactAgingFac1 ! snow desctructive metamorphism compaction parameter1 [1/s] + real(kind=kind_noahmp) :: SnowCompactAgingFac2 ! snow desctructive metamorphism compaction parameter2 [1/k] + real(kind=kind_noahmp) :: SnowCompactAgingFac3 ! snow desctructive metamorphism compaction parameter3 + real(kind=kind_noahmp) :: SnowCompactAgingMax ! upper Limit on destructive metamorphism compaction [kg/m3] + real(kind=kind_noahmp) :: SnowViscosityCoeff ! snow viscosity coefficient [kg-s/m2], Anderson1979: 0.52e6~1.38e6 + real(kind=kind_noahmp) :: SnowLiqFracMax ! maximum liquid water fraction in snow + real(kind=kind_noahmp) :: SnowLiqHoldCap ! liquid water holding capacity for snowpack [m3/m3] + real(kind=kind_noahmp) :: SnowLiqReleaseFac ! snowpack water release timescale factor [1/s] + real(kind=kind_noahmp) :: IrriFloodRateFac ! flood irrigation application rate factor + real(kind=kind_noahmp) :: IrriMicroRate ! micro irrigation rate [mm/hr] + real(kind=kind_noahmp) :: SoilInfilMaxCoeff ! parameter to calculate maximum soil infiltration rate + real(kind=kind_noahmp) :: SoilImpervFracCoeff ! parameter to calculate frozen soil impermeable fraction + real(kind=kind_noahmp) :: InfilFacVic ! VIC model infiltration parameter + real(kind=kind_noahmp) :: TensionWatDistrInfl ! Tension water distribution inflection parameter + real(kind=kind_noahmp) :: TensionWatDistrShp ! Tension water distribution shape parameter + real(kind=kind_noahmp) :: FreeWatDistrShp ! Free water distribution shape parameter + real(kind=kind_noahmp) :: InfilHeteroDynVic ! DVIC heterogeniety parameter for infiltration + real(kind=kind_noahmp) :: InfilCapillaryDynVic ! DVIC Mean Capillary Drive (m) for infiltration models + real(kind=kind_noahmp) :: InfilFacDynVic ! DVIC model infiltration parameter + real(kind=kind_noahmp) :: SoilDrainSlope ! slope index for soil drainage + real(kind=kind_noahmp) :: TileDrainCoeffSp ! drainage coefficient [mm d^-1] for simple scheme + real(kind=kind_noahmp) :: DrainFacSoilWat ! drainage factor for soil moisture + real(kind=kind_noahmp) :: TileDrainCoeff ! drainage coefficent [m d^-1] for Hooghoudt scheme + real(kind=kind_noahmp) :: DrainDepthToImperv ! Actual depth of tile drainage to impermeable layer form surface + real(kind=kind_noahmp) :: LateralWatCondFac ! multiplication factor to determine lateral hydraulic conductivity + real(kind=kind_noahmp) :: TileDrainDepth ! Depth of drain [m] for Hooghoudt scheme + real(kind=kind_noahmp) :: DrainTubeDist ! distance between two drain tubes or tiles [m] + real(kind=kind_noahmp) :: DrainTubeRadius ! effective radius of drain tubes [m] + real(kind=kind_noahmp) :: DrainWatDepToImperv ! depth to impervious layer from drain water level [m] + real(kind=kind_noahmp) :: RunoffDecayFac ! runoff decay factor [m^-1] + real(kind=kind_noahmp) :: BaseflowCoeff ! baseflow coefficient [mm/s] + real(kind=kind_noahmp) :: GridTopoIndex ! gridcell mean topgraphic index (global mean) + real(kind=kind_noahmp) :: SoilSfcSatFracMax ! maximum surface soil saturated fraction (global mean) + real(kind=kind_noahmp) :: SpecYieldGw ! specific yield [-] for Niu et al. 2007 groundwater scheme + real(kind=kind_noahmp) :: MicroPoreContent ! microprore content (0.0-1.0), 0.0: close to free drainage + real(kind=kind_noahmp) :: WaterStorageLakeMax ! maximum lake water storage [mm] + real(kind=kind_noahmp) :: SnoWatEqvMaxGlacier ! Maximum SWE allowed at glaciers [mm] + real(kind=kind_noahmp) :: SoilConductivityRef ! Reference Soil Conductivity parameter (used in runoff formulation) + real(kind=kind_noahmp) :: SoilInfilFacRef ! Reference Soil Infiltration Parameter (used in runoff formulation) + real(kind=kind_noahmp) :: GroundFrzCoeff ! Frozen ground parameter to compute frozen soil impervious fraction + real(kind=kind_noahmp) :: IrriTriggerLaiMin ! minimum lai to trigger irrigation + real(kind=kind_noahmp) :: SoilWatDeficitAllow ! management allowable deficit (0-1) + real(kind=kind_noahmp) :: IrriFloodLossFrac ! factor of flood irrigation loss + real(kind=kind_noahmp) :: IrriSprinklerRate ! sprinkler irrigation rate [mm/h] + real(kind=kind_noahmp) :: IrriFracThreshold ! irrigation Fraction threshold in a grid + real(kind=kind_noahmp) :: IrriStopPrecipThr ! precipitation threshold [mm/hr] to stop irrigation trigger + real(kind=kind_noahmp) :: SnowfallDensityMax ! maximum fresh snowfall density [kg/m3] + real(kind=kind_noahmp) :: SnowMassFullCoverOld ! new snow mass to fully cover old snow [mm] + real(kind=kind_noahmp) :: SoilMatPotentialWilt ! soil metric potential for wilting point [m] + real(kind=kind_noahmp) :: SnowMeltFac ! snowmelt m parameter in snow cover fraction calculation + real(kind=kind_noahmp) :: SnowCoverFac ! snow cover factor [m] (originally hard-coded 2.5*z0 in SCF formulation) + + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilMoistureSat ! saturated value of soil moisture [m3/m3] + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilMoistureWilt ! wilting point soil moisture [m3/m3] + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilMoistureFieldCap ! reference soil moisture (field capacity) [m3/m3] + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilMoistureDry ! dry soil moisture threshold [m3/m3] + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilWatDiffusivitySat ! saturated soil hydraulic diffusivity [m2/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilWatConductivitySat ! saturated soil hydraulic conductivity [m/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilExpCoeffB ! soil exponent B paramete + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilMatPotentialSat ! saturated soil matric potential [m] + + end type parameter_type + + +!=== define water type that includes 3 subtypes (flux,state,parameter) + type, public :: water_type + + type(flux_type) :: flux + type(state_type) :: state + type(parameter_type) :: param + + end type water_type + +end module WaterVarType diff --git a/src/core_atmosphere/physics/physics_noahmp/utility/CheckNanMod.F90 b/src/core_atmosphere/physics/physics_noahmp/utility/CheckNanMod.F90 new file mode 100644 index 0000000000..54bb631d30 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/utility/CheckNanMod.F90 @@ -0,0 +1,26 @@ +module CheckNanMod + +!!! Check NaN values + + use Machine, only : kind_noahmp + + implicit none + +contains + + subroutine CheckRealNaN(NumIn, OutVal) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: embedded in NOAHMP_SFLX +! Original code: P. Valayamkunnath (2021) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + real(kind=kind_noahmp), intent(in) :: NumIn + logical , intent(out) :: OutVal + + OutVal = (NumIn /= NumIn) + + end subroutine CheckRealNaN + +end module CheckNanMod diff --git a/src/core_atmosphere/physics/physics_noahmp/utility/ErrorHandleMod.F90 b/src/core_atmosphere/physics/physics_noahmp/utility/ErrorHandleMod.F90 new file mode 100644 index 0000000000..74466efa3c --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/utility/ErrorHandleMod.F90 @@ -0,0 +1,26 @@ +module ErrorHandleMod + +!!! define subroutines handling Noah-MP model errors + + use netcdf + + implicit none + +contains + + subroutine ErrorHandle(status) + +! ------------------------ Code history ----------------------------------- +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + integer, intent (in) :: status + + if(status /= nf90_noerr) then + print *, trim( nf90_strerror(status) ) + stop "Stopped" + endif + + end subroutine ErrorHandle + +end module ErrorHandleMod diff --git a/src/core_atmosphere/physics/physics_noahmp/utility/Machine.F90 b/src/core_atmosphere/physics/physics_noahmp/utility/Machine.F90 new file mode 100644 index 0000000000..aafa838a77 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/utility/Machine.F90 @@ -0,0 +1,22 @@ +module Machine +use mpas_kind_types,only: RKIND + +!!! define machine-related constants and parameters +!!! To define real data type precision, use "-DOUBLE_PREC" in CPPFLAG in user_build_options file +!!! By default, Noah-MP uses single precision + +! ------------------------ Code history ----------------------------------- +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + save + private + + integer, public, parameter :: kind_noahmp = RKIND + integer, public, parameter :: undefined_int = -9999 ! undefined integer for variable initialization + real(kind=kind_noahmp), public, parameter :: undefined_real = -9999.0 ! undefined real for variable initializatin + integer, public, parameter :: undefined_int_neg = -9999 ! undefined integer negative for variable initialization + real(kind=kind_noahmp), public, parameter :: undefined_real_neg = -9999.0 ! undefined real negative for variable initializatin + +end module Machine diff --git a/src/core_atmosphere/physics/physics_noahmp/utility/Makefile b/src/core_atmosphere/physics/physics_noahmp/utility/Makefile new file mode 100644 index 0000000000..c5b5846554 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/utility/Makefile @@ -0,0 +1,30 @@ +.SUFFIXES: .F90 .o + +.PHONY: utility utility_lib + +all: dummy utility + +dummy: + echo "****** compiling physics_noahmp/utility ******" + +OBJS = Machine.o \ + CheckNanMod.o + +utility: $(OBJS) + +utility_lib: + ar -ru ./../../libphys.a $(OBJS) + +# DEPENDENCIES: +CheckNanMod.o: \ + Machine.o + +clean: + $(RM) *.f90 *.o *.mod + @# Certain systems with intel compilers generate *.i files + @# This removes them during the clean process + $(RM) *.i + +.F90.o: + $(FC) $(CPPFLAGS) $(COREDEF) $(FFLAGS) -c $*.F90 $(CPPINCLUDES) $(FCINCLUDES) -I../../../../framework + diff --git a/src/core_atmosphere/physics/physics_wrf/Makefile b/src/core_atmosphere/physics/physics_wrf/Makefile index e9dabbc0ed..0c8f45a3dd 100644 --- a/src/core_atmosphere/physics/physics_wrf/Makefile +++ b/src/core_atmosphere/physics/physics_wrf/Makefile @@ -1,5 +1,7 @@ .SUFFIXES: .F .o +.PHONY: physics_wrf physics_wrf_lib + all: dummy physics_wrf dummy: @@ -20,12 +22,14 @@ OBJS = \ module_cu_kfeta.o \ module_mp_kessler.o \ module_mp_thompson.o \ + module_mp_thompson_aerosols.o \ module_mp_thompson_cldfra3.o \ module_mp_wsm6.o \ module_ra_cam.o \ module_ra_cam_support.o \ module_ra_rrtmg_lw.o \ module_ra_rrtmg_sw.o \ + module_ra_rrtmg_sw_aerosols.o \ module_ra_rrtmg_vinterp.o \ module_sf_bem.o \ module_sf_bep.o \ @@ -43,9 +47,15 @@ OBJS = \ module_sf_urban.o \ bl_mynn_post.o \ bl_mynn_pre.o \ - sf_mynn_pre.o + cu_ntiedtke_post.o \ + cu_ntiedtke_pre.o \ + sf_mynn_pre.o \ + sf_sfclayrev_pre.o + physics_wrf: $(OBJS) + +physics_wrf_lib: ar -ru ./../libphys.a $(OBJS) # DEPENDENCIES: @@ -56,6 +66,10 @@ module_bl_mynn.o: \ module_cam_support.o: \ module_cam_shr_kind_mod.o +module_cu_ntiedtke.o: \ + cu_ntiedtke_post.o \ + cu_ntiedtke_pre.o + module_ra_cam.o: \ module_cam_support.o \ module_ra_cam_support.o @@ -79,6 +93,9 @@ module_sf_bep_bem.o: \ module_sf_mynn.o: \ sf_mynn_pre.o +module_sf_sfclayrev.o: \ + sf_sfclayrev_pre.o + module_sf_noahdrv.o: \ module_sf_bem.o \ module_sf_bep.o \ diff --git a/src/core_atmosphere/physics/physics_wrf/bl_mynn_post.F b/src/core_atmosphere/physics/physics_wrf/bl_mynn_post.F index 096010ed15..ffca583a89 100644 --- a/src/core_atmosphere/physics/physics_wrf/bl_mynn_post.F +++ b/src/core_atmosphere/physics/physics_wrf/bl_mynn_post.F @@ -1,6 +1,6 @@ !================================================================================================================= module bl_mynn_post - use ccpp_kinds,only: kind_phys + use ccpp_kind_types,only: kind_phys implicit none private @@ -57,6 +57,9 @@ subroutine bl_mynn_post_finalize(errmsg,errflg) end subroutine bl_mynn_post_finalize !================================================================================================================= +!>\section arg_table_bl_mynn_post_run +!!\html\include bl_mynn_post_run.html +!! subroutine bl_mynn_post_run(its,ite,kte,f_qc,f_qi,f_qs,delt,qv,qc,qi,qs,dqv,dqc,dqi,dqs,errmsg,errflg) !================================================================================================================= diff --git a/src/core_atmosphere/physics/physics_wrf/bl_mynn_pre.F b/src/core_atmosphere/physics/physics_wrf/bl_mynn_pre.F index dfd5831203..5b76969601 100644 --- a/src/core_atmosphere/physics/physics_wrf/bl_mynn_pre.F +++ b/src/core_atmosphere/physics/physics_wrf/bl_mynn_pre.F @@ -1,6 +1,6 @@ !================================================================================================================= module bl_mynn_pre - use ccpp_kinds,only: kind_phys + use ccpp_kind_types,only: kind_phys implicit none private diff --git a/src/core_atmosphere/physics/physics_wrf/cu_ntiedtke_post.F b/src/core_atmosphere/physics/physics_wrf/cu_ntiedtke_post.F new file mode 100644 index 0000000000..e08c87d9f5 --- /dev/null +++ b/src/core_atmosphere/physics/physics_wrf/cu_ntiedtke_post.F @@ -0,0 +1,120 @@ +!================================================================================================================= + module cu_ntiedtke_post + use ccpp_kind_types,only: kind_phys + + implicit none + private + public:: cu_ntiedtke_post_init, & + cu_ntiedtke_post_finalize, & + cu_ntiedtke_post_run + + + contains + + +!================================================================================================================= +!>\section arg_table_cu_ntiedtke_post_init +!!\html\include cu_ntiedtke_post_init.html +!! + subroutine cu_ntiedtke_post_init(errmsg,errflg) +!================================================================================================================= + +!--- output arguments: + character(len=*),intent(out):: & + errmsg ! output error message (-). + + integer,intent(out):: & + errflg ! output error flag (-). + +!----------------------------------------------------------------------------------------------------------------- + +!--- output error flag and message: + errflg = 0 + errmsg = " " + + end subroutine cu_ntiedtke_post_init + +!================================================================================================================= +!>\section arg_table_cu_ntiedtke_post_finalize +!!\html\include cu_ntiedtke_post_finalize.html +!! + subroutine cu_ntiedtke_post_finalize(errmsg,errflg) +!================================================================================================================= + +!--- output arguments: + character(len=*),intent(out):: & + errmsg ! output error message (-). + + integer,intent(out):: & + errflg ! output error flag (-). + +!----------------------------------------------------------------------------------------------------------------- + +!--- output error flag and message: + errflg = 0 + errmsg = " " + + end subroutine cu_ntiedtke_post_finalize + +!================================================================================================================= +!>\section arg_table_cu_ntiedtke_post_run +!!\html\include cu_ntiedtke_post_run.html +!! + subroutine cu_ntiedtke_post_run(its,ite,kts,kte,stepcu,dt,exner,qv,qc,qi,t,u,v,qvf,qcf,qif,tf,uf,vf,rn,raincv, & + pratec,rthcuten,rqvcuten,rqccuten,rqicuten,rucuten,rvcuten,errmsg,errflg) +!================================================================================================================= + +!--- input arguments: + integer,intent(in):: its,ite,kts,kte + integer,intent(in):: stepcu + + real(kind=kind_phys),intent(in):: dt + real(kind=kind_phys),intent(in),dimension(its:ite):: rn + real(kind=kind_phys),intent(in),dimension(its:ite,kts:kte):: exner,qv,qc,qi,t,u,v,qvf,qcf,qif,tf,uf,vf + +!--- inout arguments: + real(kind=kind_phys),intent(inout),dimension(its:ite):: raincv,pratec + real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte):: rqvcuten,rqccuten,rqicuten + real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte):: rthcuten,rucuten,rvcuten + +!--- output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!--- local variables and arrays: + integer:: i,k,pp,zz + + real(kind=kind_phys):: delt,rdelt + +!----------------------------------------------------------------------------------------------------------------- + + delt = dt*stepcu + rdelt = 1./delt + + do i = its,ite + raincv(i) = rn(i)/stepcu + pratec(i) = rn(i)/(stepcu*dt) + enddo + + pp = 0 + do k = kts,kte + zz = kte - pp + do i = its,ite + rthcuten(i,k) = (tf(i,zz)-t(i,k))/exner(i,k)*rdelt + rqvcuten(i,k) = (qvf(i,zz)-qv(i,k))*rdelt + rqccuten(i,k) = (qcf(i,zz)-qc(i,k))*rdelt + rqicuten(i,k) = (qif(i,zz)-qi(i,k))*rdelt + rucuten(i,k) = (uf(i,zz)-u(i,k))*rdelt + rvcuten(i,k) = (vf(i,zz)-v(i,k))*rdelt + enddo + pp = pp + 1 + enddo + + errmsg = 'cu_ntiedtke_post_run OK' + errflg = 0 + + end subroutine cu_ntiedtke_post_run + +!================================================================================================================= + end module cu_ntiedtke_post +!================================================================================================================= diff --git a/src/core_atmosphere/physics/physics_wrf/cu_ntiedtke_pre.F b/src/core_atmosphere/physics/physics_wrf/cu_ntiedtke_pre.F new file mode 100644 index 0000000000..84d2d89a54 --- /dev/null +++ b/src/core_atmosphere/physics/physics_wrf/cu_ntiedtke_pre.F @@ -0,0 +1,187 @@ +!================================================================================================================= + module cu_ntiedtke_pre + use ccpp_kind_types,only: kind_phys + + implicit none + private + public:: cu_ntiedtke_pre_init, & + cu_ntiedtke_pre_finalize, & + cu_ntiedtke_pre_run + + + contains + + +!================================================================================================================= +!>\section arg_table_cu_ntiedtke_pre_init +!!\html\include cu_ntiedtke_pre_init.html +!! + subroutine cu_ntiedtke_pre_init(errmsg,errflg) +!================================================================================================================= + +!--- output arguments: + character(len=*),intent(out):: & + errmsg ! output error message (-). + + integer,intent(out):: & + errflg ! output error flag (-). + +!----------------------------------------------------------------------------------------------------------------- + +!--- output error flag and message: + errflg = 0 + errmsg = " " + + end subroutine cu_ntiedtke_pre_init + +!================================================================================================================= +!>\section arg_table_cu_ntiedtke_pre_finalize +!!\html\include cu_ntiedtke_pre_finalize.html +!! + subroutine cu_ntiedtke_pre_finalize(errmsg,errflg) +!================================================================================================================= + +!--- output arguments: + character(len=*),intent(out):: & + errmsg ! output error message (-). + + integer,intent(out):: & + errflg ! output error flag (-). + +!----------------------------------------------------------------------------------------------------------------- + +!--- output error flag and message: + errflg = 0 + errmsg = " " + + end subroutine cu_ntiedtke_pre_finalize + +!================================================================================================================= +!>\section arg_table_cu_ntiedtke_pre_run +!!\html\include cu_ntiedtke_pre_run.html +!! + subroutine cu_ntiedtke_pre_run(its,ite,kts,kte,im,kx,kx1,itimestep,stepcu,dt,grav,xland,dz,pres,presi, & + t,rho,qv,qc,qi,u,v,w,qvften,thften,qvftenz,thftenz,slimsk,delt,prsl,ghtl, & + tf,qvf,qcf,qif,uf,vf,prsi,ghti,omg,errmsg,errflg) +!================================================================================================================= + +!--- input arguments: + integer,intent(in):: its,ite,kts,kte + integer,intent(in):: itimestep + integer,intent(in):: stepcu + + real(kind=kind_phys),intent(in):: dt,grav + real(kind=kind_phys),intent(in),dimension(its:ite):: xland + real(kind=kind_phys),intent(in),dimension(its:ite,kts:kte):: dz,pres,t,rho,qv,qc,qi,u,v + real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte):: qvften,thften + real(kind=kind_phys),intent(in),dimension(its:ite,kts:kte+1):: presi,w + +!--- inout arguments: + integer,intent(inout):: im,kx,kx1 + integer,intent(inout),dimension(its:ite):: slimsk + + real(kind=kind_phys),intent(inout):: delt + real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte):: tf,qvf,qcf,qif,uf,vf + real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte):: ghtl,omg,prsl + real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte):: qvftenz,thftenz + real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte+1):: ghti,prsi + +!--- output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!--- local variables and arrays: + integer:: i,k,pp,zz + + real(kind=kind_phys),dimension(its:ite,kts:kte):: zl,dot + real(kind=kind_phys),dimension(its:ite,kts:kte+1):: zi + +!----------------------------------------------------------------------------------------------------------------- + + im = ite-its+1 + kx = kte-kts+1 + kx1 = kx+1 + + delt = dt*stepcu + + do i = its,ite + slimsk(i) = (abs(xland(i)-2.)) + enddo + + k = kts + do i = its,ite + zi(i,k) = 0. + enddo + do k = kts,kte + do i = its,ite + zi(i,k+1) = zi(i,k)+dz(i,k) + enddo + enddo + do k = kts,kte + do i = its,ite + zl(i,k) = 0.5*(zi(i,k)+zi(i,k+1)) + dot(i,k) = -0.5*grav*rho(i,k)*(w(i,k)+w(i,k+1)) + enddo + enddo + + pp = 0 + do k = kts,kte+1 + zz = kte + 1 - pp + do i = its,ite + ghti(i,zz) = zi(i,k) + prsi(i,zz) = presi(i,k) + enddo + pp = pp + 1 + enddo + pp = 0 + do k = kts,kte + zz = kte-pp + do i = its,ite + ghtl(i,zz) = zl(i,k) + omg(i,zz) = dot(i,k) + prsl(i,zz) = pres(i,k) + enddo + pp = pp + 1 + enddo + + pp = 0 + do k = kts,kte + zz = kte-pp + do i = its,ite + tf(i,zz) = t(i,k) + qvf(i,zz) = qv(i,k) + qcf(i,zz) = qc(i,k) + qif(i,zz) = qi(i,k) + uf(i,zz) = u(i,k) + vf(i,zz) = v(i,k) + enddo + pp = pp + 1 + enddo + + if(itimestep == 1) then + do k = kts,kte + do i = its,ite + qvftenz(i,k) = 0. + thftenz(i,k) = 0. + enddo + enddo + else + pp = 0 + do k = kts,kte + zz = kte-pp + do i = its,ite + qvftenz(i,zz) = qvften(i,k) + thftenz(i,zz) = thften(i,k) + enddo + pp = pp + 1 + enddo + endif + + errmsg = 'cu_ntiedtke_pre_run OK' + errflg = 0 + + end subroutine cu_ntiedtke_pre_run + +!================================================================================================================= + end module cu_ntiedtke_pre +!================================================================================================================= diff --git a/src/core_atmosphere/physics/physics_wrf/module_bl_ysu.F b/src/core_atmosphere/physics/physics_wrf/module_bl_ysu.F index d516bf1b4f..cf7340aaf8 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_bl_ysu.F +++ b/src/core_atmosphere/physics/physics_wrf/module_bl_ysu.F @@ -1,10 +1,10 @@ #define NEED_B4B_DURING_CCPP_TESTING 1 !================================================================================================================= module module_bl_ysu - use mpas_log use mpas_kind_types,only: kind_phys => RKIND use bl_ysu + implicit none private public:: ysu @@ -232,8 +232,11 @@ subroutine ysu(u3d,v3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d, & !temporary allocation of local chemical species and/or passive tracers that are vertically- !mixed in subroutine bl_ysu_run: + logical:: l_topdown_pblmix + integer, parameter :: nmix = 0 integer :: n + real(kind=kind_phys), dimension(ims:ime,kms:kme,jms:jme,nmix):: qmix real(kind=kind_phys), dimension(ims:ime,kms:kme,jms:jme,nmix):: rqmixblten @@ -304,9 +307,13 @@ subroutine ysu(u3d,v3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d, & integer, dimension(its:ite) :: & kpbl2d_hv - real, dimension(its:ite) :: & + real(kind=kind_phys), dimension(its:ite) :: & frcurb_hv +!----------------------------------------------------------------------------------------------------------------- + + l_topdown_pblmix = .false. + if(ysu_topdown_pblmix .eq. 1) l_topdown_pblmix = .true. do j = jts,jte ! @@ -417,7 +424,7 @@ subroutine ysu(u3d,v3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d, & ,u10=u10_hv,v10=v10_hv & ,uox=uoce_hv,vox=voce_hv & ,rthraten=rthraten_hv & - ,ysu_topdown_pblmix=ysu_topdown_pblmix & + ,ysu_topdown_pblmix=l_topdown_pblmix & ,ctopo=ctopo_hv,ctopo2=ctopo2_hv & ,a_u=a_u_hv,a_v=a_v_hv,a_t=a_t_hv,a_q=a_q_hv,a_e=a_e_hv & ,b_u=b_u_hv,b_v=b_v_hv,b_t=b_t_hv,b_q=b_q_hv,b_e=b_e_hv & diff --git a/src/core_atmosphere/physics/physics_wrf/module_cu_ntiedtke.F b/src/core_atmosphere/physics/physics_wrf/module_cu_ntiedtke.F index b36cb5e610..806de7c518 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_cu_ntiedtke.F +++ b/src/core_atmosphere/physics/physics_wrf/module_cu_ntiedtke.F @@ -1,12 +1,11 @@ !================================================================================================================= module module_cu_ntiedtke - use mpas_kind_types,only: RKIND,StrKIND - - use cu_ntiedtke,only: cu_ntiedtke_run, & - cu_ntiedtke_init, & - cu_ntiedtke_timestep_init, & - cu_ntiedtke_timestep_final + use mpas_kind_types,only: kind_phys => RKIND + use cu_ntiedtke,only: cu_ntiedtke_run, & + cu_ntiedtke_init use cu_ntiedtke_common + use cu_ntiedtke_post,only: cu_ntiedtke_post_run + use cu_ntiedtke_pre,only: cu_ntiedtke_pre_run implicit none private @@ -94,7 +93,7 @@ subroutine cu_ntiedtke_driver( & integer,intent(in):: itimestep,stepcu - real(kind=RKIND),intent(in):: cp,grav,rd,rv,xlf,xls,xlv + real(kind=kind_phys),intent(in):: cp,grav,rd,rv,xlf,xls,xlv real(kind=kind_phys),intent(in):: dt @@ -204,7 +203,7 @@ subroutine cu_ntiedtke_driver( & enddo enddo - call cu_ntiedtke_timestep_init( & + call cu_ntiedtke_pre_run( & its = its , ite = ite , kts = kts , kte = kte , & im = im , kx = kx , kx1 = kx1 , itimestep = itimestep , & stepcu = stepcu , dt = dt , grav = grav , xland = xland_hv , & @@ -216,7 +215,7 @@ subroutine cu_ntiedtke_driver( & qvf = qvf , qcf = qcf , qif = qif , uf = uf , & vf = vf , prsi = prsi , ghti = ghti , omg = omg , & errmsg = errmsg , errflg = errflg & - ) + ) call cu_ntiedtke_run( & pu = uf , pv = vf , pt = tf , pqv = qvf , & @@ -227,7 +226,7 @@ subroutine cu_ntiedtke_driver( & dt = delt , dx = dx_hv , errmsg = errmsg , errflg = errflg & ) - call cu_ntiedtke_timestep_final( & + call cu_ntiedtke_post_run( & its = its , ite = ite , kts = kts , kte = kte , & stepcu = stepcu , dt = dt , exner = pi_hv , qv = qv_hv , & qc = qc_hv , qi = qi_hv , t = t_hv , u = u_hv , & @@ -236,7 +235,7 @@ subroutine cu_ntiedtke_driver( & raincv = raincv_hv , pratec = pratec_hv , rthcuten = rthcuten_hv , rqvcuten = rqvcuten_hv , & rqccuten = rqccuten_hv , rqicuten = rqicuten_hv , rucuten = rucuten_hv , rvcuten = rvcuten_hv , & errmsg = errmsg , errflg = errflg & - ) + ) do i = its,ite raincv(i,j) = raincv_hv(i) diff --git a/src/core_atmosphere/physics/physics_wrf/module_mp_thompson.F b/src/core_atmosphere/physics/physics_wrf/module_mp_thompson.F index 9abf279048..8e24340501 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_mp_thompson.F +++ b/src/core_atmosphere/physics/physics_wrf/module_mp_thompson.F @@ -1,4 +1,7 @@ !================================================================================================================= +!reference: WRF-v4.1.4 +!Laura D. Fowler (laura@ucar.edu) / 2020-01-10. + !module_mp_thompson was originally copied from./phys/module_mp_thompson.F from WRF version 3.8. Modifications made !to the original sourcecode are mostly confined to subroutine thompson_init. !Laura D. Fowler (laura@ucar.edu) / 2016-06-04. @@ -11,7 +14,18 @@ ! Laura D. Fowler (laura@ucar.edu) / 2016-10-29. ! * in subroutine mp_gt_driver, moved the initialization of variables Nt_c and mu_c ! before initialization of local mixing ratios and number concentrations. -! Laura D. Fowler (lara@ucar.edu) / 2916-12-30. +! Laura D. Fowler (laura@ucar.edu) / 2016-12-30. +! * in subroutine freezeH2O, modified the calculation of the variable prob, following +! Greg Thompson for the release of WRF version 3.9.0. +! Laura D. Fowler (laura@ucar.edu) / 2017-03-27. +! * in subroutine mp_gt_driver, added the variables vqr, vqi, vqs, and vqg to output the +! mean mass-weighted fall velocities of rain, cloud ice, snow, and graupel to compute +! diagnostics of lightning flash rates. +! Laura D. Fowler (laura@ucar.edu) / 2017-04-19. +! * in subroutine mp_gt_driver, changed the declarations of arrays vqg1d, vqid1,vqr1d, and vqs1d, +! from (kts:kte) to (kts:kte+1) to match the dimensions of arrays vtgk, vtik, vtsk, and vtrk, in +! subroutine mp_thompson. +! Laura D. Fowler (laura@ucar.edu) / 2017-08-31. !+---+-----------------------------------------------------------------+ @@ -52,7 +66,7 @@ !.. Remaining values should probably be left alone. !.. !..Author: Greg Thompson, NCAR-RAL, gthompsn@ucar.edu, 303-497-2805 -!..Last modified: 01 Aug 2016 Aerosol additions to v3.5.1 code 9/2013 +!..Last modified: 24 Jan 2018 Aerosol additions to v3.5.1 code 9/2013 !.. Cloud fraction additions 11/2014 part of pre-v3.7 !+---+-----------------------------------------------------------------+ !wrft:model_layer:physics @@ -60,6 +74,7 @@ ! MODULE module_mp_thompson + use mpas_log use mpas_kind_types use mpas_atmphys_functions, only: gammp,wgamma,rslf,rsif use mpas_atmphys_utilities @@ -90,6 +105,8 @@ MODULE module_mp_thompson !.. 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. +!.. MPAS: Nt_c is initialized to 100.E6 over oceans and 300.E6 over land as +! a function of landmask in subroutine init_thompson_clouddroplets_forMPAS. ! REAL, PARAMETER, PRIVATE:: Nt_c = 100.E6 REAL, PARAMETER, PRIVATE:: Nt_c_max = 1999.E6 REAL, PRIVATE:: Nt_c @@ -97,10 +114,12 @@ MODULE module_mp_thompson !..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 +!.. MPAS: naIN0, naIN1, naCCN0, and naCCN1 are used in init_thompson_aerosols_forMPAS +!.. for initialization of nwfa. and nifa. + REAL, PARAMETER, PUBLIC:: naIN0 = 1.5E6 + REAL, PARAMETER, PUBLIC:: naIN1 = 0.5E6 + REAL, PARAMETER, PUBLIC:: naCCN0 = 300.0E6 + REAL, PARAMETER, PUBLIC:: naCCN1 = 50.0E6 !..Generalized gamma distributions for rain, graupel and cloud ice. !.. N(D) = N_0 * D**mu * exp(-lamda*D); mu=0 is exponential. @@ -235,12 +254,12 @@ MODULE module_mp_thompson 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, PARAMETER, PUBLIC:: ntb_arc = 7 + INTEGER, PARAMETER, PUBLIC:: ntb_arw = 9 + INTEGER, PARAMETER, PUBLIC:: ntb_art = 7 + INTEGER, PARAMETER, PUBLIC:: ntb_arr = 5 + INTEGER, PARAMETER, PUBLIC:: ntb_ark = 4 + INTEGER, PARAMETER, PUBLIC:: ntb_IN = 55 INTEGER, PRIVATE:: niIN2 DOUBLE PRECISION, DIMENSION(nbins+1):: xDx @@ -979,17 +998,18 @@ END SUBROUTINE thompson_init !+---+-----------------------------------------------------------------+ !..This is a wrapper routine designed to transfer values from 3D to 1D. !+---+-----------------------------------------------------------------+ - SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & - nwfa, nifa, nwfa2d, & - th, pii, p, w, dz, dt_in, itimestep, & - RAINNC, RAINNCV, & - SNOWNC, SNOWNCV, & - GRAUPELNC, GRAUPELNCV, SR, & + SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & + nwfa, nifa, nwfa2d, nifa2d, & + th, pii, p, w, dz, dt_in, itimestep, & + RAINNC, RAINNCV, & + SNOWNC, SNOWNCV, & + GRAUPELNC, GRAUPELNCV, SR, & + rainprod, evapprod, & refl_10cm, diagflag, do_radar_ref, & re_cloud, re_ice, re_snow, & has_reqc, has_reqi, has_reqs, & #if defined(mpas) - ntc,muc,rainprod,evapprod, & + ntc,muc, & #endif ids,ide, jds,jde, kds,kde, & ! domain dims ims,ime, jms,jme, kms,kme, & ! memory dims @@ -1005,7 +1025,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & qv, qc, qr, qi, qs, qg, ni, nr, th REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT):: & nc, nwfa, nifa - REAL, DIMENSION(ims:ime, jms:jme), OPTIONAL, INTENT(IN):: nwfa2d + REAL, DIMENSION(ims:ime, jms:jme), OPTIONAL, INTENT(IN):: nwfa2d, nifa2d 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 @@ -1015,11 +1035,11 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & RAINNC, RAINNCV, SR REAL, DIMENSION(ims:ime, jms:jme), OPTIONAL, INTENT(INOUT):: & SNOWNC, SNOWNCV, GRAUPELNC, GRAUPELNCV + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT):: & + rainprod,evapprod #if defined(mpas) REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN):: & ntc,muc - REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: & - rainprod,evapprod REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT), OPTIONAL:: & refl_10cm #else @@ -1035,10 +1055,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & nr1d, nc1d, nwfa1d, nifa1d, & t1d, p1d, w1d, dz1d, rho, dBZ REAL, DIMENSION(kts:kte):: re_qc1d, re_qi1d, re_qs1d -#if defined(mpas) - REAL, DIMENSION(kts:kte):: & - rainprod1d, evapprod1d -#endif + REAL, DIMENSION(kts:kte):: rainprod1d, evapprod1d REAL, DIMENSION(its:ite, jts:jte):: pcp_ra, pcp_sn, pcp_gr, pcp_ic REAL:: dt, pptrain, pptsnow, pptgraul, pptice REAL:: qc_max, qr_max, qs_max, qi_max, qg_max, ni_max, nr_max @@ -1050,7 +1067,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & INTEGER:: i_start, j_start, i_end, j_end LOGICAL, OPTIONAL, INTENT(IN) :: diagflag INTEGER, OPTIONAL, INTENT(IN) :: do_radar_ref - CHARACTER*256:: mp_debug +! CHARACTER*256:: mp_debug !+---+ @@ -1098,9 +1115,9 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & kmax_qg = 0 kmax_ni = 0 kmax_nr = 0 - do i = 1, 256 - mp_debug(i:i) = char(0) - enddo +! 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 @@ -1128,6 +1145,11 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & Nt_c = ntc(i,j) mu_c = muc(i,j) #endif + do k = kts,kte + rainprod1d(k) = 0. + evapprod1d(k) = 0. + enddo + do k = kts, kte t1d(k) = th(i,k,j)*pii(i,k,j) p1d(k) = p(i,k,j) @@ -1141,6 +1163,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & 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 @@ -1151,7 +1174,6 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & nwfa1 = nwfa2d(i,j) else do k = kts, kte - rho(k) = 0.622*p1d(k)/(R*t1d(k)*(qv1d(k)+0.622)) nc1d(k) = Nt_c/rho(k) nwfa1d(k) = 11.1E6/rho(k) nifa1d(k) = naIN1*0.01/rho(k) @@ -1161,10 +1183,8 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & call mp_thompson(qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & nr1d, nc1d, nwfa1d, nifa1d, t1d, p1d, w1d, dz1d, & - pptrain, pptsnow, pptgraul, pptice, & -#if defined(mpas) - rainprod1d, evapprod1d, & -#endif + pptrain, pptsnow, pptgraul, pptice, & + rainprod1d, evapprod1d, & kts, kte, dt, i, j) pcp_ra(i,j) = pptrain @@ -1191,6 +1211,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & if (is_aerosol_aware) then !-GT nwfa1d(kts) = nwfa1 nwfa1d(kts) = nwfa1d(kts) + nwfa2d(i,j)*dt_in + nifa1d(kts) = nifa1d(kts) + nifa2d(i,j)*dt_in do k = kts, kte nc(i,k,j) = nc1d(k) @@ -1219,8 +1240,10 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & 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 mpas_log_write('--- WARNING, negative qc $r at i,j,k = $i $i $i ', & + realArgs=(/qc1d(k)/),intArgs=(/i,j,k/)) +! 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 @@ -1229,8 +1252,10 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & 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 mpas_log_write('--- WARNING, negative qr $r at i,j,k = $i $i $i ', & + realArgs=(/qr1d(k)/),intArgs=(/i,j,k/)) +! 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 @@ -1239,8 +1264,10 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & 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 mpas_log_write('--- WARNING, negative nr $r at i,j,k = $i $i $i ', & + realArgs=(/nr1d(k)/),intArgs=(/i,j,k/)) +! 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 @@ -1249,8 +1276,10 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & 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 mpas_log_write('--- WARNING, negative qs $r at i,j,k = $i $i $i ', & + realArgs=(/qs1d(k)/),intArgs=(/i,j,k/)) +! 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 @@ -1259,8 +1288,10 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & 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 mpas_log_write('--- WARNING, negative qi $r at i,j,k = $i $i $i ', & + realArgs=(/qi1d(k)/),intArgs=(/i,j,k/)) +! 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 @@ -1269,8 +1300,10 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & 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 mpas_log_write('--- WARNING, negative qg $r at i,j,k = $i $i $i ', & + realArgs=(/qg1d(k)/),intArgs=(/i,j,k/)) +! 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 @@ -1279,21 +1312,31 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & 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 mpas_log_write('--- WARNING, negative qni $r at i,j,k = $i $i $i ', & + realArgs=(/ni1d(k)/),intArgs=(/i,j,k/)) +! 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) + call mpas_log_write('--- WARNING, negative qv $r at i,j,k = $i $i $i ', & + realArgs=(/qv1d(k)/),intArgs=(/i,j,k/)) 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) + call mpas_log_write('-- below and above are: $r $r',realArgs=(/qv(i,k-1,j), qv(i,k+1,j)/)) 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 +! 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 @@ -1326,20 +1369,20 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & 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, ')' +! 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 +! do i = 1, 256 +! mp_debug(i:i) = char(0) +! enddo END SUBROUTINE mp_gt_driver @@ -1354,12 +1397,10 @@ END SUBROUTINE mp_gt_driver !.. Thompson et al. (2004, 2008). !+---+-----------------------------------------------------------------+ ! - subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & + subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & nr1d, nc1d, nwfa1d, nifa1d, t1d, p1d, w1d, dzq, & - pptrain, pptsnow, pptgraul, pptice, & -#if defined(mpas) - rainprod, evapprod, & -#endif + pptrain, pptsnow, pptgraul, pptice, & + rainprod, evapprod, & kts, kte, dt, ii, jj) implicit none @@ -1372,10 +1413,8 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & REAL, DIMENSION(kts:kte), INTENT(IN):: p1d, w1d, dzq REAL, INTENT(INOUT):: pptrain, pptsnow, pptgraul, pptice REAL, INTENT(IN):: dt -#if defined(mpas) REAL, DIMENSION(kts:kte), INTENT(INOUT):: & rainprod, evapprod -#endif !..Local variables REAL, DIMENSION(kts:kte):: tten, qvten, qcten, qiten, & @@ -1449,7 +1488,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & REAL:: r_frac, g_frac REAL:: Ef_rw, Ef_sw, Ef_gw, Ef_rr REAL:: Ef_ra, Ef_sa, Ef_ga - REAL:: dtsave, odts, odt, odzq, hgt_agl + REAL:: dtsave, odts, odt, odzq, hgt_agl, SR REAL:: xslw1, ygra1, zans1, eva_factor INTEGER:: i, k, k2, n, nn, nstep, k_0, kbot, IT, iexfrq INTEGER, DIMENSION(5):: ksed1 @@ -1463,9 +1502,14 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & CHARACTER*256:: mp_debug INTEGER:: nu_c +! modifications proposed by Ted Mansell for MPAS. +! Laura D. Fowler (laura@ucar.edu) / 2017-03-27. +! real, parameter:: mvd_r_breakup = 1.e-3 +!... end modifications. + LOGICAL, DIMENSION(kts:kte):: L_nifa,L_nwfa + REAL:: tem !+---+ - debug_flag = .false. ! if (ii.eq.901 .and. jj.eq.379) debug_flag = .true. if(debug_flag) then @@ -1576,12 +1620,19 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & pnd_scd(k) = 0. pnd_gcd(k) = 0. enddo -#if defined(mpas) do k = kts, kte rainprod(k) = 0. evapprod(k) = 0. enddo -#endif +!.. initialize the logicals L_nifa and L_nwfa used to detect instances of the cloud +!.. ice and cloud liquid water mixing ratios being greater than R1 but their number +!.. concentration being less than 2. and R2: + if(is_aerosol_aware) then + do k = kts, kte + L_nifa(k) = .false. + L_nwfa(k) = .false. + enddo + endif !..Bug fix (2016Jun15), prevent use of uninitialized value(s) of snow moments. do k = kts, kte @@ -1611,8 +1662,10 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & if (qc1d(k) .gt. R1) then no_micro = .false. rc(k) = qc1d(k)*rho(k) - nc(k) = MAX(2., nc1d(k)*rho(k)) + nc(k) = MAX(2., MIN(nc1d(k)*rho(k), Nt_c_max)) L_qc(k) = .true. +!.. set L_nwfa to true when the cloud liquid water number concentration is less than 2.: + if(is_aerosol_aware .and. nc(k) .le. 2.) L_nwfa(k) = .true. nu_c = MIN(15, NINT(1000.E6/nc(k)) + 2) lamc = (nc(k)*am_r*ccg(2,nu_c)*ocg1(nu_c)/rc(k))**obmr xDc = (bm_r + nu_c + 1.) / lamc @@ -1636,17 +1689,20 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & no_micro = .false. ri(k) = qi1d(k)*rho(k) ni(k) = MAX(R2, ni1d(k)*rho(k)) + L_qi(k) = .true. +!.. set L_nifa to true when the cloud ice number concentration is less than R2: + if(is_aerosol_aware .and. ni(k) .le. R2) L_nifa(k) = .true. if (ni(k).le. R2) then - lami = cie(2)/25.E-6 - ni(k) = MIN(499.D3, cig(1)*oig2*ri(k)/am_i*lami**bm_i) + lami = cie(2)/5.E-6 + ni(k) = MIN(9999.D3, cig(1)*oig2*ri(k)/am_i*lami**bm_i) endif - L_qi(k) = .true. +! 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(499.D3, cig(1)*oig2*ri(k)/am_i*lami**bm_i) + ni(k) = MIN(9999.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 @@ -1925,7 +1981,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & tau = 3.72/(rc(k)*taud) prr_wau(k) = zeta/tau prr_wau(k) = MIN(DBLE(rc(k)*odts), prr_wau(k)) - pnr_wau(k) = prr_wau(k) / (am_r*nu_c*D0r*D0r*D0r) ! RAIN2M + pnr_wau(k) = prr_wau(k) / (am_r*nu_c*200.*D0r*D0r*D0r) ! RAIN2M pnc_wau(k) = MIN(DBLE(nc(k)*odts), prr_wau(k) & / (am_r*mvd_c(k)*mvd_c(k)*mvd_c(k))) ! Qc2M endif @@ -1964,8 +2020,12 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !..Compute all frozen hydrometeor species' process terms. !+---+-----------------------------------------------------------------+ if (.not. iiwarm) then + !..vts_boost is the factor applied to snow terminal + !..fallspeed due to riming of snow do k = kts, kte - vts_boost(k) = 1.5 + vts_boost(k) = 1.0 + xDs = 0.0 + if (L_qs(k)) xDs = smoc(k) / smob(k) !..Temperature lookup table indexes. tempc = temp(k) - 273.15 @@ -2117,13 +2177,12 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !..Snow collecting cloud water. In CE, assume Dc< mvd_r_breakup ) then + pnr_rcg(k) = -5.0*tnr_gacr(idx_g1,idx_g,idx_r1,idx_r) ! RAIN2M +! else +! pnr_rcg(k) = -3.0*tnr_gacr(idx_g1,idx_g,idx_r1,idx_r) ! RAIN2M +! endif endif endif endif @@ -2287,8 +2351,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & pnr_rfz(k) = MIN(DBLE(nr(k)*odts), pnr_rfz(k)) elseif (rr(k).gt. R1 .and. temp(k).lt.HGFR) then pri_rfz(k) = rr(k)*odts - pnr_rfz(k) = nr(k)*odts ! RAIN2M - pni_rfz(k) = pnr_rfz(k) + pni_rfz(k) = nr(k)*odts ! RAIN2M endif if (rc(k).gt. r_c(1)) then @@ -2319,7 +2382,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !..Freezing of aqueous aerosols based on Koop et al (2001, Nature) xni = smo0(k)+ni(k) + (pni_rfz(k)+pni_wfz(k)+pni_inu(k))*dtsave - if (is_aerosol_aware .AND. homogIce .AND. (xni.le.500.E3) & + if (is_aerosol_aware .AND. homogIce .AND. (xni.le.999.E3) & & .AND.(temp(k).lt.238).AND.(ssati(k).ge.0.4) ) then xnc = iceKoop(temp(k),qv(k),qvs(k),nwfa(k), dtsave) pni_iha(k) = xnc*odts @@ -2442,7 +2505,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & prs_sde(k).gt.eps) then r_frac = MIN(30.0D0, prs_scw(k)/prs_sde(k)) g_frac = MIN(0.95, 0.15 + (r_frac-2.)*.028) - vts_boost(k) = MIN(1.5, 1.1 + (r_frac-2.)*.016) + vts_boost(k) = MIN(1.5, 1.1 + (r_frac-2.)*.014) prg_scw(k) = g_frac*prs_scw(k) prs_scw(k) = (1. - g_frac)*prs_scw(k) endif @@ -2454,12 +2517,13 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & if (L_qs(k)) then prr_sml(k) = (tempc*tcond(k)-lvap0*diffu(k)*delQvs(k)) & * (t1_qs_me*smo1(k) + t2_qs_me*rhof2(k)*vsc2(k)*smof(k)) - prr_sml(k) = prr_sml(k) + 4218.*olfus*tempc & - * (prr_rcs(k)+prs_scw(k)) + if (prr_sml(k) .gt. 0.) then + prr_sml(k) = prr_sml(k) + 4218.*olfus*tempc & + * (prr_rcs(k)+prs_scw(k)) + endif prr_sml(k) = MIN(DBLE(rs(k)*odts), MAX(0.D0, prr_sml(k))) pnr_sml(k) = smo0(k)/rs(k)*prr_sml(k) * 10.0**(-0.25*tempc) ! RAIN2M pnr_sml(k) = MIN(DBLE(smo0(k)*odts), pnr_sml(k)) -! if (tempc.gt.3.5 .or. rs(k).lt.0.005E-3) pnr_sml(k)=0.0 if (ssati(k).lt. 0.) then prs_sde(k) = C_cube*t1_subl*diffu(k)*ssati(k)*rvs & @@ -2478,7 +2542,6 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & prr_gml(k) = MIN(DBLE(rg(k)*odts), MAX(0.D0, prr_gml(k))) pnr_gml(k) = N0_g(k)*cgg(2)*ilamg(k)**cge(2) / rg(k) & ! RAIN2M * prr_gml(k) * 10.0**(-0.5*tempc) -! if (tempc.gt.7.5 .or. rg(k).lt.0.005E-3) pnr_gml(k)=0.0 if (ssati(k).lt. 0.) then prg_gde(k) = C_cube*t1_subl*diffu(k)*ssati(k)*rvs & @@ -2514,7 +2577,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !.. supersat again. sump = pri_inu(k) + pri_ide(k) + prs_ide(k) & + prs_sde(k) + prg_gde(k) + pri_iha(k) - rate_max = (qv(k)-qvsi(k))*odts*0.999 + rate_max = (qv(k)-qvsi(k))*rho(k)*odts*0.999 if ( (sump.gt. eps .and. sump.gt. rate_max) .or. & (sump.lt. -eps .and. sump.lt. rate_max) ) then ratio = rate_max/sump @@ -2687,7 +2750,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & xDi = (bm_i + mu_i + 1.) * ilami if (xDi.lt. 5.E-6) then lami = cie(2)/5.E-6 - xni = MIN(499.D3, cig(1)*oig2*xri/am_i*lami**bm_i) + xni = MIN(9999.D3, cig(1)*oig2*xri/am_i*lami**bm_i) niten(k) = (xni-ni1d(k)*rho(k))*odts*orho elseif (xDi.gt. 300.E-6) then lami = cie(2)/300.E-6 @@ -2698,8 +2761,8 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & niten(k) = -ni1d(k)*odts endif xni=MAX(0.,(ni1d(k) + niten(k)*dtsave)*rho(k)) - if (xni.gt.499.E3) & - niten(k) = (499.E3-ni1d(k)*rho(k))*odts*orho + if (xni.gt.9999.E3) & + niten(k) = (9999.E3-ni1d(k)*rho(k))*odts*orho !..Rain tendency qrten(k) = qrten(k) + (prr_wau(k) + prr_rcw(k) & @@ -2711,7 +2774,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !..Rain number tendency nrten(k) = nrten(k) + (pnr_wau(k) + pnr_sml(k) + pnr_gml(k) & - (pnr_rfz(k) + pnr_rcr(k) + pnr_rcg(k) & - + pnr_rcs(k) + pnr_rci(k)) ) & + + pnr_rcs(k) + pnr_rci(k) + pni_rfz(k)) ) & * orho !..Rain mass/number balance; keep median volume diameter between @@ -2799,10 +2862,12 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & lvt2(k)=lvap(k)*lvap(k)*ocp(k)*oRv*otemp*otemp nwfa(k) = MAX(11.1E6, (nwfa1d(k) + nwfaten(k)*DT)*rho(k)) + enddo + do k = kts, kte if ((qc1d(k) + qcten(k)*DT) .gt. R1) then rc(k) = (qc1d(k) + qcten(k)*DT)*rho(k) - nc(k) = MAX(2., (nc1d(k) + ncten(k)*DT)*rho(k)) + nc(k) = MAX(2., MIN((nc1d(k)+ncten(k)*DT)*rho(k), Nt_c_max)) if (.NOT. is_aerosol_aware) nc(k) = Nt_c L_qc(k) = .true. else @@ -2864,6 +2929,12 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !.. intercepts/slopes of graupel and rain. !+---+-----------------------------------------------------------------+ if (.not. iiwarm) then + do k = kts, kte + smo2(k) = 0. + smob(k) = 0. + smoc(k) = 0. + smod(k) = 0. + enddo do k = kts, kte if (.not. L_qs(k)) CYCLE tc0 = MIN(-0.1, temp(k)-273.15) @@ -3031,9 +3102,10 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & ! -tpc_wev(idx_d, idx_c, idx_n)*orho*odt) prw_vcd(k) = MAX(DBLE(-rc(k)*0.99*orho*odt), prw_vcd(k)) pnc_wcd(k) = MAX(DBLE(-nc(k)*0.99*orho*odt), & - DBLE(-tnc_wev(idx_d, idx_c, idx_n)*orho*odt)) + -tnc_wev(idx_d, idx_c, idx_n)*orho*odt) endif + if(is_aerosol_aware .and. L_nwfa(k)) L_nwfa(k) = .false. else prw_vcd(k) = -rc(k)*orho*odt pnc_wcd(k) = -nc(k)*orho*odt @@ -3047,7 +3119,8 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & nwfaten(k) = nwfaten(k) - pnc_wcd(k) tten(k) = tten(k) + lvap(k)*ocp(k)*prw_vcd(k)*(1-IFDRY) rc(k) = MAX(R1, (qc1d(k) + DT*qcten(k))*rho(k)) - nc(k) = MAX(2., (nc1d(k) + DT*ncten(k))*rho(k)) + if (rc(k).eq.R1) L_qc(k) = .false. + nc(k) = MAX(2., MIN((nc1d(k)+ncten(k)*DT)*rho(k), Nt_c_max)) if (.NOT. is_aerosol_aware) nc(k) = Nt_c qv(k) = MAX(1.E-10, qv1d(k) + DT*qvten(k)) temp(k) = t1d(k) + DT*tten(k) @@ -3108,7 +3181,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & prv_rev(k) = MIN(DBLE(rate_max), prv_rev(k)*orho) !..TEST: G. Thompson 10 May 2013 -!..Reduce the rain evaporation in same places as melting graupel occurs. +!..Reduce the rain evaporation in same places as melting graupel occurs. !..Rationale: falling and simultaneous melting graupel in subsaturated !..regions will not melt as fast because particle temperature stays !..at 0C. Also not much shedding of the water from the graupel so @@ -3136,7 +3209,6 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & rho(k) = 0.622*pres(k)/(R*temp(k)*(qv(k)+0.622)) endif enddo -#if defined(mpas) do k = kts, kte evapprod(k) = prv_rev(k) - (min(zeroD0,prs_sde(k)) + & min(zeroD0,prg_gde(k))) @@ -3145,7 +3217,6 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & prg_gcw(k) + prs_sci(k) + & pri_rci(k) enddo -#endif !+---+-----------------------------------------------------------------+ !..Find max terminal fallspeed (distribution mass-weighted mean @@ -3168,6 +3239,8 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & 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)) @@ -3198,9 +3271,11 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & 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 @@ -3221,11 +3296,13 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & vtnck(k) = vtc endif enddo + endif !+---+-----------------------------------------------------------------+ if (.not. iiwarm) then + if (ANY(L_qi .eqv. .true.)) then nstep = 0 do k = kte, kts, -1 vti = 0. @@ -3253,9 +3330,11 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & 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. @@ -3273,8 +3352,8 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & 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 (temp(k).gt. (T_0+0.1)) then - vtsk(k) = MAX(vts*vts_boost(k), & - & vts*((vtrk(k)-vts*vts_boost(k))/(temp(k)-T_0))) + SR = rs(k)/(rs(k)+rr(k)) + vtsk(k) = vts*SR + (1.-SR)*vtrk(k) else vtsk(k) = vts*vts_boost(k) endif @@ -3290,9 +3369,11 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & 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. @@ -3316,18 +3397,16 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & 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. -!.. New in v3.0+ is computing separate for rain, ice, snow, and -!.. graupel species thus making code faster with credit to J. Schmidt. -!.. Bug fix, 2013Nov01 to tendencies using rho(k+1) correction thanks to -!.. Eric Skyllingstad. !+---+-----------------------------------------------------------------+ + if (ANY(L_qr .eqv. .true.)) then nstep = NINT(1./onstep(1)) do n = 1, nstep do k = kte, kts, -1 @@ -3354,12 +3433,14 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & *odzq*DT*onstep(1)) enddo - if (rr(kts).gt.R1*10.) & + 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) @@ -3372,9 +3453,11 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & 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 + endif !+---+-----------------------------------------------------------------+ + if (ANY(L_qi .eqv. .true.)) then nstep = NINT(1./onstep(2)) do n = 1, nstep do k = kte, kts, -1 @@ -3401,12 +3484,14 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & *odzq*DT*onstep(2)) enddo - if (ri(kts).gt.R1*10.) & + 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 @@ -3426,12 +3511,14 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & *odzq*DT*onstep(3)) enddo - if (rs(kts).gt.R1*10.) & + 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 @@ -3451,9 +3538,10 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & *odzq*DT*onstep(4)) enddo - if (rg(kts).gt.R1*10.) & + 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 @@ -3490,10 +3578,10 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & 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), nc1d(k) + ncten(k)*DT) - nwfa1d(k) = MAX(11.1E6/rho(k), MIN(9999.E6/rho(k), & + nc1d(k) = MAX(2./rho(k), MIN(nc1d(k) + ncten(k)*DT, Nt_c_max)) + nwfa1d(k) = MAX(11.1E6, MIN(9999.E6, & (nwfa1d(k)+nwfaten(k)*DT))) - nifa1d(k) = MAX(naIN1*0.01, MIN(9999.E6/rho(k), & + nifa1d(k) = MAX(naIN1*0.01, MIN(9999.E6, & (nifa1d(k)+nifaten(k)*DT))) if (qc1d(k) .le. R1) then @@ -3527,7 +3615,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & lami = cie(2)/300.E-6 endif ni1d(k) = MIN(cig(1)*oig2*qi1d(k)/am_i*lami**bm_i, & - 499.D3/rho(k)) + 9999.D3/rho(k)) endif qr1d(k) = qr1d(k) + qrten(k)*DT nr1d(k) = MAX(R2/rho(k), nr1d(k) + nrten(k)*DT) @@ -3640,7 +3728,8 @@ subroutine qr_acr_qg tcg_racg(i,j,k,m) = t1 tmr_racg(i,j,k,m) = DMIN1(z1, r_r(m)*1.0d0) tcr_gacr(i,j,k,m) = t2 - tmg_gacr(i,j,k,m) = z2 + tmg_gacr(i,j,k,m) = DMIN1(z2, r_g(j)*1.0d0) + !DAVE tmg_gacr(i,j,k,m) = DMIN1(z2, DBLE(r_g(j))) tnr_racg(i,j,k,m) = y1 tnr_gacr(i,j,k,m) = y2 enddo @@ -3829,8 +3918,10 @@ subroutine freezeH2O !..Local variables INTEGER:: i, j, k, m, n, n2 - DOUBLE PRECISION, DIMENSION(nbr):: N_r, massr - DOUBLE PRECISION, DIMENSION(nbc):: N_c, massc + INTEGER:: km, km_s, km_e + DOUBLE PRECISION:: N_r, N_c + DOUBLE PRECISION, DIMENSION(nbr):: massr + DOUBLE PRECISION, DIMENSION(nbc):: massc DOUBLE PRECISION:: sum1, sum2, sumn1, sumn2, & prob, vol, Texp, orho_w, & lam_exp, lamr, N0_r, lamc, N0_c, y @@ -3848,10 +3939,14 @@ subroutine freezeH2O massc(n) = am_r*Dc(n)**bm_r enddo + km_s = 0 + km_e = ntb_IN*45 - 1 + !..Freeze water (smallest drops become cloud ice, otherwise graupel). - do m = 1, ntb_IN - T_adjust = MAX(-3.0, MIN(3.0 - ALOG10(Nt_IN(m)), 3.0)) - do k = 1, 45 + do km = km_s, km_e + m = km / 45 + 1 + k = mod( km , 45 ) + 1 + T_adjust = MAX(-3.0, MIN(3.0 - ALOG10(Nt_IN(m)), 3.0)) ! print*, ' Freezing water for temp = ', -k Texp = DEXP( REAL(k,KIND=R8SIZE) - T_adjust*1.0D0 ) - 1.0D0 do j = 1, ntb_r1 @@ -3864,15 +3959,15 @@ subroutine freezeH2O sumn1 = 0.0d0 sumn2 = 0.0d0 do n2 = nbr, 1, -1 - N_r(n2) = N0_r*Dr(n2)**mu_r*DEXP(-lamr*Dr(n2))*dtr(n2) + N_r = N0_r*Dr(n2)**mu_r*DEXP(-lamr*Dr(n2))*dtr(n2) vol = massr(n2)*orho_w - prob = 1.0D0 - DEXP(-120.0D0*vol*5.2D-4 * Texp) + prob = MAX(0.0D0, 1.0D0 - DEXP(-120.0D0*vol*5.2D-4 * Texp)) if (massr(n2) .lt. xm0g) then - sumn1 = sumn1 + prob*N_r(n2) - sum1 = sum1 + prob*N_r(n2)*massr(n2) + sumn1 = sumn1 + prob*N_r + sum1 = sum1 + prob*N_r*massr(n2) else - sumn2 = sumn2 + prob*N_r(n2) - sum2 = sum2 + prob*N_r(n2)*massr(n2) + sumn2 = sumn2 + prob*N_r + sum2 = sum2 + prob*N_r*massr(n2) endif if ((sum1+sum2).ge.r_r(i)) EXIT enddo @@ -3892,10 +3987,10 @@ subroutine freezeH2O sumn2 = 0.0d0 do n = nbc, 1, -1 vol = massc(n)*orho_w - prob = 1.0D0 - DEXP(-120.0D0*vol*5.2D-4 * Texp) - N_c(n) = N0_c*Dc(n)**nu_c*EXP(-lamc*Dc(n))*dtc(n) - sumn2 = MIN(t_Nc(j), sumn2 + prob*N_c(n)) - sum1 = sum1 + prob*N_c(n)*massc(n) + prob = MAX(0.0D0, 1.0D0 - DEXP(-120.0D0*vol*5.2D-4 * Texp)) + N_c = N0_c*Dc(n)**nu_c*EXP(-lamc*Dc(n))*dtc(n) + sumn2 = MIN(t_Nc(j), sumn2 + prob*N_c) + sum1 = sum1 + prob*N_c*massc(n) if (sum1 .ge. r_c(i)) EXIT enddo tpi_qcfz(i,j,k,m) = sum1 @@ -3903,9 +3998,9 @@ subroutine freezeH2O enddo enddo enddo - enddo end subroutine freezeH2O + !+---+-----------------------------------------------------------------+ !ctrlL !+---+-----------------------------------------------------------------+ @@ -4282,7 +4377,7 @@ subroutine table_ccnAct end subroutine table_ccnAct #endif -!^L +! !+---+-----------------------------------------------------------------+ !..Retrieve fraction of CCN that gets activated given the model temp, !.. vertical velocity, and available CCN concentration. The lookup @@ -4622,7 +4717,7 @@ real function iceDeMott(tempc, qv, qvs, qvsi, rho, nifa) ! 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 = nifa*RHO_NOT0*1.E-6/rho + 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)) @@ -4739,7 +4834,7 @@ subroutine calc_effectRad (t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d, & 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(R2, nc1d(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)) @@ -4751,6 +4846,7 @@ subroutine calc_effectRad (t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d, & 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 if (nc(k).lt.100) then inu_c = 15 @@ -4766,14 +4862,16 @@ subroutine calc_effectRad (t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d, & if (has_qi) then do k = kts, kte + re_qi1d(k) = 2.49E-6 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(5.01E-6, MIN(SNGL(0.5D0 * DBLE(3.+mu_i)/lami), 125.E-6)) + 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 + re_qs1d(k) = 4.99E-6 if (rs(k).le.R1) CYCLE tc0 = MIN(-0.1, t1d(k)-273.15) smob = rs(k)*oams @@ -4808,7 +4906,7 @@ subroutine calc_effectRad (t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d, & & + 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(10.E-6, MIN(0.5*(smoc/smob), 999.E-6)) + re_qs1d(k) = MAX(5.01E-6, MIN(0.5*(smoc/smob), 999.E-6)) enddo endif @@ -4909,6 +5007,14 @@ subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & !..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 (ANY(L_qs .eqv. .true.)) then + do k = kts, kte + if (.not. L_qs(k)) CYCLE tc0 = MIN(-0.1, temp(k)-273.15) smob(k) = rs(k)*oams @@ -4957,11 +5063,13 @@ subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & & + 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 N0_min = gonv_max k_0 = kts do k = kte, kts, -1 @@ -4984,6 +5092,7 @@ subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & ilamg(k) = 1./lamg N0_g(k) = N0_exp/(cgg(2)*lam_exp) * lamg**cge(2) enddo + endif !+---+-----------------------------------------------------------------+ !..Locate K-level of start of melting (k_0 is level above). diff --git a/src/core_atmosphere/physics/physics_wrf/module_mp_thompson_aerosols.F b/src/core_atmosphere/physics/physics_wrf/module_mp_thompson_aerosols.F new file mode 100644 index 0000000000..48fb6fb641 --- /dev/null +++ b/src/core_atmosphere/physics/physics_wrf/module_mp_thompson_aerosols.F @@ -0,0 +1,214 @@ +!================================================================================================================= +!module_mp_thompson_aerosols includes subroutine gt_aod. gt_aod is called from subroutine radiation_sw_from_MPAS +!in mpas_atmphys_driver_radiation_sw.F. gt_aod calculates the 550 nm aerosol optical depth of "water-friendly" +!and "ice-friendly" aerosols from the Thompson cloud microphysics scheme. gt_aod was copied from WRF-4.0.2 (see +!module_radiation_driver.F). +!Laura D. Fowler (laura@ucar.edu) / 2019-01-13. + + module module_mp_thompson_aerosols + use mpas_atmphys_functions,only: rslf + use mpas_atmphys_utilities, only: physics_error_fatal,physics_message +#define FATAL_ERROR(M) call physics_error_fatal(M) +#define WRITE_MESSAGE(M) call physics_message(M) + + implicit none + private + public:: gt_aod + + + contains + + +!================================================================================================================= + SUBROUTINE gt_aod(p_phy,DZ8W,t_phy,qvapor, nwfa,nifa, taod5503d, & + & ims,ime, jms,jme, kms,kme, its,ite, jts,jte, kts,kte) + +! USE module_mp_thompson, only: RSLF + +! IMPLICIT NONE + + INTEGER, INTENT(IN):: ims,ime, jms,jme, kms,kme, & + & its,ite, jts,jte, kts,kte + + REAL, DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(IN) :: & + & t_phy,p_phy, DZ8W, & + & qvapor, nifa, nwfa + REAL,DIMENSION(ims:ime,kms:kme,jms:jme),INTENT(INOUT):: taod5503d + + !..Local variables. + + REAL, DIMENSION(its:ite,kts:kte,jts:jte):: AOD_wfa, AOD_ifa + REAL:: RH, a_RH,b_RH, rh_d,rh_f, rhoa,qvsat, unit_bext1,unit_bext3 + REAL:: ntemp + INTEGER :: i, k, j, RH_idx, RH_idx1, RH_idx2, t_idx + INTEGER, PARAMETER:: rind=8 + REAL, DIMENSION(rind), PARAMETER:: rh_arr = & + & (/10., 60., 70., 80., 85., 90., 95., 99.8/) + REAL, DIMENSION(rind,4,2) :: lookup_tabl ! RH, temp, water-friendly, ice-friendly + + lookup_tabl(1,1,1) = 5.73936E-15 + lookup_tabl(1,1,2) = 2.63577E-12 + lookup_tabl(1,2,1) = 5.73936E-15 + lookup_tabl(1,2,2) = 2.63577E-12 + lookup_tabl(1,3,1) = 5.73936E-15 + lookup_tabl(1,3,2) = 2.63577E-12 + lookup_tabl(1,4,1) = 5.73936E-15 + lookup_tabl(1,4,2) = 2.63577E-12 + + lookup_tabl(2,1,1) = 6.93515E-15 + lookup_tabl(2,1,2) = 2.72095E-12 + lookup_tabl(2,2,1) = 6.93168E-15 + lookup_tabl(2,2,2) = 2.72092E-12 + lookup_tabl(2,3,1) = 6.92570E-15 + lookup_tabl(2,3,2) = 2.72091E-12 + lookup_tabl(2,4,1) = 6.91833E-15 + lookup_tabl(2,4,2) = 2.72087E-12 + + lookup_tabl(3,1,1) = 7.24707E-15 + lookup_tabl(3,1,2) = 2.77219E-12 + lookup_tabl(3,2,1) = 7.23809E-15 + lookup_tabl(3,2,2) = 2.77222E-12 + lookup_tabl(3,3,1) = 7.23108E-15 + lookup_tabl(3,3,2) = 2.77201E-12 + lookup_tabl(3,4,1) = 7.21800E-15 + lookup_tabl(3,4,2) = 2.77111E-12 + + lookup_tabl(4,1,1) = 8.95130E-15 + lookup_tabl(4,1,2) = 2.87263E-12 + lookup_tabl(4,2,1) = 9.01582E-15 + lookup_tabl(4,2,2) = 2.87252E-12 + lookup_tabl(4,3,1) = 9.13216E-15 + lookup_tabl(4,3,2) = 2.87241E-12 + lookup_tabl(4,4,1) = 9.16219E-15 + lookup_tabl(4,4,2) = 2.87211E-12 + + lookup_tabl(5,1,1) = 1.06695E-14 + lookup_tabl(5,1,2) = 2.96752E-12 + lookup_tabl(5,2,1) = 1.06370E-14 + lookup_tabl(5,2,2) = 2.96726E-12 + lookup_tabl(5,3,1) = 1.05999E-14 + lookup_tabl(5,3,2) = 2.96702E-12 + lookup_tabl(5,4,1) = 1.05443E-14 + lookup_tabl(5,4,2) = 2.96603E-12 + + lookup_tabl(6,1,1) = 1.37908E-14 + lookup_tabl(6,1,2) = 3.15081E-12 + lookup_tabl(6,2,1) = 1.37172E-14 + lookup_tabl(6,2,2) = 3.15020E-12 + lookup_tabl(6,3,1) = 1.36362E-14 + lookup_tabl(6,3,2) = 3.14927E-12 + lookup_tabl(6,4,1) = 1.35287E-14 + lookup_tabl(6,4,2) = 3.14817E-12 + + lookup_tabl(7,1,1) = 2.26019E-14 + lookup_tabl(7,1,2) = 3.66798E-12 + lookup_tabl(7,2,1) = 2.24435E-14 + lookup_tabl(7,2,2) = 3.66540E-12 + lookup_tabl(7,3,1) = 2.23254E-14 + lookup_tabl(7,3,2) = 3.66173E-12 + lookup_tabl(7,4,1) = 2.20496E-14 + lookup_tabl(7,4,2) = 3.65796E-12 + + lookup_tabl(8,1,1) = 4.41983E-13 + lookup_tabl(8,1,2) = 7.50091E-11 + lookup_tabl(8,2,1) = 3.93335E-13 + lookup_tabl(8,2,2) = 6.79097E-11 + lookup_tabl(8,3,1) = 3.45569E-13 + lookup_tabl(8,3,2) = 6.07845E-11 + lookup_tabl(8,4,1) = 2.96971E-13 + lookup_tabl(8,4,2) = 5.36085E-11 + + DO j=jts,jte + DO k=kts,kte + DO i=its,ite + AOD_wfa(i,k,j) = 0. + AOD_ifa(i,k,j) = 0. + END DO + END DO + END DO + + DO j=jts,jte + DO k=kts,kte + DO i=its,ite + rhoa = p_phy(i,k,j)/(287.*t_phy(i,k,j)) + t_idx = MAX(1, MIN(nint(10.999-0.0333*t_phy(i,k,j)),4)) + qvsat = rslf(p_phy(i,k,j),t_phy(i,k,j)) + RH = MIN(98., MAX(10.1, qvapor(i,k,j)/qvsat*100.)) + + !..Get the index for the RH array element + + if (RH .lt. 60) then + RH_idx1 = 1 + RH_idx2 = 2 + elseif (RH .ge. 60 .AND. RH.lt.80) then + a_RH = 0.1 + b_RH = -4 + RH_idx = nint(a_RH*RH+b_RH) + rh_d = rh-rh_arr(rh_idx) + if (rh_d .lt. 0) then + RH_idx1 = RH_idx-1 + RH_idx2 = RH_idx + else + RH_idx1 = RH_idx + RH_idx2 = RH_idx+1 + if (RH_idx2.gt.rind) then + RH_idx2 = rind + RH_idx1 = rind-1 + endif + endif + else + a_RH = 0.2 + b_RH = -12. + RH_idx = MIN(rind, nint(a_RH*RH+b_RH)) + rh_d = rh-rh_arr(rh_idx) + if (rh_d .lt. 0) then + RH_idx1 = RH_idx-1 + RH_idx2 = RH_idx + else + RH_idx1 = RH_idx + RH_idx2 = RH_idx+1 + if (RH_idx2.gt.rind) then + RH_idx2 = rind + RH_idx1 = rind-1 + endif + endif + endif + + !..RH fraction to be used + + rh_f = MAX(0., MIN(1.0, (rh/(100-rh)-rh_arr(rh_idx1) & + & /(100-rh_arr(rh_idx1))) & + & /(rh_arr(rh_idx2)/(100-rh_arr(rh_idx2)) & + & -rh_arr(rh_idx1)/(100-rh_arr(rh_idx1))) )) + + + unit_bext1 = lookup_tabl(RH_idx1,t_idx,1) & + & + (lookup_tabl(RH_idx2,t_idx,1) & + & - lookup_tabl(RH_idx1,t_idx,1))*rh_f + unit_bext3 = lookup_tabl(RH_idx1,t_idx,2) & + & + (lookup_tabl(RH_idx2,t_idx,2) & + & - lookup_tabl(RH_idx1,t_idx,2))*rh_f + + ntemp = MAX(1., MIN(99999.E6, nwfa(i,k,j))) + AOD_wfa(i,k,j) = unit_bext1*ntemp*dz8w(i,k,j)*rhoa + + ntemp = MAX(0.01, MIN(9999.E6, nifa(i,k,j))) + AOD_ifa(i,k,j) = unit_bext3*ntemp*dz8w(i,k,j)*rhoa + + END DO + END DO + END DO + + DO j=jts,jte + DO k=kts,kte + DO i=its,ite + taod5503d(i,k,j) = aod_wfa(i,k,j) + aod_ifa(i,k,j) + END DO + END DO + END DO + + END SUBROUTINE gt_aod + +!================================================================================================================= + end module module_mp_thompson_aerosols +!================================================================================================================= diff --git a/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_sw.F b/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_sw.F index be36c4afb1..49f8169a45 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_sw.F +++ b/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_sw.F @@ -9840,6 +9840,13 @@ MODULE module_ra_rrtmg_sw !> microphysics scheme as inputs to the subroutine rrtmg_swrad. revised the initialization of arrays rel, !> rei, and res, accordingly. !> Laura D. Fowler (laura@ucar.edu) / 2016-07-07. +!> * added the optional arguments, tauaer3d, ssaaer3d, and asyaer3d to include the optical depth, single +!> scattering albedo, and asymmetry factor of aerosols. to date, the only kind of aerosols included in MPAS +!> are the "water-friendly" and "ice-friendly" aerosols used in the Thompson cloud microphysics scheme. +!> Laura D. Fowler (laura@ucar.edu) / 2024-05-16. +!> * added the option aer_opt in the argument list. revised the initialization of arrays tauaer,ssaaer, and +!> asmaer to include the optical properties of aerosols. +!> Laura D. Fowler (laura@ucar.edu) / 2024-05-16. !MPAS specfic end. #else @@ -9873,6 +9880,7 @@ subroutine rrtmg_swrad( & noznlevels,pin,o3clim,gsw,swcf,rthratensw, & has_reqc,has_reqi,has_reqs,re_cloud, & re_ice,re_snow, & + aer_opt,tauaer3d,ssaaer3d,asyaer3d, & swupt,swuptc,swdnt,swdntc, & swupb,swupbc,swdnb,swdnbc, & swupflx, swupflxc, swdnflx, swdnflxc, & @@ -9909,6 +9917,12 @@ subroutine rrtmg_swrad( & real,intent(in),dimension(1:noznlevels),optional:: pin real,intent(in),dimension(ims:ime,1:noznlevels,jms:jme),optional:: o3clim +!--- additional input arguments of the aerosol optical depth, single scattering albedo, and asymmetry factor. to +! date, the only kind of aerosols included in MPAS are the "water-friendly" and "ice-friendly" aerosols used +! in the Thompson cloud microphysics scheme: + integer,intent(in),optional:: aer_opt + real,intent(in),dimension(ims:ime,kms:kme,jms:jme,1:nbndsw),optional:: tauaer3d,ssaaer3d,asyaer3d + !--- inout arguments: real,intent(inout),dimension(ims:ime,jms:jme):: coszr,gsw,swcf real,intent(inout),dimension(ims:ime,jms:jme),optional:: & @@ -9967,7 +9981,6 @@ subroutine rrtmg_swrad( & !--- additional local variables related to the implementation of aerosols in rrtmg_swrad in WRF 3.8. ! In WRF 3.8, these variables are in the argument list of subroutine rrtmg_swrad, but are made ! local here: - integer:: aer_opt real,dimension(1,kts:kte+1,naerec):: ecaer !--- set trace gas volume mixing ratios, 2005 values, IPCC (2007): @@ -10131,7 +10144,6 @@ subroutine rrtmg_swrad( & enddo !--- initialization of aerosol optical properties: - aer_opt = 0 do n = 1, ncol do k = 1, nlay do na = 1, naerec @@ -10367,13 +10379,27 @@ subroutine rrtmg_swrad( & fsfcmcl) !--- initialization of aerosol optical properties: - do nb = 1, nbndsw - do k = kts, kte+1 + if(present(tauaer3d) .and. present(ssaaer3d) .and. present(asyaer3d)) then + do nb = 1, nbndsw + do k = kts, kte + tauaer(ncol,k,nb) = tauaer3d(i,k,j,nb) + ssaaer(ncol,k,nb) = ssaaer3d(i,k,j,nb) + asmaer(ncol,k,nb) = asyaer3d(i,k,j,nb) + enddo + k = kte+1 tauaer(ncol,k,nb) = 0. ssaaer(ncol,k,nb) = 1. asmaer(ncol,k,nb) = 0. enddo - enddo + else + do nb = 1, nbndsw + do k = kts, kte+1 + tauaer(ncol,k,nb) = 0. + ssaaer(ncol,k,nb) = 1. + asmaer(ncol,k,nb) = 0. + enddo + enddo + endif do na = 1, naerec do k = kts, kte+1 diff --git a/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_sw_aerosols.F b/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_sw_aerosols.F new file mode 100644 index 0000000000..58ba658886 --- /dev/null +++ b/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_sw_aerosols.F @@ -0,0 +1,925 @@ +!================================================================================================================= +!module_ra_rrtmg_sw_aerosols includes subroutine calc_aerosol_rrtmg_sw. subroutine calc_aerosol_rrtmg_sw is called +!from subroutine radiation_sw_from_MPAS in mpas_atmphys_driver_radiation_sw.F. calc_aerosol_rrtmg_sw calculates +!the optical properties (aerosol optical depth,asymmetry factor,and single-scattering albedo) of "water-friendly" +!and "ice-friendly" aerosols from the Thompson cloud microphysics scheme. calc_aerosol_rrtmg_sw was copied from +!from WRF-4.0.2 (see module_radiation_driver.F). +!Laura D. Fowler (laura@ucar.edu) / 2024-05-16. + + module module_ra_rrtmg_sw_aerosols + use mpas_log + use mpas_atmphys_functions,only: rslf + use mpas_atmphys_utilities, only: physics_error_fatal,physics_message +#define FATAL_ERROR(M) call physics_error_fatal(M) +#define WRITE_MESSAGE(M) call physics_message(M) + + implicit none + private + public:: calc_aerosol_rrtmg_sw + + + contains + + +!================================================================================================================= +!-------------------------------------------------------------- +! INDICES CONVENTION +!-------------------------------------------------------------- +! kms:kme define the range for full-level indices +! kts:kte define the range for half-level indices +! +! kms=1 is the first full level at surface +! kts=1 is the first half level at surface +! +! kme is the last full level at toa +! kte is the last half level at toa +! +! There is one more full level than half levels. +! Therefore, kme=kte+1. I checked it in one of my +! simulations: +! +! namelist.input: +! s_vert=1 e_vert=28 +! code: +! kms= 1 kts= 1 +! kms=28 kte=27 +! +! In the vertical dimension there is no tiling for +! parallelization as in the horizontal dimensions. +! For i-dim and j-dim, the t-indices define the +! range of indices over which each tile runs. +!-------------------------------------------------------------- +! +! namelist options: +! aer_aod550_opt = [1,2] : +! 1 = input constant value for AOD at 550 nm from namelist. +! In this case, the value is read from aer_aod550_val; +! 2 = input value from auxiliary input 15. It is a time-varying 2D grid in netcdf wrf-compatible +! format. The default operation is aer_aod550_opt=1 and aer_aod550_val=0.12 +! aer_angexp_opt = [1,2,3] : +! 1 = input constant value for Angstrom exponent from namelist. In this case, the value is read +! from aer_angexp_val; +! 2 = input value from auxiliary input 15, as in aer_aod550_opt; +! 3 = Angstrom exponent value estimated from the aerosol type defined in aer_type, and modulated +! with the RH in WRF. Default operation is aer_angexp_opt = 1, and aer_angexp_val=1.3. +! aer_ssa_opt and aer_asy_opt are similar to aer_angexp_opt. +! +! aer_type = [1,2,3] : 1 for rural, 2 is urban and 3 is maritime. +!-------------------------------------------------------------- + +subroutine calc_aerosol_rrtmg_sw(ht,dz8w,p,t3d,qv3d,aer_type, & + aer_aod550_opt, aer_angexp_opt, aer_ssa_opt, aer_asy_opt, & + aer_aod550_val, aer_angexp_val, aer_ssa_val, aer_asy_val, & + aod5502d, angexp2d, aerssa2d, aerasy2d, & + ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte, & + tauaer, ssaaer, asyaer, aod5503d ) + + ! constants + integer, parameter :: N_BANDS=14 + ! local index variables + integer :: i,j,k,nb + + real :: lower_wvl(N_BANDS),upper_wvl(N_BANDS) + data (lower_wvl(i),i=1,N_BANDS) /3.077,2.500,2.150,1.942,1.626,1.299,1.242,0.7782,0.6250,0.4415,0.3448,0.2632,0.2000,3.846/ + data (upper_wvl(i),i=1,N_BANDS) /3.846,3.077,2.500,2.150,1.942,1.626,1.299,1.2420,0.7782,0.6250,0.4415,0.3448,0.2632,12.195/ + + ! I/O variables + integer, intent(in) :: ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte + + real, dimension(ims:ime, kms:kme, jms:jme), intent(in) :: p, & ! pressure (Pa) + t3d, & ! temperature (K) + dz8w, & ! dz between full levels (m) + qv3d ! water vapor mixing ratio (kg/kg) +!-- MPAS modifications: aer_type is a function of the land-sea mask, and set to 1 over land (or rural classification in WRF), +! and set to 0 over oceans (or maritime classification in WRF): +! integer, intent(in) :: aer_type + integer, dimension(ims:ime,jms:jme), intent(in):: aer_type + character(len=256):: wrf_err_message +!-- end MPAS modifications.. + integer, intent(in) :: aer_aod550_opt, aer_angexp_opt, aer_ssa_opt, aer_asy_opt + real, intent(in) :: aer_aod550_val, aer_angexp_val, aer_ssa_val, aer_asy_val + + real, dimension(ims:ime, jms:jme), intent(in) :: ht + real, dimension(ims:ime, jms:jme), optional, intent(inout) :: aod5502d, angexp2d, aerssa2d, aerasy2d + real, dimension(ims:ime, kms:kme, jms:jme, 1:N_BANDS), intent(inout) :: tauaer, ssaaer, asyaer + + real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(in) :: aod5503d ! trude + + ! local variables + real :: angexp_val,aod_rate,x,xy,xx + real, dimension(ims:ime, jms:jme, 1:N_BANDS) :: aod550spc + real, dimension(ims:ime, kms:kme, jms:jme, 1:N_BANDS) :: aod550spc3d ! trude + real, dimension(ims:ime, kms:kme, jms:jme) :: rh ! relative humidity + + call calc_relative_humidity(p,t3d,qv3d, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte, & + rh ) + + aer_aod550_opt_select: select case(aer_aod550_opt) + !case(0) + ! reserved for climatology + case(1) + if (aer_aod550_val .lt. 0) then + write(wrf_err_message,'("aer_aod550_val must be positive. Negative value ",F7.4," found")') aer_aod550_val + FATAL_ERROR(trim(wrf_err_message)) + end if + write( wrf_err_message, '("aer_aod550_opt=",I1,": AOD@550 nm fixed to value ",F6.3)') aer_aod550_opt,aer_aod550_val + WRITE_MESSAGE(trim(wrf_err_message)) + do j=jts,jte + do i=its,ite + aod5502d(i,j)=aer_aod550_val + end do + end do + + case(2) + if (.not.(present(aod5502d))) then + write(wrf_err_message,*) 'Expected gridded total AOD@550 nm, but it is not in the radiation driver' + FATAL_ERROR(trim(wrf_err_message)) + end if + if (minval(aod5502d) .lt. 0) then + FATAL_ERROR('AOD@550 must be positive. Negative value(s) found in auxinput') + end if +! call mpas_log_write('--- aer_aod550_opt = $i: AOD@550 nm read from auxinput min = $r max = $r', & +! intArgs=(/aer_aod550_opt/),realArgs=(/minval(aod5502d(its:ite,jts:jte)), & +! maxval(aod5502d(its:ite,jts:jte))/)) + case default + write(wrf_err_message,*) 'Expected aer_aod550_opt=[1,2]. Got',aer_aod550_opt + FATAL_ERROR(trim(wrf_err_message)) + end select aer_aod550_opt_select + + + ! here, the 3d aod550 is calculated according to the aer_angexp_opt case + aer_angexp_opt_select: select case(aer_angexp_opt) + !case(0) + ! reserved for climatology + case(1) + if (aer_angexp_val .lt. -0.3) then + write(wrf_err_message,'("WARNING: aer_angexp_val limited to -0.3. Illegal value ",F7.4," found")') aer_angexp_val + WRITE_MESSAGE(trim(wrf_err_message)) + end if + if (aer_angexp_val .gt. 2.5) then + write(wrf_err_message,'("WARNING: aer_angexp_val limited to 2.5. Illegal value ",F7.4," found")') aer_angexp_val + WRITE_MESSAGE(trim(wrf_err_message)) + end if + write( wrf_err_message , '("aer_angexp_opt=",I1,": Aerosol Angstrom exponent fixed to value ",F6.3)') & + aer_angexp_opt,aer_angexp_val + WRITE_MESSAGE(trim(wrf_err_message)) + angexp_val=min(2.5,max(-0.3,aer_angexp_val)) + do nb=1,N_BANDS + if ((angexp_val .lt. 0.999) .or. (angexp_val .gt. 1.001)) then + aod_rate=((0.55**angexp_val)*(upper_wvl(nb)**(1.-angexp_val)- & + lower_wvl(nb)**(1.-angexp_val)))/((1.-angexp_val)*(upper_wvl(nb)-lower_wvl(nb))) + else + aod_rate=(0.55/(upper_wvl(nb)-lower_wvl(nb)))*log(upper_wvl(nb)/lower_wvl(nb)) + end if + do j=jts,jte + do i=its,ite + aod550spc(i,j,nb)=aod5502d(i,j)*aod_rate + end do + end do + end do + do j=jts,jte + do i=its,ite + angexp2d(i,j)=angexp_val + end do + end do + case(2) + if (.not.(present(angexp2d))) then + write(wrf_err_message,*) 'Expected gridded aerosol Angstrom exponent, but it is not in the radiation driver' + FATAL_ERROR(trim(wrf_err_message)) + end if + write( wrf_err_message, '("aer_angexp_opt=",I1,": Angstrom exponent read from auxinput (min=",F6.3," max=",F6.3,")")') & + aer_angexp_opt,minval(angexp2d),maxval(angexp2d) + WRITE_MESSAGE(trim(wrf_err_message)) + do j=jts,jte + do i=its,ite + angexp_val=min(2.5,max(-0.3,angexp2d(i,j))) + do nb=1,N_BANDS + if ((angexp_val .lt. 0.999) .or. (angexp_val .gt. 1.001)) then + aod_rate=((0.55**angexp_val)*(upper_wvl(nb)**(1.-angexp_val)- & + lower_wvl(nb)**(1.-angexp_val)))/((1.-angexp_val)*(upper_wvl(nb)-lower_wvl(nb))) + else + aod_rate=(0.55/(upper_wvl(nb)-lower_wvl(nb)))*log(upper_wvl(nb)/lower_wvl(nb)) + end if + aod550spc(i,j,nb)=aod5502d(i,j)*aod_rate + end do + end do + end do + + case(3) + ! spectral disaggregation based on a prescribed aerosol type and relative humidity +! call mpas_log_write('--- aer_angexp_opt = $i: angstrom exponent calculated from RH and aer_type $i', & +! intArgs=(/aer_angexp_opt,aer_type/)) + call calc_spectral_aod_rrtmg_sw(ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte, & + rh,aer_type,aod5502d, & + aod550spc, & + aod5503d, aod550spc3d) ! trude + +!-- MPAS modifications: we do not need the variable angexp2d outside of subroutine calc_aerosol_rrtmg_sw. Since it is +! declared as an optional variable, we simply test if it is present or not (Laura D. Fowler/2019-01-13): + if(present(angexp2d)) then + do j=jts,jte + do i=its,ite + angexp2d(i,j) = 0.0 + enddo + enddo + + if (present(aod5503d)) then + do j=jts,jte + do k=kts,kte + do i=its,ite + xy=0 + xx=0 + do nb=8,N_BANDS-3 ! bands between 0.4 and 1.0 um + ! the slope of a linear regression with intercept=0 is m=E(xy)/E(x^2), where y=m*x + x=log(0.5*(lower_wvl(nb)+upper_wvl(nb))/0.55) + xy=xy+x*log(aod550spc3d(i,k,j,nb)/aod5503d(i,k,j)) + xx=xx+x*x + end do + angexp2d(i,j) = angexp2d(i,j) - (xy/(N_BANDS-3-8+1))/(xx/(N_BANDS-3-8+1)) + enddo + enddo + enddo + else + + ! added July, 16th, 2013: angexp2d is in the wrfout when aer_angexp_opt=3. It is the average + ! value in the spectral bands between 0.4 and 1. um + do j=jts,jte + do i=its,ite + xy=0 + xx=0 + do nb=8,N_BANDS-3 ! bands between 0.4 and 1.0 um + ! the slope of a linear regression with intercept=0 is m=E(xy)/E(x^2), where y=m*x + x=log(0.5*(lower_wvl(nb)+upper_wvl(nb))/0.55) + xy=xy+x*log(aod550spc(i,j,nb)/aod5502d(i,j)) + xx=xx+x*x + end do + angexp2d(i,j)=-(xy/(N_BANDS-3-8+1))/(xx/(N_BANDS-3-8+1)) + end do + end do + endif + endif ! end MPAS modifications. + + case default + write(wrf_err_message,*) 'Expected aer_angexp_opt=[1,2,3]. Got',aer_angexp_opt + FATAL_ERROR(trim(wrf_err_message)) + end select aer_angexp_opt_select + +!..If 3D AOD (at 550nm) was provided explicitly, then no need to assume a +!.. vertical distribution, just use what was provided. (Trude) + + if (present(aod5503d)) then + do nb=1,N_BANDS + do j=jts,jte + do k=kts,kte + do i=its,ite + tauaer(i,k,j,nb) = aod550spc3d(i,k,j,nb) + enddo + enddo + enddo + enddo + else + ! exponental -vertical- profile + call aod_profiler(ht,dz8w,aod550spc,n_bands,ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte,tauaer ) + endif + + aer_ssa_opt_select: select case(aer_ssa_opt) + !case(0) + ! reserved for climatology + case(1) + if ((aer_ssa_val .lt. 0) .or. (aer_ssa_val .gt. 1)) then + write(wrf_err_message,'("aer_ssa_val must be within [0,1]. Illegal value ",F7.4," found")') aer_ssa_val + FATAL_ERROR(trim(wrf_err_message)) + end if + write( wrf_err_message, & + '("aer_ssa_opt=",I1,": single-scattering albedo fixed to value ",F6.3)') aer_ssa_opt,aer_ssa_val + WRITE_MESSAGE(trim(wrf_err_message)) + do j=jts,jte + do i=its,ite + do k=kts,kte + do nb=1,N_BANDS + ! no spectral disaggregation + ssaaer(i,k,j,nb)=aer_ssa_val + end do + end do + end do + end do + do j=jts,jte + do i=its,ite + aerssa2d(i,j)=aer_ssa_val + end do + end do + + case(2) + if (.not.(present(aerssa2d))) then + write(wrf_err_message,*) 'Expected gridded aerosol single-scattering albedo, but it is not in the radiation driver' + FATAL_ERROR(trim(wrf_err_message)) + end if + if ((minval(aerssa2d) .lt. 0) .or. (maxval(aerssa2d) .gt. 1)) then + write(wrf_err_message,*) 'Aerosol single-scattering albedo must be within [0,1]. ' // & + 'Out of bounds value(s) found in auxinput' + FATAL_ERROR(trim(wrf_err_message)) + end if + write( wrf_err_message, '("aer_ssa_opt=",I1,": single-scattering albedo from auxinput (min=",F6.3," max=",F6.3,")")') & + aer_ssa_opt,minval(aerssa2d),maxval(aerssa2d) + WRITE_MESSAGE(trim(wrf_err_message)) + do j=jts,jte + do i=its,ite + do k=kts,kte + do nb=1,N_BANDS + ! no spectral disaggregation + ssaaer(i,k,j,nb)=aerssa2d(i,j) + end do + end do + end do + end do + + case(3) + ! spectral disaggregation based on a prescribed aerosol type and relative humidity +! call mpas_log_write('--- aer_ssa_opt = $i: single-scattering albedo calculated from RH and aer_type $i', & +! intArgs=(/aer_ssa_opt,aer_type/)) + call calc_spectral_ssa_rrtmg_sw(ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte, & + rh,aer_type,ssaaer ) +!-- MPAS modifications: we do not need the variable aerssa2d outside of subroutine calc_aerosol_rrtmg_sw. Since it is +! declared as an optional variable, we simply test if it is present or not (Laura D. Fowler/2018=04-09): + if(present(aerssa2d)) then + ! added July, 16th, 2013: aerssa2d is in the wrfout when aer_ssa_opt=3. It is the average + ! value in the spectral bands between 0.4 and 1. um + do j=jts,jte + do i=its,ite + aerssa2d(i,j)=0 + end do + end do + do j=jts,jte + do i=its,ite + do nb=8,N_BANDS-3 ! bands between 0.4 and 1.0 um + aerssa2d(i,j)=aerssa2d(i,j)+ssaaer(i,kts,j,nb) + end do + aerssa2d(i,j)=aerssa2d(i,j)/(N_BANDS-3-8+1) + end do + end do + endif ! end MPAS modifications. + + case default + write(wrf_err_message,*) 'Expected aer_ssa_opt=[1,2,3]. Got',aer_ssa_opt + FATAL_ERROR(trim(wrf_err_message)) + end select aer_ssa_opt_select + + aer_asy_opt_select: select case(aer_asy_opt) + !case(0) + ! reserved for climatology + case(1) + if ((aer_asy_val .lt. 0) .or. (aer_asy_val .gt. 1)) then + write(wrf_err_message,'("aer_asy_val must be withing [-1,1]. Illegal value ",F7.4," found")') aer_asy_val + FATAL_ERROR(trim(wrf_err_message)) + end if + write( wrf_err_message , '("aer_asy_opt=",I1,": asymmetry parameter fixed to value ",F6.3)') aer_asy_opt,aer_asy_val + WRITE_MESSAGE(trim(wrf_err_message)) + do j=jts,jte + do i=its,ite + do k=kts,kte + do nb=1,N_BANDS + asyaer(i,k,j,nb)=aer_asy_val + end do + end do + end do + end do + do j=jts,jte + do i=its,ite + aerasy2d(i,j)=aer_asy_val + end do + end do + + case(2) + if (.not.(present(aerasy2d))) then + write(wrf_err_message,*) 'Expected gridded aerosol asymmetry parameter, but it is not in the radiation driver' + FATAL_ERROR(trim(wrf_err_message)) + end if + if ((minval(aerasy2d) .lt. -1) .or. (maxval(aerasy2d) .gt. 1)) then + FATAL_ERROR('Aerosol asymmetry parameter must be within [-1,1]. Out of bounds value(s) found in auxinput') + end if + write( wrf_err_message, '("aer_asy_opt=",I1,": asymmetry parameter read from auxinput (min=",F6.3," max=",F6.3,")")') & + aer_asy_opt,minval(aerasy2d),maxval(aerasy2d) + WRITE_MESSAGE(trim(wrf_err_message)) + do j=jts,jte + do i=its,ite + do k=kts,kte + do nb=1,N_BANDS + asyaer(i,k,j,nb)=aerasy2d(i,j) + end do + end do + end do + end do + + case(3) + ! spectral disaggregation based on a prescribed aerosol type and relative humidity +! call mpas_log_write('--- aer_asy_opt = $i: asymmetry parameter calculated from RH and aer_type $i', & +! intArgs=(/aer_asy_opt,aer_type/)) + call calc_spectral_asy_rrtmg_sw(ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte, & + rh,aer_type,asyaer ) +!-- MPAS modifications: we do not need the variable aerasy2d outside of subroutine calc_aerosol_rrtmg_sw. Since it is +! declared as an optional variable, we simply test if it is present or not (Laura D. Fowler/2018=04-09): + if(present(aerasy2d)) then + ! added July, 16th, 2013: aerasy2d is in the wrfout when aer_asy_opt=3. It is the average + ! value in the spectral bands between 0.4 and 1. um + do j=jts,jte + do i=its,ite + aerasy2d(i,j)=0 + end do + end do + do j=jts,jte + do i=its,ite + do nb=8,N_BANDS-3 ! bands between 0.4 and 1.0 um + aerasy2d(i,j)=aerasy2d(i,j)+asyaer(i,kts,j,nb) + end do + aerasy2d(i,j)=aerasy2d(i,j)/(N_BANDS-3-8+1) + end do + end do + endif ! end MPAS modifications. + + case default + write(wrf_err_message,*) 'Expected aer_asy_opt=[1,2,3]. Got',aer_asy_opt + FATAL_ERROR(trim(wrf_err_message)) + end select aer_asy_opt_select + +end subroutine calc_aerosol_rrtmg_sw + +subroutine calc_spectral_aod_rrtmg_sw(ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte, & + rh,aer_type,aod550, & + tauaer, & + aod550_3d, tauaer3d) ! trude + + implicit none + + ! constants + integer, parameter :: N_AER_TYPES=3 + integer, parameter :: N_RH=8 + integer, parameter :: N_BANDS=14 + integer, parameter :: N_INT_POINTS=4 + + ! I/O variables + integer, intent(in) :: ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte +!- MPAS modifications: aer_type is a function of the land-sea mask, and set to 1 over land (or rural classification in WRF), +! and set to 0 over oceans (or maritime classification in WRF): +! integer, intent(in) :: aer_type + integer:: aer_t + integer, dimension(ims:ime,jms:jme), intent(in):: aer_type +!- end MPAS modifications (Laura D. Fowler/2018=04-09). + + real, dimension(ims:ime, kms:kme, jms:jme), intent(in) :: rh ! relative humidity + real, dimension(ims:ime, jms:jme), intent(in) :: aod550 ! Total AOD at 550 nm at surface + real, dimension(ims:ime, jms:jme, 1:N_BANDS), intent(inout) :: tauaer ! Total spectral aerosol optical depth at surface + + ! ++ Trude + real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(in) :: aod550_3d ! 3D AOD at 550 nm + real, dimension(ims:ime, kms:kme, jms:jme, 1:N_BANDS), optional, intent(inout) :: tauaer3d ! + ! -- Trude + + ! local variables + integer :: i,j,k,ib,imax,imin,ii,jj,kk + real :: rhs(N_RH),lj + real :: raod_lut(N_AER_TYPES,N_BANDS,N_RH) + + ! relative humidity steps + data (rhs(i),i=1,8) /0.,50.,70.,80.,90.,95.,98.,99./ + + ! aer_type = 1 : rural (SF79) + data (raod_lut(1,ib,1),ib=1,N_BANDS) /0.0735,0.0997,0.1281,0.1529,0.1882,0.2512,0.3010,0.4550,0.7159,1.0357, & + 1.3582,1.6760,2.2523,0.0582/ + data (raod_lut(1,ib,2),ib=1,N_BANDS) /0.0741,0.1004,0.1289,0.1537,0.1891,0.2522,0.3021,0.4560,0.7166,1.0351, & + 1.3547,1.6687,2.2371,0.0587/ + data (raod_lut(1,ib,3),ib=1,N_BANDS) /0.0752,0.1017,0.1304,0.1554,0.1909,0.2542,0.3042,0.4580,0.7179,1.0342, & + 1.3485,1.6559,2.2102,0.0596/ + data (raod_lut(1,ib,4),ib=1,N_BANDS) /0.0766,0.1034,0.1323,0.1575,0.1932,0.2567,0.3068,0.4605,0.7196,1.0332, & + 1.3411,1.6407,2.1785,0.0608/ + data (raod_lut(1,ib,5),ib=1,N_BANDS) /0.0807,0.1083,0.1379,0.1635,0.1998,0.2639,0.3143,0.4677,0.7244,1.0305, & + 1.3227,1.6031,2.1006,0.0644/ + data (raod_lut(1,ib,6),ib=1,N_BANDS) /0.0884,0.1174,0.1482,0.1746,0.2118,0.2769,0.3277,0.4805,0.7328,1.0272, & + 1.2977,1.5525,1.9976,0.0712/ + data (raod_lut(1,ib,7),ib=1,N_BANDS) /0.1072,0.1391,0.1724,0.2006,0.2396,0.3066,0.3581,0.5087,0.7510,1.0231, & + 1.2622,1.4818,1.8565,0.0878/ + data (raod_lut(1,ib,8),ib=1,N_BANDS) /0.1286,0.1635,0.1991,0.2288,0.2693,0.3377,0.3895,0.5372,0.7686,1.0213, & + 1.2407,1.4394,1.7739,0.1072/ + + ! aer_type = 2 : urban (SF79) + data (raod_lut(2,ib,1),ib=1,N_BANDS) /0.1244,0.1587,0.1939,0.2233,0.2635,0.3317,0.3835,0.5318,0.7653,1.0344, & + 1.3155,1.5885,2.0706,0.1033/ + data (raod_lut(2,ib,2),ib=1,N_BANDS) /0.1159,0.1491,0.1834,0.2122,0.2518,0.3195,0.3712,0.5207,0.7585,1.0331, & + 1.3130,1.5833,2.0601,0.0956/ + data (raod_lut(2,ib,3),ib=1,N_BANDS) /0.1093,0.1416,0.1752,0.2035,0.2427,0.3099,0.3615,0.5118,0.7529,1.0316, & + 1.3083,1.5739,2.0408,0.0898/ + data (raod_lut(2,ib,4),ib=1,N_BANDS) /0.1062,0.1381,0.1712,0.1993,0.2382,0.3052,0.3567,0.5074,0.7501,1.0302, & + 1.3025,1.5620,2.0168,0.0870/ + data (raod_lut(2,ib,5),ib=1,N_BANDS) /0.1045,0.1361,0.1690,0.1970,0.2357,0.3025,0.3540,0.5049,0.7486,1.0271, & + 1.2864,1.5297,1.9518,0.0854/ + data (raod_lut(2,ib,6),ib=1,N_BANDS) /0.1065,0.1384,0.1716,0.1997,0.2386,0.3056,0.3571,0.5078,0.7504,1.0227, & + 1.2603,1.4780,1.8492,0.0872/ + data (raod_lut(2,ib,7),ib=1,N_BANDS) /0.1147,0.1478,0.1820,0.2107,0.2503,0.3179,0.3696,0.5192,0.7575,1.0146, & + 1.2116,1.3830,1.6658,0.0946/ + data (raod_lut(2,ib,8),ib=1,N_BANDS) /0.1247,0.1590,0.1943,0.2237,0.2639,0.3322,0.3840,0.5322,0.7656,1.0082, & + 1.1719,1.3075,1.5252,0.1036/ + + ! aer_type = 3 : maritime (SF79) + data (raod_lut(3,ib,1),ib=1,N_BANDS) /0.3053,0.3507,0.3932,0.4261,0.4681,0.5334,0.5797,0.6962,0.8583,1.0187, & + 1.1705,1.3049,1.5205,0.2748/ + data (raod_lut(3,ib,2),ib=1,N_BANDS) /0.3566,0.4023,0.4443,0.4765,0.5170,0.5792,0.6227,0.7298,0.8756,1.0162, & + 1.1472,1.2614,1.4415,0.3256/ + data (raod_lut(3,ib,3),ib=1,N_BANDS) /0.4359,0.4803,0.5203,0.5505,0.5879,0.6441,0.6828,0.7756,0.8985,1.0135, & + 1.1198,1.2109,1.3518,0.4051/ + data (raod_lut(3,ib,4),ib=1,N_BANDS) /0.5128,0.5544,0.5913,0.6187,0.6523,0.7020,0.7358,0.8149,0.9174,1.0115, & + 1.0995,1.1740,1.2875,0.4835/ + data (raod_lut(3,ib,5),ib=1,N_BANDS) /0.6479,0.6816,0.7108,0.7320,0.7575,0.7946,0.8193,0.8752,0.9455,1.0092, & + 1.0728,1.1263,1.2061,0.6236/ + data (raod_lut(3,ib,6),ib=1,N_BANDS) /0.7582,0.7831,0.8043,0.8196,0.8377,0.8636,0.8806,0.9184,0.9649,1.0080, & + 1.0564,1.0973,1.1576,0.7399/ + data (raod_lut(3,ib,7),ib=1,N_BANDS) /0.8482,0.8647,0.8785,0.8884,0.9000,0.9164,0.9272,0.9506,0.9789,1.0072, & + 1.0454,1.0780,1.1256,0.8360/ + data (raod_lut(3,ib,8),ib=1,N_BANDS) /0.8836,0.8965,0.9073,0.9149,0.9239,0.9365,0.9448,0.9626,0.9841,1.0069, & + 1.0415,1.0712,1.1145,0.8741/ + +! ++ Trude ; if 3D AOD, disaggreaget at all levels. + if (present(aod550_3d)) then + do j=jts,jte + do i=its,ite + !-- initialization of aerosol type: + aer_t = aer_type(i,j) + ! common part of the Lagrange's interpolator + ! only depends on the relative humidity value + do kk = kts,kte + ii=1 + do while ( (ii.le.N_RH) .and. (rh(i,kk,j).gt.rhs(ii)) ) + ii=ii+1 + end do + imin=max(1,ii-N_INT_POINTS/2-1) + imax=min(N_RH,ii+N_INT_POINTS/2) + + do ib=1,N_BANDS + tauaer3d(i,kk,j,ib)=0. + do jj=imin,imax + lj=1. + do k=imin,imax + if (k.ne.jj) lj=lj*(rh(i,kk,j)-rhs(k))/(rhs(jj)-rhs(k)) + end do + tauaer3d(i,kk,j,ib)=tauaer3d(i,kk,j,ib)+lj*raod_lut(aer_t,ib,jj)*aod550_3d(i,kk,j) + end do + end do + end do + end do + end do + else +! -- Trude + + do j=jts,jte + do i=its,ite + !-- initialization of aerosol type: + aer_t = aer_type(i,j) + ! common part of the Lagrange's interpolator + ! only depends on the relative humidity value + ii=1 + do while ( (ii.le.N_RH) .and. (rh(i,kts,j).gt.rhs(ii)) ) + ii=ii+1 + end do + imin=max(1,ii-N_INT_POINTS/2-1) + imax=min(N_RH,ii+N_INT_POINTS/2) + + do ib=1,N_BANDS + tauaer(i,j,ib)=0. + do jj=imin,imax + lj=1. + do k=imin,imax + if (k.ne.jj) lj=lj*(rh(i,kts,j)-rhs(k))/(rhs(jj)-rhs(k)) + end do + tauaer(i,j,ib)=tauaer(i,j,ib)+lj*raod_lut(aer_t,ib,jj)*aod550(i,j) + end do + end do + end do + end do + endif + +end subroutine calc_spectral_aod_rrtmg_sw + +subroutine calc_spectral_ssa_rrtmg_sw(ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte, & + rh,aer_type, & + ssaaer ) + implicit none + + ! constants + integer, parameter :: N_AER_TYPES=3 + integer, parameter :: N_RH=8 + integer, parameter :: N_BANDS=14 + integer, parameter :: N_INT_POINTS=4 + + ! I/O variables + integer, intent(in) :: ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte +!- MPAS modifications: aer_type is a function of the land-sea mask, and set to 1 over land (or rural classification in WRF), +! and set to 0 over oceans (or maritime classification in WRF): +! integer, intent(in) :: aer_type + integer:: aer_t + integer, dimension(ims:ime,jms:jme), intent(in):: aer_type +!- end MPAS modifications (Laura D. Fowler/2018=04-09). + real, dimension(ims:ime, kms:kme, jms:jme), intent(in) :: rh ! surface relative humidity + real, dimension(ims:ime, kms:kme, jms:jme, 1:N_BANDS), intent(inout) :: ssaaer ! aerosol single-scattering albedo at surface + + ! local variables + integer :: i,j,k,kk,ib,imax,imin,ii,jj + real :: rhs(N_RH),lj + real :: ssa_lut(N_AER_TYPES,N_BANDS,N_RH) + + ! relative humidity steps + data (rhs(i),i=1,8) /0.,50.,70.,80.,90.,95.,98.,99./ + + ! aer_type = 1 : rural (SF79) + data (ssa_lut(1,ib,1),ib=1,N_BANDS) /0.8730,0.6695,0.8530,0.8601,0.8365,0.7949,0.8113,0.8810,0.9305,0.9436, & + 0.9532,0.9395,0.8007,0.8634/ + data (ssa_lut(1,ib,2),ib=1,N_BANDS) /0.8428,0.6395,0.8571,0.8645,0.8408,0.8007,0.8167,0.8845,0.9326,0.9454, & + 0.9545,0.9416,0.8070,0.8589/ + data (ssa_lut(1,ib,3),ib=1,N_BANDS) /0.8000,0.6025,0.8668,0.8740,0.8503,0.8140,0.8309,0.8943,0.9370,0.9489, & + 0.9577,0.9451,0.8146,0.8548/ + data (ssa_lut(1,ib,4),ib=1,N_BANDS) /0.7298,0.5666,0.9030,0.9049,0.8863,0.8591,0.8701,0.9178,0.9524,0.9612, & + 0.9677,0.9576,0.8476,0.8578/ + data (ssa_lut(1,ib,5),ib=1,N_BANDS) /0.7010,0.5606,0.9312,0.9288,0.9183,0.9031,0.9112,0.9439,0.9677,0.9733, & + 0.9772,0.9699,0.8829,0.8590/ + data (ssa_lut(1,ib,6),ib=1,N_BANDS) /0.6933,0.5620,0.9465,0.9393,0.9346,0.9290,0.9332,0.9549,0.9738,0.9782, & + 0.9813,0.9750,0.8980,0.8594/ + data (ssa_lut(1,ib,7),ib=1,N_BANDS) /0.6842,0.5843,0.9597,0.9488,0.9462,0.9470,0.9518,0.9679,0.9808,0.9839, & + 0.9864,0.9794,0.9113,0.8648/ + data (ssa_lut(1,ib,8),ib=1,N_BANDS) /0.6786,0.5897,0.9658,0.9522,0.9530,0.9610,0.9651,0.9757,0.9852,0.9871, & + 0.9883,0.9835,0.9236,0.8618/ + + ! aer_type = 2: urban (SF79) + data (ssa_lut(2,ib,1),ib=1,N_BANDS) /0.4063,0.3663,0.4093,0.4205,0.4487,0.4912,0.5184,0.5743,0.6233,0.6392, & + 0.6442,0.6408,0.6105,0.4094/ + data (ssa_lut(2,ib,2),ib=1,N_BANDS) /0.4113,0.3654,0.4215,0.4330,0.4604,0.5022,0.5293,0.5848,0.6336,0.6493, & + 0.6542,0.6507,0.6205,0.4196/ + data (ssa_lut(2,ib,3),ib=1,N_BANDS) /0.4500,0.3781,0.4924,0.5050,0.5265,0.5713,0.6048,0.6274,0.6912,0.7714, & + 0.7308,0.7027,0.6772,0.4820/ + data (ssa_lut(2,ib,4),ib=1,N_BANDS) /0.5075,0.4139,0.5994,0.6127,0.6350,0.6669,0.6888,0.7333,0.7704,0.7809, & + 0.7821,0.7762,0.7454,0.5709/ + data (ssa_lut(2,ib,5),ib=1,N_BANDS) /0.5596,0.4570,0.7009,0.7118,0.7317,0.7583,0.7757,0.8093,0.8361,0.8422, & + 0.8406,0.8337,0.8036,0.6525/ + data (ssa_lut(2,ib,6),ib=1,N_BANDS) /0.6008,0.4971,0.7845,0.7906,0.8075,0.8290,0.8418,0.8649,0.8824,0.8849, & + 0.8815,0.8739,0.8455,0.7179/ + data (ssa_lut(2,ib,7),ib=1,N_BANDS) /0.6401,0.5407,0.8681,0.8664,0.8796,0.8968,0.9043,0.9159,0.9244,0.9234, & + 0.9182,0.9105,0.8849,0.7796/ + data (ssa_lut(2,ib,8),ib=1,N_BANDS) /0.6567,0.5618,0.9073,0.9077,0.9182,0.9279,0.9325,0.9398,0.9440,0.9413, & + 0.9355,0.9278,0.9039,0.8040/ + + ! aer_type = 3 : maritime (SF79) + data (ssa_lut(3,ib,1),ib=1,N_BANDS) /0.9697,0.9183,0.9749,0.9820,0.9780,0.9712,0.9708,0.9778,0.9831,0.9827, & + 0.9826,0.9723,0.8763,0.9716/ + data (ssa_lut(3,ib,2),ib=1,N_BANDS) /0.9070,0.8491,0.9730,0.9816,0.9804,0.9742,0.9738,0.9802,0.9847,0.9841, & + 0.9838,0.9744,0.8836,0.9546/ + data (ssa_lut(3,ib,3),ib=1,N_BANDS) /0.8378,0.7761,0.9797,0.9827,0.9829,0.9814,0.9812,0.9852,0.9882,0.9875, & + 0.9871,0.9791,0.9006,0.9348/ + data (ssa_lut(3,ib,4),ib=1,N_BANDS) /0.7866,0.7249,0.9890,0.9822,0.9856,0.9917,0.9924,0.9932,0.9943,0.9938, & + 0.9933,0.9887,0.9393,0.9204/ + data (ssa_lut(3,ib,5),ib=1,N_BANDS) /0.7761,0.7164,0.9959,0.9822,0.9834,0.9941,0.9955,0.9952,0.9960,0.9956, & + 0.9951,0.9922,0.9538,0.9152/ + data (ssa_lut(3,ib,6),ib=1,N_BANDS) /0.7671,0.7114,0.9902,0.9786,0.9838,0.9954,0.9970,0.9965,0.9971,0.9968, & + 0.9964,0.9943,0.9644,0.9158/ + data (ssa_lut(3,ib,7),ib=1,N_BANDS) /0.7551,0.7060,0.9890,0.9743,0.9807,0.9966,0.9989,0.9978,0.9982,0.9980, & + 0.9978,0.9964,0.9757,0.9122/ + data (ssa_lut(3,ib,8),ib=1,N_BANDS) /0.7439,0.7000,0.9870,0.9695,0.9769,0.9970,1.0000,0.9984,0.9988,0.9986, & + 0.9984,0.9975,0.9825,0.9076/ + + do j=jts,jte + do i=its,ite + !-- initialization of aerosol type: + aer_t = aer_type(i,j) + do k=kts,kte + ! common part of the Lagrange's interpolator + ! only depends on the relative humidity value + ii=1 + do while ( (ii.le.N_RH) .and. (rh(i,k,j).gt.rhs(ii)) ) + ii=ii+1 + end do + imin=max(1,ii-N_INT_POINTS/2-1) + imax=min(N_RH,ii+N_INT_POINTS/2) + + do ib=1,N_BANDS + ssaaer(i,k,j,ib)=0. + do jj=imin,imax + lj=1. + do kk=imin,imax + if (kk.ne.jj) lj=lj*(rh(i,k,j)-rhs(kk))/(rhs(jj)-rhs(kk)) + end do + ssaaer(i,k,j,ib)=ssaaer(i,k,j,ib)+lj*ssa_lut(aer_t,ib,jj) + end do + end do + end do + end do + end do +end subroutine calc_spectral_ssa_rrtmg_sw + +subroutine calc_spectral_asy_rrtmg_sw(ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte, & + rh,aer_type, & + asyaer ) + implicit none + + ! constants + integer, parameter :: N_AER_TYPES=3 + integer, parameter :: N_RH=8 + integer, parameter :: N_BANDS=14 + integer, parameter :: N_INT_POINTS=4 + + ! I/O variables + integer, intent(in) :: ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte +!- MPAS modifications: aer_type is a function of the land-sea mask, and set to 1 over land (or rural classification in WRF), +! and set to 0 over oceans (or maritime classification in WRF): +! integer, intent(in) :: aer_type + integer:: aer_t + integer, dimension(ims:ime,jms:jme), intent(in):: aer_type +!- end MPAS modifications (Laura D. Fowler/2018=04-09). + real, dimension(ims:ime, kms:kme, jms:jme), intent(in) :: rh ! surface relative humidity + real, dimension(ims:ime, kms:kme, jms:jme, 1:N_BANDS), intent(inout) :: asyaer ! aerosol asymmetry parameter at surface + + ! local variables + integer :: i,j,k,kk,ib,imax,imin,ii,jj + real :: rhs(N_RH),lj + real :: asy_lut(N_AER_TYPES,N_BANDS,N_RH) + + ! relative humidity steps + data (rhs(i),i=1,8) /0.,50.,70.,80.,90.,95.,98.,99./ + + ! aer_type = 1 : rural (SF79) + data (asy_lut(1,ib,1),ib=1,N_BANDS) /0.7444,0.7711,0.7306,0.7103,0.6693,0.6267,0.6169,0.6207,0.6341,0.6497, & + 0.6630,0.6748,0.7208,0.7419/ + data (asy_lut(1,ib,2),ib=1,N_BANDS) /0.7444,0.7747,0.7314,0.7110,0.6711,0.6301,0.6210,0.6251,0.6392,0.6551, & + 0.6680,0.6799,0.7244,0.7436/ + data (asy_lut(1,ib,3),ib=1,N_BANDS) /0.7438,0.7845,0.7341,0.7137,0.6760,0.6381,0.6298,0.6350,0.6497,0.6657, & + 0.6790,0.6896,0.7300,0.7477/ + data (asy_lut(1,ib,4),ib=1,N_BANDS) /0.7336,0.7934,0.7425,0.7217,0.6925,0.6665,0.6616,0.6693,0.6857,0.7016, & + 0.7139,0.7218,0.7495,0.7574/ + data (asy_lut(1,ib,5),ib=1,N_BANDS) /0.7111,0.7865,0.7384,0.7198,0.6995,0.6864,0.6864,0.6987,0.7176,0.7326, & + 0.7427,0.7489,0.7644,0.7547/ + data (asy_lut(1,ib,6),ib=1,N_BANDS) /0.7009,0.7828,0.7366,0.7196,0.7034,0.6958,0.6979,0.7118,0.7310,0.7452, & + 0.7542,0.7593,0.7692,0.7522/ + data (asy_lut(1,ib,7),ib=1,N_BANDS) /0.7226,0.8127,0.7621,0.7434,0.7271,0.7231,0.7248,0.7351,0.7506,0.7622, & + 0.7688,0.7719,0.7756,0.7706/ + data (asy_lut(1,ib,8),ib=1,N_BANDS) /0.7296,0.8219,0.7651,0.7513,0.7404,0.7369,0.7386,0.7485,0.7626,0.7724, & + 0.7771,0.7789,0.7790,0.7760/ + + ! aer_type = 2: urban (SF79) + data (asy_lut(2,ib,1),ib=1,N_BANDS) /0.7399,0.7372,0.7110,0.6916,0.6582,0.6230,0.6147,0.6214,0.6412,0.6655, & + 0.6910,0.7124,0.7538,0.7395/ + data (asy_lut(2,ib,2),ib=1,N_BANDS) /0.7400,0.7419,0.7146,0.6952,0.6626,0.6287,0.6209,0.6280,0.6481,0.6723, & + 0.6974,0.7180,0.7575,0.7432/ + data (asy_lut(2,ib,3),ib=1,N_BANDS) /0.7363,0.7614,0.7303,0.7100,0.6815,0.6550,0.6498,0.6590,0.6802,0.7032, & + 0.7255,0.7430,0.7735,0.7580/ + data (asy_lut(2,ib,4),ib=1,N_BANDS) /0.7180,0.7701,0.7358,0.7163,0.6952,0.6807,0.6801,0.6935,0.7160,0.7370, & + 0.7553,0.7681,0.7862,0.7623/ + data (asy_lut(2,ib,5),ib=1,N_BANDS) /0.7013,0.7733,0.7374,0.7203,0.7057,0.7006,0.7035,0.7192,0.7415,0.7596, & + 0.7739,0.7827,0.7906,0.7596/ + data (asy_lut(2,ib,6),ib=1,N_BANDS) /0.6922,0.7773,0.7404,0.7264,0.7170,0.7179,0.7228,0.7389,0.7595,0.7746, & + 0.7851,0.7909,0.7918,0.7562/ + data (asy_lut(2,ib,7),ib=1,N_BANDS) /0.6928,0.7875,0.7491,0.7393,0.7345,0.7397,0.7455,0.7602,0.7773,0.7883, & + 0.7944,0.7970,0.7912,0.7555/ + data (asy_lut(2,ib,8),ib=1,N_BANDS) /0.7021,0.7989,0.7590,0.7512,0.7613,0.7746,0.7718,0.7727,0.7867,0.7953, & + 0.7988,0.7994,0.7906,0.7600/ + + ! aer_type = 3 : maritime (SF79) + data (asy_lut(3,ib,1),ib=1,N_BANDS) /0.6620,0.7011,0.7111,0.7068,0.6990,0.6918,0.6883,0.6827,0.6768,0.6773, & + 0.6863,0.6940,0.7245,0.6719/ + data (asy_lut(3,ib,2),ib=1,N_BANDS) /0.6880,0.7394,0.7297,0.7240,0.7162,0.7083,0.7038,0.6957,0.6908,0.6917, & + 0.6952,0.7035,0.7356,0.6977/ + data (asy_lut(3,ib,3),ib=1,N_BANDS) /0.7266,0.7970,0.7666,0.7593,0.7505,0.7427,0.7391,0.7293,0.7214,0.7210, & + 0.7212,0.7265,0.7519,0.7340/ + data (asy_lut(3,ib,4),ib=1,N_BANDS) /0.7683,0.8608,0.8120,0.8030,0.7826,0.7679,0.7713,0.7760,0.7723,0.7716, & + 0.7726,0.7767,0.7884,0.7768/ + data (asy_lut(3,ib,5),ib=1,N_BANDS) /0.7776,0.8727,0.8182,0.8083,0.7985,0.7939,0.7953,0.7913,0.7846,0.7870, & + 0.7899,0.7918,0.7969,0.7870/ + data (asy_lut(3,ib,6),ib=1,N_BANDS) /0.7878,0.8839,0.8231,0.8130,0.8050,0.7977,0.7945,0.7932,0.7955,0.7992, & + 0.8025,0.8035,0.8055,0.7956/ + data (asy_lut(3,ib,7),ib=1,N_BANDS) /0.8005,0.8957,0.8273,0.8179,0.8105,0.8035,0.8010,0.8030,0.8081,0.8108, & + 0.8143,0.8174,0.8174,0.8042/ + data (asy_lut(3,ib,8),ib=1,N_BANDS) /0.8104,0.9034,0.8294,0.8212,0.8144,0.8087,0.8077,0.8118,0.8175,0.8202, & + 0.8239,0.8265,0.8246,0.8095/ + + do j=jts,jte + do i=its,ite + !-- initialization of aerosol type: + aer_t = aer_type(i,j) + do k=kts,kte + ! common part of the Lagrange's interpolator + ! only depends on the relative humidity value + ii=1 + do while ( (ii.le.N_RH) .and. (rh(i,k,j).gt.rhs(ii)) ) + ii=ii+1 + end do + imin=max(1,ii-N_INT_POINTS/2-1) + imax=min(N_RH,ii+N_INT_POINTS/2) + + do ib=1,N_BANDS + asyaer(i,k,j,ib)=0. + do jj=imin,imax + lj=1. + do kk=imin,imax + if (kk.ne.jj) lj=lj*(rh(i,k,j)-rhs(kk))/(rhs(jj)-rhs(kk)) + end do + asyaer(i,k,j,ib)=asyaer(i,k,j,ib)+lj*asy_lut(aer_t,ib,jj) + end do + end do + end do + end do + end do +end subroutine calc_spectral_asy_rrtmg_sw + +subroutine aod_profiler(ht,dz8w,taod550,n_bands, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte, & + aod550 & + ) + implicit none + + ! constants + real, parameter :: scale_height=2500. ! meters + + ! I/O variables + integer, intent(in) :: n_bands + integer, intent(in) :: ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte + real, dimension( ims:ime, jms:jme), intent(in) :: ht + real, dimension( ims:ime, kms:kme, jms:jme ), intent(in) :: dz8w + real, dimension( ims:ime, jms:jme, 1:n_bands), intent(in) :: taod550 + real, dimension( ims:ime, kms:kme, jms:jme, 1:n_bands ), intent(inout) :: aod550 + + ! local variables + real, dimension(its:ite,kts:kte) :: z2d,aod5502d + real, dimension(its:ite) :: htoa + real :: aod_scale + real :: aod_acum + integer :: i,j,k,nb + + ! input variables from driver are defined such as kms is sfc and + ! kme is toa. Equivalently, kts is sfc and kte is toa + do j=jts,jte + ! heigth profile + ! kts=surface, kte=toa + do i=its,ite + z2d(i,kts)=ht(i,j)+0.5*dz8w(i,kts,j) + do k=kts+1,kte + z2d(i,k)=z2d(i,k-1)+0.5*(dz8w(i,k-1,j)+dz8w(i,k,j)) + end do + htoa(i)=z2d(i,kte)+0.5*dz8w(i,kte,j) + end do + + do nb=1,n_bands + ! AOD exponential profile + do i=its,ite + aod_scale=taod550(i,j,nb)/(scale_height*(exp(-ht(i,j)/scale_height)-exp(-htoa(i)/scale_height))) + do k=kts,kte + aod550(i,k,j,nb)=aod_scale*dz8w(i,k,j)*exp(-z2d(i,k)/scale_height) + end do + end do + end do ! nb-loop + end do ! j-loop +end subroutine aod_profiler + +subroutine calc_relative_humidity(p,t3d,qv3d, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte, & + rh ) + implicit none + + ! I/O variables + integer, intent(in) :: ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte + ! Naming convention: 8~at => p8w reads as "p-at-w" (w=full levels) + real, dimension(ims:ime, kms:kme, jms:jme), intent(in) :: p, & ! pressure (Pa) + t3d, & ! temperature (K) + qv3d ! water vapor mixing ratio (kg/kg) + real, dimension(ims:ime, kms:kme, jms:jme), intent(inout) :: rh ! relative humidity at surface + + ! local variables + real :: tc,rv,es,e + integer :: i,j,k + + do j=jts,jte + do i=its,ite + do k=kts,kte ! only calculations at surface level + tc=t3d(i,k,j)-273.15 ! temperature (C) + rv=max(0.,qv3d(i,k,j)) ! water vapor mixing ration (kg kg-1) + es=6.112*exp((17.6*tc)/(tc+243.5)) ! saturation vapor pressure, hPa, Bolton (1980) + e =0.01*rv*p(i,k,j)/(rv+0.62197) ! vapor pressure, hPa, (ECMWF handouts, page 6, Atmosph. Thermdyn.) + ! rv=eps * e/(p-e) -> e=p * rv/(rv+eps), eps=0.62197 + rh(i,k,j)=min(99.,max(0.,100.*e/es)) ! relative humidity (%) + end do + end do + end do + +end subroutine calc_relative_humidity + +!================================================================================================================= + end module module_ra_rrtmg_sw_aerosols +!================================================================================================================= diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_sfclayrev.F b/src/core_atmosphere/physics/physics_wrf/module_sf_sfclayrev.F index ce6e71bff8..ac70882989 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_sfclayrev.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_sfclayrev.F @@ -1,11 +1,9 @@ !================================================================================================================= module module_sf_sfclayrev - use mpas_log - use ccpp_kinds,only: kind_phys - - use sf_sfclayrev,only: sf_sfclayrev_run, & - sf_sfclayrev_timestep_init + use mpas_kind_types,only: kind_phys => RKIND + use sf_sfclayrev,only: sf_sfclayrev_run + use sf_sfclayrev_pre,only: sf_sfclayrev_pre_run implicit none private @@ -24,13 +22,12 @@ subroutine sfclayrev(u3d,v3d,t3d,qv3d,p3d,dz8w, & u10,v10,th2,t2,q2, & gz1oz0,wspd,br,isfflx,dx, & svp1,svp2,svp3,svpt0,ep1,ep2, & - karman,eomeg,stbolt, & - p1000mb, & + karman,p1000mb,lakemask, & ids,ide,jds,jde,kds,kde, & ims,ime,jms,jme,kms,kme, & its,ite,jts,jte,kts,kte, & ustm,ck,cka,cd,cda,isftcflx,iz0tlnd, & - shalwater_z0,water_depth,shalwater_depth, & + shalwater_z0,water_depth, & scm_force_flux,errmsg,errflg) !================================================================================================================= @@ -45,10 +42,9 @@ subroutine sfclayrev(u3d,v3d,t3d,qv3d,p3d,dz8w, & integer,intent(in),optional:: scm_force_flux real(kind=kind_phys),intent(in):: svp1,svp2,svp3,svpt0 - real(kind=kind_phys),intent(in):: ep1,ep2,karman,eomeg,stbolt - real(kind=kind_phys),intent(in):: P1000mb + 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):: shalwater_depth real(kind=kind_phys),intent(in),dimension(ims:ime,jms:jme):: & dx, & @@ -57,6 +53,7 @@ subroutine sfclayrev(u3d,v3d,t3d,qv3d,p3d,dz8w, & psfc, & tsk, & xland, & + lakemask, & water_depth real(kind=kind_phys),intent(in),dimension(ims:ime,kms:kme,jms:jme):: & @@ -115,11 +112,15 @@ subroutine sfclayrev(u3d,v3d,t3d,qv3d,p3d,dz8w, & ustm !--- local variables and arrays: + logical:: l_isfflx + logical:: l_shalwater_z0 + logical:: l_scm_force_flux + integer:: i,j,k real(kind=kind_phys),dimension(its:ite):: dz1d,u1d,v1d,qv1d,p1d,t1d real(kind=kind_phys),dimension(its:ite):: & - dx_hv,mavail_hv,pblh_hv,psfc_hv,tsk_hv,xland_hv,water_depth_hv + dx_hv,mavail_hv,pblh_hv,psfc_hv,tsk_hv,xland_hv,water_depth_hv,lakemask_hv real(kind=kind_phys),dimension(its:ite,kts:kte):: & dz_hv,u_hv,v_hv,qv_hv,p_hv,t_hv @@ -137,6 +138,13 @@ subroutine sfclayrev(u3d,v3d,t3d,qv3d,p3d,dz8w, & !----------------------------------------------------------------------------------------------------------------- + l_isfflx = .false. + l_shalwater_z0 = .false. + l_scm_force_flux = .false. + if(isfflx .eq. 1) l_isfflx = .true. + if(shalwater_z0 .eq. 1) l_shalwater_z0 = .true. + if(scm_force_flux .eq. 1) l_scm_force_flux = .true. + do j = jts,jte do i = its,ite @@ -147,6 +155,7 @@ subroutine sfclayrev(u3d,v3d,t3d,qv3d,p3d,dz8w, & psfc_hv(i) = psfc(i,j) tsk_hv(i) = tsk(i,j) xland_hv(i) = xland(i,j) + lakemask_hv(i) = lakemask(i,j) water_depth_hv(i) = water_depth(i,j) do k = kts,kte @@ -190,7 +199,7 @@ subroutine sfclayrev(u3d,v3d,t3d,qv3d,p3d,dz8w, & enddo endif - call sf_sfclayrev_timestep_init(dz2d=dz_hv,u2d=u_hv,v2d=v_hv,qv2d=qv_hv,p2d=p_hv,t2d=t_hv, & + call sf_sfclayrev_pre_run(dz2d=dz_hv,u2d=u_hv,v2d=v_hv,qv2d=qv_hv,p2d=p_hv,t2d=t_hv, & dz1d=dz1d,u1d=u1d,v1d=v1d,qv1d=qv1d,p1d=p1d,t1d=t1d, & its=its,ite=ite,kts=kts,kte=kte,errmsg=errmsg,errflg=errflg) @@ -199,20 +208,16 @@ subroutine sfclayrev(u3d,v3d,t3d,qv3d,p3d,dz8w, & chs2=chs2_hv,cqs2=cqs2_hv,cpm=cpm_hv,pblh=pblh_hv, & rmol=rmol_hv,znt=znt_hv,ust=ust_hv,mavail=mavail_hv, & zol=zol_hv,mol=mol_hv,regime=regime_hv,psim=psim_hv, & - psih=psih_hv,fm=fm_hv,fh=fh_hv,xland=xland_hv, & + psih=psih_hv,fm=fm_hv,fh=fh_hv,xland=xland_hv,lakemask=lakemask_hv, & hfx=hfx_hv,qfx=qfx_hv,tsk=tsk_hv,u10=u10_hv, & v10=v10_hv,th2=th2_hv,t2=t2_hv,q2=q2_hv,flhc=flhc_hv, & flqc=flqc_hv,qgh=qgh_hv,qsfc=qsfc_hv,lh=lh_hv, & - gz1oz0=gz1oz0_hv,wspd=wspd_hv,br=br_hv,isfflx=isfflx,dx=dx_hv, & + gz1oz0=gz1oz0_hv,wspd=wspd_hv,br=br_hv,isfflx=l_isfflx,dx=dx_hv, & svp1=svp1,svp2=svp2,svp3=svp3,svpt0=svpt0,ep1=ep1,ep2=ep2,karman=karman, & - eomeg=eomeg,stbolt=stbolt,p1000mb=p1000mb, & - shalwater_z0=shalwater_z0,water_depth=water_depth_hv, & - shalwater_depth=shalwater_depth, & + p1000mb=p1000mb,shalwater_z0=l_shalwater_z0,water_depth=water_depth_hv, & + isftcflx=isftcflx,iz0tlnd=iz0tlnd,scm_force_flux=l_scm_force_flux, & + ustm=ustm_hv,ck=ck_hv,cka=cka_hv,cd=cd_hv,cda=cda_hv, & its=its,ite=ite,errmsg=errmsg,errflg=errflg & -#if ( ( EM_CORE == 1 ) || ( defined(mpas) ) ) - ,isftcflx=isftcflx,iz0tlnd=iz0tlnd,scm_force_flux=scm_force_flux, & - ustm=ustm_hv,ck=ck_hv,cka=cka_hv,cd=cd_hv,cda=cda_hv & -#endif ) do i = its,ite diff --git a/src/core_atmosphere/physics/physics_wrf/sf_mynn_pre.F b/src/core_atmosphere/physics/physics_wrf/sf_mynn_pre.F index e4d07a85d4..5e9ab3f61b 100644 --- a/src/core_atmosphere/physics/physics_wrf/sf_mynn_pre.F +++ b/src/core_atmosphere/physics/physics_wrf/sf_mynn_pre.F @@ -1,6 +1,6 @@ !================================================================================================================= module sf_mynn_pre - use ccpp_kinds,only: kind_phys + use ccpp_kind_types,only: kind_phys implicit none private diff --git a/src/core_atmosphere/physics/physics_wrf/sf_sfclayrev_pre.F b/src/core_atmosphere/physics/physics_wrf/sf_sfclayrev_pre.F new file mode 100644 index 0000000000..bff574dca5 --- /dev/null +++ b/src/core_atmosphere/physics/physics_wrf/sf_sfclayrev_pre.F @@ -0,0 +1,101 @@ +!================================================================================================================= + module sf_sfclayrev_pre + use ccpp_kind_types,only: kind_phys + + implicit none + private + public:: sf_sfclayrev_pre_init, & + sf_sfclayrev_pre_finalize, & + sf_sfclayrev_pre_run + + + contains + + +!================================================================================================================= +!>\section arg_table_sf_sfclayrev_pre_init +!!\html\include sf_sfclayrev_pre_init.html +!! + subroutine sf_sfclayrev_pre_init(errmsg,errflg) +!================================================================================================================= + +!--- output arguments: + character(len=*),intent(out):: & + errmsg ! output error message (-). + + integer,intent(out):: & + errflg ! output error flag (-). + +!----------------------------------------------------------------------------------------------------------------- + +!--- output error flag and message: + errflg = 0 + errmsg = " " + + end subroutine sf_sfclayrev_pre_init + +!================================================================================================================= +!>\section arg_table_sf_sfclayrev_pre_finalize +!!\html\include sf_sfclayrev_pre_finalize.html +!! + subroutine sf_sfclayrev_pre_finalize(errmsg,errflg) +!================================================================================================================= + +!--- output arguments: + character(len=*),intent(out):: & + errmsg ! output error message (-). + + integer,intent(out):: & + errflg ! output error flag (-). + +!----------------------------------------------------------------------------------------------------------------- + +!--- output error flag and message: + errflg = 0 + errmsg = " " + + end subroutine sf_sfclayrev_pre_finalize + +!================================================================================================================= +!>\section arg_table_sf_sfclayrev_pre_run +!!\html\include sf_sfclayrev_pre_run.html +!! + subroutine sf_sfclayrev_pre_run(dz2d,u2d,v2d,qv2d,p2d,t2d,dz1d,u1d,v1d,qv1d,p1d,t1d, & + its,ite,kts,kte,errmsg,errflg) +!================================================================================================================= + +!--- input arguments: + integer,intent(in):: its,ite,kts,kte + + real(kind=kind_phys),intent(in),dimension(its:ite,kts:kte):: & + dz2d,u2d,v2d,qv2d,p2d,t2d + +!--- output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + + real(kind=kind_phys),intent(out),dimension(its:ite):: & + dz1d,u1d,v1d,qv1d,p1d,t1d + +!--- local variables: + integer:: i + +!----------------------------------------------------------------------------------------------------------------- + + do i = its,ite + dz1d(i) = dz2d(i,kts) + u1d(i) = u2d(i,kts) + v1d(i) = v2d(i,kts) + qv1d(i) = qv2d(i,kts) + p1d(i) = p2d(i,kts) + t1d(i) = t2d(i,kts) + enddo + + errmsg = 'sf_sfclayrev_pre_run OK' + errflg = 0 + + end subroutine sf_sfclayrev_pre_run + +!================================================================================================================= + end module sf_sfclayrev_pre +!================================================================================================================= diff --git a/src/core_atmosphere/tools/manage_externals/.gitignore b/src/core_atmosphere/tools/manage_externals/.gitignore new file mode 100644 index 0000000000..a71ac0cd75 --- /dev/null +++ b/src/core_atmosphere/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/src/core_atmosphere/tools/manage_externals/LICENSE.txt b/src/core_atmosphere/tools/manage_externals/LICENSE.txt new file mode 100644 index 0000000000..665ee03fbc --- /dev/null +++ b/src/core_atmosphere/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/src/core_atmosphere/tools/manage_externals/README.md b/src/core_atmosphere/tools/manage_externals/README.md new file mode 100644 index 0000000000..9475301b5d --- /dev/null +++ b/src/core_atmosphere/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/src/core_atmosphere/tools/manage_externals/README_FIRST b/src/core_atmosphere/tools/manage_externals/README_FIRST new file mode 100644 index 0000000000..c8a47d7806 --- /dev/null +++ b/src/core_atmosphere/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/src/core_atmosphere/tools/manage_externals/checkout_externals b/src/core_atmosphere/tools/manage_externals/checkout_externals new file mode 100755 index 0000000000..536c64eb65 --- /dev/null +++ b/src/core_atmosphere/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/src/core_atmosphere/tools/manage_externals/manic/__init__.py b/src/core_atmosphere/tools/manage_externals/manic/__init__.py new file mode 100644 index 0000000000..11badedd3b --- /dev/null +++ b/src/core_atmosphere/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/src/core_atmosphere/tools/manage_externals/manic/checkout.py b/src/core_atmosphere/tools/manage_externals/manic/checkout.py new file mode 100755 index 0000000000..25c05ea233 --- /dev/null +++ b/src/core_atmosphere/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/src/core_atmosphere/tools/manage_externals/manic/externals_description.py b/src/core_atmosphere/tools/manage_externals/manic/externals_description.py new file mode 100644 index 0000000000..546e7fdcb4 --- /dev/null +++ b/src/core_atmosphere/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/src/core_atmosphere/tools/manage_externals/manic/externals_status.py b/src/core_atmosphere/tools/manage_externals/manic/externals_status.py new file mode 100644 index 0000000000..6bc29e9732 --- /dev/null +++ b/src/core_atmosphere/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/src/core_atmosphere/tools/manage_externals/manic/global_constants.py b/src/core_atmosphere/tools/manage_externals/manic/global_constants.py new file mode 100644 index 0000000000..0e91cffc90 --- /dev/null +++ b/src/core_atmosphere/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/src/core_atmosphere/tools/manage_externals/manic/repository.py b/src/core_atmosphere/tools/manage_externals/manic/repository.py new file mode 100644 index 0000000000..ea4230fb7b --- /dev/null +++ b/src/core_atmosphere/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/src/core_atmosphere/tools/manage_externals/manic/repository_factory.py b/src/core_atmosphere/tools/manage_externals/manic/repository_factory.py new file mode 100644 index 0000000000..18c73ffc4b --- /dev/null +++ b/src/core_atmosphere/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/src/core_atmosphere/tools/manage_externals/manic/repository_git.py b/src/core_atmosphere/tools/manage_externals/manic/repository_git.py new file mode 100644 index 0000000000..aab1a468a8 --- /dev/null +++ b/src/core_atmosphere/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/src/core_atmosphere/tools/manage_externals/manic/repository_svn.py b/src/core_atmosphere/tools/manage_externals/manic/repository_svn.py new file mode 100644 index 0000000000..b66c72e079 --- /dev/null +++ b/src/core_atmosphere/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/src/core_atmosphere/tools/manage_externals/manic/sourcetree.py b/src/core_atmosphere/tools/manage_externals/manic/sourcetree.py new file mode 100644 index 0000000000..cf2a5b7569 --- /dev/null +++ b/src/core_atmosphere/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/src/core_atmosphere/tools/manage_externals/manic/utils.py b/src/core_atmosphere/tools/manage_externals/manic/utils.py new file mode 100644 index 0000000000..9c63ffe65e --- /dev/null +++ b/src/core_atmosphere/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/src/core_atmosphere/tools/manage_externals/version.txt b/src/core_atmosphere/tools/manage_externals/version.txt new file mode 100644 index 0000000000..cbda54c515 --- /dev/null +++ b/src/core_atmosphere/tools/manage_externals/version.txt @@ -0,0 +1 @@ +manic-1.2.24-3-gba00e50 diff --git a/src/core_init_atmosphere/CMakeLists.txt b/src/core_init_atmosphere/CMakeLists.txt new file mode 100644 index 0000000000..cd67fb4d2e --- /dev/null +++ b/src/core_init_atmosphere/CMakeLists.txt @@ -0,0 +1,78 @@ +# MPAS/src/core_init_atmosphere +# +# Targets +# MPAS::core::init_atmosphere + +## Generated includes +set(init_atm_core_inc + block_dimension_routines.inc + core_variables.inc + define_packages.inc + domain_variables.inc + namelist_call.inc + namelist_defines.inc + setup_immutable_streams.inc + structs_and_variables.inc) + +## core_init_atosphere +set(init_atm_core_srcs + mpas_atm_advection.F + mpas_atmphys_constants.F + mpas_atmphys_date_time.F + mpas_atmphys_functions.F + mpas_atmphys_initialize_real.F + mpas_atmphys_utilities.F + mpas_geotile_manager.F + mpas_init_atm_bitarray.F + mpas_init_atm_cases.F + mpas_init_atm_core.F + mpas_init_atm_core_interface.F + mpas_init_atm_gwd.F + mpas_init_atm_hinterp.F + mpas_init_atm_llxy.F + mpas_init_atm_queue.F + mpas_init_atm_read_met.F + mpas_init_atm_static.F + mpas_init_atm_surface.F + mpas_init_atm_vinterp.F + mpas_kd_tree.F + mpas_parse_geoindex.F + mpas_stack.F + read_geogrid.c) + +add_library(core_init_atmosphere ${init_atm_core_srcs}) +if (${DO_PHYSICS}) + target_compile_definitions(core_init_atmosphere PRIVATE DO_PHYSICS) +endif () +if (MPAS_DOUBLE_PRECISION) + set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -fdefault-real-8 -fdefault-double-8") +else () + target_compile_definitions(core_init_atmosphere PRIVATE SINGLE_PRECISION) +endif () +if (${CMAKE_BUILD_TYPE} MATCHES "Debug") + target_compile_definitions(core_init_atmosphere PRIVATE MPAS_DEBUG) +endif () +if (${PIO_FOUND}) + FILE(STRINGS ${PIO_PREFIX}/lib/libpio.settings PIO_SETTINGS) + foreach (setting ${PIO_SETTINGS}) + string(FIND ${setting} "PIO Version" found) + if (${found} GREATER -1) + string(FIND ${setting} "2." pos) + if (${pos} GREATER -1) + set(PIO_VERSION 2) + else () + set(PIO_VERSION 1) + endif () + break() + endif () + endforeach () + if (${PIO_VERSION} EQUAL 1) + target_compile_definitions(core_init_atmosphere PRIVATE USE_PIO1) + else () + target_compile_definitions(core_init_atmosphere PRIVATE USE_PIO2) + endif () + target_compile_definitions(core_init_atmosphere PRIVATE MPAS_PIO_SUPPORT) +endif () +target_compile_definitions(core_init_atmosphere PRIVATE mpas=1) +target_compile_definitions(framework PRIVATE MPAS_NATIVE_TIMERS) +mpas_core_target(CORE init_atmosphere TARGET core_init_atmosphere INCLUDES ${init_atm_core_inc}) diff --git a/src/core_init_atmosphere/Makefile b/src/core_init_atmosphere/Makefile index 9494a5b7c2..984b7c367a 100644 --- a/src/core_init_atmosphere/Makefile +++ b/src/core_init_atmosphere/Makefile @@ -14,6 +14,7 @@ OBJS = \ mpas_init_atm_gwd.o \ mpas_init_atm_surface.o \ mpas_init_atm_vinterp.o \ + mpas_init_atm_thompson_aerosols.o \ read_geogrid.o \ mpas_atmphys_constants.o \ mpas_atmphys_date_time.o \ @@ -41,7 +42,7 @@ core_input_gen: gen_includes: $(CPP) $(CPPFLAGS) $(CPPINCLUDES) Registry.xml > Registry_processed.xml (if [ ! -d inc ]; then mkdir -p inc; fi) # To generate *.inc files - (cd inc; $(REG_PARSE) < ../Registry_processed.xml ) + (cd inc; $(REG_PARSE) ../Registry_processed.xml $(CPPFLAGS) ) post_build: if [ ! -e $(ROOT_DIR)/default_inputs ]; then mkdir $(ROOT_DIR)/default_inputs; fi @@ -57,6 +58,7 @@ mpas_init_atm_cases.o: \ mpas_init_atm_static.o \ mpas_init_atm_gwd.o \ mpas_init_atm_surface.o \ + mpas_init_atm_thompson_aerosols.o \ mpas_init_atm_vinterp.o \ mpas_atmphys_constants.o \ mpas_atmphys_functions.o \ @@ -64,6 +66,14 @@ mpas_init_atm_cases.o: \ mpas_init_atm_hinterp.o: mpas_init_atm_queue.o mpas_init_atm_bitarray.o +mpas_init_atm_thompson_aerosols.o: \ + mpas_init_atm_read_met.o \ + mpas_init_atm_hinterp.o \ + mpas_init_atm_llxy.o \ + mpas_init_atm_vinterp.o \ + mpas_atmphys_date_time.o \ + mpas_atmphys_utilities.o + mpas_advection.o: mpas_init_atm_read_met.o: diff --git a/src/core_init_atmosphere/Registry.xml b/src/core_init_atmosphere/Registry.xml index 1773a80e54..ee422f40b5 100644 --- a/src/core_init_atmosphere/Registry.xml +++ b/src/core_init_atmosphere/Registry.xml @@ -1,5 +1,5 @@ - + @@ -38,6 +38,10 @@ description="The number of first-guess soil layers"/> + + @@ -123,6 +127,11 @@ description="The number of vertical soil levels in the first-guess dataset (case 7 only)" possible_values="Positive integer values"/> + + + @@ -416,6 +426,11 @@ + + + + + @@ -516,6 +531,11 @@ + + + + + @@ -550,7 +570,7 @@ - + @@ -800,6 +820,22 @@ + + + + + + + + + + + + + + + + + + + + + + @@ -1010,6 +1067,14 @@ + + + + diff --git a/src/core_init_atmosphere/mpas_geotile_manager.F b/src/core_init_atmosphere/mpas_geotile_manager.F index 64e89212f7..04f9c60d0b 100644 --- a/src/core_init_atmosphere/mpas_geotile_manager.F +++ b/src/core_init_atmosphere/mpas_geotile_manager.F @@ -345,9 +345,9 @@ function mpas_geotile_mgr_finalize(mgr) result(ierr) endif enddo enddo - deallocate(mgr % hash) + deallocate(mgr % hash, stat=ierr) - if (associated(mgr % hash)) then + if (associated(mgr % hash) .or. (ierr /= 0)) then call mpas_log_write("Problem deallocating the geotile hash table", messageType=MPAS_LOG_ERR) ierr = -1 return diff --git a/src/core_init_atmosphere/mpas_init_atm_cases.F b/src/core_init_atmosphere/mpas_init_atm_cases.F index afc18f1135..7d43b5ee83 100644 --- a/src/core_init_atmosphere/mpas_init_atm_cases.F +++ b/src/core_init_atmosphere/mpas_init_atm_cases.F @@ -19,6 +19,7 @@ module init_atm_cases use mpas_timer use mpas_init_atm_static use mpas_init_atm_surface + use mpas_init_atm_thompson_aerosols, only: init_atm_thompson_aerosols, init_atm_thompson_aerosols_lbc use mpas_atmphys_constants, only: svpt0,svp1,svp2,svp3 use mpas_atmphys_functions use mpas_atmphys_initialize_real @@ -78,7 +79,7 @@ subroutine init_atm_setup_case(domain, stream_manager) type (MPAS_Time_type) :: curr_time, stop_time, start_time type (MPAS_TimeInterval_type) :: clock_interval, lbc_stream_interval, surface_stream_interval type (MPAS_TimeInterval_type) :: time_since_start - character(len=StrKIND) :: timeString + character(len=StrKIND) :: timeStart,timeString integer, pointer :: nCells integer, pointer :: nEdges @@ -244,6 +245,7 @@ subroutine init_atm_setup_case(domain, stream_manager) diag, diag_physics, block_ptr % dimensions, block_ptr % configs) if (config_met_interp) then + call init_atm_thompson_aerosols(block_ptr, mesh, block_ptr % configs, diag, state) call physics_initialize_real(mesh, fg, domain % dminfo, block_ptr % dimensions, block_ptr % configs) end if @@ -328,6 +330,9 @@ subroutine init_atm_setup_case(domain, stream_manager) call init_atm_case_lbc(timeString, block_ptr, mesh, nCells, nEdges, nVertLevels, fg, state, & diag, lbc_state, block_ptr % dimensions, block_ptr % configs) + call mpas_get_time(start_time, dateTimeString=timeStart) + call init_atm_thompson_aerosols_lbc(timeString, timeStart, block_ptr, mesh, diag, state, lbc_state) + block_ptr => block_ptr % next end do diff --git a/src/core_init_atmosphere/mpas_init_atm_core_interface.F b/src/core_init_atmosphere/mpas_init_atm_core_interface.F index 6fca9a737b..6229e50fdc 100644 --- a/src/core_init_atmosphere/mpas_init_atm_core_interface.F +++ b/src/core_init_atmosphere/mpas_init_atm_core_interface.F @@ -112,11 +112,13 @@ function init_atm_setup_packages(configs, streamInfo, packages, iocontext) resul type (mpas_pool_type), intent(inout) :: packages type (mpas_io_context_type), intent(inout) :: iocontext integer :: ierr + logical :: lexist logical, pointer :: initial_conds, sfc_update, lbcs logical, pointer :: gwd_stage_in, gwd_stage_out, vertical_stage_in, vertical_stage_out, met_stage_in, met_stage_out logical, pointer :: config_native_gwd_static, config_static_interp, config_vertical_grid, config_met_interp logical, pointer :: first_guess_field + logical, pointer :: mp_thompson_aers_in integer, pointer :: config_init_case @@ -155,6 +157,9 @@ function init_atm_setup_packages(configs, streamInfo, packages, iocontext) resul nullify(met_stage_out) call mpas_pool_get_package(packages, 'met_stage_outActive', met_stage_out) + nullify(mp_thompson_aers_in) + call mpas_pool_get_package(packages, 'mp_thompson_aers_inActive', mp_thompson_aers_in) + if (.not. associated(initial_conds) .or. & .not. associated(sfc_update) .or. & .not. associated(gwd_stage_in) .or. & @@ -162,7 +167,8 @@ function init_atm_setup_packages(configs, streamInfo, packages, iocontext) resul .not. associated(vertical_stage_in) .or. & .not. associated(vertical_stage_out) .or. & .not. associated(met_stage_in) .or. & - .not. associated(met_stage_out)) then + .not. associated(met_stage_out) .or. & + .not. associated(mp_thompson_aers_in)) then call mpas_log_write('********************************************************************************', messageType=MPAS_LOG_ERR) call mpas_log_write('* Error while setting up packages for init_atmosphere core.', messageType=MPAS_LOG_ERR) call mpas_log_write('********************************************************************************', messageType=MPAS_LOG_ERR) @@ -180,8 +186,12 @@ function init_atm_setup_packages(configs, streamInfo, packages, iocontext) resul if (config_init_case == 9) then lbcs = .true. + mp_thompson_aers_in = .false. + inquire(file="QNWFA_QNIFA_SIGMA_MONTHLY.dat",exist=lexist) + if(lexist) mp_thompson_aers_in = .true. else lbcs = .false. + mp_thompson_aers_in = .false. end if if (config_init_case == 7) then @@ -204,6 +214,10 @@ function init_atm_setup_packages(configs, streamInfo, packages, iocontext) resul (.not. config_vertical_grid) met_stage_out = config_met_interp + mp_thompson_aers_in = .false. + inquire(file="QNWFA_QNIFA_SIGMA_MONTHLY.dat",exist=lexist) + if((lexist .and. met_stage_out) .or. (lexist .and. met_stage_in)) mp_thompson_aers_in = .true. + else if (config_init_case == 8) then gwd_stage_in = .false. gwd_stage_out = .false. @@ -224,6 +238,10 @@ function init_atm_setup_packages(configs, streamInfo, packages, iocontext) resul met_stage_in = .true. met_stage_out = .true. + mp_thompson_aers_in = .false. + inquire(file="QNWFA_QNIFA_SIGMA_MONTHLY.dat",exist=lexist) + if((lexist .and. met_stage_out) .or. (lexist .and. met_stage_in)) mp_thompson_aers_in = .true. + initial_conds = .false. ! Also, turn off the initial_conds package to avoid writing the IC "output" stream else if (config_init_case == 13) then @@ -325,9 +343,7 @@ function init_atm_setup_log(logInfo, domain, unitNumbers) result(iErr)!{{{ use mpas_derived_types, only : mpas_log_type, domain_type use mpas_log, only : mpas_log_init, mpas_log_open -#ifdef MPAS_OPENMP - use mpas_threading, only : mpas_threading_get_num_threads -#endif + use mpas_framework, only : mpas_framework_report_settings implicit none @@ -356,53 +372,8 @@ function init_atm_setup_log(logInfo, domain, unitNumbers) result(iErr)!{{{ call mpas_log_write('') call mpas_log_write('MPAS Init-Atmosphere Version '//trim(domain % core % modelVersion)) call mpas_log_write('') - call mpas_log_write('') - call mpas_log_write('Output from ''git describe --dirty'': '//trim(domain % core % git_version)) - call mpas_log_write('') - call mpas_log_write('Compile-time options:') - call mpas_log_write(' Build target: '//trim(domain % core % build_target)) - call mpas_log_write(' OpenMP support: ' // & -#ifdef MPAS_OPENMP - 'yes') -#else - 'no') -#endif - call mpas_log_write(' OpenACC support: ' // & -#ifdef MPAS_OPENACC - 'yes') -#else - 'no') -#endif - call mpas_log_write(' Default real precision: ' // & -#ifdef SINGLE_PRECISION - 'single') -#else - 'double') -#endif - call mpas_log_write(' Compiler flags: ' // & -#ifdef MPAS_DEBUG - 'debug') -#else - 'optimize') -#endif - call mpas_log_write(' I/O layer: ' // & -#ifdef MPAS_PIO_SUPPORT -#ifdef USE_PIO2 - 'PIO 2.x') -#else - 'PIO 1.x') -#endif -#else - 'SMIOL') -#endif - call mpas_log_write('') - call mpas_log_write('Run-time settings:') - call mpas_log_write(' MPI task count: $i', intArgs=[domain % dminfo % nprocs]) -#ifdef MPAS_OPENMP - call mpas_log_write(' OpenMP max threads: $i', intArgs=[mpas_threading_get_max_threads()]) -#endif - call mpas_log_write('') + call mpas_framework_report_settings(domain) end function init_atm_setup_log!}}} diff --git a/src/core_init_atmosphere/mpas_init_atm_static.F b/src/core_init_atmosphere/mpas_init_atm_static.F index a4686f7ce6..09fe4c57a1 100644 --- a/src/core_init_atmosphere/mpas_init_atm_static.F +++ b/src/core_init_atmosphere/mpas_init_atm_static.F @@ -89,11 +89,14 @@ end subroutine interp_accumulation_function ! use module level variables for now... ! integer (kind=I8KIND), dimension(:), pointer :: ter_integer + integer (kind=I8KIND), dimension(:,:), pointer :: soilcomp_int + real (kind=RKIND) :: soilcomp_msgval = 255.0_RKIND ! Modified later based on index file for soilcomp integer, dimension(:), pointer :: lu_index integer, dimension(:), pointer :: soilcat_top integer, dimension(:), pointer :: nhs integer, dimension(:,:), allocatable:: ncat - ! Landmask is used by the accumulation function for maxsnoalb so it needs to be a global variable + ! Landmask is used by the accumulation function for maxsnoalb and soilcomp, + ! so it needs to be a global variable integer, dimension(:), pointer :: landmask integer, pointer :: category_min @@ -1168,6 +1171,56 @@ subroutine init_atm_static(mesh, dims, configs) call mpas_log_write('--- end interpolate ALBEDO12M') +! +! Interpolate SOILCOMP +! + geog_sub_path = 'soilgrids/soilcomp/' + call mpas_log_write('--- start interpolate SOILCOMP') + call interp_soilcomp(mesh, tree, trim(geog_data_path)//trim(geog_sub_path), & + supersample_fac=supersample_fac_30s) + call mpas_log_write('--- end interpolate SOILCOMP') + +! +! Interpolate SOILCL1 +! + geog_sub_path = 'soilgrids/texture_layer1/' + + call mpas_log_write('--- start interpolate SOILCL1') + call interp_soil_texture('soilcl1', mesh, tree, trim(geog_data_path)//trim(geog_sub_path), & + supersample_fac=supersample_fac_30s) + call mpas_log_write('--- end interpolate SOILCL1') + +! +! Interpolate SOILCL2 +! + geog_sub_path = 'soilgrids/texture_layer2/' + + call mpas_log_write('--- start interpolate SOILCL2') + call interp_soil_texture('soilcl2', mesh, tree, trim(geog_data_path)//trim(geog_sub_path), & + supersample_fac=supersample_fac_30s) + call mpas_log_write('--- end interpolate SOILCL2') + +! +! Interpolate SOILCL3 +! + geog_sub_path = 'soilgrids/texture_layer3/' + + call mpas_log_write('--- start interpolate SOILCL3') + call interp_soil_texture('soilcl3', mesh, tree, trim(geog_data_path)//trim(geog_sub_path), & + supersample_fac=supersample_fac_30s) + call mpas_log_write('--- end interpolate SOILCL3') + +! +! Interpolate SOILCL4 +! + geog_sub_path = 'soilgrids/texture_layer4/' + + call mpas_log_write('--- start interpolate SOILCL4') + call interp_soil_texture('soilcl4', mesh, tree, trim(geog_data_path)//trim(geog_sub_path), & + supersample_fac=supersample_fac_30s) + call mpas_log_write('--- end interpolate SOILCL4') + + ! ! Deallocate and free the KD Tree ! @@ -1432,6 +1485,33 @@ subroutine terrain_interp_accumulation(iCell, pixel) end subroutine terrain_interp_accumulation + !*********************************************************************** + ! + ! routine soilcomp_interp_accumulation + ! + !> \brief Accumulate soilcomp dataset values + !> \author Michael G. Duda + !> \date 31 May 2024 + !> \details + !> This routine accumulates soilcomp values for the init_atm_map_static_data + !> routine. + ! + !----------------------------------------------------------------------- + subroutine soilcomp_interp_accumulation(iCell, pixel) + + integer, intent(in) ::iCell + integer (kind=I8KIND), dimension(:), intent(in) :: pixel + + if (landmask(iCell) == 0) return + + if (pixel(1) /= soilcomp_msgval) then + soilcomp_int(:,iCell) = soilcomp_int(:,iCell) + int(pixel(:), kind=I8KIND) + nhs(iCell) = nhs(iCell) + 1 + end if + + end subroutine soilcomp_interp_accumulation + + !*********************************************************************** ! ! routine interp_terrain @@ -1510,6 +1590,104 @@ subroutine interp_terrain(mesh, kdtree, geog_data_path, supersample_fac) end subroutine interp_terrain + !*********************************************************************** + ! + ! routine interp_soilcomp + ! + !> \brief Interpolate the soilcomp field for Noah-MP + !> \author Michael G. Duda + !> \date 31 May 2024 + !> \details + !> Interpolate soilcomp using the init_atm_map_static_data routine, + !> accumulating pixel values into cells using the soilcomp_interp_accumulation + !> method. + !> + !> The mesh argument is an mpas_pool that contains soilcomp as well as + !> the nCells dimension. kdtree is an initialized kdtree of (xCell, yCell, zCell), + !> and geog_data_path specifies the path to the soilcomp dataset. + !> + !> The supersample_fac argument specifies the supersampling factor to be + !> applied to the source dataset. + ! + !----------------------------------------------------------------------- + subroutine interp_soilcomp(mesh, kdtree, geog_data_path, supersample_fac) + + implicit none + + ! Input variables + type (mpas_pool_type), intent(inout) :: mesh + type (mpas_kd_type), pointer, intent(in) :: kdtree + character (len=*), intent(in) :: geog_data_path + integer, intent(in), optional :: supersample_fac + + ! Local variables + type (mpas_geotile_mgr_type) :: mgr + integer, pointer :: nCells, nSoilComps + real (kind=RKIND), pointer :: scalefactor + real (kind=RKIND), pointer :: missing_value + + real (kind=RKIND), dimension(:,:), pointer :: soilcomp + + integer :: iCell + integer :: ierr + + ierr = mgr % init(trim(geog_data_path)) + if (ierr /= 0) then + call mpas_log_write('Error occurred initializing interpolation for '//trim(geog_data_path), & + messageType=MPAS_LOG_CRIT) + + return ! Program execution should not reach this statement + ! since the preceding message is a critical error + end if + + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_dimension(mesh, 'nSoilComps', nSoilComps) + call mpas_pool_get_array(mesh, 'soilcomp', soilcomp) + + call mpas_pool_get_config(mgr % pool, 'scale_factor', scalefactor) + call mpas_pool_get_config(mgr % pool, 'missing_value', missing_value) + + soilcomp_msgval = missing_value + + allocate(soilcomp_int(nSoilComps,nCells)) + allocate(nhs(nCells)) + + ! + ! Store tile values as a I8KIND integer temporarily to avoid floating + ! point round off differences and to have +/- 9.22x10^18 range of representative + ! values. For example, a 120 km mesh with a 1 meter data set with 6 decimal of + ! precision will allow for values of 180x10^12. + ! + soilcomp(:,:) = 0.0 + soilcomp_int(:,:) = 0 + nhs(:) = 0 + + call init_atm_map_static_data(mesh, mgr, kdtree, continuous_interp_criteria, & + soilcomp_interp_accumulation, & + supersample_fac=supersample_fac) + + do iCell = 1, nCells + if (nhs(iCell) > 0) then + soilcomp(:,iCell) = real(real(soilcomp_int(:,iCell), kind=R8KIND) & + / real(nhs(iCell), kind=R8KIND), kind=RKIND) + end if + end do + soilcomp(:,:) = soilcomp(:,:) * scalefactor + + deallocate(soilcomp_int) + deallocate(nhs) + + ierr = mgr % finalize() + if (ierr /= 0) then + call mpas_log_write('Error occurred finalizing interpolation for '//trim(geog_data_path), & + messageType=MPAS_LOG_CRIT) + + return ! Program execution should not reach this statement + ! since the preceding message is a critical error + end if + + end subroutine interp_soilcomp + !-------------------------------------------------------------------------------------------------- ! Categorical interpolations - Landuse and Soiltype !-------------------------------------------------------------------------------------------------- @@ -1895,6 +2073,85 @@ subroutine interp_soiltemp(mesh, dims, configs) end subroutine interp_soiltemp + !*********************************************************************** + ! + ! routine interp_soil_texture + ! + !> \brief Interpolate soil texture category for Noah-MP + !> \author Michael G. Duda + !> \date 31 May 2024 + !> \details + !> Interpolate soil texture category fields by using the init_atm_map_static_data + !> routine, accumulating the pixel values into each cell using + !> categorical_interp_accumulation. + !> + !> The fieldname argument specifies the specific soil texture category + !> field from the mesh pool onto which the dataset specified by geog_data_path + !> should be remapped. + !> + !> The mesh argument is an mpas_pool_type that contains the specified fieldname, + !> kdtree is an initialized mpas_kd_type tree with (xCell, yCell, zCell), and + !> supersample_fac is the supersampling factor to be applied to the source dataset. + !> + !----------------------------------------------------------------------- + subroutine interp_soil_texture(fieldname, mesh, kdtree, geog_data_path, supersample_fac) + + implicit none + + ! Input variables + character (len=*), intent(in) :: fieldname + type (mpas_pool_type), intent(inout) :: mesh + type (mpas_kd_type), pointer, intent(in) :: kdtree + character (len=*), intent(in) :: geog_data_path + integer, intent(in), optional :: supersample_fac + + ! Local variables + real, dimension(:), pointer :: soilclx + type (mpas_geotile_mgr_type) :: mgr + integer, pointer :: nCells + + integer :: iCell + integer :: ierr + + ierr = mgr % init(trim(geog_data_path)) + if (ierr /= 0) then + call mpas_log_write('Error occured initalizing interpolation for '//trim(geog_data_path), & + messageType=MPAS_LOG_CRIT) + return + end if + + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_array(mesh, trim(fieldname), soilclx) + call mpas_pool_get_config(mgr % pool, 'category_min', category_min) + call mpas_pool_get_config(mgr % pool, 'category_max', category_max) + + allocate(ncat(category_min:category_max, nCells)) + ncat(:,:) = 0 + + call init_atm_map_static_data(mesh, mgr, kdtree, categorical_interp_criteria, & + categorical_interp_accumulation, & + supersample_fac=supersample_fac) + + do iCell = 1, nCells + ! Because maxloc returns the location of the maximum value of an array as if the + ! starting index of the array is 1, and dataset categories do not necessarily start + ! at 1, we need to use category_min to ensure the correct category location is chosen. + soilclx(iCell) = real(maxloc(ncat(:,iCell), dim=1) - 1 + category_min, kind=RKIND) + end do + deallocate(ncat) + + ierr = mgr % finalize() + if (ierr /= 0) then + call mpas_log_write('Error occured finalizing interpolation for '//trim(geog_data_path), & + messageType=MPAS_LOG_CRIT) + return + end if + + nullify(category_min) + nullify(category_max) + + end subroutine interp_soil_texture + !================================================================================================== subroutine init_atm_check_read_error(istatus, fname) !================================================================================================== diff --git a/src/core_init_atmosphere/mpas_init_atm_thompson_aerosols.F b/src/core_init_atmosphere/mpas_init_atm_thompson_aerosols.F new file mode 100644 index 0000000000..660a836e6e --- /dev/null +++ b/src/core_init_atmosphere/mpas_init_atm_thompson_aerosols.F @@ -0,0 +1,867 @@ +! Copyright (c) 2024 The University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!================================================================================================================= + module mpas_init_atm_thompson_aerosols + use mpas_derived_types + use mpas_kind_types + use mpas_log + use mpas_dmpar + use mpas_pool_routines + + use init_atm_read_met + use init_atm_hinterp + use init_atm_llxy + use init_atm_vinterp + use mpas_atmphys_date_time + use mpas_atmphys_utilities + + implicit none + private + public:: init_atm_thompson_aerosols,init_atm_thompson_aerosols_lbc + +!mpas_init_atm_thompson_aerosols contains the subroutines needed for the interpolation of climatological +!monthly-averaged hygroscopic ("water friendly") and nonhygroscopic ("ice friendly") aerosols used in the +!Thompson parameterization of cloud microphysics with Gocart CCN and IN nucleation. +!Laura D. Fowler (laura@ucar.edu) / 2024-04-10. + + + contains + + +!================================================================================================================= + subroutine init_atm_thompson_aerosols(block,mesh,configs,diag,state) +!================================================================================================================= + +!input arguments: + type (mpas_pool_type),intent(in):: configs + type(mpas_pool_type),intent(in):: diag + +!inout arguments: + type(block_type),intent(inout),target:: block + type(mpas_pool_type),intent(inout) :: mesh + type(mpas_pool_type),intent(inout) :: state +!local variables and pointers: + character (len=StrKIND),pointer:: config_start_time + character(len=StrKIND):: filename_gocart + character(len=StrKIND):: initial_date,mess + + logical:: lexist + +!----------------------------------------------------------------------------------------------------------------- +!call mpas_log_write('--- enter subroutine init_atm_gocart:') + +!inquire if the GOCART input file exists: + lexist = .false. + filename_gocart = "QNWFA_QNIFA_SIGMA_MONTHLY.dat" + + inquire(file=filename_gocart,exist=lexist) + if(lexist) then + + call mpas_pool_get_config(configs,'config_start_time',config_start_time) + + !--- horizontal interpolation of the climatological monthly-averaged GOCART data to the MPAS mesh: + call init_hinterp_gocart(block,mesh) + + !--- interpolation of the monthly-averaged GOCART data to the initial date, and vertical interpolation to + ! the MPAS levels: + initial_date = trim(config_start_time) + call init_vinterp_gocart(initial_date,mesh,diag,state) + else + call mpas_log_write('QNWFA_QNIFA_SIGMA_MONTHLY.dat was not found in local directory:') + call mpas_log_write('nwfa and nifa are set to zero and not interpolated from climatological data.') + endif + +!call mpas_log_write('--- end subroutine init_atm_gocart.') + call mpas_log_write(' ') + + end subroutine init_atm_thompson_aerosols + +!================================================================================================================= + subroutine init_vinterp_gocart(initial_date,mesh,diag,state) +!================================================================================================================= + +!input arguments: + character(len=StrKIND),intent(in):: initial_date + type(mpas_pool_type),intent(in):: diag + +!inout arguments: + type(mpas_pool_type),intent(inout):: mesh + type(mpas_pool_type),intent(inout):: state + +!local variables and pointers: + integer,pointer:: nCells,nGocartLevels,nVertLevels,nMonths + integer,pointer:: index_nifa,index_nwfa + integer:: iCell,k,kk,n + + real(kind=RKIND),dimension(:,:),pointer :: nifa,nwfa,pressure + real(kind=RKIND),dimension(:,:,:),pointer:: nifa_clim,nwfa_clim,pwif_clim + real(kind=RKIND),dimension(:,:,:),pointer:: scalars + + real(kind=RKIND):: target_p + real(kind=RKIND),dimension(:,:),allocatable:: nifa_int,nwfa_int,pwif_int,sorted_arr + + real(kind=RKIND),dimension(:),allocatable:: dummy2 + real(kind=RKIND),dimension(:,:),allocatable:: dummy1 + +!----------------------------------------------------------------------------------------------------------------- +!call mpas_log_write('--- enter subroutine init_vinterp_gocart:') + + call mpas_pool_get_dimension(mesh,'nCells' ,nCells ) + call mpas_pool_get_dimension(mesh,'nGocartLevels',nGocartLevels) + call mpas_pool_get_dimension(mesh,'nVertLevels' ,nVertLevels ) + call mpas_pool_get_dimension(mesh,'nMonths' ,nMonths ) + + call mpas_pool_get_dimension(state,'index_nifa',index_nifa) + call mpas_pool_get_dimension(state,'index_nwfa',index_nwfa) + + call mpas_pool_get_array(diag,'pressure_base',pressure) + + call mpas_pool_get_array(mesh,'nifa_gocart_clim',nifa_clim) + call mpas_pool_get_array(mesh,'nwfa_gocart_clim',nwfa_clim) + call mpas_pool_get_array(mesh,'pwif_gocart_clim',pwif_clim) + + call mpas_pool_get_array(state,'scalars',scalars) + nifa => scalars(index_nifa,:,:) + nwfa => scalars(index_nwfa,:,:) + + if(.not.allocated(nifa_int) ) allocate(nifa_int(nGocartLevels,nCells)) + if(.not.allocated(nwfa_int) ) allocate(nwfa_int(nGocartLevels,nCells)) + if(.not.allocated(pwif_int) ) allocate(pwif_int(nGocartLevels,nCells)) + if(.not.allocated(sorted_arr)) allocate(sorted_arr(2,nGocartLevels)) + +!--- interpolation of the monthly-averaged GOCART data to the initial date, and vertical interpolation to the +! MPAS levels: + if(.not.allocated(dummy2)) allocate(dummy2(nCells)) + if(.not.allocated(dummy1)) allocate(dummy1(nMonths,nCells)) + + do k = 1, nGocartLevels + dummy2(1:nCells) = 0._RKIND + dummy1(1:nMonths,1:nCells) = pwif_clim(1:nMonths,k,1:nCells) + call monthly_interp_to_date(nCells,initial_date,dummy1,dummy2) + pwif_int(k,1:nCells) = dummy2(1:nCells) + enddo + +!--- nifa: + do k = 1, nGocartLevels + dummy2(1:nCells) = 0._RKIND + dummy1(1:nMonths,1:nCells) = nifa_clim(1:nMonths,k,1:nCells) + call monthly_interp_to_date(nCells,initial_date,dummy1,dummy2) + nifa_int(k,1:nCells) = dummy2(1:nCells) + enddo + do iCell = 1, nCells + sorted_arr(1,1:nGocartLevels) = 0._RKIND + sorted_arr(2,1:nGocartLevels) = 0._RKIND + do k = 1, nGocartLevels + kk = nGocartLevels + 1 -k + sorted_arr(1,kk) = pwif_int(k,iCell) + sorted_arr(2,kk) = nifa_int(k,iCell) + enddo + do k = nVertLevels, 1, -1 + target_p = pressure(k,iCell) + nifa(k,iCell) = vertical_interp(target_p,nGocartLevels-1, & + sorted_arr(:,1:nGocartLevels-1),order=1,extrap=0) + if(target_p >= pwif_int(1,iCell) .and. k < nVertLevels) nifa(k,iCell) = nifa(k+1,iCell) + enddo + enddo + +!--- nwfa: + do k = 1, nGocartLevels + dummy2(1:nCells) = 0._RKIND + dummy1(1:nMonths,1:nCells) = nwfa_clim(1:nMonths,k,1:nCells) + call monthly_interp_to_date(nCells,initial_date,dummy1,dummy2) + nwfa_int(k,1:nCells) = dummy2(1:nCells) + enddo + do iCell = 1, nCells + sorted_arr(1,1:nGocartLevels) = 0._RKIND + sorted_arr(2,1:nGocartLevels) = 0._RKIND + do k = 1, nGocartLevels + kk = nGocartLevels + 1 -k + sorted_arr(1,kk) = pwif_int(k,iCell) + sorted_arr(2,kk) = nwfa_int(k,iCell) + enddo + do k = nVertLevels, 1, -1 + target_p = pressure(k,iCell) + nwfa(k,iCell) = vertical_interp(target_p,nGocartLevels-1, & + sorted_arr(:,1:nGocartLevels-1),order=1,extrap=0) + if(target_p >= pwif_int(1,iCell) .and. k < nVertLevels) nwfa(k,iCell) = nwfa(k+1,iCell) + enddo + enddo + +!--- deallocation of local arrays: + if(allocated(dummy1) ) deallocate(dummy1 ) + if(allocated(dummy2) ) deallocate(dummy2 ) + if(allocated(nifa_int) ) deallocate(nifa_int ) + if(allocated(nwfa_int) ) deallocate(nwfa_int ) + if(allocated(pwif_int) ) deallocate(pwif_int ) + if(allocated(sorted_arr)) deallocate(sorted_arr) + +!call mpas_log_write('--- end subroutine init_vinterp_gocart:') + + end subroutine init_vinterp_gocart + +!================================================================================================================= + subroutine init_hinterp_gocart(block,mesh) +!================================================================================================================= + +!inout arguments: + type(block_type),intent(inout),target:: block + type (mpas_pool_type),intent(inout) :: mesh + +!local variables: + type(dm_info),pointer:: dminfo + type(met_data) :: field !real*4 meteorological data. + type(proj_info):: proj + + character(len=StrKIND):: filename_gocart + logical:: have_landmask + + integer,pointer:: nCells + integer:: i,j + integer:: iCell,istatus,k,masked,nmonths,nInterpPoints + integer,dimension(5):: interp_list + integer,dimension(:),pointer:: landmask + integer,dimension(:),pointer:: mask_array + + real(kind=RKIND):: fillval,maskval,msgval + real(kind=RKIND):: lat,lon,x,y + real(kind=RKIND),dimension(:),pointer :: latCell,lonCell + real(kind=RKIND),dimension(:),pointer :: latPoints,lonPoints + real(kind=RKIND),dimension(:,:,:),pointer:: nifa_clim,nwfa_clim,pwif_clim + real(kind=RKIND),dimension(:,:,:),pointer:: destField3d + + real(kind=RKIND),dimension(:,:),allocatable:: maskslab,rslab + +!----------------------------------------------------------------------------------------------------------------- +!call mpas_log_write('--- enter subroutine init_hinterp_gocart:') + + dminfo => block%domain%dminfo + + filename_gocart = "QNWFA_QNIFA_SIGMA_MONTHLY.dat" + + call mpas_pool_get_dimension(mesh,'nCells',nCells) + + call mpas_pool_get_array(mesh,'landmask',landmask) + call mpas_pool_get_array(mesh,'latCell' ,latCell ) + call mpas_pool_get_array(mesh,'lonCell' ,lonCell ) + + call mpas_pool_get_array(mesh,'nifa_gocart_clim',nifa_clim) + call mpas_pool_get_array(mesh,'nwfa_gocart_clim',nwfa_clim) + call mpas_pool_get_array(mesh,'pwif_gocart_clim',pwif_clim) + +!open intermediate file: + istatus = 0 + call read_met_init(trim(filename_gocart),.true.,'not needed',istatus) + if(istatus /= 0) then + call mpas_log_write('********************************************************************************') + call mpas_log_write('Error opening gocart file '//trim(filename_gocart)) + call mpas_log_write('********************************************************************************') + call mpas_dmpar_abort(dminfo) + else + call mpas_log_write('Processing file '//trim(filename_gocart)) + end if + +!scan through all fields in the file, looking for the LANDSEA field: + have_landmask = .false. + call read_next_met_field(field,istatus) + do while (istatus == 0) + if(index(field % field, 'LANDSEA') /= 0) then + have_landmask = .true. + if(.not.allocated(maskslab)) allocate(maskslab(-2:field%nx+3,field%ny)) + + maskslab(1:field%nx,1:field%ny) = field%slab(1:field%nx,1:field%ny) + maskslab(0 ,1:field%ny) = field%slab(field%nx ,1:field%ny) + maskslab(-1,1:field%ny) = field%slab(field%nx-1,1:field%ny) + maskslab(-2,1:field%ny) = field%slab(field%nx-2,1:field%ny) + maskslab(field%nx+1,1:field%ny) = field%slab(1,1:field%ny) + maskslab(field%nx+2,1:field%ny) = field%slab(2,1:field%ny) + maskslab(field%nx+3,1:field%ny) = field%slab(3,1:field%ny) +! call mpas_log_write('minval, maxval of LANDSEA = $r $r',realArgs=(/minval(maskslab),maxval(maskslab)/)) + end if + deallocate(field%slab) + call read_next_met_field(field,istatus) + end do + call read_met_close() + + if(.not. have_landmask) then + call mpas_log_write('********************************************************************************') + call mpas_log_write('Landsea mask not available from the surface file') + call mpas_log_write('********************************************************************************') + end if + + +!read gocart data: + istatus = 0 + call read_met_init(trim(filename_gocart),.true.,'not needed',istatus) + if(istatus /= 0) then + call mpas_log_write('********************************************************************************') + call mpas_log_write('Error opening gocart file '// trim(filename_gocart)) + call mpas_log_write('********************************************************************************') + call mpas_dmpar_abort(dminfo) + endif + call read_next_met_field(field, istatus) + +!horizontally interpolate GOCART data: + do while(istatus == 0) + + interp_list(1) = FOUR_POINT + interp_list(2) = W_AVERAGE4 + interp_list(3) = W_AVERAGE16 + interp_list(4) = SEARCH + interp_list(5) = 0 + + maskval = -1.0 + masked = -1 + fillval = 0.0 + msgval = 0.0 + + mask_array => landmask + + if(index(field % field, 'QNIFA_JAN') /= 0 .or. & + index(field % field, 'QNIFA_FEB') /= 0 .or. & + index(field % field, 'QNIFA_MAR') /= 0 .or. & + index(field % field, 'QNIFA_APR') /= 0 .or. & + index(field % field, 'QNIFA_MAY') /= 0 .or. & + index(field % field, 'QNIFA_JUN') /= 0 .or. & + index(field % field, 'QNIFA_JUL') /= 0 .or. & + index(field % field, 'QNIFA_AUG') /= 0 .or. & + index(field % field, 'QNIFA_SEP') /= 0 .or. & + index(field % field, 'QNIFA_OCT') /= 0 .or. & + index(field % field, 'QNIFA_NOV') /= 0 .or. & + index(field % field, 'QNIFA_DEC') /= 0 .or. & + index(field % field, 'QNWFA_JAN') /= 0 .or. & + index(field % field, 'QNWFA_FEB') /= 0 .or. & + index(field % field, 'QNWFA_MAR') /= 0 .or. & + index(field % field, 'QNWFA_APR') /= 0 .or. & + index(field % field, 'QNWFA_MAY') /= 0 .or. & + index(field % field, 'QNWFA_JUN') /= 0 .or. & + index(field % field, 'QNWFA_JUL') /= 0 .or. & + index(field % field, 'QNWFA_AUG') /= 0 .or. & + index(field % field, 'QNWFA_SEP') /= 0 .or. & + index(field % field, 'QNWFA_OCT') /= 0 .or. & + index(field % field, 'QNWFA_NOV') /= 0 .or. & + index(field % field, 'QNWFA_DEC') /= 0 .or. & + index(field % field, 'P_WIF_JAN') /= 0 .or. & + index(field % field, 'P_WIF_FEB') /= 0 .or. & + index(field % field, 'P_WIF_MAR') /= 0 .or. & + index(field % field, 'P_WIF_APR') /= 0 .or. & + index(field % field, 'P_WIF_MAY') /= 0 .or. & + index(field % field, 'P_WIF_JUN') /= 0 .or. & + index(field % field, 'P_WIF_JUL') /= 0 .or. & + index(field % field, 'P_WIF_AUG') /= 0 .or. & + index(field % field, 'P_WIF_SEP') /= 0 .or. & + index(field % field, 'P_WIF_OCT') /= 0 .or. & + index(field % field, 'P_WIF_NOV') /= 0 .or. & + index(field % field, 'P_WIF_DEC') /= 0) then + + ! + !set up projection: + ! + call map_init(proj) + + if(field%iproj == PROJ_LATLON) then + call map_set(PROJ_LATLON,proj, & + latinc = real(field%deltalat,RKIND), & + loninc = real(field%deltalon,RKIND), & + knowni = 1.0_RKIND, & + knownj = 1.0_RKIND, & + lat1 = real(field%startlat,RKIND), & + lon1 = real(field%startlon,RKIND)) + elseif(field%iproj == PROJ_GAUSS) then + call map_set(PROJ_GAUSS,proj, & + nlat = nint(field%deltalat), & + loninc = 360.0_RKIND / real(field%nx,RKIND), & + lat1 = real(field%startlat,RKIND), & + lon1 = real(field%startlon,RKIND)) + endif + + ! + !horizontally interpolate field at level k: + ! + if(index(field%field,'QNIFA_JAN') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating QNIFA_JAN at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'nifa_gocart_clim',destField3d) + nmonths = 1 + elseif(index(field%field,'QNIFA_FEB') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating QNIFA_FEB at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'nifa_gocart_clim',destField3d) + nmonths = 2 + elseif(index(field%field,'QNIFA_MAR') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating QNIFA_MAR at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'nifa_gocart_clim',destField3d) + nmonths = 3 + elseif(index(field%field,'QNIFA_APR') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating QNIFA_APR at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'nifa_gocart_clim',destField3d) + nmonths = 4 + elseif(index(field%field,'QNIFA_MAY') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating QNIFA_MAY at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'nifa_gocart_clim',destField3d) + nmonths = 5 + elseif(index(field%field,'QNIFA_JUN') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating QNIFA_JUN at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'nifa_gocart_clim',destField3d) + nmonths = 6 + elseif(index(field%field,'QNIFA_JUL') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating QNIFA_JUL at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'nifa_gocart_clim',destField3d) + nmonths = 7 + elseif(index(field%field,'QNIFA_AUG') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating QNIFA_AUG at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'nifa_gocart_clim',destField3d) + nmonths = 8 + elseif(index(field%field,'QNIFA_SEP') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating QNIFA_SEP at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'nifa_gocart_clim',destField3d) + nmonths = 9 + elseif(index(field%field,'QNIFA_OCT') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating QNIFA_OCT at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'nifa_gocart_clim',destField3d) + nmonths = 10 + elseif(index(field%field,'QNIFA_NOV') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating QNIFA_NOV at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'nifa_gocart_clim',destField3d) + nmonths = 11 + elseif(index(field%field,'QNIFA_DEC') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating QNIFA_DEC at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'nifa_gocart_clim',destField3d) + nmonths = 12 + elseif(index(field%field,'QNWFA_JAN') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating QNWFA_JAN at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'nwfa_gocart_clim',destField3d) + nmonths = 1 + elseif(index(field%field,'QNWFA_FEB') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating QNWFA_FEB at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'nwfa_gocart_clim',destField3d) + nmonths = 2 + elseif(index(field%field,'QNWFA_MAR') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating QNWFA_MAR at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'nwfa_gocart_clim',destField3d) + nmonths = 3 + elseif(index(field%field,'QNWFA_APR') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating QNWFA_APR at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'nwfa_gocart_clim',destField3d) + nmonths = 4 + elseif(index(field%field,'QNWFA_MAY') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating QNWFA_MAY at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'nwfa_gocart_clim',destField3d) + nmonths = 5 + elseif(index(field%field,'QNWFA_JUN') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating QNWFA_JUN at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'nwfa_gocart_clim',destField3d) + nmonths = 6 + elseif(index(field%field,'QNWFA_JUL') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating QNWFA_JUL at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'nwfa_gocart_clim',destField3d) + nmonths = 7 + elseif(index(field%field,'QNWFA_AUG') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating QNWFA_AUG at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'nwfa_gocart_clim',destField3d) + nmonths = 8 + elseif(index(field%field,'QNWFA_SEP') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating QNWFA_SEP at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'nwfa_gocart_clim',destField3d) + nmonths = 9 + elseif(index(field%field,'QNWFA_OCT') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating QNWFA_OCT at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'nwfa_gocart_clim',destField3d) + nmonths = 10 + elseif(index(field%field,'QNWFA_NOV') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating QNWFA_NOV at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'nwfa_gocart_clim',destField3d) + nmonths = 11 + elseif(index(field%field,'QNWFA_DEC') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating QNWFA_DEC at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'nwfa_gocart_clim',destField3d) + nmonths = 12 + elseif(index(field%field,'P_WIF_JAN') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating P_WIF_JAN at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'pwif_gocart_clim',destField3d) + nmonths = 1 + elseif(index(field%field,'P_WIF_FEB') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating P_WIF_FEB at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'pwif_gocart_clim',destField3d) + nmonths = 2 + elseif(index(field%field,'P_WIF_MAR') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating P_WIF_MAR at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'pwif_gocart_clim',destField3d) + nmonths = 3 + elseif(index(field%field,'P_WIF_APR') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating P_WIF_APR at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'pwif_gocart_clim',destField3d) + nmonths = 4 + elseif(index(field%field,'P_WIF_MAY') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating P_WIF_MAY at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'pwif_gocart_clim',destField3d) + nmonths = 5 + elseif(index(field%field,'P_WIF_JUN') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating P_WIF_JUN at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'pwif_gocart_clim',destField3d) + nmonths = 6 + elseif(index(field%field,'P_WIF_JUL') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating P_WIF_JUL at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'pwif_gocart_clim',destField3d) + nmonths = 7 + elseif(index(field%field,'P_WIF_AUG') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating P_WIF_AUG at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'pwif_gocart_clim',destField3d) + nmonths = 8 + elseif(index(field%field,'P_WIF_SEP') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating P_WIF_SEP at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'pwif_gocart_clim',destField3d) + nmonths = 9 + elseif(index(field%field,'P_WIF_OCT') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating P_WIF_OCT at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'pwif_gocart_clim',destField3d) + nmonths = 10 + elseif(index(field%field,'P_WIF_NOV') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating P_WIF_NOV at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'pwif_gocart_clim',destField3d) + nmonths = 11 + elseif(index(field%field,'P_WIF_DEC') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating P_WIF_DEC at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'pwif_gocart_clim',destField3d) + nmonths = 12 + endif + + allocate(rslab(-2:field%nx+3,field%ny)) + rslab(1:field%nx,1:field%ny) = field%slab(1:field%nx,1:field%ny) + rslab(0,1:field%ny) = field%slab(field%nx ,1:field%ny) + rslab(-1,1:field%ny) = field%slab(field%nx-1,1:field%ny) + rslab(-2,1:field%ny) = field%slab(field%nx-2,1:field%ny) + rslab(field%nx+1,1:field%ny) = field%slab(1,1:field%ny) + rslab(field%nx+2,1:field%ny) = field%slab(2,1:field%ny) + rslab(field%nx+3,1:field%ny) = field%slab(3,1:field%ny) + + do iCell = 1, nInterpPoints + if(mask_array(iCell) /= masked) then + lat = latPoints(iCell)*DEG_PER_RAD + lon = lonPoints(iCell)*DEG_PER_RAD + call latlon_to_ij(proj,lat,lon,x,y) + if(x < 0.5) then + lon = lon + 360.0 + call latlon_to_ij(proj,lat,lon,x,y) + elseif(x > real(field%nx,kind=RKIND)+ 0.5) then + lon = lon - 360.0 + call latlon_to_ij(proj,lat,lon,x,y) + endif + + if(maskval /= -1.0) then + destField3d(nmonths,k,iCell) = interp_sequence(x,y,1,rslab,-2,field%nx+3,1,field%ny,1,1,msgval, & + interp_list,1,maskval=maskval,mask_array=maskslab) + else + destField3d(nmonths,k,iCell) = interp_sequence(x,y,1,rslab,-2,field%nx+3,1,field%ny,1,1,msgval, & + interp_list,1) + endif + else + destField3d(nmonths,k,iCell) = fillval + endif + enddo + deallocate(rslab) + + endif + deallocate(field%slab) + call read_next_met_field(field,istatus) + + enddo + + call read_met_close() + +!call mpas_log_write('--- end subroutine init_hinterp_gocart:') + + end subroutine init_hinterp_gocart + +!================================================================================================================= + subroutine init_atm_thompson_aerosols_lbc(timestamp,timestart,block,mesh,diag,state,lbc_state) +!================================================================================================================= + +!input arguments: + character(len=StrKIND),intent(in):: timestart,timestamp + type(mpas_pool_type),intent(in):: diag + type(mpas_pool_type),intent(in):: state + +!inout arguments: + type(block_type),intent(inout),target:: block + type(mpas_pool_type),intent(inout):: mesh + type(mpas_pool_type),intent(inout):: lbc_state + +!local variables and pointers: + logical:: lexist + character(len=StrKIND):: filename_gocart + + integer,pointer:: nCells,nGocartLevels,nVertLevels,nMonths + integer,pointer:: index_nifa,index_nwfa + integer:: iCell,k,kk,n + + real(kind=RKIND),dimension(:,:),pointer :: nifa,nwfa,pressure + real(kind=RKIND),dimension(:,:,:),pointer:: nifa_clim,nwfa_clim,pwif_clim + real(kind=RKIND),dimension(:,:,:),pointer:: scalars + + real(kind=RKIND):: target_p + real(kind=RKIND),dimension(:,:),allocatable:: nifa_int,nwfa_int,pwif_int,sorted_arr + + real(kind=RKIND),dimension(:),allocatable:: dummy2 + real(kind=RKIND),dimension(:,:),allocatable:: dummy1 + +!----------------------------------------------------------------------------------------------------------------- +!call mpas_log_write('--- enter subroutine init_lbc_gocart at time: ' //trim(timestamp)) + +!inquire if the GOCART input file exists: + lexist = .false. + filename_gocart = "QNWFA_QNIFA_SIGMA_MONTHLY.dat" + inquire(file=filename_gocart,exist=lexist) + if(.not. lexist) return + + +!horizontally interpolate GOCART input when computing when the initial conditions at start time: + if(timestamp == timestart) then + call init_hinterp_gocart(block,mesh) + endif + + + call mpas_pool_get_dimension(mesh,'nCells' ,nCells ) + call mpas_pool_get_dimension(mesh,'nGocartLevels',nGocartLevels) + call mpas_pool_get_dimension(mesh,'nVertLevels' ,nVertLevels ) + call mpas_pool_get_dimension(mesh,'nMonths' ,nMonths ) + + call mpas_pool_get_dimension(state,'index_nifa',index_nifa) + call mpas_pool_get_dimension(state,'index_nwfa',index_nwfa) + + call mpas_pool_get_array(diag,'pressure_base',pressure) + + call mpas_pool_get_array(mesh,'nifa_gocart_clim',nifa_clim) + call mpas_pool_get_array(mesh,'nwfa_gocart_clim',nwfa_clim) + call mpas_pool_get_array(mesh,'pwif_gocart_clim',pwif_clim) + + call mpas_pool_get_array(lbc_state,'lbc_scalars',scalars) + nifa => scalars(index_nifa,:,:) + nwfa => scalars(index_nwfa,:,:) + + if(.not.allocated(nifa_int) ) allocate(nifa_int(nGocartLevels,nCells)) + if(.not.allocated(nwfa_int) ) allocate(nwfa_int(nGocartLevels,nCells)) + if(.not.allocated(pwif_int) ) allocate(pwif_int(nGocartLevels,nCells)) + if(.not.allocated(sorted_arr)) allocate(sorted_arr(2,nGocartLevels)) + + nifa(:,:) = 0._RKIND + nwfa(:,:) = 0._RKIND + +!--- interpolation of the monthly-averaged GOCART data to the initial date, and vertical interpolation to the +! MPAS levels: + if(.not.allocated(dummy2)) allocate(dummy2(nCells)) + if(.not.allocated(dummy1)) allocate(dummy1(nMonths,nCells)) + + do k = 1, nGocartLevels + dummy2(1:nCells) = 0._RKIND + dummy1(1:nMonths,1:nCells) = pwif_clim(1:nMonths,k,1:nCells) + call monthly_interp_to_date(nCells,timestamp,dummy1,dummy2) + pwif_int(k,1:nCells) = dummy2(1:nCells) + enddo + +!--- nifa: + do k = 1, nGocartLevels + dummy2(1:nCells) = 0._RKIND + dummy1(1:nMonths,1:nCells) = nifa_clim(1:nMonths,k,1:nCells) + call monthly_interp_to_date(nCells,timestamp,dummy1,dummy2) + nifa_int(k,1:nCells) = dummy2(1:nCells) + enddo + do iCell = 1, nCells + sorted_arr(1,1:nGocartLevels) = 0._RKIND + sorted_arr(2,1:nGocartLevels) = 0._RKIND + do k = 1, nGocartLevels + kk = nGocartLevels + 1 -k + sorted_arr(1,kk) = pwif_int(k,iCell) + sorted_arr(2,kk) = nifa_int(k,iCell) + enddo + do k = nVertLevels, 1, -1 + target_p = pressure(k,iCell) + nifa(k,iCell) = vertical_interp(target_p,nGocartLevels-1, & + sorted_arr(:,1:nGocartLevels-1),order=1,extrap=0) + if(target_p >= pwif_int(1,iCell) .and. k < nVertLevels) nifa(k,iCell) = nifa(k+1,iCell) + enddo + enddo + +!--- nwfa: + do k = 1, nGocartLevels + dummy2(1:nCells) = 0._RKIND + dummy1(1:nMonths,1:nCells) = nwfa_clim(1:nMonths,k,1:nCells) + call monthly_interp_to_date(nCells,timestamp,dummy1,dummy2) + nwfa_int(k,1:nCells) = dummy2(1:nCells) + enddo + do iCell = 1, nCells + sorted_arr(1,1:nGocartLevels) = 0._RKIND + sorted_arr(2,1:nGocartLevels) = 0._RKIND + do k = 1, nGocartLevels + kk = nGocartLevels + 1 -k + sorted_arr(1,kk) = pwif_int(k,iCell) + sorted_arr(2,kk) = nwfa_int(k,iCell) + enddo + do k = nVertLevels, 1, -1 + target_p = pressure(k,iCell) + nwfa(k,iCell) = vertical_interp(target_p,nGocartLevels-1, & + sorted_arr(:,1:nGocartLevels-1),order=1,extrap=0) + if(target_p >= pwif_int(1,iCell) .and. k < nVertLevels) nwfa(k,iCell) = nwfa(k+1,iCell) + enddo + enddo + +!--- deallocation of local arrays: + if(allocated(dummy1) ) deallocate(dummy1 ) + if(allocated(dummy2) ) deallocate(dummy2 ) + if(allocated(nifa_int) ) deallocate(nifa_int ) + if(allocated(nwfa_int) ) deallocate(nwfa_int ) + if(allocated(pwif_int) ) deallocate(pwif_int ) + if(allocated(sorted_arr)) deallocate(sorted_arr) + +!call mpas_log_write('--- end subroutine init_lbc_gocart:') + + end subroutine init_atm_thompson_aerosols_lbc + +!================================================================================================================= + end module mpas_init_atm_thompson_aerosols +!================================================================================================================= diff --git a/src/core_landice/Makefile b/src/core_landice/Makefile index d7dc35bd0a..89280f29e4 100644 --- a/src/core_landice/Makefile +++ b/src/core_landice/Makefile @@ -31,7 +31,7 @@ core_reg: gen_includes: $(CPP) $(CPPFLAGS) $(CPPINCLUDES) Registry.xml > Registry_processed.xml (if [ ! -d inc ]; then mkdir -p inc; fi) # To generate *.inc files - (cd inc; $(REG_PARSE) < ../Registry_processed.xml ) + (cd inc; $(REG_PARSE) ../Registry_processed.xml $(CPPFLAGS) ) post_build: if [ ! -e $(ROOT_DIR)/default_inputs ]; then mkdir $(ROOT_DIR)/default_inputs; fi diff --git a/src/core_landice/Registry.xml b/src/core_landice/Registry.xml index 115d29024b..39af560a1a 100644 --- a/src/core_landice/Registry.xml +++ b/src/core_landice/Registry.xml @@ -1,5 +1,5 @@ - + diff --git a/src/core_ocean/Makefile b/src/core_ocean/Makefile index 24ae631991..a793d09603 100644 --- a/src/core_ocean/Makefile +++ b/src/core_ocean/Makefile @@ -31,7 +31,7 @@ core_input_gen: gen_includes: $(CPP) $(CPPFLAGS) $(CPPINCLUDES) Registry.xml > Registry_processed.xml (if [ ! -d inc ]; then mkdir -p inc; fi) # To generate *.inc files - (cd inc; $(REG_PARSE) < ../Registry_processed.xml ) + (cd inc; $(REG_PARSE) ../Registry_processed.xml $(CPPFLAGS) ) post_build: if [ ! -e $(ROOT_DIR)/default_inputs ]; then mkdir $(ROOT_DIR)/default_inputs; fi diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index 97345172c3..0fada27075 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -1,5 +1,5 @@ - + Registry_processed.xml (if [ ! -d inc ]; then mkdir -p inc; fi) # To generate *.inc files - (cd inc; $(REG_PARSE) < ../Registry_processed.xml ) + (cd inc; $(REG_PARSE) ../Registry_processed.xml $(CPPFLAGS) ) core_input_gen: if [ ! -e default_inputs ]; then mkdir default_inputs; fi diff --git a/src/core_seaice/Registry.xml b/src/core_seaice/Registry.xml index 22a3dd2ca0..9196d22d2c 100644 --- a/src/core_seaice/Registry.xml +++ b/src/core_seaice/Registry.xml @@ -1,5 +1,5 @@ - + Registry_processed.xml (if [ ! -d inc ]; then mkdir -p inc; fi) # To generate *.inc files - (cd inc; $(REG_PARSE) < ../Registry_processed.xml ) + (cd inc; $(REG_PARSE) ../Registry_processed.xml $(CPPFLAGS) ) post_build: if [ ! -e $(ROOT_DIR)/default_inputs ]; then mkdir $(ROOT_DIR)/default_inputs; fi diff --git a/src/core_sw/Registry.xml b/src/core_sw/Registry.xml index 2ffebc0dfe..a1b3c36bbc 100644 --- a/src/core_sw/Registry.xml +++ b/src/core_sw/Registry.xml @@ -1,5 +1,5 @@ - + diff --git a/src/core_test/Makefile b/src/core_test/Makefile index 556992262a..5518eceda0 100644 --- a/src/core_test/Makefile +++ b/src/core_test/Makefile @@ -10,7 +10,8 @@ OBJS = mpas_test_core.o \ mpas_halo_testing.o \ mpas_test_core_string_utils.o \ mpas_test_core_dmpar.o \ - mpas_test_core_stream_inquiry.o + mpas_test_core_stream_inquiry.o \ + mpas_test_openacc.o all: core_test @@ -28,7 +29,7 @@ core_input_gen: gen_includes: $(CPP) $(CPPFLAGS) $(CPPINCLUDES) Registry.xml > Registry_processed.xml (if [ ! -d inc ]; then mkdir -p inc; fi) # To generate *.inc files - (cd inc; $(REG_PARSE) < ../Registry_processed.xml ) + (cd inc; $(REG_PARSE) ../Registry_processed.xml $(CPPFLAGS) ) post_build: if [ ! -e $(ROOT_DIR)/default_inputs ]; then mkdir $(ROOT_DIR)/default_inputs; fi @@ -41,7 +42,7 @@ mpas_test_core.o: mpas_test_core_halo_exch.o mpas_test_core_streams.o \ mpas_test_core_field_tests.o mpas_test_core_timekeeping_tests.o \ mpas_test_core_sorting.o mpas_halo_testing.o \ mpas_test_core_string_utils.o mpas_test_core_dmpar.o \ - mpas_test_core_stream_inquiry.o + mpas_test_core_stream_inquiry.o mpas_test_openacc.o mpas_test_core_halo_exch.o: diff --git a/src/core_test/Registry.xml b/src/core_test/Registry.xml index f9e4d90e1c..e5ef8dd94f 100644 --- a/src/core_test/Registry.xml +++ b/src/core_test/Registry.xml @@ -1,5 +1,5 @@ - + @@ -184,7 +184,10 @@ + - + + + diff --git a/src/core_test/mpas_test_core.F b/src/core_test/mpas_test_core.F index d51974cdf3..d0a826c771 100644 --- a/src/core_test/mpas_test_core.F +++ b/src/core_test/mpas_test_core.F @@ -96,6 +96,7 @@ function test_core_run(domain) result(iErr)!{{{ use test_core_string_utils, only : mpas_test_string_utils use mpas_test_core_dmpar, only : mpas_test_dmpar use mpas_test_core_stream_inquiry, only : mpas_test_stream_inquiry + use mpas_test_core_openacc, only : mpas_test_openacc implicit none @@ -211,6 +212,23 @@ function test_core_run(domain) result(iErr)!{{{ call mpas_stream_mgr_write(domain % streamManager, forceWriteNow=.true.) + ! + ! Run mpas_test_openacc + ! + call mpas_log_write('') +#ifdef MPAS_OPENACC + iErr = mpas_test_openacc(domain) + if (iErr == 0) then + call mpas_log_write('All tests PASSED') + else + call mpas_log_write('$i tests FAILED', intArgs=[iErr]) + end if +#else + call mpas_log_write('MPAS_OPENACC not defined, skipping OpenACC tests') +#endif + call mpas_log_write('') + + deallocate(threadErrs) end function test_core_run!}}} diff --git a/src/core_test/mpas_test_core_halo_exch.F b/src/core_test/mpas_test_core_halo_exch.F index f3979f74ac..b098fcfc6a 100644 --- a/src/core_test/mpas_test_core_halo_exch.F +++ b/src/core_test/mpas_test_core_halo_exch.F @@ -7,6 +7,7 @@ ! !#define HALO_EXCH_DEBUG +!#define HALO_EXCH_DEBUG_VERBOSE module test_core_halo_exch @@ -51,7 +52,7 @@ subroutine test_core_halo_exch_test(domain, threadErrs, err)!{{{ call mpas_timer_start('halo exch tests') if ( threadNum == 0 ) then - call mpas_log_write(' - Performing exchange group tests') + call mpas_log_write(' - Performing group halo exchange tests') end if call test_core_halo_exch_group_test(domain, threadErrs, iErr) call mpas_threading_barrier() @@ -80,6 +81,16 @@ subroutine test_core_halo_exch_test(domain, threadErrs, err)!{{{ err = ior(err, iErr) end if + if ( threadNum == 0 ) then + call mpas_log_write(' - Performing halo exchange adjoint tests') + end if + call test_halo_adj_exch_fields(domain, threadErrs, iErr) + call mpas_threading_barrier() + if ( threadNum == 0 ) then + call mpas_log_write(' -- Return code: $i', intArgs=(/iErr/)) + err = ior(err, iErr) + end if + call mpas_timer_stop('halo exch tests') end subroutine test_core_halo_exch_test!}}} @@ -115,6 +126,7 @@ subroutine test_core_halo_exch_full_test(domain, threadErrs, err)!{{{ type (field2DInteger), pointer :: int2DField type (field1DInteger), pointer :: int1DField + integer :: iErr integer :: threadNum threadNum = mpas_threading_get_thread_num() + 1 @@ -247,7 +259,8 @@ subroutine test_core_halo_exch_full_test(domain, threadErrs, err)!{{{ call mpas_threading_barrier() - call test_core_halo_exch_validate_fields(domain, threadErrs, err) + call test_core_halo_exch_validate_fields(domain, threadErrs, iErr) + err = ior(err, iErr) end subroutine test_core_halo_exch_full_test!}}} @@ -983,6 +996,7 @@ end subroutine test_core_halo_exch_setup_fields!}}} !----------------------------------------------------------------------- function computeErrors(nColumns, expectedValues, real5D, real4D, real3D, real2D, real1D, & int3d, int2d, int1d) result(errorCode) + integer, intent(in) :: nColumns !< the outermost dimension size to be checked integer, dimension(:), pointer, intent(in) :: expectedValues !< an array of expected values !< the following are multi-dimension arrays whose elements are checked @@ -1370,5 +1384,262 @@ subroutine test_core_halo_exch_validate_fields(domain, threadErrs, err)!{{{ end subroutine test_core_halo_exch_validate_fields!}}} + !*********************************************************************** + !> \brief Identify cells that are adjacent to other marked cells + !> \author Michael Duda + !> \date 24 January 2024 + !> \details + !> Given a cell mask field, cellMask, and a specified (positive) non-zero mask + !> value, sentinelValue, this routine sets the cell mask field to (sentinelValue+1) + !> for all cells that are (1) adjacent to cells with the sentinelValue mask value + !> and (2) that have an initial cellMask value of zero. + !> + !> Cell adjacency is determined by the cellsOnCell and nEdgesOnCell fields. + !> + !> This routine returns the total number of cells that were marked as being + !> adjacent to cells with the sentinelValue mask value. + !----------------------------------------------------------------------- + function mark_interior_cells(cellMask, sentinelValue, cellsOnCell, nEdgesOnCell) result(nCellsMarked) + + ! Arguments + integer, dimension(:), intent(inout) :: cellMask !< mask field + integer, intent(in) :: sentinelValue !< value in mask field for which adjacent cells are marked + integer, dimension(:,:), intent(in) :: cellsOnCell !< indices of cell neighbors for each cell + integer, dimension(:), intent(in) :: nEdgesOnCell !< number of cell neighbors for each cell + + ! Return value + integer :: nCellsMarked + + ! Local variables + integer :: iCell, j + + + nCellsMarked = 0 + + do iCell = 1, size(cellMask) + if (cellMask(iCell) == 0) then + do j = 1, nEdgesOnCell(iCell) + if (cellMask(cellsOnCell(j, iCell)) == sentinelValue) then + cellMask(iCell) = sentinelValue + 1 + nCellsMarked = nCellsMarked + 1 +#ifdef HALO_EXCH_DEBUG_VERBOSE + call mpas_log_write(' mark_interior iCell:$i abuts:$i', & + intArgs = (/iCell, cellsOnCell(j,iCell)/)) +#endif + exit + end if + end do + end if + end do + +#ifdef HALO_EXCH_DEBUG_VERBOSE + call mpas_log_write(' mark_interior nCellsMarked:$i sentinel:$i', & + intArgs=(/nCellsMarked, sentinelValue/)) +#endif + + end function mark_interior_cells + + !*********************************************************************** + !> \brief Identify cells in the outermost N layers of owned cells in a block + !> \author Jim Wittig, Michael Duda + !> \date 29 January 2024 + !> \details + !> This function identifies cells that are in the outermost N layers of owned + !> cells in a block, where N is the number of halo layers (nHaloLayers). The + !> function returns an array of values indicating the location of a cell. + !> In the returned array, a value of zero indicates that the cell is not in + !> the outermost N layers of owned cells, and non-zero values indicate: + !> 1. the cell is a halo cell (not owned by this block) + !> 2. the cell is a distance of 1 away from a halo cell (i.e., adjacent to a halo cell) + !> 3. the cell is a distance of 2 away from a halo cell (i.e., adjacent to a cell marked '2') + !> 4. the cell is a distance of 3 away from a halo cell (i.e., adjacent to a cell marked '3') + !> + !> The result of this routine may be used to determine which cells will be modified + !> by the adjoint of a halo exchange; for example: + !> - cells marked with a 2 will be updated from halo layer 1, + !> - cells marked with a 3 will be updated from halo layer 2, etc. + !> + !----------------------------------------------------------------------- + function findExteriorCells(nCellsSolve, nCells, cellsOnCell, edgesOnCell, nHaloLayers) & + result(exteriorCells) + + ! Arguments + integer, intent(in) :: nCellsSolve !< the number of cells in this block + integer, intent(in) :: nCells !< total number of cells (cells in this block plus halo cells) + integer, dimension(:,:), intent(in) :: cellsOnCell !< array with adjacent cells for each cell + integer, dimension(:), intent(in) :: edgesOnCell !< array with edges for each cell + integer, intent(in) :: nHaloLayers !< the number of halo layers + + ! Return value + integer, dimension(:), allocatable :: exteriorCells + + ! Local variables + integer nInterior, nEdge, nLayers + + allocate(exteriorCells(nCells)) + exteriorCells(1:nCellsSolve) = 0 !< mark all owned cells as interior + exteriorCells(nCellsSolve+1:nCells) = 1 !< mark all halo cells as edge + nInterior = 0 + nEdge = 0 +#ifdef HALO_EXCH_DEBUG_VERBOSE + call mpas_log_write(' halo cellsOnCell($i x $i)', & + intArgs=(/size(cellsOnCell, dim=1), size(cellsOnCell, dim=2)/)) +#endif + + ! At this point, only halo cells are marked 1, and all owned cells are marked 0 + ! for each halo layer, mark cells adjacent to already marked cells with next highest marker + do nLayers = 1, nHaloLayers + nEdge = nEdge + mark_interior_cells(exteriorCells(1:nCells), nLayers, cellsOnCell, edgesOnCell) + end do + + nInterior = nCellsSolve - nEdge + +#ifdef HALO_EXCH_DEBUG_VERBOSE + call mpas_log_write(' halo nInterior:$i nEdge:$i', intArgs=(/nInterior, nEdge/)) +#endif + + end function findExteriorCells + + !*********************************************************************** + !> \brief MPAS Test Core halo adjoint exchange + !> \author Jim Wittig + !> \date 29 January 2024 + !> \details + !> This routine applies the adjoint of a halo exchangeto a 2-d array and + !> verifies that (1) the values for cells more than a distance N away from + !> a halo cell do not change (where N is the number of halo layers), and + !> (2) cells within a distance of N from a halo cell are updated. + !> + !> This routine assumes that a halo exchange has already been applied to + !> the cellPersistReal2D field before this routine has been called. + !> + !> Upon success, a value of 0 is returned; otherwise, a non-zero status + !> code is returned. + !----------------------------------------------------------------------- + subroutine test_halo_adj_exch_fields(domain, threadErrs, err) + + ! Arguments + type (domain_type), intent(inout) :: domain + integer, dimension(:), intent(out) :: threadErrs + integer, intent(out) :: err + + ! Local variables + type (block_type), pointer :: block + type (mpas_pool_type), pointer :: meshPool, haloExchTestPool + type (field2DReal), pointer :: real2DField + real (kind=RKIND), dimension(:, :), pointer :: real2D + real (kind=RKIND), dimension(:, :), allocatable :: real2Dorig + integer, dimension(:,:), pointer :: cellsOnCell + integer, dimension(:), pointer :: nEdgesOnCell + integer, dimension(:), allocatable :: exteriorCells + integer, pointer :: nCells, nCellsSolve + integer :: iCell, iEdgeOnCell, nInterior, nEdge, nHaloLayers + + err = 0 + + ! get a variable to call the adjoint halo on + block => domain % blocklist + + call mpas_pool_get_subpool(block % structs, 'haloExchTest', haloExchTestPool) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_field(haloExchTestPool, 'cellPersistReal2D', real2DField) + call mpas_pool_get_dimension(haloExchTestPool, 'nCells', nCells) + call mpas_pool_get_dimension(haloExchTestPool, 'nCellsSolve', nCellsSolve) +#ifdef HALO_EXCH_DEBUG_VERBOSE + call mpas_log_write(' test_halo_adj_exch_fields nCellsSolve:$i nCells:$i', & + intArgs=(/nCellsSolve, nCells/)) +#endif + + ! make a copy of the data before applying the adjoint halo + call mpas_pool_get_array(haloExchTestPool, 'cellPersistReal2D', real2D) + allocate(real2Dorig(size(real2D, 2), size(real2D, 1))) + real2Dorig = real2D + + ! find cells with adjoining ghost cells + call MPAS_pool_get_array(meshPool, 'cellsOnCell', cellsOnCell) + call MPAS_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) +#ifdef HALO_EXCH_DEBUG_VERBOSE + call mpas_log_write(' halo_adj_ cellsOnCell size:$ix$i', & + intArgs=(/size(cellsOnCell,2), size(cellsOnCell, 1)/)) +#endif + + nHaloLayers = size(real2DField % sendList % halos) + exteriorCells = findExteriorCells(nCellsSolve, nCells, cellsOnCell, nEdgesOnCell, nHaloLayers) + + ! run the adjoint halo, this will update owned cells + call mpas_dmpar_exch_halo_adj_field(real2DField) + + do while ( associated(block) ) + + ! get the real2D array after calling mpas_dmpar_exch_halo_adj_field + call mpas_pool_get_array(haloExchTestPool, 'cellPersistReal2D', real2D) + + ! check the adjoint halo operation populated fields correctly + err = check_adjoint_values(nCellsSolve, real2Dorig, real2D, exteriorCells) + block => block % next + end do + + end subroutine test_halo_adj_exch_fields + + !*********************************************************************** + !> \brief MPAS Test check pre and post adjoint exchange values + !> \author Jim Wittig + !> \date 29 January 2024 + !> \details + !> This routine checks the pre-adjoint halo exchange values aganst + !> post-adjoint halo exhange values. + !> Interior cell's values aren't expected to change, and border cell's values are + !> expected to change. + !> Returns 0 on success, non-0 on failure. + !----------------------------------------------------------------------- + integer function check_adjoint_values(nCellsSolve, orig, adjoint, exteriorCells) + + integer, pointer, intent(in) :: nCellsSolve !< the number of local owned cells + real (kind=RKIND), dimension(:,:), intent(in) :: orig !< values of the cells before applying the adjoint exchange + real (kind=RKIND), dimension(:,:), intent(in) :: adjoint !< values of cells after applying the adjoint exchange + integer, dimension(:), intent(in) :: exteriorCells !< array indicating a cell is interior or on the edge + + integer :: i, j, nError, nInterior, nEdge + integer :: iDim1, iDim2 + + nError = 0 + iDim1 = nCellsSolve + iDim2 = size(orig, dim=1) + nInterior = 0 + nEdge = 0 + + do i = 1, iDim1 + do j = 1, iDim2 + if (exteriorCells(i) == 0) then + if (j == 1) then + nInterior = nInterior + 1 + ! interior cells shouldn't have changed + if (orig(j, i) /= adjoint(j, i)) then + call mpas_log_write(' halo changed value for interior cell at:$i:$i orig:$r new:$r', & + intArgs=(/j,i/), realArgs=(/orig(j,i), adjoint(j,i)/)) + nError = nError + 1 + end if + end if + else + if (j == 1) then + nEdge = nEdge + 1 + ! edge cells should change + if (orig(j, i) == adjoint(j, i)) then + call mpas_log_write(' halo unchanged value for edge cell at:$i:$i $r vs $r', & + intArgs=(/i,j/), realArgs=(/orig(j, i), adjoint(j, i)/)) + nError = nError + 1 + end if + end if + end if + end do + end do +#ifdef HALO_EXCH_DEBUG_VERBOSE + call mpas_log_write(' halo nInterior:$i nEdge:$i, nError:$i', & + intArgs=(/nInterior, nEdge, nError/)) +#endif + + check_adjoint_values = nError + + end function check_adjoint_values end module test_core_halo_exch diff --git a/src/core_test/mpas_test_core_interface.F b/src/core_test/mpas_test_core_interface.F index 3988f7288e..e600824bc4 100644 --- a/src/core_test/mpas_test_core_interface.F +++ b/src/core_test/mpas_test_core_interface.F @@ -227,6 +227,7 @@ function test_setup_log(logInfo, domain, unitNumbers) result(iErr)!{{{ use mpas_derived_types use mpas_log + use mpas_framework, only : mpas_framework_report_settings implicit none @@ -252,6 +253,8 @@ function test_setup_log(logInfo, domain, unitNumbers) result(iErr)!{{{ call mpas_log_open(err=local_err) iErr = ior(iErr, local_err) + call mpas_framework_report_settings(domain) + end function test_setup_log!}}} diff --git a/src/core_test/mpas_test_openacc.F b/src/core_test/mpas_test_openacc.F new file mode 100644 index 0000000000..c3b9e6b424 --- /dev/null +++ b/src/core_test/mpas_test_openacc.F @@ -0,0 +1,312 @@ +! Copyright (c) 2024 The University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at https://mpas-dev.github.io/license.html . +! +module mpas_test_core_openacc + + use mpas_log, only : mpas_log_write + + private + + public :: mpas_test_openacc + + contains + + !----------------------------------------------------------------------- + ! function mpas_test_openacc + ! + !> \brief Main driver for tests of OpenACC functionality in MPAS + !> \author G. Dylan Dickerson + !> \date 14 May 2024 + !> \details + !> This routine invokes tests for expected OpenACC behavior and any + !> framework routines that are specific to OpenACC. + !> + !> Return value: The total number of test that failed on any MPI rank. + ! + !----------------------------------------------------------------------- + function mpas_test_openacc(domain) result(ierr_count) + + use mpas_derived_types, only : domain_type + use mpas_kind_types, only : StrKIND + use mpas_dmpar, only : mpas_dmpar_max_int + + implicit none + + ! Arguments + type (domain_type), intent(inout) :: domain + + ! Return value + integer :: ierr_count + + ! Local variables + integer :: ierr, ierr_global + ! Use test_log_str to track what is being tested next + character(len=StrKIND) :: test_log_str + + ierr_count = 0 + + call mpas_log_write('--- Begin OpenACC tests') + + test_log_str = 'Simple CPU-GPU reproducibility test' + ierr = openacc_test_rep_arrs(domain) + if (ierr == 0) then + call mpas_log_write(' '//trim(test_log_str)//' - PASSED') + else + ierr_count = ierr_count + 1 + call mpas_log_write(' '//trim(test_log_str)//' - FAILED') + end if + + ! Make sure all threads have the max number of tests failed in + call mpas_dmpar_max_int(domain % dminfo, ierr_count, ierr_global) + ierr_count = ierr_global + + end function mpas_test_openacc + + + !----------------------------------------------------------------------- + ! routine openacc_test_rep_arrs + ! + !> \brief OpenACC test of representative of array usage + !> \author G. Dylan Dickerson + !> \date 29 May 2024 + !> \details + !> Replicates patterns from the core_atmosphere dynamics and + !> compares the results on the CPU to those on the GPU. These + !> patterns include a main routine that fetches arrays and + !> dimensions that are passed to work routines and loops + !> in the work routine that calculate some helper values before the + !> result. + !> + !> Return value: 0 (success) if the CPU and GPU results match on + !> all ranks, 1 otherwise + !----------------------------------------------------------------------- + function openacc_test_rep_arrs(domain) result(ierr) + + use mpas_derived_types, only : domain_type, mpas_pool_type + use mpas_kind_types, only : RKIND + use mpas_pool_routines, only : mpas_pool_get_subpool,mpas_pool_get_dimension, & + mpas_pool_get_array + + implicit none + + ! Arguments + type (domain_type), intent(inout) :: domain + + ! Return value + integer :: ierr + + ! Local variables + real (kind=RKIND) :: diff + + type (mpas_pool_type), pointer :: mesh_pool + integer, pointer :: nCells,nCellsSolve + integer, pointer :: nEdges,nEdgesSolve + real (kind=RKIND), dimension(:), pointer :: areaCell + integer, dimension(:), pointer :: indexToCellID + integer, dimension(:), pointer :: nEdgesOnCell + integer, dimension(:,:), pointer :: cellsOnEdge + + type (mpas_pool_type), pointer :: openaccTest_pool + real (kind=RKIND), dimension(:), pointer :: array_cpu + real (kind=RKIND), dimension(:), pointer :: array_gpu + + ierr = 0 + diff = 0.0_RKIND + + ! + ! Fetch variables + ! + nullify(mesh_pool) + call mpas_pool_get_subpool(domain % blocklist % structs, 'mesh', mesh_pool) + + nullify(nCells) + call mpas_pool_get_dimension(mesh_pool, 'nCells', nCells) + + nullify(nEdges) + call mpas_pool_get_dimension(mesh_pool, 'nEdges', nEdges) + + nullify(nCellsSolve) + call mpas_pool_get_dimension(mesh_pool, 'nCellsSolve', nCellsSolve) + + nullify(nEdgesSolve) + call mpas_pool_get_dimension(mesh_pool, 'nEdgesSolve', nEdgesSolve) + + nullify(areaCell) + call mpas_pool_get_array(mesh_pool, 'areaCell', areaCell) + + nullify(indexToCellID) + call mpas_pool_get_array(mesh_pool, 'indexToCellID', indexToCellID) + + nullify(nEdgesOnCell) + call mpas_pool_get_array(mesh_pool, 'nEdgesOnCell', nEdgesOnCell) + + nullify(cellsOnEdge) + call mpas_pool_get_array(mesh_pool, 'cellsOnEdge', cellsOnEdge) + + nullify(openaccTest_pool) + call mpas_pool_get_subpool(domain % blocklist % structs, 'openaccTest', openaccTest_pool) + + nullify(array_cpu) + call mpas_pool_get_array(openaccTest_pool, 'edge_cpu', array_cpu) + + nullify(array_gpu) + call mpas_pool_get_array(openaccTest_pool, 'edge_gpu', array_gpu) + + call rep_arrs_work_cpu(nCells,nEdges,nCellsSolve,nEdgesSolve, & + areaCell,indexToCellID,nEdgesOnCell,cellsOnEdge, & + array_cpu) + + call rep_arrs_work_gpu(nCells,nEdges,nCellsSolve,nEdgesSolve, & + areaCell,indexToCellID,nEdgesOnCell,cellsOnEdge, & + array_gpu) + + diff = sum(abs(array_cpu(1:nEdges) - array_gpu(1:nEdges))) + + if (diff > 0.0_RKIND) then + ierr = ierr + 1 + end if + + end function openacc_test_rep_arrs + + + !----------------------------------------------------------------------- + ! routine rep_arrs_work_cpu + ! + !> \brief CPU work routine for OpenACC representative arrays test + !> \author G. Dylan Dickerson + !> \date 29 May 2024 + !> \details + !> Performs some array work on the CPU, based on patterns in the + !> MPAS-A dycore. + ! + !----------------------------------------------------------------------- + subroutine rep_arrs_work_cpu(nCells, nEdges, nCellsSolve, nEdgesSolve, & + areaCell, indexToCellID, nEdgesOnCell, cellsOnEdge, & + edge_arr_cpu) + + use mpas_kind_types, only : RKIND + + implicit none + + ! arguments + integer, intent(in) :: nCells, nEdges, nCellsSolve, nEdgesSolve + real (kind=RKIND), dimension(:), intent(in) :: areaCell + integer, dimension(:), intent(in) :: indexToCellID + integer, dimension(:), intent(in) :: nEdgesOnCell + integer, dimension(:,:), intent(in) :: cellsOnEdge + real (kind=RKIND), dimension(:), intent(inout) :: edge_arr_cpu + + ! locals + integer :: iCell, iEdge, cell1, cell2 + real (kind=RKIND), dimension(nCells) :: invArea, help_arr + + ! Compute any helpers and initialize arrs + do iCell=1,nCells + invArea(iCell) = 1.0_RKIND / areaCell(iCell) + help_arr(iCell) = 0.0_RKIND + end do + do iEdge=1,nEdges + edge_arr_cpu(iEdge) = 0.0_RKIND + end do + + ! Compute helper values (for all owned cells) + do iCell=1,nCellsSolve + help_arr(iCell) = (nEdgesOnCell(iCell)+indexToCellID(iCell)) * invArea(iCell) + end do + + ! Compute final value (for all owned edges) + do iEdge=1,nEdgesSolve + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + + edge_arr_cpu(iEdge) = 0.5_RKIND * (help_arr(cell1) + help_arr(cell2)) + end do + end subroutine rep_arrs_work_cpu + + + !----------------------------------------------------------------------- + ! routine rep_arrs_work_gpu + ! + !> \brief GPU work routine for OpenACC representative arrays test + !> \author G. Dylan Dickerson + !> \date 29 May 2024 + !> \details + !> Performs some array work on the GPU, based on patterns in the + !> MPAS-A dycore. + ! + !----------------------------------------------------------------------- + subroutine rep_arrs_work_gpu(nCells, nEdges, nCellsSolve, nEdgesSolve, & + areaCell, indexToCellID, nEdgesOnCell, cellsOnEdge, & + edge_arr_gpu) + + use mpas_kind_types, only : RKIND + + implicit none + + ! arguments + integer, intent(in) :: nCells, nEdges, nCellsSolve, nEdgesSolve + real (kind=RKIND), dimension(:), intent(in) :: areaCell + integer, dimension(:), intent(in) :: indexToCellID + integer, dimension(:), intent(in) :: nEdgesOnCell + integer, dimension(:,:), intent(in) :: cellsOnEdge + real (kind=RKIND), dimension(:), intent(inout) :: edge_arr_gpu + + ! locals + integer :: iCell, iEdge, cell1, cell2 + real (kind=RKIND), dimension(nCells) :: invArea + real (kind=RKIND), dimension(nCells) :: help_arr + + !$acc enter data copyin(nCells,nEdges, & + !$acc areaCell(:), indexToCellID(:), & + !$acc nEdgesOnCell(:),cellsOnEdge(:,:)) + + !$acc enter data create(edge_arr_gpu(:),iCell,iEdge,cell1,cell2, & + !$acc invArea(:),help_arr(:)) + + ! Compute any helpers and initialize arrs + !$acc parallel default(present) async + !$acc loop gang worker vector + do iCell=1,nCells + invArea(iCell) = 1.0_RKIND / areaCell(iCell) + help_arr(iCell) = 0.0_RKIND + end do + + !$acc loop gang worker vector + do iEdge=1,nEdges + edge_arr_gpu(iEdge) = 0.0_RKIND + end do + !$acc end parallel + + ! Compute helper values (for all owned cells) + !$acc parallel default(present) wait + !$acc loop gang worker vector + do iCell=1,nCellsSolve + help_arr(iCell) = (nEdgesOnCell(iCell)+indexToCellID(iCell)) * invArea(iCell) + end do + !$acc end parallel + + ! Compute final value (for all owned edges) + !$acc parallel default(present) wait + !$acc loop gang worker vector private(cell1, cell2) + do iEdge=1,nEdgesSolve + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + + edge_arr_gpu(iEdge) = 0.5_RKIND * (help_arr(cell1) + help_arr(cell2)) + end do + !$acc end parallel + + !$acc exit data delete(nCells,nEdges, & + !$acc areaCell(:), indexToCellID(:), & + !$acc nEdgesOnCell(:),cellsOnEdge(:,:), & + !$acc iCell,iEdge,cell1,cell2,invArea(:),help_arr(:)) + + !$acc exit data copyout(edge_arr_gpu(:)) + + end subroutine rep_arrs_work_gpu + + +end module mpas_test_core_openacc diff --git a/src/external/esmf_time_f90/CMakeLists.txt b/src/external/esmf_time_f90/CMakeLists.txt new file mode 100644 index 0000000000..6546880fb4 --- /dev/null +++ b/src/external/esmf_time_f90/CMakeLists.txt @@ -0,0 +1,34 @@ + +set(_esmf_time_src + ESMF_AlarmClockMod.F90 + ESMF_AlarmMod.F90 + ESMF_BaseMod.F90 + ESMF_BaseTimeMod.F90 + ESMF_CalendarMod.F90 + ESMF_ClockMod.F90 + ESMF.F90 + ESMF_FractionMod.F90 + ESMF_Macros.inc + ESMF_ShrTimeMod.F90 + ESMF_Stubs.F90 + ESMF_TimeIntervalMod.F90 + ESMF_TimeMgr.inc + ESMF_TimeMod.F90 + MeatMod.F90 + wrf_error_fatal.F90 + wrf_message.F90) + +add_library(esmf ${_esmf_time_src}) +mpas_fortran_target(esmf) +add_library(${PROJECT_NAME}::external::esmf ALIAS esmf) + +target_compile_definitions(esmf PRIVATE HIDE_MPI=1) + +target_include_directories(esmf PUBLIC $) + +target_link_libraries(esmf PUBLIC MPI::MPI_Fortran) + +install(TARGETS esmf EXPORT ${PROJECT_NAME}ExportsExternal + ARCHIVE DESTINATION ${CMAKE_INSTALL_LIBDIR} + LIBRARY DESTINATION ${CMAKE_INSTALL_LIBDIR}) + diff --git a/src/external/ezxml/CMakeLists.txt b/src/external/ezxml/CMakeLists.txt new file mode 100644 index 0000000000..34955dbd98 --- /dev/null +++ b/src/external/ezxml/CMakeLists.txt @@ -0,0 +1,8 @@ + +add_library(ezxml ezxml.c) +add_library(${PROJECT_NAME}::external::ezxml ALIAS ezxml) +target_include_directories(ezxml PUBLIC $) + +install(TARGETS ezxml EXPORT ${PROJECT_NAME}ExportsExternal + ARCHIVE DESTINATION ${CMAKE_INSTALL_LIBDIR} + LIBRARY DESTINATION ${CMAKE_INSTALL_LIBDIR}) diff --git a/src/framework/CMakeLists.txt b/src/framework/CMakeLists.txt new file mode 100644 index 0000000000..535ba07891 --- /dev/null +++ b/src/framework/CMakeLists.txt @@ -0,0 +1,70 @@ + +set(MPAS_FRAMEWORK_SOURCES + mpas_block_creator.F + mpas_block_decomp.F + mpas_bootstrapping.F + mpas_c_interfacing.F + mpas_constants.F + mpas_decomp.F + mpas_domain_routines.F + mpas_field_routines.F + mpas_forcing.F + mpas_hash.F + mpas_io_units.F + mpas_kind_types.F + mpas_pool_routines.F + mpas_sort.F + mpas_stream_list.F + mpas_threading.F + mpas_timer.F + mpas_abort.F + mpas_attlist.F + mpas_derived_types.F + mpas_dmpar.F + mpas_framework.F + mpas_halo.F + mpas_io.F + mpas_io_streams.F + mpas_log.F + mpas_stream_inquiry.F + mpas_stream_manager.F + mpas_string_utils.F + mpas_timekeeping.F + pool_hash.c + random_id.c + regex_matching.c + xml_stream_parser.c + stream_inquiry.c) + +add_library(framework ${MPAS_FRAMEWORK_SOURCES}) +set_MPAS_DEBUG_flag(framework) +set(FRAMEWORK_COMPILE_DEFINITIONS + USE_PIO2 + MPAS_PIO_SUPPORT + mpas=1 + MPAS_NATIVE_TIMERS) +target_compile_definitions(framework PRIVATE ${FRAMEWORK_COMPILE_DEFINITIONS}) + +mpas_fortran_target(framework) +add_library(${PROJECT_NAME}::framework ALIAS framework) + +set_target_properties(framework PROPERTIES OUTPUT_NAME mpas_framework) + +set(FRAMEWORK_LINK_LIBRARIES + ${PROJECT_NAME}::external::esmf + ${PROJECT_NAME}::external::ezxml + PIO::PIO_Fortran + PIO::PIO_C + PnetCDF::PnetCDF_Fortran + NetCDF::NetCDF_Fortran + NetCDF::NetCDF_C + MPI::MPI_Fortran) + +if (MPAS_PROFILE) + list(APPEND FRAMEWORK_LINK_LIBRARIES GPTL::GPTL) +endif () +target_link_libraries(framework PUBLIC ${FRAMEWORK_LINK_LIBRARIES}) + +install(TARGETS framework EXPORT ${PROJECT_NAME}Exports + ARCHIVE DESTINATION ${CMAKE_INSTALL_LIBDIR} + LIBRARY DESTINATION ${CMAKE_INSTALL_LIBDIR}) diff --git a/src/framework/mpas_abort.F b/src/framework/mpas_abort.F index f2707944aa..e00a3cfd67 100644 --- a/src/framework/mpas_abort.F +++ b/src/framework/mpas_abort.F @@ -33,7 +33,7 @@ subroutine mpas_dmpar_global_abort(mesg, deferredAbort)!{{{ #ifdef _MPI #ifndef NOMPIMOD #ifdef MPAS_USE_MPI_F08 - use mpi_f08 + use mpi_f08, only : MPI_COMM_WORLD, MPI_Comm_rank, MPI_Comm_size, MPI_Abort #else use mpi #endif diff --git a/src/framework/mpas_dmpar.F b/src/framework/mpas_dmpar.F index 033c818f47..0addb63ed0 100644 --- a/src/framework/mpas_dmpar.F +++ b/src/framework/mpas_dmpar.F @@ -32,7 +32,16 @@ module mpas_dmpar #ifdef _MPI #ifndef NOMPIMOD #ifdef MPAS_USE_MPI_F08 - use mpi_f08 + use mpi_f08, only : MPI_Comm, MPI_Datatype + use mpi_f08, only : MPI_INTEGER, MPI_2INTEGER, MPI_REAL, MPI_2REAL, MPI_DOUBLE_PRECISION, & + MPI_2DOUBLE_PRECISION, MPI_CHARACTER, MPI_INTEGER8 + use mpi_f08, only : MPI_COMM_SELF, MPI_COMM_WORLD, MPI_INFO_NULL, MPI_THREAD_SINGLE, & + MPI_THREAD_SERIALIZED, MPI_THREAD_FUNNELED, MPI_THREAD_MULTIPLE, MPI_STATUS_IGNORE + use mpi_f08, only : MPI_Query_thread, MPI_Comm_dup + use mpi_f08, only : MPI_Init_thread , MPI_Init, MPI_Comm_rank, MPI_Comm_size, MPI_Finalize, & + MPI_Comm_free, MPI_Abort, MPI_Bcast, MPI_Allreduce, MPI_Scatterv, MPI_Recv, & + MPI_Send, MPI_Request, MPI_Irecv, MPI_Isend, MPI_Wait, MPI_Wtime, MPI_Test + use mpi_f08, only : MPI_SUM, MPI_MIN, MPI_MAX, MPI_MINLOC, MPI_MAXLOC #else use mpi #endif @@ -170,6 +179,14 @@ module mpas_dmpar module procedure mpas_dmpar_exch_halo_field5d_real end interface + interface mpas_dmpar_exch_halo_adj_field + module procedure mpas_dmpar_exch_halo_adj_field2d_real + end interface + + public :: mpas_dmpar_exch_halo_adj_field + + private :: mpas_dmpar_exch_halo_adj_field2d_real + public :: mpas_dmpar_exch_halo_field private :: mpas_dmpar_exch_halo_field1d_integer @@ -5486,6 +5503,7 @@ subroutine mpas_dmpar_exch_halo_field2d_real(field, haloLayersIn)!{{{ end do else nHaloLayers = size(field % sendList % halos) + DMPAR_DEBUG_WRITE('exch_halo nHaloLayers:$i destList halos:$i' COMMA intArgs=(/nHaloLayers COMMA size(field%recvList%halos)/)) allocate(haloLayers(nHaloLayers)) do iHalo = 1, nHaloLayers haloLayers(iHalo) = iHalo @@ -6195,6 +6213,193 @@ subroutine mpas_dmpar_exch_halo_field5d_real(field, haloLayersIn)!{{{ end subroutine mpas_dmpar_exch_halo_field5d_real!}}} + !----------------------------------------------------------------------- + ! routine mpas_dmpar_exch_halo_adj_field2d_real + ! + !> \brief MPAS dmpar halo exchange adjoint 2D real field + !> \author BJ Jung + !> \date 09/2020 + !> \details + !> This routine handles the adjoint of halo exchange communication of an input field across all processors. + !> It accumulates the values of owned point with the values of halos. It is based on mpas_dmpar_exch_halo_field2d_real. + !> + !> Note the number of halo layers impacts the number of cells which will be updated by this routine: + !> The first halo layer will update the owned 'edge' cells, where 'edge' cells are adjacent to ghost cells. + !> The second halo layer will update owned cells which are adjacent to the 'edge' cells. + !> The third halo layer will update owned cells which are adjacent to the cells updated by the seconds halo layer, etc. + !----------------------------------------------------------------------- + subroutine mpas_dmpar_exch_halo_adj_field2d_real(field, haloLayersIn)!{{{ + + implicit none + + type (field2dReal), pointer, intent(inout) :: field !< Input: Field to communicate + integer, dimension(:), intent(in), optional :: haloLayersIn !< Input: List of halo layers to communicate. Defaults to all + type (dm_info), pointer :: dminfo + type (field2dReal), pointer :: fieldCursor, fieldCursor2 + type (mpas_exchange_list), pointer :: exchListPtr + type (mpas_communication_list), pointer :: sendList, recvList, commListPtr + integer :: mpi_ierr, threadNum + integer :: nHaloLayers, iHalo, i, j + integer :: bufferOffset, nAdded + integer, dimension(:), pointer :: haloLayers + + if ( .not. field % isActive ) then + DMPAR_DEBUG_WRITE(' -- Skipping halo exchange for deactivated field: ' // trim(field % fieldName)) + return + end if + + do i = 1, 2 + if(field % dimSizes(i) <= 0) then + return + end if + end do + + dminfo => field % block % domain % dminfo + threadNum = mpas_threading_get_thread_num() + + if ( threadNum == 0 ) then + if(present(haloLayersIn)) then + nHaloLayers = size(haloLayersIn) + allocate(haloLayers(nHaloLayers)) + do iHalo = 1, nHaloLayers + haloLayers(iHalo) = haloLayersIn(iHalo) + end do + else + nHaloLayers = size(field % sendList % halos) + DMPAR_DEBUG_WRITE('exch_halo_adjoint nHaloLayers:$i destList halos:$i' COMMA intArgs=(/nHaloLayers COMMA size(field%recvList%halos)/)) + allocate(haloLayers(nHaloLayers)) + do iHalo = 1, nHaloLayers + haloLayers(iHalo) = iHalo + end do + end if + +#ifdef _MPI + ! Setup Communication Lists + call mpas_dmpar_build_comm_lists(field % sendList, field % recvList, haloLayers, field % dimsizes, sendList, recvList) + + ! Allocate space in recv lists, and initiate mpi_irecv calls + commListPtr => sendList + do while(associated(commListPtr)) + allocate(commListPtr % rbuffer(commListPtr % nList)) + nullify(commListPtr % ibuffer) + call MPI_Irecv(commListPtr % rbuffer, commListPtr % nList, MPI_REALKIND, commListPtr % procID, commListPtr % procID, dminfo % comm, commListPtr % reqID, mpi_ierr) + + commListPtr => commListPtr % next + end do + + ! Allocate space in send lists, copy data into buffer, and initiate mpi_isend calls + commListPtr => recvList + do while(associated(commListPtr)) + allocate(commListPtr % rbuffer(commListPtr % nList)) + nullify(commListPtr % ibuffer) + bufferOffset = 0 + do iHalo = 1, nHaloLayers + nAdded = 0 + fieldCursor => field + do while(associated(fieldCursor)) + exchListPtr => fieldCursor % recvList % halos(haloLayers(iHalo)) % exchList + do while(associated(exchListPtr)) + if(exchListPtr % endPointID == commListPtr % procID) then + do i = 1, exchListPtr % nList + do j = 1, fieldCursor % dimSizes(1) + commListPtr % rbuffer((exchListPtr % srcList(i)-1) * fieldCursor % dimSizes(1) + j + bufferOffset) = fieldCursor % array(j, exchListPtr % destList(i)) + ! update halo cell + fieldCursor % array(j, exchListPtr % destList(i)) = 0.0_RKIND + nAdded = nAdded + 1 + end do + end do + end if + + exchListPtr => exchListPtr % next + end do + + fieldCursor => fieldCursor % next + end do + bufferOffset = bufferOffset + nAdded + end do + + call MPI_Isend(commListPtr % rbuffer, commListPtr % nList, MPI_REALKIND, commListPtr % procID, dminfo % my_proc_id, dminfo % comm, commListPtr % reqID, mpi_ierr) + commListPtr => commListPtr % next + end do +#endif + + ! Handle local copy. If MPI is off, then only local copies are performed. + fieldCursor => field + do while(associated(fieldCursor)) + do iHalo = 1, nHaloLayers + exchListPtr => fieldCursor % copyList % halos(haloLayers(iHalo)) % exchList + + do while(associated(exchListPtr)) + fieldCursor2 => field + do while(associated(fieldCursor2)) + if(exchListPtr % endPointID == fieldCursor2 % block % localBlockID) then + do i = 1, exchListPtr % nList + !fieldCursor2 % array(:, exchListPtr % destList(i)) = fieldCursor % array(:, exchListPtr % srcList(i)) + fieldCursor % array(:, exchListPtr % srcList(i)) = fieldCursor % array(:, exchListPtr % srcList(i)) + fieldCursor2 % array(:, exchListPtr % destList(i)) + fieldCursor2 % array(:, exchListPtr % destList(i)) = 0.0_RKIND + end do + end if + + fieldCursor2 => fieldCursor2 % next + end do + + exchListPtr => exchListPtr % next + end do + end do + + fieldCursor => fieldCursor % next + end do + +#ifdef _MPI + + ! Wait for mpi_irecv to finish, and unpack data from buffer + commListPtr => sendList + do while(associated(commListPtr)) + call MPI_Wait(commListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr) + bufferOffset = 0 + do iHalo = 1, nHaloLayers + nAdded = 0 + fieldCursor => field + do while(associated(fieldCursor)) + exchListPtr => fieldCursor % sendList % halos(haloLayers(iHalo)) % exchList + do while(associated(exchListPtr)) + if(exchListPtr % endPointID == commListPtr % procID) then + do i = 1, exchListPtr % nList + do j = 1, fieldCursor % dimSizes(1) + ! update cell in our block + fieldCursor % array(j, exchListPtr % srcList(i)) = fieldCursor % array(j, exchListPtr % srcList(i)) + commListPtr % rbuffer((exchListPtr % destList(i)-1) * fieldCursor % dimSizes(1) + j + bufferOffset) + commListPtr % rbuffer((exchListPtr % destList(i)-1) * fieldCursor % dimSizes(1) + j + bufferOffset) = 0.0_RKIND + end do + end do + nAdded = max(nAdded, maxval(exchListPtr % destList) * fieldCursor % dimSizes(1)) + end if + exchListPtr => exchListPtr % next + end do + + fieldCursor => fieldCursor % next + end do + bufferOffset = bufferOffset + nAdded + end do + commListPtr => commListPtr % next + end do + + ! wait for mpi_isend to finish. + commListPtr => recvList + do while(associated(commListPtr)) + call MPI_Wait(commListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr) + commListPtr => commListPtr % next + end do + + ! Destroy commLists. + call mpas_dmpar_destroy_communication_list(sendList) + call mpas_dmpar_destroy_communication_list(recvList) +#endif + + deallocate(haloLayers) + end if + + end subroutine mpas_dmpar_exch_halo_adj_field2d_real!}}} + !----------------------------------------------------------------------- ! routine mpas_dmpar_init_multihalo_exchange_list ! diff --git a/src/framework/mpas_framework.F b/src/framework/mpas_framework.F index 68445d186c..7986383656 100644 --- a/src/framework/mpas_framework.F +++ b/src/framework/mpas_framework.F @@ -27,6 +27,8 @@ module mpas_framework use mpas_io_units use mpas_block_decomp + private :: report_acc_devices + contains @@ -184,4 +186,135 @@ subroutine mpas_framework_finalize(dminfo, domain, io_system)!{{{ end subroutine mpas_framework_finalize!}}} + +!----------------------------------------------------------------------- +! routine mpas_framework_report_settings +! +!> \brief Report information about compile- and run-time settings to the log file +!> \author Michael Duda +!> \date 1 May 2024 +!> \details +!> This routine writes information about compile-time and run-time settings for +!> an MPAS core to the log file. +! +!----------------------------------------------------------------------- + subroutine mpas_framework_report_settings(domain) + +#ifdef MPAS_OPENMP + use mpas_threading, only : mpas_threading_get_num_threads +#endif + + implicit none + + type (domain_type), pointer :: domain + + + call mpas_log_write('') + call mpas_log_write('Output from ''git describe --dirty'': '//trim(domain % core % git_version)) + + call mpas_log_write('') + call mpas_log_write('Compile-time options:') + call mpas_log_write(' Build target: '//trim(domain % core % build_target)) + call mpas_log_write(' OpenMP support: ' // & +#ifdef MPAS_OPENMP + 'yes') +#else + 'no') +#endif + call mpas_log_write(' OpenACC support: ' // & +#ifdef MPAS_OPENACC + 'yes') +#else + 'no') +#endif + call mpas_log_write(' Default real precision: ' // & +#ifdef SINGLE_PRECISION + 'single') +#else + 'double') +#endif + call mpas_log_write(' Compiler flags: ' // & +#ifdef MPAS_DEBUG + 'debug') +#else + 'optimize') +#endif + call mpas_log_write(' I/O layer: ' // & +#ifdef MPAS_PIO_SUPPORT +#ifdef USE_PIO2 + 'PIO 2.x') +#else + 'PIO 1.x') +#endif +#else + 'SMIOL') +#endif + call mpas_log_write('') + + call mpas_log_write('Run-time settings:') + call mpas_log_write(' MPI task count: $i', intArgs=[domain % dminfo % nprocs]) +#ifdef MPAS_OPENMP + call mpas_log_write(' OpenMP max threads: $i', intArgs=[mpas_threading_get_max_threads()]) +#endif + call mpas_log_write('') + +#ifdef MPAS_OPENACC + call report_acc_devices() +#endif + + end subroutine mpas_framework_report_settings + + +#ifdef MPAS_OPENACC + !*********************************************************************** + ! + ! function report_acc_devices + ! + !> \brief Queries OpenACC devices and reports device info to log file + !> \author Michael G. Duda + !> \date 28 March 2024 + !> \details + !> This routine makes use of the OpenACC runtime library to obtain + !> information about how many and which kind of OpenACC devices are + !> available to the current MPI rank. + !> + !> NB: This routine is only compiled and only called if OPENACC=true. + ! + !----------------------------------------------------------------------- + subroutine report_acc_devices() + + use mpas_c_interfacing, only : mpas_sanitize_string + use openacc, only : acc_get_property_string, acc_get_property, acc_get_num_devices, acc_get_device_num, & + acc_get_device_type, acc_device_kind, acc_device_property, acc_property_vendor, & + acc_property_name, acc_property_driver + + implicit none + + integer(kind=acc_device_kind) :: device + character(len=StrKIND) :: device_vendor, device_name, driver_vers + integer :: ndevices, device_num + + + device = acc_get_device_type() + ndevices = acc_get_num_devices(device) + device_num = acc_get_device_num(device_num) + call acc_get_property_string(device_num, device, acc_property_vendor, device_vendor) + call acc_get_property_string(device_num, device, acc_property_name, device_name) + call acc_get_property_string(device_num, device, acc_property_driver, driver_vers) + + call mpas_sanitize_string(device_vendor) + call mpas_sanitize_string(device_name) + call mpas_sanitize_string(driver_vers) + + call mpas_log_write('OpenACC configuration:') + call mpas_log_write(' Number of visible devices: $i', intArgs=[ndevices]) + call mpas_log_write(' Device # for this MPI task: $i', intArgs=[device_num]) + call mpas_log_write(' Device vendor: '//trim(device_vendor)) + call mpas_log_write(' Device name: '//trim(device_name)) + call mpas_log_write(' Device driver version: '//trim(driver_vers)) + call mpas_log_write('') + + end subroutine report_acc_devices +#endif + end module mpas_framework diff --git a/src/framework/mpas_halo.F b/src/framework/mpas_halo.F index 57f89db875..09db77c5b2 100644 --- a/src/framework/mpas_halo.F +++ b/src/framework/mpas_halo.F @@ -486,7 +486,10 @@ end subroutine mpas_halo_exch_group_add_field subroutine mpas_halo_exch_group_full_halo_exch(domain, groupName, iErr) #ifdef MPAS_USE_MPI_F08 - use mpi_f08 + use mpi_f08, only : MPI_Datatype, MPI_Comm + use mpi_f08, only : MPI_REAL, MPI_DOUBLE_PRECISION, MPI_REQUEST_NULL, & + MPI_STATUS_IGNORE, MPI_STATUSES_IGNORE + use mpi_f08, only : MPI_Irecv, MPI_Isend, MPI_Waitany, MPI_Waitall #else use mpi #endif diff --git a/src/framework/mpas_log.F b/src/framework/mpas_log.F index 8462545fba..2b7bbaec22 100644 --- a/src/framework/mpas_log.F +++ b/src/framework/mpas_log.F @@ -809,7 +809,7 @@ subroutine log_abort() #ifdef _MPI #ifndef NOMPIMOD #ifdef MPAS_USE_MPI_F08 - use mpi_f08 + use mpi_f08, only : MPI_COMM_WORLD, MPI_Abort #else use mpi #endif diff --git a/src/operators/CMakeLists.txt b/src/operators/CMakeLists.txt new file mode 100644 index 0000000000..5c04339b80 --- /dev/null +++ b/src/operators/CMakeLists.txt @@ -0,0 +1,24 @@ +list(APPEND _mpas_operators_src + mpas_geometry_utils.F + mpas_matrix_operations.F + mpas_rbf_interpolation.F + mpas_spline_interpolation.F + mpas_tensor_operations.F + mpas_tracer_advection_helpers.F + mpas_tracer_advection_mono.F + mpas_tracer_advection_std.F + mpas_vector_operations.F + mpas_vector_reconstruction.F) + +add_library(operators ${_mpas_operators_src}) + +mpas_fortran_target(operators) + +add_library(${PROJECT_NAME}::operators ALIAS operators) + +set_target_properties(operators PROPERTIES OUTPUT_NAME mpas_operators) +target_link_libraries(operators PUBLIC ${PROJECT_NAME}::framework) + +install(TARGETS operators EXPORT ${PROJECT_NAME}Exports + ARCHIVE DESTINATION ${CMAKE_INSTALL_LIBDIR} + LIBRARY DESTINATION ${CMAKE_INSTALL_LIBDIR}) diff --git a/src/tools/CMakeLists.txt b/src/tools/CMakeLists.txt new file mode 100644 index 0000000000..513ae48cf1 --- /dev/null +++ b/src/tools/CMakeLists.txt @@ -0,0 +1,30 @@ + +if (DEFINED ENV{MPAS_TOOL_DIR}) + message(STATUS "*** Using MPAS tools from $ENV{MPAS_TOOL_DIR} ***") + add_custom_target(namelist_gen) + add_custom_command( + TARGET namelist_gen PRE_BUILD + COMMAND ${CMAKE_COMMAND} -E copy $ENV{MPAS_TOOL_DIR}/input_gen/namelist_gen ${CMAKE_CURRENT_BINARY_DIR}/namelist_gen) + add_custom_target(streams_gen) + add_custom_command( + TARGET streams_gen PRE_BUILD + COMMAND ${CMAKE_COMMAND} -E copy $ENV{MPAS_TOOL_DIR}/input_gen/streams_gen ${CMAKE_CURRENT_BINARY_DIR}/streams_gen) + add_custom_target(parse) + add_custom_command( + TARGET parse PRE_BUILD + COMMAND ${CMAKE_COMMAND} -E copy $ENV{MPAS_TOOL_DIR}/input_gen/parse ${CMAKE_CURRENT_BINARY_DIR}/parse) +else() + message(STATUS "*** Building MPAS tools from source ***") + # Make build tools, need to be compiled with serial compiler. + set(CMAKE_C_COMPILER ${SCC}) + + add_executable(streams_gen input_gen/streams_gen.c input_gen/test_functions.c ../external/ezxml/ezxml.c) + add_executable(namelist_gen input_gen/namelist_gen.c input_gen/test_functions.c ../external/ezxml/ezxml.c) + add_executable(parse registry/parse.c registry/dictionary.c registry/gen_inc.c registry/fortprintf.c registry/utility.c ../external/ezxml/ezxml.c) + + foreach(EXEITEM streams_gen namelist_gen parse) + target_compile_definitions(${EXEITEM} PRIVATE ${CPPDEFS}) + target_compile_options(${EXEITEM} PRIVATE "-Uvector") + target_include_directories(${EXEITEM} PRIVATE ${INCLUDES}) + endforeach() +endif() diff --git a/src/tools/input_gen/CMakeLists.txt b/src/tools/input_gen/CMakeLists.txt new file mode 100644 index 0000000000..2b8c770476 --- /dev/null +++ b/src/tools/input_gen/CMakeLists.txt @@ -0,0 +1,6 @@ + +add_executable(mpas_namelist_gen namelist_gen.c test_functions.c) +target_link_libraries(mpas_namelist_gen PUBLIC ${PROJECT_NAME}::external::ezxml) + +add_executable(mpas_streams_gen streams_gen.c test_functions.c) +target_link_libraries(mpas_streams_gen PUBLIC ${PROJECT_NAME}::external::ezxml) diff --git a/src/tools/registry/CMakeLists.txt b/src/tools/registry/CMakeLists.txt new file mode 100644 index 0000000000..7d18e3f3b6 --- /dev/null +++ b/src/tools/registry/CMakeLists.txt @@ -0,0 +1,17 @@ + +#Parsing library core-independent code +add_library(parselib dictionary.c fortprintf.c utility.c) +target_link_libraries(parselib PUBLIC ${PROJECT_NAME}::external::ezxml) +target_link_libraries(parselib PUBLIC ${PROJECT_NAME}::external::esmf) + +# Generate parser for each core +# +# Note: One parser is required per-core because the gen_inc.c depends on +# a pre-processor define MPAS_NAMELIST_SUFFIX which is core specific +foreach(_core IN LISTS MPAS_CORES) + add_executable(mpas_parse_${_core} parse.c gen_inc.c) + target_link_libraries(mpas_parse_${_core} PUBLIC parselib) + target_compile_definitions(mpas_parse_${_core} PRIVATE MPAS_NAMELIST_SUFFIX=${_core} + MPAS_GIT_VERSION=${MPAS_GIT_VERSION} + MPAS_EXE_NAME=${_core}_model) +endforeach() diff --git a/src/tools/registry/gen_inc.c b/src/tools/registry/gen_inc.c index 5823273092..94f5f714d3 100644 --- a/src/tools/registry/gen_inc.c +++ b/src/tools/registry/gen_inc.c @@ -15,8 +15,8 @@ #include "fortprintf.h" #include "utility.h" -#define STR(s) #s -#define MACRO_TO_STR(s) STR(s) +void process_core_macro(const char *macro, const char *val, va_list ap); +void process_domain_macro(const char *macro, const char *val, va_list ap); #define NUM_MODIFIED_ATTRS 2 #define NUM_IGNORED_ATTRS 9 @@ -44,12 +44,7 @@ static const char *ATTRS_TO_MODIFY[NUM_MODIFIED_ATTRS][2] = { }; -void write_model_variables(ezxml_t registry){/*{{{*/ - const char * suffix = MACRO_TO_STR(MPAS_NAMELIST_SUFFIX); - const char * exe_name = MACRO_TO_STR(MPAS_EXE_NAME); - const char * git_ver = MACRO_TO_STR(MPAS_GIT_VERSION); - const char * build_target = MACRO_TO_STR(MPAS_BUILD_TARGET); - +void write_model_variables(ezxml_t registry, int macro_count, const char **macros){/*{{{*/ const char *modelname, *corename, *version; FILE *fd; @@ -62,22 +57,45 @@ void write_model_variables(ezxml_t registry){/*{{{*/ fortprintf(fd, " core %% modelName = '%s'\n", modelname); fortprintf(fd, " core %% coreName = '%s'\n", corename); fortprintf(fd, " core %% modelVersion = '%s'\n", version); - fortprintf(fd, " core %% executableName = '%s'\n", exe_name); - fortprintf(fd, " core %% git_version = '%s'\n", git_ver); - fortprintf(fd, " core %% build_target = '%s'\n", build_target); + + parse_macros(process_core_macro, macro_count, macros, fd); fclose(fd); fd = fopen("domain_variables.inc", "w+"); - fortprintf(fd, " domain %% namelist_filename = 'namelist.%s'\n", suffix); - fortprintf(fd, " domain %% streams_filename = 'streams.%s'\n", suffix); + parse_macros(process_domain_macro, macro_count, macros, fd); fclose(fd); }/*}}}*/ +void process_core_macro(const char *macro, const char *val, va_list ap) +{ + FILE *fd = va_arg(ap, FILE *); + + if (strcmp(macro, "MPAS_EXE_NAME") == 0) { + fortprintf(fd, " core %% executableName = '%s'\n", val); + } else if (strcmp(macro, "MPAS_GIT_VERSION") == 0) { + fortprintf(fd, " core %% git_version = '%s'\n", val); + } else if (strcmp(macro, "MPAS_BUILD_TARGET") == 0) { + fortprintf(fd, " core %% build_target = '%s'\n", val); + } +} + + +void process_domain_macro(const char *macro, const char *val, va_list ap) +{ + FILE *fd = va_arg(ap, FILE *); + + if (strcmp(macro, "MPAS_NAMELIST_SUFFIX") == 0) { + fortprintf(fd, " domain %% namelist_filename = 'namelist.%s'\n", val); + fortprintf(fd, " domain %% streams_filename = 'streams.%s'\n", val); + } +} + + int write_field_pointer_arrays(FILE* fd){/*{{{*/ fortprintf(fd, "\n"); fortprintf(fd, " type (field0DReal), pointer :: r0Ptr\n"); @@ -2514,5 +2532,3 @@ int parse_structs_from_registry(ezxml_t registry)/*{{{*/ return 0; }/*}}}*/ - - diff --git a/src/tools/registry/gen_inc.h b/src/tools/registry/gen_inc.h index 3833456d66..fc94e78b79 100644 --- a/src/tools/registry/gen_inc.h +++ b/src/tools/registry/gen_inc.h @@ -11,7 +11,7 @@ void add_attribute_if_not_ignored(FILE *fd, char *index, char *att_name, char *pointer_name_arr, char *temp_str); int find_string_in_array(char *input_string, const char *array[], size_t rows); -void write_model_variables(ezxml_t registry); +void write_model_variables(ezxml_t registry, int macro_count, const char **macros); int write_field_pointer_arrays(FILE* fd); int set_pointer_name(int type, int ndims, char *pointer_name, int time_levs); int add_package_to_list(const char * package, const char * package_list); diff --git a/src/tools/registry/parse.c b/src/tools/registry/parse.c index 858ff0f77c..4e68576ba9 100644 --- a/src/tools/registry/parse.c +++ b/src/tools/registry/parse.c @@ -33,11 +33,14 @@ int main(int argc, char ** argv)/*{{{*/ struct package * pkgs; int err; - if (argc != 2) { - fprintf(stderr,"Reading registry file from standard input\n"); - regfile = stdin; + if (argc < 2) { + fprintf(stderr,"\nUsage: %s [macro definitions]\n\n", argv[0]); + fprintf(stderr," where [macro definitions] may be any number of macro\n"); + fprintf(stderr," definitions of the form -D[=]\n\n"); + return 1; } - else if (!(regfile = fopen(argv[1], "r"))) { + + if (!(regfile = fopen(argv[1], "r"))) { fprintf(stderr,"\nError: Could not open file %s for reading.\n\n", argv[1]); return 1; } @@ -58,7 +61,11 @@ int main(int argc, char ** argv)/*{{{*/ return 1; } - write_model_variables(registry); + if (argc > 2) { + write_model_variables(registry, (argc-2), (const char**)&argv[2]); + } else { + write_model_variables(registry, 0, NULL); + } if (parse_reg_xml(registry)) { fprintf(stderr, "Parsing failed.....\n"); diff --git a/src/tools/registry/utility.c b/src/tools/registry/utility.c index 444889d448..e722d399f8 100644 --- a/src/tools/registry/utility.c +++ b/src/tools/registry/utility.c @@ -9,6 +9,7 @@ #include #include #include +#include #include "ezxml.h" #include "registry_types.h" @@ -263,3 +264,78 @@ int check_persistence(const char * persistence){/*{{{*/ return PERSISTENT; } }/*}}}*/ + + +/****************************************************************************** + * + * parse_macros + * + * Given an array of strings that are assumed to be in the form of C + * pre-processor macro definitions, e.g., + * + * { "-DMPAS_NAMELIST_SUFFIX=test", + * "-DSINGLE_PRECISION", + * "-DHISTORY=Not available" } + * + * which could come from the command-line arguments + * + * -DMPAS_NAMELIST_SUFFIX=test -DSINGLE_PRECISION -DHISTORY="Not available" + * + * this routine parses the macro name and macro definition from each string, + * and invokes a callback routine with the macro name and definition. The macro + * name is the name of the macro itself, without the "-D" definition prefix. + * + * Any arguments after the macros argument to this function are passed as a + * va_list to the callback. + * + * For the above array of macro definition strings, the callback would be + * invoked three times with the following arguments: + * + * "MPAS_NAMELIST_SUFFIX", "test" + * "SINGLE_PRECISION", "" + * "HISTORY", "Not available" + * + * The callback function may be NULL. + * + * Upon successful completion, a value of 0 is returned. If errors were + * encountered in parsing macro definition strings, a non-zero value is + * returned. + * + ******************************************************************************/ +int parse_macros(void(*callback)(const char *macro, const char *val, va_list ap), + int count, const char **macros, ...) +{ + int i; + + for (i = 0; i < count; i++) { + char *tmp; + char *macrotmp; + char *macro; + char *val; + + tmp = strdup(macros[i]); + macrotmp = strtok_r(tmp, "=", &val); + + if (macrotmp == NULL || val == NULL) { + return 1; + } + + if (strstr(macrotmp, "-D") == macrotmp) { + macro = ¯otmp[2]; + } else { + macro = macrotmp; + } + + if (callback != NULL) { + va_list ap; + + va_start(ap, macros); + callback(macro, val, ap); + va_end(ap); + } + + free(tmp); + } + + return 0; +} diff --git a/src/tools/registry/utility.h b/src/tools/registry/utility.h index 37c9d0de27..90a2e83ca7 100644 --- a/src/tools/registry/utility.h +++ b/src/tools/registry/utility.h @@ -15,3 +15,5 @@ char * check_packages(ezxml_t registry, char * packages); char * check_dimensions(ezxml_t registry, char * dims); char * check_streams(ezxml_t registry, char * streams); int check_persistence(const char * persistence); +int parse_macros(void(*callback)(const char *macro, const char *val, va_list ap), + int count, const char **macros, ...);